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