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.
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)
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
25 Do the tough things for DATA statement (and INTEGER FOO/.../-style
26 initializations), like implied-DO and suchlike.
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
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
78 ffeinfoBasictype basic_type
;
79 ffeinfoKindtype kind_type
;
80 ffetargetCharacterSize size
;
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
110 static ffetargetOffset ffedata_expected_
; /* Number of elements to
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
,
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
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. */
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
;
162 /* ffedata_end -- End of initialization sequence
164 if (ffedata_end(FALSE))
167 Make sure the end of the list is valid here. */
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_
));
185 /* Pop off any impdo stacks (present only if ffedata_symbol_ != NULL). */
187 while (ffedata_stack_
!= NULL
)
190 if (ffedata_list_
!= NULL
)
192 assert (reported_error
);
193 ffedata_list_
= NULL
;
199 /* ffedata_gather -- Gather previously disparate initializations into one place
201 ffestorag st; // A typeCBLOCK or typeLOCAL aggregate.
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
212 ffedata_gather (ffestorag st
)
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
))
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
244 ffelexToken t; // Points to the value.
245 if (ffedata_value(1,value,t))
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. */
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. */
262 && (ffebld_op (value
) == FFEBLD_opCONTER
)
263 && ffebld_constant_is_zero (ffebld_conter (value
)))
265 else if ((value
!= NULL
)
266 && (ffebld_op (value
) == FFEBLD_opANY
))
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_. */
279 ffedata_convert_cache_use_
= -1; /* Don't bother caching. */
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_
),
297 ffesymbol_signal_unreported (ffedata_symbol_
);
299 if (!ffedata_value_ (value
, token
))
306 /* ffedata_advance_ -- Advance initialization target to next item in list
308 if (ffedata_advance_())
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. */
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. */
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. */
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
)))
400 ffebad_start (FFEBAD_DATA_REINIT
);
401 ffest_ffebad_here_current_stmt (0);
402 ffebad_string (ffesymbol_text (ffedata_symbol_
));
404 ffedata_reported_error_
= TRUE
;
407 ffedata_reinit_
= TRUE
;
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;
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
428 ffedata_expected_
= ffedata_arraysize_
;
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;
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
)))
459 ffebad_start (FFEBAD_DATA_REINIT
);
460 ffest_ffebad_here_current_stmt (0);
461 ffebad_string (ffesymbol_text (ffedata_symbol_
));
463 ffedata_reported_error_
= TRUE
;
466 ffedata_reinit_
= TRUE
;
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... */
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
487 ffedata_expected_
= 1;
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;
499 case FFEBLD_opSUBSTR
: /* Substring reference to scalar or array
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
)))
527 ffebad_start (FFEBAD_DATA_REINIT
);
528 ffest_ffebad_here_current_stmt (0);
529 ffebad_string (ffesymbol_text (ffedata_symbol_
));
531 ffedata_reported_error_
= TRUE
;
534 ffedata_reinit_
= TRUE
;
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;
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
555 ffedata_expected_
= arrayref
? 1 : ffedata_arraysize_
;
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;
569 case FFEBLD_opIMPDO
: /* Implied-DO construct. */
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
);
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
);
594 if (ffeinfo_basictype (ffebld_info (start
)) != FFEINFO_basictypeINTEGER
)
596 ffebad_start (FFEBAD_DATA_EVAL
);
597 ffest_ffebad_here_current_stmt (0);
600 ffedata_reported_error_
= TRUE
;
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
)
610 ffebad_start (FFEBAD_DATA_EVAL
);
611 ffest_ffebad_here_current_stmt (0);
614 ffedata_reported_error_
= TRUE
;
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
);
624 ffedata_stack_
->increment
= 1;
627 if (ffeinfo_basictype (ffebld_info (incr
)) != FFEINFO_basictypeINTEGER
)
629 ffebad_start (FFEBAD_DATA_EVAL
);
630 ffest_ffebad_here_current_stmt (0);
633 ffedata_reported_error_
= TRUE
;
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)
643 ffebad_start (FFEBAD_DATA_ZERO
);
644 ffest_ffebad_here_current_stmt (0);
645 ffebad_string (ffesymbol_text (ffedata_stack_
->itervar
));
648 ffedata_reported_error_
= TRUE
;
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
)
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
));
668 goto tail_recurse
; /* :::::::::::::::::::: */
671 ffedata_reported_error_
= TRUE
;
675 assert ("bad op" == NULL
);
682 /* ffedata_convert_ -- Convert source expression to given type using cache
685 ffelexToken source_token;
686 ffelexToken dest_token; // Any appropriate token for "destination".
689 ffetargetCharactersize sz;
690 source = ffedata_convert_(source,source_token,dest_token,bt,kt,sz);
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
697 ffedata_convert_ (ffebld source
, ffelexToken source_token
,
698 ffelexToken dest_token
, ffeinfoBasictype bt
,
699 ffeinfoKindtype kt
, ffeinfoRank rk
,
700 ffetargetCharacterSize sz
)
705 ffedataConvertCache_ cache
;
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
;
714 converted
= ffeexpr_convert (source
, source_token
, dest_token
, bt
, kt
, rk
,
715 sz
, FFEEXPR_contextDATA
);
717 if (ffedata_convert_cache_use_
>= ffedata_convert_cache_max_
)
719 if (ffedata_convert_cache_max_
== 0)
722 max
= ffedata_convert_cache_max_
<< 1;
724 if (max
> ffedata_convert_cache_max_
)
726 cache
= (ffedataConvertCache_
) malloc_new_ks (malloc_pool_image (),
727 "FFEDATA cache", max
* sizeof (*cache
));
728 if (ffedata_convert_cache_max_
!= 0)
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
));
735 ffedata_convert_cache_
= cache
;
736 ffedata_convert_cache_max_
= max
;
739 return converted
; /* In case int overflows! */
742 i
= ffedata_convert_cache_use_
++;
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
;
753 /* ffedata_eval_integer1_ -- Evaluate expression
755 ffetargetIntegerDefault result;
756 ffebld expr; // must be kindtypeINTEGER1.
758 result = ffedata_eval_integer1_(expr);
760 Evalues the expression (which yields a kindtypeINTEGER1 result) and
761 returns the result. */
763 static ffetargetIntegerDefault
764 ffedata_eval_integer1_ (ffebld expr
)
766 ffetargetInteger1 result
;
769 assert (expr
!= NULL
);
771 switch (ffebld_op (expr
))
773 case FFEBLD_opCONTER
:
774 return ffebld_constant_integer1 (ffebld_conter (expr
));
776 case FFEBLD_opSYMTER
:
777 return ffesymbol_value (ffebld_symter (expr
));
780 return ffedata_eval_integer1_ (ffebld_left (expr
));
782 case FFEBLD_opUMINUS
:
783 error
= ffetarget_uminus_integer1 (&result
,
784 ffedata_eval_integer1_ (ffebld_left (expr
)));
788 error
= ffetarget_add_integer1 (&result
,
789 ffedata_eval_integer1_ (ffebld_left (expr
)),
790 ffedata_eval_integer1_ (ffebld_right (expr
)));
793 case FFEBLD_opSUBTRACT
:
794 error
= ffetarget_subtract_integer1 (&result
,
795 ffedata_eval_integer1_ (ffebld_left (expr
)),
796 ffedata_eval_integer1_ (ffebld_right (expr
)));
799 case FFEBLD_opMULTIPLY
:
800 error
= ffetarget_multiply_integer1 (&result
,
801 ffedata_eval_integer1_ (ffebld_left (expr
)),
802 ffedata_eval_integer1_ (ffebld_right (expr
)));
805 case FFEBLD_opDIVIDE
:
806 error
= ffetarget_divide_integer1 (&result
,
807 ffedata_eval_integer1_ (ffebld_left (expr
)),
808 ffedata_eval_integer1_ (ffebld_right (expr
)));
813 ffebld r
= ffebld_right (expr
);
815 if ((ffeinfo_basictype (ffebld_info (r
)) != FFEINFO_basictypeINTEGER
)
816 || (ffeinfo_kindtype (ffebld_info (r
)) != FFEINFO_kindtypeINTEGERDEFAULT
))
817 error
= FFEBAD_DATA_EVAL
;
819 error
= ffetarget_power_integerdefault_integerdefault (&result
,
820 ffedata_eval_integer1_ (ffebld_left (expr
)),
821 ffedata_eval_integer1_ (r
));
825 #if 0 /* Only for character basictype. */
826 case FFEBLD_opCONCATENATE
:
832 error
= ffetarget_not_integer1 (&result
,
833 ffedata_eval_integer1_ (ffebld_left (expr
)));
836 #if 0 /* Only for logical basictype. */
863 error
= ffetarget_and_integer1 (&result
,
864 ffedata_eval_integer1_ (ffebld_left (expr
)),
865 ffedata_eval_integer1_ (ffebld_right (expr
)));
869 error
= ffetarget_or_integer1 (&result
,
870 ffedata_eval_integer1_ (ffebld_left (expr
)),
871 ffedata_eval_integer1_ (ffebld_right (expr
)));
875 error
= ffetarget_xor_integer1 (&result
,
876 ffedata_eval_integer1_ (ffebld_left (expr
)),
877 ffedata_eval_integer1_ (ffebld_right (expr
)));
881 error
= ffetarget_eqv_integer1 (&result
,
882 ffedata_eval_integer1_ (ffebld_left (expr
)),
883 ffedata_eval_integer1_ (ffebld_right (expr
)));
887 error
= ffetarget_neqv_integer1 (&result
,
888 ffedata_eval_integer1_ (ffebld_left (expr
)),
889 ffedata_eval_integer1_ (ffebld_right (expr
)));
893 return ffedata_eval_integer1_ (ffebld_left (expr
));
895 #if 0 /* ~~ no idea how to do this */
896 case FFEBLD_opPERCENT_LOC
:
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
))))
906 case FFEINFO_basictypeINTEGER
:
907 switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr
))))
910 error
= FFEBAD_DATA_EVAL
;
915 case FFEINFO_basictypeREAL
:
916 switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr
))))
919 error
= FFEBAD_DATA_EVAL
;
927 #if 0 /* not valid ops */
928 case FFEBLD_opREPEAT
:
932 case FFEBLD_opBOUNDS
:
937 #if 0 /* not allowed by ANSI, but perhaps as an
938 extension someday? */
939 case FFEBLD_opFUNCREF
:
944 #if 0 /* not valid ops */
945 case FFEBLD_opSUBRREF
:
949 case FFEBLD_opARRAYREF
:
954 #if 0 /* not valid for integer1 */
955 case FFEBLD_opSUBSTR
:
961 error
= FFEBAD_DATA_EVAL
;
967 ffebad_start (error
);
968 ffest_ffebad_here_current_stmt (0);
976 /* ffedata_eval_offset_ -- Evaluate offset info array
978 ffetargetOffset offset; // 0...max-1.
979 ffebld subscripts; // an opITEM list of subscript exprs.
980 ffebld dims; // an opITEM list of opBOUNDS exprs.
982 result = ffedata_eval_offset_(expr);
984 Evalues the expression (which yields a kindtypeINTEGER1 result) and
985 returns the result. */
987 static ffetargetOffset
988 ffedata_eval_offset_ (ffebld subscripts
, ffebld dims
)
990 ffetargetIntegerDefault offset
= 0;
991 ffetargetIntegerDefault width
= 1;
992 ffetargetIntegerDefault value
;
993 ffetargetIntegerDefault lowbound
;
994 ffetargetIntegerDefault highbound
;
995 ffetargetOffset final
;
1003 while (subscripts
!= NULL
)
1005 ffeinfoKindtype sub_kind
, low_kind
, hi_kind
;
1006 ffebld sub1
, low1
, hi1
;
1009 assert (dims
!= NULL
);
1011 subscript
= ffebld_head (subscripts
);
1012 dim
= ffebld_head (dims
);
1014 assert (ffeinfo_basictype (ffebld_info (subscript
)) == FFEINFO_basictypeINTEGER
);
1015 if (ffebld_op (subscript
) == FFEBLD_opCONTER
)
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
);
1027 value
= ffedata_eval_integer1_ (subscript
);
1029 assert (ffebld_op (dim
) == FFEBLD_opBOUNDS
);
1030 low
= ffebld_left (dim
);
1031 high
= ffebld_right (dim
);
1037 assert (ffeinfo_basictype (ffebld_info (low
)) == FFEINFO_basictypeINTEGER
);
1038 if (ffebld_op (low
) == FFEBLD_opCONTER
)
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
);
1050 lowbound
= ffedata_eval_integer1_ (low
);
1053 assert (ffeinfo_basictype (ffebld_info (high
)) == FFEINFO_basictypeINTEGER
);
1054 if (ffebld_op (high
) == FFEBLD_opCONTER
)
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
);
1066 highbound
= ffedata_eval_integer1_ (high
);
1068 if ((value
< lowbound
) || (value
> highbound
))
1072 sprintf (rankstr
, "%d", rank
);
1074 ffebad_start (FFEBAD_DATA_SUBSCRIPT
);
1075 ffebad_string (ffesymbol_text (ffedata_symbol_
));
1076 ffebad_string (rankstr
);
1080 subscripts
= ffebld_trail (subscripts
);
1081 dims
= ffebld_trail (dims
);
1083 offset
+= width
* (value
- lowbound
);
1084 if (subscripts
!= NULL
)
1085 width
*= highbound
- lowbound
+ 1;
1088 assert (dims
== NULL
);
1090 ok
= ffetarget_offset (&final
, offset
);
1096 /* ffedata_eval_substr_begin_ -- Evaluate begin-point of substr reference
1098 ffetargetCharacterSize beginpoint;
1099 ffebld endval; // head(colon).
1101 beginpoint = ffedata_eval_substr_end_(endval);
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. */
1107 static ffetargetCharacterSize
1108 ffedata_eval_substr_begin_ (ffebld expr
)
1110 ffetargetIntegerDefault val
;
1115 assert (ffeinfo_basictype (ffebld_info (expr
)) == FFEINFO_basictypeINTEGER
);
1116 assert (ffeinfo_kindtype (ffebld_info (expr
)) == FFEINFO_kindtypeINTEGERDEFAULT
);
1118 val
= ffedata_eval_integer1_ (expr
);
1123 ffebad_start (FFEBAD_DATA_RANGE
);
1124 ffest_ffebad_here_current_stmt (0);
1125 ffebad_string (ffesymbol_text (ffedata_symbol_
));
1127 ffedata_reported_error_
= TRUE
;
1133 /* ffedata_eval_substr_end_ -- Evaluate end-point of substr reference
1135 ffetargetCharacterSize endpoint;
1136 ffebld endval; // head(trail(colon)).
1137 ffetargetCharacterSize min; // beginpoint of substr reference.
1138 ffetargetCharacterSize max; // size of entity.
1140 endpoint = ffedata_eval_substr_end_(endval,dflt);
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. */
1146 static ffetargetCharacterSize
1147 ffedata_eval_substr_end_ (ffebld expr
, ffetargetCharacterSize min
,
1148 ffetargetCharacterSize max
)
1150 ffetargetIntegerDefault val
;
1155 assert (ffeinfo_basictype (ffebld_info (expr
)) == FFEINFO_basictypeINTEGER
);
1156 assert (ffeinfo_kindtype (ffebld_info (expr
)) == FFEINFO_kindtypeINTEGER1
);
1158 val
= ffedata_eval_integer1_ (expr
);
1160 if ((val
< (ffetargetIntegerDefault
) min
)
1161 || (val
> (ffetargetIntegerDefault
) max
))
1164 ffebad_start (FFEBAD_DATA_RANGE
);
1165 ffest_ffebad_here_current_stmt (0);
1166 ffebad_string (ffesymbol_text (ffedata_symbol_
));
1168 ffedata_reported_error_
= TRUE
;
1174 /* ffedata_gather_ -- Gather initial values for sym into master sym inits
1176 ffestorag mst; // A typeCBLOCK or typeLOCAL aggregate.
1177 ffestorag st; // A typeCOMMON or typeEQUIV member.
1178 ffedata_gather_(mst,st);
1180 If st has any initialization info, transfer that info into mst and
1184 ffedata_gather_ (ffestorag mst
, ffestorag st
)
1187 ffesymbol s_whine
; /* Symbol to complain about in diagnostics. */
1189 ffetargetOffset offset
;
1190 ffetargetOffset units_expected
;
1192 ffebldConstantArray array
;
1194 ffetargetCopyfunc fn
;
1198 ffeinfoBasictype bt
;
1200 ffeinfoBasictype ign_bt
;
1201 ffeinfoKindtype ign_kt
;
1202 ffetargetAlign units
;
1204 ffetargetOffset source_offset
;
1208 return; /* Nothing to do. */
1210 s
= ffestorag_symbol (st
);
1212 assert (s
!= NULL
); /* Must have a corresponding symbol (else how
1214 assert (ffestorag_init (st
) == NULL
); /* No init info on storage itself. */
1215 assert (ffestorag_accretion (st
) == NULL
);
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. */
1224 /* b now holds the init/accretion expr. */
1226 ffesymbol_set_init (s
, NULL
);
1227 ffesymbol_set_accretion (s
, NULL
);
1228 ffesymbol_set_accretes (s
, 0);
1230 s_whine
= ffestorag_symbol (mst
);
1231 if (s_whine
== NULL
)
1234 /* Make sure we haven't fully accreted during an array init. */
1236 if (ffestorag_init (mst
) != NULL
)
1238 ffebad_start (FFEBAD_DATA_MULTIPLE
);
1239 ffebad_here (0, ffewhere_line_unknown (), ffewhere_column_unknown ());
1240 ffebad_string (ffesymbol_text (s_whine
));
1245 bt
= ffeinfo_basictype (ffebld_info (b
));
1246 kt
= ffeinfo_kindtype (ffebld_info (b
));
1248 /* Calculate offset for aggregate area. */
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_
;
1259 /* Does an accretion array exist? If not, create it. */
1261 if (ffestorag_accretion (mst
) == NULL
)
1263 #if FFEDATA_sizeTOO_BIG_INIT_ != 0
1264 if (ffedata_storage_size_
>= FFEDATA_sizeTOO_BIG_INIT_
)
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
);
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_
,
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_
);
1294 accter
= ffestorag_accretion (mst
);
1295 assert (ffedata_storage_size_
== (ffetargetOffset
) ffebld_accter_size (accter
));
1296 array
= ffebld_accter (accter
);
1299 /* Put value in accretion array at desired offset. */
1301 fn
= ffetarget_aggregate_ptr_memcpy (ffedata_storage_bt_
, ffedata_storage_kt_
,
1304 switch (ffebld_op (b
))
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
)),
1311 (*fn
) (ptr1
, ptr2
, size
); /* Does the appropriate memcpy-like
1313 ffebit_count (ffebld_accter_bits (accter
),
1314 offset
, FALSE
, units_expected
, &actual
); /* How many FALSE? */
1315 if (units_expected
!= (ffetargetOffset
) actual
)
1317 ffebad_start (FFEBAD_DATA_MULTIPLE
);
1318 ffebad_here (0, ffewhere_line_unknown (), ffewhere_column_unknown ());
1319 ffebad_string (ffesymbol_text (s
));
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
);
1328 /* If done accreting for this storage area, establish as initialized. */
1330 if (ffestorag_accretes (mst
) == 0)
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
);
1346 case FFEBLD_opARRTER
:
1347 ffebld_constantarray_preparray (&ptr1
, &ptr2
, &size
, array
, ffedata_storage_bt_
,
1348 ffedata_storage_kt_
, offset
, ffebld_arrter (b
),
1350 size
*= ffebld_arrter_size (b
);
1351 units_expected
*= ffebld_arrter_size (b
);
1352 (*fn
) (ptr1
, ptr2
, size
); /* Does the appropriate memcpy-like
1354 ffebit_count (ffebld_accter_bits (accter
),
1355 offset
, FALSE
, units_expected
, &actual
); /* How many FALSE? */
1356 if (units_expected
!= (ffetargetOffset
) actual
)
1358 ffebad_start (FFEBAD_DATA_MULTIPLE
);
1359 ffebad_here (0, ffewhere_line_unknown (), ffewhere_column_unknown ());
1360 ffebad_string (ffesymbol_text (s
));
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
);
1369 /* If done accreting for this storage area, establish as initialized. */
1371 if (ffestorag_accretes (mst
) == 0)
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
);
1387 case FFEBLD_opACCTER
:
1388 ffebld_constantarray_preparray (&ptr1
, &ptr2
, &size
, array
, ffedata_storage_bt_
,
1389 ffedata_storage_kt_
, offset
, ffebld_accter (b
),
1391 bits
= ffebld_accter_bits (b
);
1396 ffetargetOffset unexp
;
1397 ffetargetOffset siz
;
1401 ffebit_test (bits
, source_offset
, &value
, &length
);
1403 break; /* Exit the loop early. */
1404 siz
= size
* length
;
1405 unexp
= units_expected
* length
;
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
))
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
));
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
);
1425 source_offset
+= length
;
1427 ptr1
= ((char *) ptr1
) + siz
;
1428 ptr2
= ((char *) ptr2
) + siz
;
1431 /* If done accreting for this storage area, establish as initialized. */
1433 if (ffestorag_accretes (mst
) == 0)
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
);
1450 assert ("bad init op in gather_" == NULL
);
1455 /* ffedata_pop_ -- Pop an impdo stack entry
1462 ffedataImpdo_ victim
= ffedata_stack_
;
1464 assert (victim
!= NULL
);
1466 ffedata_stack_
= ffedata_stack_
->outer
;
1468 malloc_kill_ks (ffe_pool_program_unit (), victim
, sizeof (*victim
));
1471 /* ffedata_push_ -- Push an impdo stack entry
1480 baby
= malloc_new_ks (ffe_pool_program_unit (), "ffedataImpdo_", sizeof (*baby
));
1482 baby
->outer
= ffedata_stack_
;
1483 ffedata_stack_
= baby
;
1486 /* ffedata_value_ -- Provide an initial value
1489 ffelexToken t; // Points to the value.
1490 if (ffedata_value(value,t))
1493 Makes sure the value is ok, then remembers it according to the list
1494 provided to ffedata_begin. */
1497 ffedata_value_ (ffebld value
, ffelexToken token
)
1500 /* If already reported an error, don't do anything. */
1502 if (ffedata_reported_error_
)
1505 /* If the value is an error marker, remember we've seen one and do nothing
1509 && (ffebld_op (value
) == FFEBLD_opANY
))
1511 ffedata_reported_error_
= TRUE
;
1515 /* If too many values (no more targets), complain. */
1517 if (ffedata_symbol_
== NULL
)
1519 ffebad_start (FFEBAD_DATA_TOOMANY
);
1520 ffebad_here (0, ffelex_token_where_line (token
),
1521 ffelex_token_where_column (token
));
1523 ffedata_reported_error_
= TRUE
;
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. */
1531 if (ffedata_reinit_
)
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_
));
1538 ffedata_reported_error_
= TRUE
;
1542 #if FFEGLOBAL_ENABLED
1543 if (ffesymbol_common (ffedata_symbol_
) != NULL
)
1544 ffeglobal_init_common (ffesymbol_common (ffedata_symbol_
), token
);
1547 /* Convert value to desired type. */
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
);
1566 /* If we couldn't, bug out. */
1568 if ((value
!= NULL
) && (ffebld_op (value
) == FFEBLD_opANY
))
1570 ffedata_reported_error_
= TRUE
;
1574 /* Handle the case where initializes go to a parent's storage area. */
1576 if (ffedata_storage_
!= NULL
)
1578 ffetargetOffset offset
;
1579 ffetargetOffset units_expected
;
1581 ffebldConstantArray array
;
1583 ffetargetCopyfunc fn
;
1587 ffeinfoBasictype ign_bt
;
1588 ffeinfoKindtype ign_kt
;
1589 ffetargetAlign units
;
1591 /* Make sure we haven't fully accreted during an array init. */
1593 if (ffestorag_init (ffedata_storage_
) != NULL
)
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_
));
1600 ffedata_reported_error_
= TRUE
;
1604 /* Calculate offset. */
1606 offset
= ffedata_offset_
* ffedata_size_
+ ffedata_charoffset_
;
1608 /* Is offset within range? If not, whine, but don't do anything else. */
1610 if (offset
+ ffedata_charexpected_
- 1 > ffedata_symbolsize_
)
1612 ffebad_start (FFEBAD_DATA_RANGE
);
1613 ffest_ffebad_here_current_stmt (0);
1614 ffebad_string (ffesymbol_text (ffedata_symbol_
));
1616 ffedata_reported_error_
= TRUE
;
1620 /* Now calculate offset for aggregate area. */
1622 ffetarget_aggregate_info (&ign_bt
, &ign_kt
, &units
, ffedata_basictype_
,
1623 ffedata_kindtype_
); /* Find out unit size of
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_
;
1632 assert (offset
+ units_expected
- 1 <= ffedata_storage_size_
);
1634 /* Does an accretion array exist? If not, create it. */
1638 if (ffestorag_accretion (ffedata_storage_
) == NULL
)
1640 #if FFEDATA_sizeTOO_BIG_INIT_ != 0
1641 if (ffedata_storage_size_
>= FFEDATA_sizeTOO_BIG_INIT_
)
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
);
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_
,
1665 FFEINFO_whereCONSTANT
,
1667 == FFEINFO_basictypeCHARACTER
)
1668 ? 1 : FFETARGET_charactersizeNONE
));
1669 ffestorag_set_accretion (ffedata_storage_
, accter
);
1670 ffestorag_set_accretes (ffedata_storage_
, ffedata_storage_size_
);
1674 accter
= ffestorag_accretion (ffedata_storage_
);
1675 assert (ffedata_storage_size_
== (ffetargetOffset
) ffebld_accter_size (accter
));
1676 array
= ffebld_accter (accter
);
1679 /* Put value in accretion array at desired offset. */
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
1691 ffebit_count (ffebld_accter_bits (accter
),
1692 offset
, FALSE
, units_expected
,
1693 &actual
); /* How many FALSE? */
1694 if (units_expected
!= (ffetargetOffset
) actual
)
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_
));
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
,
1709 /* If done accreting for this storage area, establish as
1712 if (ffestorag_accretes (ffedata_storage_
) == 0)
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_
),
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_
),
1727 ffecom_notify_init_storage (ffedata_storage_
);
1731 /* If still accreting, adjust specs accordingly and return. */
1733 if (++ffedata_number_
< ffedata_expected_
)
1739 return ffedata_advance_ ();
1742 /* Figure out where the value goes -- in an accretion array or directly
1743 into the final initial-value slot for the symbol. */
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
;
1752 ffebldConstantArray array
;
1753 ffebld accter
= NULL
;
1755 /* Calculate offset. */
1757 offset
= ffedata_offset_
* ffedata_size_
+ ffedata_charoffset_
;
1759 /* Is offset within range? If not, whine, but don't do anything else. */
1761 if (offset
+ ffedata_charexpected_
- 1 > ffedata_symbolsize_
)
1763 ffebad_start (FFEBAD_DATA_RANGE
);
1764 ffest_ffebad_here_current_stmt (0);
1765 ffebad_string (ffesymbol_text (ffedata_symbol_
));
1767 ffedata_reported_error_
= TRUE
;
1771 /* Does an accretion array exist? If not, create it. */
1775 if (ffesymbol_accretion (ffedata_symbol_
) == NULL
)
1777 #if FFEDATA_sizeTOO_BIG_INIT_ != 0
1778 if (ffedata_symbolsize_
>= FFEDATA_sizeTOO_BIG_INIT_
)
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
);
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_
,
1802 FFEINFO_whereCONSTANT
,
1804 == FFEINFO_basictypeCHARACTER
)
1805 ? 1 : FFETARGET_charactersizeNONE
));
1806 ffesymbol_set_accretion (ffedata_symbol_
, accter
);
1807 ffesymbol_set_accretes (ffedata_symbol_
, ffedata_symbolsize_
);
1811 accter
= ffesymbol_accretion (ffedata_symbol_
);
1812 assert (ffedata_symbolsize_
1813 == (ffetargetOffset
) ffebld_accter_size (accter
));
1814 array
= ffebld_accter (accter
);
1817 /* Put value in accretion array at desired offset. */
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_
)
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_
));
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_
);
1842 /* If still accreting, adjust specs accordingly and return. */
1844 if (++ffedata_number_
< ffedata_expected_
)
1850 /* Else, if done accreting for this symbol, establish as initialized. */
1853 && (ffesymbol_accretes (ffedata_symbol_
) == 0))
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_
);
1867 else if (value
!= NULL
)
1869 /* Simple, direct, one-shot assignment. */
1870 ffesymbol_set_init (ffedata_symbol_
, value
);
1871 ffecom_notify_init_symbol (ffedata_symbol_
);
1874 /* Call on advance function to get next target in list. */
1876 return ffedata_advance_ ();