diff options
Diffstat (limited to 'contrib/gcc/f/data.c')
| -rw-r--r-- | contrib/gcc/f/data.c | 1877 |
1 files changed, 0 insertions, 1877 deletions
diff --git a/contrib/gcc/f/data.c b/contrib/gcc/f/data.c deleted file mode 100644 index 2040f0a..0000000 --- a/contrib/gcc/f/data.c +++ /dev/null @@ -1,1877 +0,0 @@ -/* 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_ (void) -{ - 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 = 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_ (void) -{ - 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_ (void) -{ - 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_ (); -} |
