1878 lines
56 KiB
C
1878 lines
56 KiB
C
/* data.c -- Implementation File (module.c template V1.0)
|
||
Copyright (C) 1995, 1996, 2002, 2003 Free Software Foundation, Inc.
|
||
Contributed by James Craig Burley.
|
||
|
||
This file is part of GNU Fortran.
|
||
|
||
GNU Fortran is free software; you can redistribute it and/or modify
|
||
it under the terms of the GNU General Public License as published by
|
||
the Free Software Foundation; either version 2, or (at your option)
|
||
any later version.
|
||
|
||
GNU Fortran is distributed in the hope that it will be useful,
|
||
but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||
GNU General Public License for more details.
|
||
|
||
You should have received a copy of the GNU General Public License
|
||
along with GNU Fortran; see the file COPYING. If not, write to
|
||
the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA
|
||
02111-1307, USA.
|
||
|
||
Related Modules:
|
||
|
||
Description:
|
||
Do the tough things for DATA statement (and INTEGER FOO/.../-style
|
||
initializations), like implied-DO and suchlike.
|
||
|
||
Modifications:
|
||
*/
|
||
|
||
/* Include files. */
|
||
|
||
#include "proj.h"
|
||
#include "data.h"
|
||
#include "bit.h"
|
||
#include "bld.h"
|
||
#include "com.h"
|
||
#include "expr.h"
|
||
#include "global.h"
|
||
#include "malloc.h"
|
||
#include "st.h"
|
||
#include "storag.h"
|
||
#include "top.h"
|
||
|
||
/* Externals defined here. */
|
||
|
||
|
||
/* Simple definitions and enumerations. */
|
||
|
||
/* I picked this value as one that, when plugged into a couple of small
|
||
but nearly identical test cases I have called BIG-0.f and BIG-1.f,
|
||
causes BIG-1.f to take about 10 times as long (elapsed) to compile
|
||
(in f771 only) as BIG-0.f. These test cases differ in that BIG-0.f
|
||
doesn't put the one initialized variable in a common area that has
|
||
a large uninitialized array in it, while BIG-1.f does. The size of
|
||
the array is this many elements, as long as they all are INTEGER
|
||
type. Note that, as of 0.5.18, sparse cases are better handled,
|
||
so BIG-2.f now is used; it provides nonzero initial
|
||
values for all elements of the same array BIG-0 has. */
|
||
#ifndef FFEDATA_sizeTOO_BIG_INIT_
|
||
#define FFEDATA_sizeTOO_BIG_INIT_ 75*1024
|
||
#endif
|
||
|
||
/* Internal typedefs. */
|
||
|
||
typedef struct _ffedata_convert_cache_ *ffedataConvertCache_;
|
||
typedef struct _ffedata_impdo_ *ffedataImpdo_;
|
||
|
||
/* Private include files. */
|
||
|
||
|
||
/* Internal structure definitions. */
|
||
|
||
struct _ffedata_convert_cache_
|
||
{
|
||
ffebld converted; /* Results of converting expr to following
|
||
type. */
|
||
ffeinfoBasictype basic_type;
|
||
ffeinfoKindtype kind_type;
|
||
ffetargetCharacterSize size;
|
||
ffeinfoRank rank;
|
||
};
|
||
|
||
struct _ffedata_impdo_
|
||
{
|
||
ffedataImpdo_ outer; /* Enclosing IMPDO construct. */
|
||
ffebld outer_list; /* Item after my IMPDO on the outer list. */
|
||
ffebld my_list; /* Beginning of list in my IMPDO. */
|
||
ffesymbol itervar; /* Iteration variable. */
|
||
ffetargetIntegerDefault increment;
|
||
ffetargetIntegerDefault final;
|
||
};
|
||
|
||
/* Static objects accessed by functions in this module. */
|
||
|
||
static ffedataImpdo_ ffedata_stack_ = NULL;
|
||
static ffebld ffedata_list_ = NULL;
|
||
static bool ffedata_reinit_; /* value_ should report REINIT error. */
|
||
static bool ffedata_reported_error_; /* Error has been reported. */
|
||
static ffesymbol ffedata_symbol_ = NULL; /* Symbol being initialized. */
|
||
static ffeinfoBasictype ffedata_basictype_; /* Info on symbol. */
|
||
static ffeinfoKindtype ffedata_kindtype_;
|
||
static ffestorag ffedata_storage_; /* If non-NULL, inits go into this parent. */
|
||
static ffeinfoBasictype ffedata_storage_bt_; /* Info on storage. */
|
||
static ffeinfoKindtype ffedata_storage_kt_;
|
||
static ffetargetOffset ffedata_storage_size_; /* Size of entire storage. */
|
||
static ffetargetAlign ffedata_storage_units_; /* #units per storage unit. */
|
||
static ffetargetOffset ffedata_arraysize_; /* Size of array being
|
||
inited. */
|
||
static ffetargetOffset ffedata_expected_; /* Number of elements to
|
||
init. */
|
||
static ffetargetOffset ffedata_number_; /* #elements inited so far. */
|
||
static ffetargetOffset ffedata_offset_; /* Offset of next element. */
|
||
static ffetargetOffset ffedata_symbolsize_; /* Size of entire sym. */
|
||
static ffetargetCharacterSize ffedata_size_; /* Size of an element. */
|
||
static ffetargetCharacterSize ffedata_charexpected_; /* #char to init. */
|
||
static ffetargetCharacterSize ffedata_charnumber_; /* #chars inited. */
|
||
static ffetargetCharacterSize ffedata_charoffset_; /* Offset of next char. */
|
||
static ffedataConvertCache_ ffedata_convert_cache_; /* Fewer conversions. */
|
||
static int ffedata_convert_cache_max_ = 0; /* #entries available. */
|
||
static int ffedata_convert_cache_use_ = 0; /* #entries in use. */
|
||
|
||
/* Static functions (internal). */
|
||
|
||
static bool ffedata_advance_ (void);
|
||
static ffebld ffedata_convert_ (ffebld source, ffelexToken source_token,
|
||
ffelexToken dest_token, ffeinfoBasictype bt, ffeinfoKindtype kt,
|
||
ffeinfoRank rk, ffetargetCharacterSize sz);
|
||
static ffetargetInteger1 ffedata_eval_integer1_ (ffebld expr);
|
||
static ffetargetOffset ffedata_eval_offset_ (ffebld subscripts,
|
||
ffebld dims);
|
||
static ffetargetCharacterSize ffedata_eval_substr_begin_ (ffebld expr);
|
||
static ffetargetCharacterSize ffedata_eval_substr_end_ (ffebld expr,
|
||
ffetargetCharacterSize min, ffetargetCharacterSize max);
|
||
static void ffedata_gather_ (ffestorag mst, ffestorag st);
|
||
static void ffedata_pop_ (void);
|
||
static void ffedata_push_ (void);
|
||
static bool ffedata_value_ (ffebld value, ffelexToken token);
|
||
|
||
/* Internal macros. */
|
||
|
||
|
||
/* ffedata_begin -- Initialize with list of targets
|
||
|
||
ffebld list;
|
||
ffedata_begin(list); // ITEM... list of SYMTERs, ARRAYs, SUBSTRs, ...
|
||
|
||
Remember the list. After this call, 0...n calls to ffedata_value must
|
||
follow, and then a single call to ffedata_end. */
|
||
|
||
void
|
||
ffedata_begin (ffebld list)
|
||
{
|
||
assert (ffedata_list_ == NULL);
|
||
ffedata_list_ = list;
|
||
ffedata_symbol_ = NULL;
|
||
ffedata_reported_error_ = FALSE;
|
||
ffedata_reinit_ = FALSE;
|
||
ffedata_advance_ ();
|
||
}
|
||
|
||
/* ffedata_end -- End of initialization sequence
|
||
|
||
if (ffedata_end(FALSE))
|
||
// everything's ok
|
||
|
||
Make sure the end of the list is valid here. */
|
||
|
||
bool
|
||
ffedata_end (bool reported_error, ffelexToken t)
|
||
{
|
||
reported_error |= ffedata_reported_error_;
|
||
|
||
/* If still targets to initialize, too few initializers, so complain. */
|
||
|
||
if ((ffedata_symbol_ != NULL) && !reported_error)
|
||
{
|
||
reported_error = TRUE;
|
||
ffebad_start (FFEBAD_DATA_TOOFEW);
|
||
ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
|
||
ffebad_string (ffesymbol_text (ffedata_symbol_));
|
||
ffebad_finish ();
|
||
}
|
||
|
||
/* Pop off any impdo stacks (present only if ffedata_symbol_ != NULL). */
|
||
|
||
while (ffedata_stack_ != NULL)
|
||
ffedata_pop_ ();
|
||
|
||
if (ffedata_list_ != NULL)
|
||
{
|
||
assert (reported_error);
|
||
ffedata_list_ = NULL;
|
||
}
|
||
|
||
return TRUE;
|
||
}
|
||
|
||
/* ffedata_gather -- Gather previously disparate initializations into one place
|
||
|
||
ffestorag st; // A typeCBLOCK or typeLOCAL aggregate.
|
||
ffedata_gather(st);
|
||
|
||
Prior to this call, st has no init or accretion info, but (presumably
|
||
at least one of) its subordinate storage areas has init or accretion
|
||
info. After this call, none of the subordinate storage areas has inits,
|
||
because they've all been moved into the newly created init/accretion
|
||
info for st. During this call, conflicting inits produce only one
|
||
error message. */
|
||
|
||
void
|
||
ffedata_gather (ffestorag st)
|
||
{
|
||
ffesymbol s;
|
||
ffebld b;
|
||
|
||
/* Prepare info on the storage area we're putting init info into. */
|
||
|
||
ffetarget_aggregate_info (&ffedata_storage_bt_, &ffedata_storage_kt_,
|
||
&ffedata_storage_units_, ffestorag_basictype (st),
|
||
ffestorag_kindtype (st));
|
||
ffedata_storage_size_ = ffestorag_size (st) / ffedata_storage_units_;
|
||
assert (ffestorag_size (st) % ffedata_storage_units_ == 0);
|
||
|
||
/* If a CBLOCK, gather all the init info for its explicit members. */
|
||
|
||
if ((ffestorag_type (st) == FFESTORAG_typeCBLOCK)
|
||
&& (ffestorag_symbol (st) != NULL))
|
||
{
|
||
s = ffestorag_symbol (st);
|
||
for (b = ffesymbol_commonlist (s); b != NULL; b = ffebld_trail (b))
|
||
ffedata_gather_ (st,
|
||
ffesymbol_storage (ffebld_symter (ffebld_head (b))));
|
||
}
|
||
|
||
/* For CBLOCK or LOCAL, gather all the init info for equivalenced members. */
|
||
|
||
ffestorag_drive (ffestorag_list_equivs (st), ffedata_gather_, st);
|
||
}
|
||
|
||
/* ffedata_value -- Provide some number of initial values
|
||
|
||
ffebld value;
|
||
ffelexToken t; // Points to the value.
|
||
if (ffedata_value(1,value,t))
|
||
// Everything's ok
|
||
|
||
Makes sure the value is ok, then remembers it according to the list
|
||
provided to ffedata_begin. As many instances of the value may be
|
||
supplied as desired, as indicated by the first argument. */
|
||
|
||
bool
|
||
ffedata_value (ffetargetIntegerDefault rpt, ffebld value, ffelexToken token)
|
||
{
|
||
ffetargetIntegerDefault i;
|
||
|
||
/* Maybe ignore zero values, to speed up compiling, even though we lose
|
||
checking for multiple initializations for now. */
|
||
|
||
if (!ffe_is_zeros ()
|
||
&& (value != NULL)
|
||
&& (ffebld_op (value) == FFEBLD_opCONTER)
|
||
&& ffebld_constant_is_zero (ffebld_conter (value)))
|
||
value = NULL;
|
||
else if ((value != NULL)
|
||
&& (ffebld_op (value) == FFEBLD_opANY))
|
||
value = NULL;
|
||
else
|
||
{
|
||
/* Must be a constant. */
|
||
assert (value != NULL);
|
||
assert (ffebld_op (value) == FFEBLD_opCONTER);
|
||
}
|
||
|
||
/* Later we can optimize certain cases by seeing that the target array can
|
||
take some number of values, and provide this number to _value_. */
|
||
|
||
if (rpt == 1)
|
||
ffedata_convert_cache_use_ = -1; /* Don't bother caching. */
|
||
else
|
||
ffedata_convert_cache_use_ = 0; /* Maybe use the cache. */
|
||
|
||
for (i = 0; i < rpt; ++i)
|
||
{
|
||
if ((ffedata_symbol_ != NULL)
|
||
&& !ffesymbol_is_init (ffedata_symbol_))
|
||
{
|
||
ffesymbol_signal_change (ffedata_symbol_);
|
||
ffesymbol_update_init (ffedata_symbol_);
|
||
if (1 || ffe_is_90 ())
|
||
ffesymbol_update_save (ffedata_symbol_);
|
||
#if FFEGLOBAL_ENABLED
|
||
if (ffesymbol_common (ffedata_symbol_) != NULL)
|
||
ffeglobal_init_common (ffesymbol_common (ffedata_symbol_),
|
||
token);
|
||
#endif
|
||
ffesymbol_signal_unreported (ffedata_symbol_);
|
||
}
|
||
if (!ffedata_value_ (value, token))
|
||
return FALSE;
|
||
}
|
||
|
||
return TRUE;
|
||
}
|
||
|
||
/* ffedata_advance_ -- Advance initialization target to next item in list
|
||
|
||
if (ffedata_advance_())
|
||
// everything's ok
|
||
|
||
Sets common info to characterize the next item in the list. Handles
|
||
IMPDO constructs accordingly. Does not handle advances within a single
|
||
item, as in the common extension "DATA CHARTYPE/33,34,35/", where
|
||
CHARTYPE is CHARACTER*3, for example. */
|
||
|
||
static bool
|
||
ffedata_advance_ ()
|
||
{
|
||
ffebld next;
|
||
|
||
/* Come here after handling an IMPDO. */
|
||
|
||
tail_recurse: /* :::::::::::::::::::: */
|
||
|
||
/* Assume we're not going to find a new target for now. */
|
||
|
||
ffedata_symbol_ = NULL;
|
||
|
||
/* If at the end of the list, we're done. */
|
||
|
||
if (ffedata_list_ == NULL)
|
||
{
|
||
ffetargetIntegerDefault newval;
|
||
|
||
if (ffedata_stack_ == NULL)
|
||
return TRUE; /* No IMPDO in progress, we is done! */
|
||
|
||
/* Iterate the IMPDO. */
|
||
|
||
newval = ffesymbol_value (ffedata_stack_->itervar)
|
||
+ ffedata_stack_->increment;
|
||
|
||
/* See if we're still in the loop. */
|
||
|
||
if (((ffedata_stack_->increment > 0)
|
||
? newval > ffedata_stack_->final
|
||
: newval < ffedata_stack_->final)
|
||
|| (((ffesymbol_value (ffedata_stack_->itervar) < 0)
|
||
== (ffedata_stack_->increment < 0))
|
||
&& ((ffesymbol_value (ffedata_stack_->itervar) < 0)
|
||
!= (newval < 0)))) /* Overflow/underflow? */
|
||
{ /* Done with the loop. */
|
||
ffedata_list_ = ffedata_stack_->outer_list; /* Restore list. */
|
||
ffedata_pop_ (); /* Pop me off the impdo stack. */
|
||
}
|
||
else
|
||
{ /* Still in the loop, reset the list and
|
||
update the iter var. */
|
||
ffedata_list_ = ffedata_stack_->my_list; /* Reset list. */
|
||
ffesymbol_set_value (ffedata_stack_->itervar, newval);
|
||
}
|
||
goto tail_recurse; /* :::::::::::::::::::: */
|
||
}
|
||
|
||
/* Move to the next item in the list. */
|
||
|
||
next = ffebld_head (ffedata_list_);
|
||
ffedata_list_ = ffebld_trail (ffedata_list_);
|
||
|
||
/* Really shouldn't happen. */
|
||
|
||
if (next == NULL)
|
||
return TRUE;
|
||
|
||
/* See what kind of target this is. */
|
||
|
||
switch (ffebld_op (next))
|
||
{
|
||
case FFEBLD_opSYMTER: /* Simple reference to scalar or array. */
|
||
ffedata_symbol_ = ffebld_symter (next);
|
||
ffedata_storage_ = (ffesymbol_storage (ffedata_symbol_) == NULL) ? NULL
|
||
: ffestorag_parent (ffesymbol_storage (ffedata_symbol_));
|
||
if (ffedata_storage_ != NULL)
|
||
{
|
||
ffetarget_aggregate_info (&ffedata_storage_bt_, &ffedata_storage_kt_,
|
||
&ffedata_storage_units_,
|
||
ffestorag_basictype (ffedata_storage_),
|
||
ffestorag_kindtype (ffedata_storage_));
|
||
ffedata_storage_size_ = ffestorag_size (ffedata_storage_)
|
||
/ ffedata_storage_units_;
|
||
assert (ffestorag_size (ffedata_storage_) % ffedata_storage_units_ == 0);
|
||
}
|
||
|
||
if ((ffesymbol_init (ffedata_symbol_) != NULL)
|
||
|| (ffesymbol_accretion (ffedata_symbol_) != NULL)
|
||
|| ((ffedata_storage_ != NULL)
|
||
&& (ffestorag_init (ffedata_storage_) != NULL)))
|
||
{
|
||
#if 0
|
||
ffebad_start (FFEBAD_DATA_REINIT);
|
||
ffest_ffebad_here_current_stmt (0);
|
||
ffebad_string (ffesymbol_text (ffedata_symbol_));
|
||
ffebad_finish ();
|
||
ffedata_reported_error_ = TRUE;
|
||
return FALSE;
|
||
#else
|
||
ffedata_reinit_ = TRUE;
|
||
return TRUE;
|
||
#endif
|
||
}
|
||
ffedata_basictype_ = ffesymbol_basictype (ffedata_symbol_);
|
||
ffedata_kindtype_ = ffesymbol_kindtype (ffedata_symbol_);
|
||
if (ffesymbol_rank (ffedata_symbol_) == 0)
|
||
ffedata_arraysize_ = 1;
|
||
else
|
||
{
|
||
ffebld size = ffesymbol_arraysize (ffedata_symbol_);
|
||
|
||
assert (size != NULL);
|
||
assert (ffebld_op (size) == FFEBLD_opCONTER);
|
||
assert (ffeinfo_basictype (ffebld_info (size))
|
||
== FFEINFO_basictypeINTEGER);
|
||
assert (ffeinfo_kindtype (ffebld_info (size))
|
||
== FFEINFO_kindtypeINTEGERDEFAULT);
|
||
ffedata_arraysize_ = ffebld_constant_integerdefault (ffebld_conter
|
||
(size));
|
||
}
|
||
ffedata_expected_ = ffedata_arraysize_;
|
||
ffedata_number_ = 0;
|
||
ffedata_offset_ = 0;
|
||
ffedata_size_ = (ffedata_basictype_ == FFEINFO_basictypeCHARACTER)
|
||
? ffesymbol_size (ffedata_symbol_) : 1;
|
||
ffedata_symbolsize_ = ffedata_size_ * ffedata_arraysize_;
|
||
ffedata_charexpected_ = ffedata_size_;
|
||
ffedata_charnumber_ = 0;
|
||
ffedata_charoffset_ = 0;
|
||
break;
|
||
|
||
case FFEBLD_opARRAYREF: /* Reference to element of array. */
|
||
ffedata_symbol_ = ffebld_symter (ffebld_left (next));
|
||
ffedata_storage_ = (ffesymbol_storage (ffedata_symbol_) == NULL) ? NULL
|
||
: ffestorag_parent (ffesymbol_storage (ffedata_symbol_));
|
||
if (ffedata_storage_ != NULL)
|
||
{
|
||
ffetarget_aggregate_info (&ffedata_storage_bt_, &ffedata_storage_kt_,
|
||
&ffedata_storage_units_,
|
||
ffestorag_basictype (ffedata_storage_),
|
||
ffestorag_kindtype (ffedata_storage_));
|
||
ffedata_storage_size_ = ffestorag_size (ffedata_storage_)
|
||
/ ffedata_storage_units_;
|
||
assert (ffestorag_size (ffedata_storage_) % ffedata_storage_units_ == 0);
|
||
}
|
||
|
||
if ((ffesymbol_init (ffedata_symbol_) != NULL)
|
||
|| ((ffedata_storage_ != NULL)
|
||
&& (ffestorag_init (ffedata_storage_) != NULL)))
|
||
{
|
||
#if 0
|
||
ffebad_start (FFEBAD_DATA_REINIT);
|
||
ffest_ffebad_here_current_stmt (0);
|
||
ffebad_string (ffesymbol_text (ffedata_symbol_));
|
||
ffebad_finish ();
|
||
ffedata_reported_error_ = TRUE;
|
||
return FALSE;
|
||
#else
|
||
ffedata_reinit_ = TRUE;
|
||
return TRUE;
|
||
#endif
|
||
}
|
||
ffedata_basictype_ = ffesymbol_basictype (ffedata_symbol_);
|
||
ffedata_kindtype_ = ffesymbol_kindtype (ffedata_symbol_);
|
||
if (ffesymbol_rank (ffedata_symbol_) == 0)
|
||
ffedata_arraysize_ = 1; /* Shouldn't happen in this case... */
|
||
else
|
||
{
|
||
ffebld size = ffesymbol_arraysize (ffedata_symbol_);
|
||
|
||
assert (size != NULL);
|
||
assert (ffebld_op (size) == FFEBLD_opCONTER);
|
||
assert (ffeinfo_basictype (ffebld_info (size))
|
||
== FFEINFO_basictypeINTEGER);
|
||
assert (ffeinfo_kindtype (ffebld_info (size))
|
||
== FFEINFO_kindtypeINTEGERDEFAULT);
|
||
ffedata_arraysize_ = ffebld_constant_integerdefault (ffebld_conter
|
||
(size));
|
||
}
|
||
ffedata_expected_ = 1;
|
||
ffedata_number_ = 0;
|
||
ffedata_offset_ = ffedata_eval_offset_ (ffebld_right (next),
|
||
ffesymbol_dims (ffedata_symbol_));
|
||
ffedata_size_ = (ffedata_basictype_ == FFEINFO_basictypeCHARACTER)
|
||
? ffesymbol_size (ffedata_symbol_) : 1;
|
||
ffedata_symbolsize_ = ffedata_size_ * ffedata_arraysize_;
|
||
ffedata_charexpected_ = ffedata_size_;
|
||
ffedata_charnumber_ = 0;
|
||
ffedata_charoffset_ = 0;
|
||
break;
|
||
|
||
case FFEBLD_opSUBSTR: /* Substring reference to scalar or array
|
||
element. */
|
||
{
|
||
bool arrayref = ffebld_op (ffebld_left (next)) == FFEBLD_opARRAYREF;
|
||
ffebld colon = ffebld_right (next);
|
||
|
||
assert (colon != NULL);
|
||
|
||
ffedata_symbol_ = ffebld_symter (ffebld_left (arrayref
|
||
? ffebld_left (next) : next));
|
||
ffedata_storage_ = (ffesymbol_storage (ffedata_symbol_) == NULL) ? NULL
|
||
: ffestorag_parent (ffesymbol_storage (ffedata_symbol_));
|
||
if (ffedata_storage_ != NULL)
|
||
{
|
||
ffetarget_aggregate_info (&ffedata_storage_bt_, &ffedata_storage_kt_,
|
||
&ffedata_storage_units_,
|
||
ffestorag_basictype (ffedata_storage_),
|
||
ffestorag_kindtype (ffedata_storage_));
|
||
ffedata_storage_size_ = ffestorag_size (ffedata_storage_)
|
||
/ ffedata_storage_units_;
|
||
assert (ffestorag_size (ffedata_storage_) % ffedata_storage_units_ == 0);
|
||
}
|
||
|
||
if ((ffesymbol_init (ffedata_symbol_) != NULL)
|
||
|| ((ffedata_storage_ != NULL)
|
||
&& (ffestorag_init (ffedata_storage_) != NULL)))
|
||
{
|
||
#if 0
|
||
ffebad_start (FFEBAD_DATA_REINIT);
|
||
ffest_ffebad_here_current_stmt (0);
|
||
ffebad_string (ffesymbol_text (ffedata_symbol_));
|
||
ffebad_finish ();
|
||
ffedata_reported_error_ = TRUE;
|
||
return FALSE;
|
||
#else
|
||
ffedata_reinit_ = TRUE;
|
||
return TRUE;
|
||
#endif
|
||
}
|
||
ffedata_basictype_ = ffesymbol_basictype (ffedata_symbol_);
|
||
ffedata_kindtype_ = ffesymbol_kindtype (ffedata_symbol_);
|
||
if (ffesymbol_rank (ffedata_symbol_) == 0)
|
||
ffedata_arraysize_ = 1;
|
||
else
|
||
{
|
||
ffebld size = ffesymbol_arraysize (ffedata_symbol_);
|
||
|
||
assert (size != NULL);
|
||
assert (ffebld_op (size) == FFEBLD_opCONTER);
|
||
assert (ffeinfo_basictype (ffebld_info (size))
|
||
== FFEINFO_basictypeINTEGER);
|
||
assert (ffeinfo_kindtype (ffebld_info (size))
|
||
== FFEINFO_kindtypeINTEGERDEFAULT);
|
||
ffedata_arraysize_ = ffebld_constant_integerdefault (ffebld_conter
|
||
(size));
|
||
}
|
||
ffedata_expected_ = arrayref ? 1 : ffedata_arraysize_;
|
||
ffedata_number_ = 0;
|
||
ffedata_offset_ = arrayref ? ffedata_eval_offset_ (ffebld_right
|
||
(ffebld_left (next)), ffesymbol_dims (ffedata_symbol_)) : 0;
|
||
ffedata_size_ = ffesymbol_size (ffedata_symbol_);
|
||
ffedata_symbolsize_ = ffedata_size_ * ffedata_arraysize_;
|
||
ffedata_charnumber_ = 0;
|
||
ffedata_charoffset_ = ffedata_eval_substr_begin_ (ffebld_head (colon));
|
||
ffedata_charexpected_ = ffedata_eval_substr_end_ (ffebld_head
|
||
(ffebld_trail (colon)), ffedata_charoffset_,
|
||
ffedata_size_) - ffedata_charoffset_ + 1;
|
||
}
|
||
break;
|
||
|
||
case FFEBLD_opIMPDO: /* Implied-DO construct. */
|
||
{
|
||
ffebld itervar;
|
||
ffebld start;
|
||
ffebld end;
|
||
ffebld incr;
|
||
ffebld item = ffebld_right (next);
|
||
|
||
itervar = ffebld_head (item);
|
||
item = ffebld_trail (item);
|
||
start = ffebld_head (item);
|
||
item = ffebld_trail (item);
|
||
end = ffebld_head (item);
|
||
item = ffebld_trail (item);
|
||
incr = ffebld_head (item);
|
||
|
||
ffedata_push_ ();
|
||
ffedata_stack_->outer_list = ffedata_list_;
|
||
ffedata_stack_->my_list = ffedata_list_ = ffebld_left (next);
|
||
|
||
assert (ffeinfo_basictype (ffebld_info (itervar))
|
||
== FFEINFO_basictypeINTEGER);
|
||
assert (ffeinfo_kindtype (ffebld_info (itervar))
|
||
== FFEINFO_kindtypeINTEGERDEFAULT);
|
||
ffedata_stack_->itervar = ffebld_symter (itervar);
|
||
if (ffeinfo_basictype (ffebld_info (start)) != FFEINFO_basictypeINTEGER)
|
||
{
|
||
ffebad_start (FFEBAD_DATA_EVAL);
|
||
ffest_ffebad_here_current_stmt (0);
|
||
ffebad_finish ();
|
||
ffedata_pop_ ();
|
||
ffedata_reported_error_ = TRUE;
|
||
return FALSE;
|
||
}
|
||
assert (ffeinfo_basictype (ffebld_info (start))
|
||
== FFEINFO_basictypeINTEGER);
|
||
assert (ffeinfo_kindtype (ffebld_info (start))
|
||
== FFEINFO_kindtypeINTEGERDEFAULT);
|
||
ffesymbol_set_value (ffedata_stack_->itervar, ffedata_eval_integer1_ (start));
|
||
if (ffeinfo_basictype (ffebld_info (end)) != FFEINFO_basictypeINTEGER)
|
||
{
|
||
ffebad_start (FFEBAD_DATA_EVAL);
|
||
ffest_ffebad_here_current_stmt (0);
|
||
ffebad_finish ();
|
||
ffedata_pop_ ();
|
||
ffedata_reported_error_ = TRUE;
|
||
return FALSE;
|
||
}
|
||
assert (ffeinfo_basictype (ffebld_info (end))
|
||
== FFEINFO_basictypeINTEGER);
|
||
assert (ffeinfo_kindtype (ffebld_info (end))
|
||
== FFEINFO_kindtypeINTEGERDEFAULT);
|
||
ffedata_stack_->final = ffedata_eval_integer1_ (end);
|
||
|
||
if (incr == NULL)
|
||
ffedata_stack_->increment = 1;
|
||
else
|
||
{
|
||
if (ffeinfo_basictype (ffebld_info (incr)) != FFEINFO_basictypeINTEGER)
|
||
{
|
||
ffebad_start (FFEBAD_DATA_EVAL);
|
||
ffest_ffebad_here_current_stmt (0);
|
||
ffebad_finish ();
|
||
ffedata_pop_ ();
|
||
ffedata_reported_error_ = TRUE;
|
||
return FALSE;
|
||
}
|
||
assert (ffeinfo_basictype (ffebld_info (incr))
|
||
== FFEINFO_basictypeINTEGER);
|
||
assert (ffeinfo_kindtype (ffebld_info (incr))
|
||
== FFEINFO_kindtypeINTEGERDEFAULT);
|
||
ffedata_stack_->increment = ffedata_eval_integer1_ (incr);
|
||
if (ffedata_stack_->increment == 0)
|
||
{
|
||
ffebad_start (FFEBAD_DATA_ZERO);
|
||
ffest_ffebad_here_current_stmt (0);
|
||
ffebad_string (ffesymbol_text (ffedata_stack_->itervar));
|
||
ffebad_finish ();
|
||
ffedata_pop_ ();
|
||
ffedata_reported_error_ = TRUE;
|
||
return FALSE;
|
||
}
|
||
}
|
||
|
||
if ((ffedata_stack_->increment > 0)
|
||
? ffesymbol_value (ffedata_stack_->itervar)
|
||
> ffedata_stack_->final
|
||
: ffesymbol_value (ffedata_stack_->itervar)
|
||
< ffedata_stack_->final)
|
||
{
|
||
ffedata_reported_error_ = TRUE;
|
||
ffebad_start (FFEBAD_DATA_EMPTY);
|
||
ffest_ffebad_here_current_stmt (0);
|
||
ffebad_string (ffesymbol_text (ffedata_stack_->itervar));
|
||
ffebad_finish ();
|
||
ffedata_pop_ ();
|
||
return FALSE;
|
||
}
|
||
}
|
||
goto tail_recurse; /* :::::::::::::::::::: */
|
||
|
||
case FFEBLD_opANY:
|
||
ffedata_reported_error_ = TRUE;
|
||
return FALSE;
|
||
|
||
default:
|
||
assert ("bad op" == NULL);
|
||
break;
|
||
}
|
||
|
||
return TRUE;
|
||
}
|
||
|
||
/* ffedata_convert_ -- Convert source expression to given type using cache
|
||
|
||
ffebld source;
|
||
ffelexToken source_token;
|
||
ffelexToken dest_token; // Any appropriate token for "destination".
|
||
ffeinfoBasictype bt;
|
||
ffeinfoKindtype kt;
|
||
ffetargetCharactersize sz;
|
||
source = ffedata_convert_(source,source_token,dest_token,bt,kt,sz);
|
||
|
||
Like ffeexpr_convert, but calls it only if necessary (if the converted
|
||
expression doesn't already exist in the cache) and then puts the result
|
||
in the cache. */
|
||
|
||
static ffebld
|
||
ffedata_convert_ (ffebld source, ffelexToken source_token,
|
||
ffelexToken dest_token, ffeinfoBasictype bt,
|
||
ffeinfoKindtype kt, ffeinfoRank rk,
|
||
ffetargetCharacterSize sz)
|
||
{
|
||
ffebld converted;
|
||
int i;
|
||
int max;
|
||
ffedataConvertCache_ cache;
|
||
|
||
for (i = 0; i < ffedata_convert_cache_use_; ++i)
|
||
if ((bt == ffedata_convert_cache_[i].basic_type)
|
||
&& (kt == ffedata_convert_cache_[i].kind_type)
|
||
&& (sz == ffedata_convert_cache_[i].size)
|
||
&& (rk == ffedata_convert_cache_[i].rank))
|
||
return ffedata_convert_cache_[i].converted;
|
||
|
||
converted = ffeexpr_convert (source, source_token, dest_token, bt, kt, rk,
|
||
sz, FFEEXPR_contextDATA);
|
||
|
||
if (ffedata_convert_cache_use_ >= ffedata_convert_cache_max_)
|
||
{
|
||
if (ffedata_convert_cache_max_ == 0)
|
||
max = 4;
|
||
else
|
||
max = ffedata_convert_cache_max_ << 1;
|
||
|
||
if (max > ffedata_convert_cache_max_)
|
||
{
|
||
cache = (ffedataConvertCache_) malloc_new_ks (malloc_pool_image (),
|
||
"FFEDATA cache", max * sizeof (*cache));
|
||
if (ffedata_convert_cache_max_ != 0)
|
||
{
|
||
memcpy (cache, ffedata_convert_cache_,
|
||
ffedata_convert_cache_max_ * sizeof (*cache));
|
||
malloc_kill_ks (malloc_pool_image (), ffedata_convert_cache_,
|
||
ffedata_convert_cache_max_ * sizeof (*cache));
|
||
}
|
||
ffedata_convert_cache_ = cache;
|
||
ffedata_convert_cache_max_ = max;
|
||
}
|
||
else
|
||
return converted; /* In case int overflows! */
|
||
}
|
||
|
||
i = ffedata_convert_cache_use_++;
|
||
|
||
ffedata_convert_cache_[i].converted = converted;
|
||
ffedata_convert_cache_[i].basic_type = bt;
|
||
ffedata_convert_cache_[i].kind_type = kt;
|
||
ffedata_convert_cache_[i].size = sz;
|
||
ffedata_convert_cache_[i].rank = rk;
|
||
|
||
return converted;
|
||
}
|
||
|
||
/* ffedata_eval_integer1_ -- Evaluate expression
|
||
|
||
ffetargetIntegerDefault result;
|
||
ffebld expr; // must be kindtypeINTEGER1.
|
||
|
||
result = ffedata_eval_integer1_(expr);
|
||
|
||
Evalues the expression (which yields a kindtypeINTEGER1 result) and
|
||
returns the result. */
|
||
|
||
static ffetargetIntegerDefault
|
||
ffedata_eval_integer1_ (ffebld expr)
|
||
{
|
||
ffetargetInteger1 result;
|
||
ffebad error;
|
||
|
||
assert (expr != NULL);
|
||
|
||
switch (ffebld_op (expr))
|
||
{
|
||
case FFEBLD_opCONTER:
|
||
return ffebld_constant_integer1 (ffebld_conter (expr));
|
||
|
||
case FFEBLD_opSYMTER:
|
||
return ffesymbol_value (ffebld_symter (expr));
|
||
|
||
case FFEBLD_opUPLUS:
|
||
return ffedata_eval_integer1_ (ffebld_left (expr));
|
||
|
||
case FFEBLD_opUMINUS:
|
||
error = ffetarget_uminus_integer1 (&result,
|
||
ffedata_eval_integer1_ (ffebld_left (expr)));
|
||
break;
|
||
|
||
case FFEBLD_opADD:
|
||
error = ffetarget_add_integer1 (&result,
|
||
ffedata_eval_integer1_ (ffebld_left (expr)),
|
||
ffedata_eval_integer1_ (ffebld_right (expr)));
|
||
break;
|
||
|
||
case FFEBLD_opSUBTRACT:
|
||
error = ffetarget_subtract_integer1 (&result,
|
||
ffedata_eval_integer1_ (ffebld_left (expr)),
|
||
ffedata_eval_integer1_ (ffebld_right (expr)));
|
||
break;
|
||
|
||
case FFEBLD_opMULTIPLY:
|
||
error = ffetarget_multiply_integer1 (&result,
|
||
ffedata_eval_integer1_ (ffebld_left (expr)),
|
||
ffedata_eval_integer1_ (ffebld_right (expr)));
|
||
break;
|
||
|
||
case FFEBLD_opDIVIDE:
|
||
error = ffetarget_divide_integer1 (&result,
|
||
ffedata_eval_integer1_ (ffebld_left (expr)),
|
||
ffedata_eval_integer1_ (ffebld_right (expr)));
|
||
break;
|
||
|
||
case FFEBLD_opPOWER:
|
||
{
|
||
ffebld r = ffebld_right (expr);
|
||
|
||
if ((ffeinfo_basictype (ffebld_info (r)) != FFEINFO_basictypeINTEGER)
|
||
|| (ffeinfo_kindtype (ffebld_info (r)) != FFEINFO_kindtypeINTEGERDEFAULT))
|
||
error = FFEBAD_DATA_EVAL;
|
||
else
|
||
error = ffetarget_power_integerdefault_integerdefault (&result,
|
||
ffedata_eval_integer1_ (ffebld_left (expr)),
|
||
ffedata_eval_integer1_ (r));
|
||
}
|
||
break;
|
||
|
||
#if 0 /* Only for character basictype. */
|
||
case FFEBLD_opCONCATENATE:
|
||
error =;
|
||
break;
|
||
#endif
|
||
|
||
case FFEBLD_opNOT:
|
||
error = ffetarget_not_integer1 (&result,
|
||
ffedata_eval_integer1_ (ffebld_left (expr)));
|
||
break;
|
||
|
||
#if 0 /* Only for logical basictype. */
|
||
case FFEBLD_opLT:
|
||
error =;
|
||
break;
|
||
|
||
case FFEBLD_opLE:
|
||
error =;
|
||
break;
|
||
|
||
case FFEBLD_opEQ:
|
||
error =;
|
||
break;
|
||
|
||
case FFEBLD_opNE:
|
||
error =;
|
||
break;
|
||
|
||
case FFEBLD_opGT:
|
||
error =;
|
||
break;
|
||
|
||
case FFEBLD_opGE:
|
||
error =;
|
||
break;
|
||
#endif
|
||
|
||
case FFEBLD_opAND:
|
||
error = ffetarget_and_integer1 (&result,
|
||
ffedata_eval_integer1_ (ffebld_left (expr)),
|
||
ffedata_eval_integer1_ (ffebld_right (expr)));
|
||
break;
|
||
|
||
case FFEBLD_opOR:
|
||
error = ffetarget_or_integer1 (&result,
|
||
ffedata_eval_integer1_ (ffebld_left (expr)),
|
||
ffedata_eval_integer1_ (ffebld_right (expr)));
|
||
break;
|
||
|
||
case FFEBLD_opXOR:
|
||
error = ffetarget_xor_integer1 (&result,
|
||
ffedata_eval_integer1_ (ffebld_left (expr)),
|
||
ffedata_eval_integer1_ (ffebld_right (expr)));
|
||
break;
|
||
|
||
case FFEBLD_opEQV:
|
||
error = ffetarget_eqv_integer1 (&result,
|
||
ffedata_eval_integer1_ (ffebld_left (expr)),
|
||
ffedata_eval_integer1_ (ffebld_right (expr)));
|
||
break;
|
||
|
||
case FFEBLD_opNEQV:
|
||
error = ffetarget_neqv_integer1 (&result,
|
||
ffedata_eval_integer1_ (ffebld_left (expr)),
|
||
ffedata_eval_integer1_ (ffebld_right (expr)));
|
||
break;
|
||
|
||
case FFEBLD_opPAREN:
|
||
return ffedata_eval_integer1_ (ffebld_left (expr));
|
||
|
||
#if 0 /* ~~ no idea how to do this */
|
||
case FFEBLD_opPERCENT_LOC:
|
||
error =;
|
||
break;
|
||
#endif
|
||
|
||
#if 0 /* not allowed by ANSI, but perhaps as an
|
||
extension someday? */
|
||
case FFEBLD_opCONVERT:
|
||
switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr))))
|
||
{
|
||
case FFEINFO_basictypeINTEGER:
|
||
switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
|
||
{
|
||
default:
|
||
error = FFEBAD_DATA_EVAL;
|
||
break;
|
||
}
|
||
break;
|
||
|
||
case FFEINFO_basictypeREAL:
|
||
switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
|
||
{
|
||
default:
|
||
error = FFEBAD_DATA_EVAL;
|
||
break;
|
||
}
|
||
break;
|
||
}
|
||
break;
|
||
#endif
|
||
|
||
#if 0 /* not valid ops */
|
||
case FFEBLD_opREPEAT:
|
||
error =;
|
||
break;
|
||
|
||
case FFEBLD_opBOUNDS:
|
||
error =;
|
||
break;
|
||
#endif
|
||
|
||
#if 0 /* not allowed by ANSI, but perhaps as an
|
||
extension someday? */
|
||
case FFEBLD_opFUNCREF:
|
||
error =;
|
||
break;
|
||
#endif
|
||
|
||
#if 0 /* not valid ops */
|
||
case FFEBLD_opSUBRREF:
|
||
error =;
|
||
break;
|
||
|
||
case FFEBLD_opARRAYREF:
|
||
error =;
|
||
break;
|
||
#endif
|
||
|
||
#if 0 /* not valid for integer1 */
|
||
case FFEBLD_opSUBSTR:
|
||
error =;
|
||
break;
|
||
#endif
|
||
|
||
default:
|
||
error = FFEBAD_DATA_EVAL;
|
||
break;
|
||
}
|
||
|
||
if (error != FFEBAD)
|
||
{
|
||
ffebad_start (error);
|
||
ffest_ffebad_here_current_stmt (0);
|
||
ffebad_finish ();
|
||
result = 0;
|
||
}
|
||
|
||
return result;
|
||
}
|
||
|
||
/* ffedata_eval_offset_ -- Evaluate offset info array
|
||
|
||
ffetargetOffset offset; // 0...max-1.
|
||
ffebld subscripts; // an opITEM list of subscript exprs.
|
||
ffebld dims; // an opITEM list of opBOUNDS exprs.
|
||
|
||
result = ffedata_eval_offset_(expr);
|
||
|
||
Evalues the expression (which yields a kindtypeINTEGER1 result) and
|
||
returns the result. */
|
||
|
||
static ffetargetOffset
|
||
ffedata_eval_offset_ (ffebld subscripts, ffebld dims)
|
||
{
|
||
ffetargetIntegerDefault offset = 0;
|
||
ffetargetIntegerDefault width = 1;
|
||
ffetargetIntegerDefault value;
|
||
ffetargetIntegerDefault lowbound;
|
||
ffetargetIntegerDefault highbound;
|
||
ffetargetOffset final;
|
||
ffebld subscript;
|
||
ffebld dim;
|
||
ffebld low;
|
||
ffebld high;
|
||
int rank = 0;
|
||
bool ok;
|
||
|
||
while (subscripts != NULL)
|
||
{
|
||
ffeinfoKindtype sub_kind, low_kind, hi_kind;
|
||
ffebld sub1, low1, hi1;
|
||
|
||
++rank;
|
||
assert (dims != NULL);
|
||
|
||
subscript = ffebld_head (subscripts);
|
||
dim = ffebld_head (dims);
|
||
|
||
assert (ffeinfo_basictype (ffebld_info (subscript)) == FFEINFO_basictypeINTEGER);
|
||
if (ffebld_op (subscript) == FFEBLD_opCONTER)
|
||
{
|
||
/* Force to default - it's a constant expression ! */
|
||
sub_kind = ffeinfo_kindtype (ffebld_info (subscript));
|
||
sub1 = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val (
|
||
sub_kind == FFEINFO_kindtypeINTEGER2 ? subscript->u.conter.expr->u.integer2 :
|
||
sub_kind == FFEINFO_kindtypeINTEGER3 ? subscript->u.conter.expr->u.integer3 :
|
||
sub_kind == FFEINFO_kindtypeINTEGER4 ? subscript->u.conter.expr->u.integer4 :
|
||
subscript->u.conter.expr->u.integer1), NULL);
|
||
value = ffedata_eval_integer1_ (sub1);
|
||
}
|
||
else
|
||
value = ffedata_eval_integer1_ (subscript);
|
||
|
||
assert (ffebld_op (dim) == FFEBLD_opBOUNDS);
|
||
low = ffebld_left (dim);
|
||
high = ffebld_right (dim);
|
||
|
||
if (low == NULL)
|
||
lowbound = 1;
|
||
else
|
||
{
|
||
assert (ffeinfo_basictype (ffebld_info (low)) == FFEINFO_basictypeINTEGER);
|
||
if (ffebld_op (low) == FFEBLD_opCONTER)
|
||
{
|
||
/* Force to default - it's a constant expression ! */
|
||
low_kind = ffeinfo_kindtype (ffebld_info (low));
|
||
low1 = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val (
|
||
low_kind == FFEINFO_kindtypeINTEGER2 ? low->u.conter.expr->u.integer2 :
|
||
low_kind == FFEINFO_kindtypeINTEGER3 ? low->u.conter.expr->u.integer3 :
|
||
low_kind == FFEINFO_kindtypeINTEGER4 ? low->u.conter.expr->u.integer4 :
|
||
low->u.conter.expr->u.integer1), NULL);
|
||
lowbound = ffedata_eval_integer1_ (low1);
|
||
}
|
||
else
|
||
lowbound = ffedata_eval_integer1_ (low);
|
||
}
|
||
|
||
assert (ffeinfo_basictype (ffebld_info (high)) == FFEINFO_basictypeINTEGER);
|
||
if (ffebld_op (high) == FFEBLD_opCONTER)
|
||
{
|
||
/* Force to default - it's a constant expression ! */
|
||
hi_kind = ffeinfo_kindtype (ffebld_info (high));
|
||
hi1 = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val (
|
||
hi_kind == FFEINFO_kindtypeINTEGER2 ? high->u.conter.expr->u.integer2 :
|
||
hi_kind == FFEINFO_kindtypeINTEGER3 ? high->u.conter.expr->u.integer3 :
|
||
hi_kind == FFEINFO_kindtypeINTEGER4 ? high->u.conter.expr->u.integer4 :
|
||
high->u.conter.expr->u.integer1), NULL);
|
||
highbound = ffedata_eval_integer1_ (hi1);
|
||
}
|
||
else
|
||
highbound = ffedata_eval_integer1_ (high);
|
||
|
||
if ((value < lowbound) || (value > highbound))
|
||
{
|
||
char rankstr[10];
|
||
|
||
sprintf (rankstr, "%d", rank);
|
||
value = lowbound;
|
||
ffebad_start (FFEBAD_DATA_SUBSCRIPT);
|
||
ffebad_string (ffesymbol_text (ffedata_symbol_));
|
||
ffebad_string (rankstr);
|
||
ffebad_finish ();
|
||
}
|
||
|
||
subscripts = ffebld_trail (subscripts);
|
||
dims = ffebld_trail (dims);
|
||
|
||
offset += width * (value - lowbound);
|
||
if (subscripts != NULL)
|
||
width *= highbound - lowbound + 1;
|
||
}
|
||
|
||
assert (dims == NULL);
|
||
|
||
ok = ffetarget_offset (&final, offset);
|
||
assert (ok);
|
||
|
||
return final;
|
||
}
|
||
|
||
/* ffedata_eval_substr_begin_ -- Evaluate begin-point of substr reference
|
||
|
||
ffetargetCharacterSize beginpoint;
|
||
ffebld endval; // head(colon).
|
||
|
||
beginpoint = ffedata_eval_substr_end_(endval);
|
||
|
||
If beginval is NULL, returns 0. Otherwise makes sure beginval is
|
||
kindtypeINTEGERDEFAULT, makes sure its value is > 0,
|
||
and returns its value minus one, or issues an error message. */
|
||
|
||
static ffetargetCharacterSize
|
||
ffedata_eval_substr_begin_ (ffebld expr)
|
||
{
|
||
ffetargetIntegerDefault val;
|
||
|
||
if (expr == NULL)
|
||
return 0;
|
||
|
||
assert (ffeinfo_basictype (ffebld_info (expr)) == FFEINFO_basictypeINTEGER);
|
||
assert (ffeinfo_kindtype (ffebld_info (expr)) == FFEINFO_kindtypeINTEGERDEFAULT);
|
||
|
||
val = ffedata_eval_integer1_ (expr);
|
||
|
||
if (val < 1)
|
||
{
|
||
val = 1;
|
||
ffebad_start (FFEBAD_DATA_RANGE);
|
||
ffest_ffebad_here_current_stmt (0);
|
||
ffebad_string (ffesymbol_text (ffedata_symbol_));
|
||
ffebad_finish ();
|
||
ffedata_reported_error_ = TRUE;
|
||
}
|
||
|
||
return val - 1;
|
||
}
|
||
|
||
/* ffedata_eval_substr_end_ -- Evaluate end-point of substr reference
|
||
|
||
ffetargetCharacterSize endpoint;
|
||
ffebld endval; // head(trail(colon)).
|
||
ffetargetCharacterSize min; // beginpoint of substr reference.
|
||
ffetargetCharacterSize max; // size of entity.
|
||
|
||
endpoint = ffedata_eval_substr_end_(endval,dflt);
|
||
|
||
If endval is NULL, returns max. Otherwise makes sure endval is
|
||
kindtypeINTEGERDEFAULT, makes sure its value is > min and <= max,
|
||
and returns its value minus one, or issues an error message. */
|
||
|
||
static ffetargetCharacterSize
|
||
ffedata_eval_substr_end_ (ffebld expr, ffetargetCharacterSize min,
|
||
ffetargetCharacterSize max)
|
||
{
|
||
ffetargetIntegerDefault val;
|
||
|
||
if (expr == NULL)
|
||
return max - 1;
|
||
|
||
assert (ffeinfo_basictype (ffebld_info (expr)) == FFEINFO_basictypeINTEGER);
|
||
assert (ffeinfo_kindtype (ffebld_info (expr)) == FFEINFO_kindtypeINTEGER1);
|
||
|
||
val = ffedata_eval_integer1_ (expr);
|
||
|
||
if ((val < (ffetargetIntegerDefault) min)
|
||
|| (val > (ffetargetIntegerDefault) max))
|
||
{
|
||
val = 1;
|
||
ffebad_start (FFEBAD_DATA_RANGE);
|
||
ffest_ffebad_here_current_stmt (0);
|
||
ffebad_string (ffesymbol_text (ffedata_symbol_));
|
||
ffebad_finish ();
|
||
ffedata_reported_error_ = TRUE;
|
||
}
|
||
|
||
return val - 1;
|
||
}
|
||
|
||
/* ffedata_gather_ -- Gather initial values for sym into master sym inits
|
||
|
||
ffestorag mst; // A typeCBLOCK or typeLOCAL aggregate.
|
||
ffestorag st; // A typeCOMMON or typeEQUIV member.
|
||
ffedata_gather_(mst,st);
|
||
|
||
If st has any initialization info, transfer that info into mst and
|
||
clear st's info. */
|
||
|
||
static void
|
||
ffedata_gather_ (ffestorag mst, ffestorag st)
|
||
{
|
||
ffesymbol s;
|
||
ffesymbol s_whine; /* Symbol to complain about in diagnostics. */
|
||
ffebld b;
|
||
ffetargetOffset offset;
|
||
ffetargetOffset units_expected;
|
||
ffebitCount actual;
|
||
ffebldConstantArray array;
|
||
ffebld accter;
|
||
ffetargetCopyfunc fn;
|
||
void *ptr1;
|
||
void *ptr2;
|
||
size_t size;
|
||
ffeinfoBasictype bt;
|
||
ffeinfoKindtype kt;
|
||
ffeinfoBasictype ign_bt;
|
||
ffeinfoKindtype ign_kt;
|
||
ffetargetAlign units;
|
||
ffebit bits;
|
||
ffetargetOffset source_offset;
|
||
bool whine = FALSE;
|
||
|
||
if (st == NULL)
|
||
return; /* Nothing to do. */
|
||
|
||
s = ffestorag_symbol (st);
|
||
|
||
assert (s != NULL); /* Must have a corresponding symbol (else how
|
||
inited?). */
|
||
assert (ffestorag_init (st) == NULL); /* No init info on storage itself. */
|
||
assert (ffestorag_accretion (st) == NULL);
|
||
|
||
if ((((b = ffesymbol_init (s)) == NULL)
|
||
&& ((b = ffesymbol_accretion (s)) == NULL))
|
||
|| (ffebld_op (b) == FFEBLD_opANY)
|
||
|| ((ffebld_op (b) == FFEBLD_opCONVERT)
|
||
&& (ffebld_op (ffebld_left (b)) == FFEBLD_opANY)))
|
||
return; /* Nothing to do. */
|
||
|
||
/* b now holds the init/accretion expr. */
|
||
|
||
ffesymbol_set_init (s, NULL);
|
||
ffesymbol_set_accretion (s, NULL);
|
||
ffesymbol_set_accretes (s, 0);
|
||
|
||
s_whine = ffestorag_symbol (mst);
|
||
if (s_whine == NULL)
|
||
s_whine = s;
|
||
|
||
/* Make sure we haven't fully accreted during an array init. */
|
||
|
||
if (ffestorag_init (mst) != NULL)
|
||
{
|
||
ffebad_start (FFEBAD_DATA_MULTIPLE);
|
||
ffebad_here (0, ffewhere_line_unknown (), ffewhere_column_unknown ());
|
||
ffebad_string (ffesymbol_text (s_whine));
|
||
ffebad_finish ();
|
||
return;
|
||
}
|
||
|
||
bt = ffeinfo_basictype (ffebld_info (b));
|
||
kt = ffeinfo_kindtype (ffebld_info (b));
|
||
|
||
/* Calculate offset for aggregate area. */
|
||
|
||
ffedata_charexpected_ = (bt == FFEINFO_basictypeCHARACTER)
|
||
? ffebld_size (b) : 1;
|
||
ffetarget_aggregate_info (&ign_bt, &ign_kt, &units, bt,
|
||
kt);/* Find out unit size of source datum. */
|
||
assert (units % ffedata_storage_units_ == 0);
|
||
units_expected = ffedata_charexpected_ * units / ffedata_storage_units_;
|
||
offset = (ffestorag_offset (st) - ffestorag_offset (mst))
|
||
/ ffedata_storage_units_;
|
||
|
||
/* Does an accretion array exist? If not, create it. */
|
||
|
||
if (ffestorag_accretion (mst) == NULL)
|
||
{
|
||
#if FFEDATA_sizeTOO_BIG_INIT_ != 0
|
||
if (ffedata_storage_size_ >= FFEDATA_sizeTOO_BIG_INIT_)
|
||
{
|
||
char bignum[40];
|
||
|
||
sprintf (&bignum[0], "%ld", (long) ffedata_storage_size_);
|
||
ffebad_start (FFEBAD_TOO_BIG_INIT);
|
||
ffebad_here (0, ffesymbol_where_line (s_whine),
|
||
ffesymbol_where_column (s_whine));
|
||
ffebad_string (ffesymbol_text (s_whine));
|
||
ffebad_string (bignum);
|
||
ffebad_finish ();
|
||
}
|
||
#endif
|
||
array = ffebld_constantarray_new (ffedata_storage_bt_,
|
||
ffedata_storage_kt_, ffedata_storage_size_);
|
||
accter = ffebld_new_accter (array, ffebit_new (ffe_pool_program_unit (),
|
||
ffedata_storage_size_));
|
||
ffebld_set_info (accter, ffeinfo_new
|
||
(ffedata_storage_bt_,
|
||
ffedata_storage_kt_,
|
||
1,
|
||
FFEINFO_kindENTITY,
|
||
FFEINFO_whereCONSTANT,
|
||
(ffedata_basictype_ == FFEINFO_basictypeCHARACTER)
|
||
? 1 : FFETARGET_charactersizeNONE));
|
||
ffestorag_set_accretion (mst, accter);
|
||
ffestorag_set_accretes (mst, ffedata_storage_size_);
|
||
}
|
||
else
|
||
{
|
||
accter = ffestorag_accretion (mst);
|
||
assert (ffedata_storage_size_ == (ffetargetOffset) ffebld_accter_size (accter));
|
||
array = ffebld_accter (accter);
|
||
}
|
||
|
||
/* Put value in accretion array at desired offset. */
|
||
|
||
fn = ffetarget_aggregate_ptr_memcpy (ffedata_storage_bt_, ffedata_storage_kt_,
|
||
bt, kt);
|
||
|
||
switch (ffebld_op (b))
|
||
{
|
||
case FFEBLD_opCONTER:
|
||
ffebld_constantarray_prepare (&ptr1, &ptr2, &size, array, ffedata_storage_bt_,
|
||
ffedata_storage_kt_, offset,
|
||
ffebld_constant_ptr_to_union (ffebld_conter (b)),
|
||
bt, kt);
|
||
(*fn) (ptr1, ptr2, size); /* Does the appropriate memcpy-like
|
||
operation. */
|
||
ffebit_count (ffebld_accter_bits (accter),
|
||
offset, FALSE, units_expected, &actual); /* How many FALSE? */
|
||
if (units_expected != (ffetargetOffset) actual)
|
||
{
|
||
ffebad_start (FFEBAD_DATA_MULTIPLE);
|
||
ffebad_here (0, ffewhere_line_unknown (), ffewhere_column_unknown ());
|
||
ffebad_string (ffesymbol_text (s));
|
||
ffebad_finish ();
|
||
}
|
||
ffestorag_set_accretes (mst,
|
||
ffestorag_accretes (mst)
|
||
- actual); /* Decrement # of values
|
||
actually accreted. */
|
||
ffebit_set (ffebld_accter_bits (accter), offset, 1, units_expected);
|
||
|
||
/* If done accreting for this storage area, establish as initialized. */
|
||
|
||
if (ffestorag_accretes (mst) == 0)
|
||
{
|
||
ffestorag_set_init (mst, accter);
|
||
ffestorag_set_accretion (mst, NULL);
|
||
ffebit_kill (ffebld_accter_bits (ffestorag_init (mst)));
|
||
ffebld_set_op (ffestorag_init (mst), FFEBLD_opARRTER);
|
||
ffebld_set_arrter (ffestorag_init (mst),
|
||
ffebld_accter (ffestorag_init (mst)));
|
||
ffebld_arrter_set_size (ffestorag_init (mst),
|
||
ffedata_storage_size_);
|
||
ffebld_arrter_set_pad (ffestorag_init (mst), 0);
|
||
ffecom_notify_init_storage (mst);
|
||
}
|
||
|
||
return;
|
||
|
||
case FFEBLD_opARRTER:
|
||
ffebld_constantarray_preparray (&ptr1, &ptr2, &size, array, ffedata_storage_bt_,
|
||
ffedata_storage_kt_, offset, ffebld_arrter (b),
|
||
bt, kt);
|
||
size *= ffebld_arrter_size (b);
|
||
units_expected *= ffebld_arrter_size (b);
|
||
(*fn) (ptr1, ptr2, size); /* Does the appropriate memcpy-like
|
||
operation. */
|
||
ffebit_count (ffebld_accter_bits (accter),
|
||
offset, FALSE, units_expected, &actual); /* How many FALSE? */
|
||
if (units_expected != (ffetargetOffset) actual)
|
||
{
|
||
ffebad_start (FFEBAD_DATA_MULTIPLE);
|
||
ffebad_here (0, ffewhere_line_unknown (), ffewhere_column_unknown ());
|
||
ffebad_string (ffesymbol_text (s));
|
||
ffebad_finish ();
|
||
}
|
||
ffestorag_set_accretes (mst,
|
||
ffestorag_accretes (mst)
|
||
- actual); /* Decrement # of values
|
||
actually accreted. */
|
||
ffebit_set (ffebld_accter_bits (accter), offset, 1, units_expected);
|
||
|
||
/* If done accreting for this storage area, establish as initialized. */
|
||
|
||
if (ffestorag_accretes (mst) == 0)
|
||
{
|
||
ffestorag_set_init (mst, accter);
|
||
ffestorag_set_accretion (mst, NULL);
|
||
ffebit_kill (ffebld_accter_bits (ffestorag_init (mst)));
|
||
ffebld_set_op (ffestorag_init (mst), FFEBLD_opARRTER);
|
||
ffebld_set_arrter (ffestorag_init (mst),
|
||
ffebld_accter (ffestorag_init (mst)));
|
||
ffebld_arrter_set_size (ffestorag_init (mst),
|
||
ffedata_storage_size_);
|
||
ffebld_arrter_set_pad (ffestorag_init (mst), 0);
|
||
ffecom_notify_init_storage (mst);
|
||
}
|
||
|
||
return;
|
||
|
||
case FFEBLD_opACCTER:
|
||
ffebld_constantarray_preparray (&ptr1, &ptr2, &size, array, ffedata_storage_bt_,
|
||
ffedata_storage_kt_, offset, ffebld_accter (b),
|
||
bt, kt);
|
||
bits = ffebld_accter_bits (b);
|
||
source_offset = 0;
|
||
|
||
for (;;)
|
||
{
|
||
ffetargetOffset unexp;
|
||
ffetargetOffset siz;
|
||
ffebitCount length;
|
||
bool value;
|
||
|
||
ffebit_test (bits, source_offset, &value, &length);
|
||
if (length == 0)
|
||
break; /* Exit the loop early. */
|
||
siz = size * length;
|
||
unexp = units_expected * length;
|
||
if (value)
|
||
{
|
||
(*fn) (ptr1, ptr2, siz); /* Does memcpy-like operation. */
|
||
ffebit_count (ffebld_accter_bits (accter), /* How many FALSE? */
|
||
offset, FALSE, unexp, &actual);
|
||
if (!whine && (unexp != (ffetargetOffset) actual))
|
||
{
|
||
whine = TRUE; /* Don't whine more than once for one gather. */
|
||
ffebad_start (FFEBAD_DATA_MULTIPLE);
|
||
ffebad_here (0, ffewhere_line_unknown (), ffewhere_column_unknown ());
|
||
ffebad_string (ffesymbol_text (s));
|
||
ffebad_finish ();
|
||
}
|
||
ffestorag_set_accretes (mst,
|
||
ffestorag_accretes (mst)
|
||
- actual); /* Decrement # of values
|
||
actually accreted. */
|
||
ffebit_set (ffebld_accter_bits (accter), offset, 1, unexp);
|
||
}
|
||
source_offset += length;
|
||
offset += unexp;
|
||
ptr1 = ((char *) ptr1) + siz;
|
||
ptr2 = ((char *) ptr2) + siz;
|
||
}
|
||
|
||
/* If done accreting for this storage area, establish as initialized. */
|
||
|
||
if (ffestorag_accretes (mst) == 0)
|
||
{
|
||
ffestorag_set_init (mst, accter);
|
||
ffestorag_set_accretion (mst, NULL);
|
||
ffebit_kill (ffebld_accter_bits (ffestorag_init (mst)));
|
||
ffebld_set_op (ffestorag_init (mst), FFEBLD_opARRTER);
|
||
ffebld_set_arrter (ffestorag_init (mst),
|
||
ffebld_accter (ffestorag_init (mst)));
|
||
ffebld_arrter_set_size (ffestorag_init (mst),
|
||
ffedata_storage_size_);
|
||
ffebld_arrter_set_pad (ffestorag_init (mst), 0);
|
||
ffecom_notify_init_storage (mst);
|
||
}
|
||
|
||
return;
|
||
|
||
default:
|
||
assert ("bad init op in gather_" == NULL);
|
||
return;
|
||
}
|
||
}
|
||
|
||
/* ffedata_pop_ -- Pop an impdo stack entry
|
||
|
||
ffedata_pop_(); */
|
||
|
||
static void
|
||
ffedata_pop_ ()
|
||
{
|
||
ffedataImpdo_ victim = ffedata_stack_;
|
||
|
||
assert (victim != NULL);
|
||
|
||
ffedata_stack_ = ffedata_stack_->outer;
|
||
|
||
malloc_kill_ks (ffe_pool_program_unit (), victim, sizeof (*victim));
|
||
}
|
||
|
||
/* ffedata_push_ -- Push an impdo stack entry
|
||
|
||
ffedata_push_(); */
|
||
|
||
static void
|
||
ffedata_push_ ()
|
||
{
|
||
ffedataImpdo_ baby;
|
||
|
||
baby = malloc_new_ks (ffe_pool_program_unit (), "ffedataImpdo_", sizeof (*baby));
|
||
|
||
baby->outer = ffedata_stack_;
|
||
ffedata_stack_ = baby;
|
||
}
|
||
|
||
/* ffedata_value_ -- Provide an initial value
|
||
|
||
ffebld value;
|
||
ffelexToken t; // Points to the value.
|
||
if (ffedata_value(value,t))
|
||
// Everything's ok
|
||
|
||
Makes sure the value is ok, then remembers it according to the list
|
||
provided to ffedata_begin. */
|
||
|
||
static bool
|
||
ffedata_value_ (ffebld value, ffelexToken token)
|
||
{
|
||
|
||
/* If already reported an error, don't do anything. */
|
||
|
||
if (ffedata_reported_error_)
|
||
return FALSE;
|
||
|
||
/* If the value is an error marker, remember we've seen one and do nothing
|
||
else. */
|
||
|
||
if ((value != NULL)
|
||
&& (ffebld_op (value) == FFEBLD_opANY))
|
||
{
|
||
ffedata_reported_error_ = TRUE;
|
||
return FALSE;
|
||
}
|
||
|
||
/* If too many values (no more targets), complain. */
|
||
|
||
if (ffedata_symbol_ == NULL)
|
||
{
|
||
ffebad_start (FFEBAD_DATA_TOOMANY);
|
||
ffebad_here (0, ffelex_token_where_line (token),
|
||
ffelex_token_where_column (token));
|
||
ffebad_finish ();
|
||
ffedata_reported_error_ = TRUE;
|
||
return FALSE;
|
||
}
|
||
|
||
/* If ffedata_advance_ wanted to register a complaint, do it now
|
||
that we have the token to point at instead of just the start
|
||
of the whole statement. */
|
||
|
||
if (ffedata_reinit_)
|
||
{
|
||
ffebad_start (FFEBAD_DATA_REINIT);
|
||
ffebad_here (0, ffelex_token_where_line (token),
|
||
ffelex_token_where_column (token));
|
||
ffebad_string (ffesymbol_text (ffedata_symbol_));
|
||
ffebad_finish ();
|
||
ffedata_reported_error_ = TRUE;
|
||
return FALSE;
|
||
}
|
||
|
||
#if FFEGLOBAL_ENABLED
|
||
if (ffesymbol_common (ffedata_symbol_) != NULL)
|
||
ffeglobal_init_common (ffesymbol_common (ffedata_symbol_), token);
|
||
#endif
|
||
|
||
/* Convert value to desired type. */
|
||
|
||
if (value != NULL)
|
||
{
|
||
if (ffedata_convert_cache_use_ == -1)
|
||
value = ffeexpr_convert
|
||
(value, token, NULL, ffedata_basictype_,
|
||
ffedata_kindtype_, 0,
|
||
(ffedata_basictype_ == FFEINFO_basictypeCHARACTER)
|
||
? ffedata_charexpected_ : FFETARGET_charactersizeNONE,
|
||
FFEEXPR_contextDATA);
|
||
else /* Use the cache. */
|
||
value = ffedata_convert_
|
||
(value, token, NULL, ffedata_basictype_,
|
||
ffedata_kindtype_, 0,
|
||
(ffedata_basictype_ == FFEINFO_basictypeCHARACTER)
|
||
? ffedata_charexpected_ : FFETARGET_charactersizeNONE);
|
||
}
|
||
|
||
/* If we couldn't, bug out. */
|
||
|
||
if ((value != NULL) && (ffebld_op (value) == FFEBLD_opANY))
|
||
{
|
||
ffedata_reported_error_ = TRUE;
|
||
return FALSE;
|
||
}
|
||
|
||
/* Handle the case where initializes go to a parent's storage area. */
|
||
|
||
if (ffedata_storage_ != NULL)
|
||
{
|
||
ffetargetOffset offset;
|
||
ffetargetOffset units_expected;
|
||
ffebitCount actual;
|
||
ffebldConstantArray array;
|
||
ffebld accter;
|
||
ffetargetCopyfunc fn;
|
||
void *ptr1;
|
||
void *ptr2;
|
||
size_t size;
|
||
ffeinfoBasictype ign_bt;
|
||
ffeinfoKindtype ign_kt;
|
||
ffetargetAlign units;
|
||
|
||
/* Make sure we haven't fully accreted during an array init. */
|
||
|
||
if (ffestorag_init (ffedata_storage_) != NULL)
|
||
{
|
||
ffebad_start (FFEBAD_DATA_MULTIPLE);
|
||
ffebad_here (0, ffelex_token_where_line (token),
|
||
ffelex_token_where_column (token));
|
||
ffebad_string (ffesymbol_text (ffedata_symbol_));
|
||
ffebad_finish ();
|
||
ffedata_reported_error_ = TRUE;
|
||
return FALSE;
|
||
}
|
||
|
||
/* Calculate offset. */
|
||
|
||
offset = ffedata_offset_ * ffedata_size_ + ffedata_charoffset_;
|
||
|
||
/* Is offset within range? If not, whine, but don't do anything else. */
|
||
|
||
if (offset + ffedata_charexpected_ - 1 > ffedata_symbolsize_)
|
||
{
|
||
ffebad_start (FFEBAD_DATA_RANGE);
|
||
ffest_ffebad_here_current_stmt (0);
|
||
ffebad_string (ffesymbol_text (ffedata_symbol_));
|
||
ffebad_finish ();
|
||
ffedata_reported_error_ = TRUE;
|
||
return FALSE;
|
||
}
|
||
|
||
/* Now calculate offset for aggregate area. */
|
||
|
||
ffetarget_aggregate_info (&ign_bt, &ign_kt, &units, ffedata_basictype_,
|
||
ffedata_kindtype_); /* Find out unit size of
|
||
source datum. */
|
||
assert (units % ffedata_storage_units_ == 0);
|
||
units_expected = ffedata_charexpected_ * units / ffedata_storage_units_;
|
||
offset *= units / ffedata_storage_units_;
|
||
offset += (ffestorag_offset (ffesymbol_storage (ffedata_symbol_))
|
||
- ffestorag_offset (ffedata_storage_))
|
||
/ ffedata_storage_units_;
|
||
|
||
assert (offset + units_expected - 1 <= ffedata_storage_size_);
|
||
|
||
/* Does an accretion array exist? If not, create it. */
|
||
|
||
if (value != NULL)
|
||
{
|
||
if (ffestorag_accretion (ffedata_storage_) == NULL)
|
||
{
|
||
#if FFEDATA_sizeTOO_BIG_INIT_ != 0
|
||
if (ffedata_storage_size_ >= FFEDATA_sizeTOO_BIG_INIT_)
|
||
{
|
||
char bignum[40];
|
||
|
||
sprintf (&bignum[0], "%ld", (long) ffedata_storage_size_);
|
||
ffebad_start (FFEBAD_TOO_BIG_INIT);
|
||
ffebad_here (0, ffelex_token_where_line (token),
|
||
ffelex_token_where_column (token));
|
||
ffebad_string (ffesymbol_text (ffedata_symbol_));
|
||
ffebad_string (bignum);
|
||
ffebad_finish ();
|
||
}
|
||
#endif
|
||
array = ffebld_constantarray_new
|
||
(ffedata_storage_bt_, ffedata_storage_kt_,
|
||
ffedata_storage_size_);
|
||
accter = ffebld_new_accter (array,
|
||
ffebit_new (ffe_pool_program_unit (),
|
||
ffedata_storage_size_));
|
||
ffebld_set_info (accter, ffeinfo_new
|
||
(ffedata_storage_bt_,
|
||
ffedata_storage_kt_,
|
||
1,
|
||
FFEINFO_kindENTITY,
|
||
FFEINFO_whereCONSTANT,
|
||
(ffedata_basictype_
|
||
== FFEINFO_basictypeCHARACTER)
|
||
? 1 : FFETARGET_charactersizeNONE));
|
||
ffestorag_set_accretion (ffedata_storage_, accter);
|
||
ffestorag_set_accretes (ffedata_storage_, ffedata_storage_size_);
|
||
}
|
||
else
|
||
{
|
||
accter = ffestorag_accretion (ffedata_storage_);
|
||
assert (ffedata_storage_size_ == (ffetargetOffset) ffebld_accter_size (accter));
|
||
array = ffebld_accter (accter);
|
||
}
|
||
|
||
/* Put value in accretion array at desired offset. */
|
||
|
||
fn = ffetarget_aggregate_ptr_memcpy
|
||
(ffedata_storage_bt_, ffedata_storage_kt_,
|
||
ffedata_basictype_, ffedata_kindtype_);
|
||
ffebld_constantarray_prepare
|
||
(&ptr1, &ptr2, &size, array, ffedata_storage_bt_,
|
||
ffedata_storage_kt_, offset,
|
||
ffebld_constant_ptr_to_union (ffebld_conter (value)),
|
||
ffedata_basictype_, ffedata_kindtype_);
|
||
(*fn) (ptr1, ptr2, size); /* Does the appropriate memcpy-like
|
||
operation. */
|
||
ffebit_count (ffebld_accter_bits (accter),
|
||
offset, FALSE, units_expected,
|
||
&actual); /* How many FALSE? */
|
||
if (units_expected != (ffetargetOffset) actual)
|
||
{
|
||
ffebad_start (FFEBAD_DATA_MULTIPLE);
|
||
ffebad_here (0, ffelex_token_where_line (token),
|
||
ffelex_token_where_column (token));
|
||
ffebad_string (ffesymbol_text (ffedata_symbol_));
|
||
ffebad_finish ();
|
||
}
|
||
ffestorag_set_accretes (ffedata_storage_,
|
||
ffestorag_accretes (ffedata_storage_)
|
||
- actual); /* Decrement # of values
|
||
actually accreted. */
|
||
ffebit_set (ffebld_accter_bits (accter), offset,
|
||
1, units_expected);
|
||
|
||
/* If done accreting for this storage area, establish as
|
||
initialized. */
|
||
|
||
if (ffestorag_accretes (ffedata_storage_) == 0)
|
||
{
|
||
ffestorag_set_init (ffedata_storage_, accter);
|
||
ffestorag_set_accretion (ffedata_storage_, NULL);
|
||
ffebit_kill (ffebld_accter_bits
|
||
(ffestorag_init (ffedata_storage_)));
|
||
ffebld_set_op (ffestorag_init (ffedata_storage_),
|
||
FFEBLD_opARRTER);
|
||
ffebld_set_arrter
|
||
(ffestorag_init (ffedata_storage_),
|
||
ffebld_accter (ffestorag_init (ffedata_storage_)));
|
||
ffebld_arrter_set_size (ffestorag_init (ffedata_storage_),
|
||
ffedata_storage_size_);
|
||
ffebld_arrter_set_pad (ffestorag_init (ffedata_storage_),
|
||
0);
|
||
ffecom_notify_init_storage (ffedata_storage_);
|
||
}
|
||
}
|
||
|
||
/* If still accreting, adjust specs accordingly and return. */
|
||
|
||
if (++ffedata_number_ < ffedata_expected_)
|
||
{
|
||
++ffedata_offset_;
|
||
return TRUE;
|
||
}
|
||
|
||
return ffedata_advance_ ();
|
||
}
|
||
|
||
/* Figure out where the value goes -- in an accretion array or directly
|
||
into the final initial-value slot for the symbol. */
|
||
|
||
if ((ffedata_number_ != 0)
|
||
|| (ffedata_arraysize_ > 1)
|
||
|| (ffedata_charnumber_ != 0)
|
||
|| (ffedata_size_ > ffedata_charexpected_))
|
||
{ /* Accrete this value. */
|
||
ffetargetOffset offset;
|
||
ffebitCount actual;
|
||
ffebldConstantArray array;
|
||
ffebld accter = NULL;
|
||
|
||
/* Calculate offset. */
|
||
|
||
offset = ffedata_offset_ * ffedata_size_ + ffedata_charoffset_;
|
||
|
||
/* Is offset within range? If not, whine, but don't do anything else. */
|
||
|
||
if (offset + ffedata_charexpected_ - 1 > ffedata_symbolsize_)
|
||
{
|
||
ffebad_start (FFEBAD_DATA_RANGE);
|
||
ffest_ffebad_here_current_stmt (0);
|
||
ffebad_string (ffesymbol_text (ffedata_symbol_));
|
||
ffebad_finish ();
|
||
ffedata_reported_error_ = TRUE;
|
||
return FALSE;
|
||
}
|
||
|
||
/* Does an accretion array exist? If not, create it. */
|
||
|
||
if (value != NULL)
|
||
{
|
||
if (ffesymbol_accretion (ffedata_symbol_) == NULL)
|
||
{
|
||
#if FFEDATA_sizeTOO_BIG_INIT_ != 0
|
||
if (ffedata_symbolsize_ >= FFEDATA_sizeTOO_BIG_INIT_ )
|
||
{
|
||
char bignum[40];
|
||
|
||
sprintf (&bignum[0], "%ld", (long) ffedata_symbolsize_);
|
||
ffebad_start (FFEBAD_TOO_BIG_INIT);
|
||
ffebad_here (0, ffelex_token_where_line (token),
|
||
ffelex_token_where_column (token));
|
||
ffebad_string (ffesymbol_text (ffedata_symbol_));
|
||
ffebad_string (bignum);
|
||
ffebad_finish ();
|
||
}
|
||
#endif
|
||
array = ffebld_constantarray_new
|
||
(ffedata_basictype_, ffedata_kindtype_,
|
||
ffedata_symbolsize_);
|
||
accter = ffebld_new_accter (array,
|
||
ffebit_new (ffe_pool_program_unit (),
|
||
ffedata_symbolsize_));
|
||
ffebld_set_info (accter, ffeinfo_new
|
||
(ffedata_basictype_,
|
||
ffedata_kindtype_,
|
||
1,
|
||
FFEINFO_kindENTITY,
|
||
FFEINFO_whereCONSTANT,
|
||
(ffedata_basictype_
|
||
== FFEINFO_basictypeCHARACTER)
|
||
? 1 : FFETARGET_charactersizeNONE));
|
||
ffesymbol_set_accretion (ffedata_symbol_, accter);
|
||
ffesymbol_set_accretes (ffedata_symbol_, ffedata_symbolsize_);
|
||
}
|
||
else
|
||
{
|
||
accter = ffesymbol_accretion (ffedata_symbol_);
|
||
assert (ffedata_symbolsize_
|
||
== (ffetargetOffset) ffebld_accter_size (accter));
|
||
array = ffebld_accter (accter);
|
||
}
|
||
|
||
/* Put value in accretion array at desired offset. */
|
||
|
||
ffebld_constantarray_put
|
||
(array, ffedata_basictype_, ffedata_kindtype_,
|
||
offset, ffebld_constant_union (ffebld_conter (value)));
|
||
ffebit_count (ffebld_accter_bits (accter), offset, FALSE,
|
||
ffedata_charexpected_,
|
||
&actual); /* How many FALSE? */
|
||
if (actual != (unsigned long int) ffedata_charexpected_)
|
||
{
|
||
ffebad_start (FFEBAD_DATA_MULTIPLE);
|
||
ffebad_here (0, ffelex_token_where_line (token),
|
||
ffelex_token_where_column (token));
|
||
ffebad_string (ffesymbol_text (ffedata_symbol_));
|
||
ffebad_finish ();
|
||
}
|
||
ffesymbol_set_accretes (ffedata_symbol_,
|
||
ffesymbol_accretes (ffedata_symbol_)
|
||
- actual); /* Decrement # of values
|
||
actually accreted. */
|
||
ffebit_set (ffebld_accter_bits (accter), offset,
|
||
1, ffedata_charexpected_);
|
||
ffesymbol_signal_unreported (ffedata_symbol_);
|
||
}
|
||
|
||
/* If still accreting, adjust specs accordingly and return. */
|
||
|
||
if (++ffedata_number_ < ffedata_expected_)
|
||
{
|
||
++ffedata_offset_;
|
||
return TRUE;
|
||
}
|
||
|
||
/* Else, if done accreting for this symbol, establish as initialized. */
|
||
|
||
if ((value != NULL)
|
||
&& (ffesymbol_accretes (ffedata_symbol_) == 0))
|
||
{
|
||
ffesymbol_set_init (ffedata_symbol_, accter);
|
||
ffesymbol_set_accretion (ffedata_symbol_, NULL);
|
||
ffebit_kill (ffebld_accter_bits (ffesymbol_init (ffedata_symbol_)));
|
||
ffebld_set_op (ffesymbol_init (ffedata_symbol_), FFEBLD_opARRTER);
|
||
ffebld_set_arrter (ffesymbol_init (ffedata_symbol_),
|
||
ffebld_accter (ffesymbol_init (ffedata_symbol_)));
|
||
ffebld_arrter_set_size (ffesymbol_init (ffedata_symbol_),
|
||
ffedata_symbolsize_);
|
||
ffebld_arrter_set_pad (ffestorag_init (ffedata_symbol_), 0);
|
||
ffecom_notify_init_symbol (ffedata_symbol_);
|
||
}
|
||
}
|
||
else if (value != NULL)
|
||
{
|
||
/* Simple, direct, one-shot assignment. */
|
||
ffesymbol_set_init (ffedata_symbol_, value);
|
||
ffecom_notify_init_symbol (ffedata_symbol_);
|
||
}
|
||
|
||
/* Call on advance function to get next target in list. */
|
||
|
||
return ffedata_advance_ ();
|
||
}
|