#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"
#ifndef FFEDATA_sizeTOO_BIG_INIT_
#define FFEDATA_sizeTOO_BIG_INIT_ 75*1024
#endif
typedef struct _ffedata_convert_cache_ *ffedataConvertCache_;
typedef struct _ffedata_impdo_ *ffedataImpdo_;
struct _ffedata_convert_cache_
{
ffebld converted;
ffeinfoBasictype basic_type;
ffeinfoKindtype kind_type;
ffetargetCharacterSize size;
ffeinfoRank rank;
};
struct _ffedata_impdo_
{
ffedataImpdo_ outer;
ffebld outer_list;
ffebld my_list;
ffesymbol itervar;
ffetargetIntegerDefault increment;
ffetargetIntegerDefault final;
};
static ffedataImpdo_ ffedata_stack_ = NULL;
static ffebld ffedata_list_ = NULL;
static bool ffedata_reinit_;
static bool ffedata_reported_error_;
static ffesymbol ffedata_symbol_ = NULL;
static ffeinfoBasictype ffedata_basictype_;
static ffeinfoKindtype ffedata_kindtype_;
static ffestorag ffedata_storage_;
static ffeinfoBasictype ffedata_storage_bt_;
static ffeinfoKindtype ffedata_storage_kt_;
static ffetargetOffset ffedata_storage_size_;
static ffetargetAlign ffedata_storage_units_;
static ffetargetOffset ffedata_arraysize_;
static ffetargetOffset ffedata_expected_;
static ffetargetOffset ffedata_number_;
static ffetargetOffset ffedata_offset_;
static ffetargetOffset ffedata_symbolsize_;
static ffetargetCharacterSize ffedata_size_;
static ffetargetCharacterSize ffedata_charexpected_;
static ffetargetCharacterSize ffedata_charnumber_;
static ffetargetCharacterSize ffedata_charoffset_;
static ffedataConvertCache_ ffedata_convert_cache_;
static int ffedata_convert_cache_max_ = 0;
static int ffedata_convert_cache_use_ = 0;
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);
void
ffedata_begin (ffebld list)
{
assert (ffedata_list_ == NULL);
ffedata_list_ = list;
ffedata_symbol_ = NULL;
ffedata_reported_error_ = FALSE;
ffedata_reinit_ = FALSE;
ffedata_advance_ ();
}
bool
ffedata_end (bool reported_error, ffelexToken t)
{
reported_error |= ffedata_reported_error_;
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 ();
}
while (ffedata_stack_ != NULL)
ffedata_pop_ ();
if (ffedata_list_ != NULL)
{
assert (reported_error);
ffedata_list_ = NULL;
}
return TRUE;
}
void
ffedata_gather (ffestorag st)
{
ffesymbol s;
ffebld b;
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 ((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))));
}
ffestorag_drive (ffestorag_list_equivs (st), ffedata_gather_, st);
}
bool
ffedata_value (ffetargetIntegerDefault rpt, ffebld value, ffelexToken token)
{
ffetargetIntegerDefault i;
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
{
assert (value != NULL);
assert (ffebld_op (value) == FFEBLD_opCONTER);
}
if (rpt == 1)
ffedata_convert_cache_use_ = -1;
else
ffedata_convert_cache_use_ = 0;
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;
}
static bool
ffedata_advance_ ()
{
ffebld next;
tail_recurse:
ffedata_symbol_ = NULL;
if (ffedata_list_ == NULL)
{
ffetargetIntegerDefault newval;
if (ffedata_stack_ == NULL)
return TRUE;
newval = ffesymbol_value (ffedata_stack_->itervar)
+ ffedata_stack_->increment;
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))))
{
ffedata_list_ = ffedata_stack_->outer_list;
ffedata_pop_ ();
}
else
{
ffedata_list_ = ffedata_stack_->my_list;
ffesymbol_set_value (ffedata_stack_->itervar, newval);
}
goto tail_recurse;
}
next = ffebld_head (ffedata_list_);
ffedata_list_ = ffebld_trail (ffedata_list_);
if (next == NULL)
return TRUE;
switch (ffebld_op (next))
{
case FFEBLD_opSYMTER:
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:
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;
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:
{
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:
{
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);
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));
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
{
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;
}
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;
}
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;
}
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
case FFEBLD_opCONCATENATE:
error =;
break;
#endif
case FFEBLD_opNOT:
error = ffetarget_not_integer1 (&result,
ffedata_eval_integer1_ (ffebld_left (expr)));
break;
#if 0
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
case FFEBLD_opPERCENT_LOC:
error =;
break;
#endif
#if 0
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
case FFEBLD_opREPEAT:
error =;
break;
case FFEBLD_opBOUNDS:
error =;
break;
#endif
#if 0
case FFEBLD_opFUNCREF:
error =;
break;
#endif
#if 0
case FFEBLD_opSUBRREF:
error =;
break;
case FFEBLD_opARRAYREF:
error =;
break;
#endif
#if 0
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;
}
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)
{
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)
{
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)
{
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;
}
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;
}
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;
}
static void
ffedata_gather_ (ffestorag mst, ffestorag st)
{
ffesymbol s;
ffesymbol s_whine;
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;
s = ffestorag_symbol (st);
assert (s != NULL);
assert (ffestorag_init (st) == NULL);
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;
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;
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));
ffedata_charexpected_ = (bt == FFEINFO_basictypeCHARACTER)
? ffebld_size (b) : 1;
ffetarget_aggregate_info (&ign_bt, &ign_kt, &units, bt,
kt);
assert (units % ffedata_storage_units_ == 0);
units_expected = ffedata_charexpected_ * units / ffedata_storage_units_;
offset = (ffestorag_offset (st) - ffestorag_offset (mst))
/ ffedata_storage_units_;
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);
}
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);
ffebit_count (ffebld_accter_bits (accter),
offset, FALSE, units_expected, &actual);
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);
ffebit_set (ffebld_accter_bits (accter), offset, 1, units_expected);
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);
ffebit_count (ffebld_accter_bits (accter),
offset, FALSE, units_expected, &actual);
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);
ffebit_set (ffebld_accter_bits (accter), offset, 1, units_expected);
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;
siz = size * length;
unexp = units_expected * length;
if (value)
{
(*fn) (ptr1, ptr2, siz);
ffebit_count (ffebld_accter_bits (accter),
offset, FALSE, unexp, &actual);
if (!whine && (unexp != (ffetargetOffset) actual))
{
whine = TRUE;
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);
ffebit_set (ffebld_accter_bits (accter), offset, 1, unexp);
}
source_offset += length;
offset += unexp;
ptr1 = ((char *) ptr1) + siz;
ptr2 = ((char *) ptr2) + siz;
}
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;
}
}
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));
}
static void
ffedata_push_ ()
{
ffedataImpdo_ baby;
baby = malloc_new_ks (ffe_pool_program_unit (), "ffedataImpdo_", sizeof (*baby));
baby->outer = ffedata_stack_;
ffedata_stack_ = baby;
}
static bool
ffedata_value_ (ffebld value, ffelexToken token)
{
if (ffedata_reported_error_)
return FALSE;
if ((value != NULL)
&& (ffebld_op (value) == FFEBLD_opANY))
{
ffedata_reported_error_ = TRUE;
return FALSE;
}
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_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
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
value = ffedata_convert_
(value, token, NULL, ffedata_basictype_,
ffedata_kindtype_, 0,
(ffedata_basictype_ == FFEINFO_basictypeCHARACTER)
? ffedata_charexpected_ : FFETARGET_charactersizeNONE);
}
if ((value != NULL) && (ffebld_op (value) == FFEBLD_opANY))
{
ffedata_reported_error_ = TRUE;
return FALSE;
}
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;
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;
}
offset = ffedata_offset_ * ffedata_size_ + ffedata_charoffset_;
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;
}
ffetarget_aggregate_info (&ign_bt, &ign_kt, &units, ffedata_basictype_,
ffedata_kindtype_);
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_);
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);
}
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);
ffebit_count (ffebld_accter_bits (accter),
offset, FALSE, units_expected,
&actual);
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);
ffebit_set (ffebld_accter_bits (accter), offset,
1, units_expected);
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 (++ffedata_number_ < ffedata_expected_)
{
++ffedata_offset_;
return TRUE;
}
return ffedata_advance_ ();
}
if ((ffedata_number_ != 0)
|| (ffedata_arraysize_ > 1)
|| (ffedata_charnumber_ != 0)
|| (ffedata_size_ > ffedata_charexpected_))
{
ffetargetOffset offset;
ffebitCount actual;
ffebldConstantArray array;
ffebld accter = NULL;
offset = ffedata_offset_ * ffedata_size_ + ffedata_charoffset_;
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;
}
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);
}
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);
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);
ffebit_set (ffebld_accter_bits (accter), offset,
1, ffedata_charexpected_);
ffesymbol_signal_unreported (ffedata_symbol_);
}
if (++ffedata_number_ < ffedata_expected_)
{
++ffedata_offset_;
return TRUE;
}
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)
{
ffesymbol_set_init (ffedata_symbol_, value);
ffecom_notify_init_symbol (ffedata_symbol_);
}
return ffedata_advance_ ();
}