diff options
Diffstat (limited to 'gcc/f/symbol.c')
| -rwxr-xr-x | gcc/f/symbol.c | 1477 |
1 files changed, 0 insertions, 1477 deletions
diff --git a/gcc/f/symbol.c b/gcc/f/symbol.c deleted file mode 100755 index 8aa7230..0000000 --- a/gcc/f/symbol.c +++ /dev/null @@ -1,1477 +0,0 @@ -/* Implementation of Fortran symbol manager - Copyright (C) 1995-1997 Free Software Foundation, Inc. - Contributed by James Craig Burley (burley@gnu.org). - -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. */ - -#include "proj.h" -#include "symbol.h" -#include "bad.h" -#include "bld.h" -#include "com.h" -#include "equiv.h" -#include "global.h" -#include "info.h" -#include "intrin.h" -#include "lex.h" -#include "malloc.h" -#include "src.h" -#include "st.h" -#include "storag.h" -#include "target.h" -#include "where.h" - -/* Choice of how to handle global symbols -- either global only within the - program unit being defined or global within the entire source file. - The former is appropriate for systems where an object file can - easily be taken apart program unit by program unit, the latter is the - UNIX/C model where the object file is essentially a monolith. */ - -#define FFESYMBOL_globalPROGUNIT_ 1 -#define FFESYMBOL_globalFILE_ 2 - -/* Choose how to handle global symbols here. */ - -#if FFECOM_targetCURRENT == FFECOM_targetFFE -#define FFESYMBOL_globalCURRENT_ FFESYMBOL_globalPROGUNIT_ -#elif FFECOM_targetCURRENT == FFECOM_targetGCC -/* Would be good to understand why PROGUNIT in this case too. - (1995-08-22). */ -#define FFESYMBOL_globalCURRENT_ FFESYMBOL_globalPROGUNIT_ -#else -#error -#endif - -/* Choose how to handle memory pools based on global symbol stuff. */ - -#if FFESYMBOL_globalCURRENT_ == FFESYMBOL_globalPROGUNIT_ -#define FFESYMBOL_SPACE_POOL_ ffe_pool_program_unit() -#elif FFESYMBOL_globalCURRENT_ == FFESYMBOL_globalFILE_ -#define FFESYMBOL_SPACE_POOL_ ffe_pool_file() -#else -#error -#endif - -/* What kind of retraction is needed for a symbol? */ - -enum _ffesymbol_retractcommand_ - { - FFESYMBOL_retractcommandDELETE_, - FFESYMBOL_retractcommandRETRACT_, - FFESYMBOL_retractcommand_ - }; -typedef enum _ffesymbol_retractcommand_ ffesymbolRetractCommand_; - -/* This object keeps track of retraction for a symbol and links to the next - such object. */ - -typedef struct _ffesymbol_retract_ *ffesymbolRetract_; -struct _ffesymbol_retract_ - { - ffesymbolRetract_ next; - ffesymbolRetractCommand_ command; - ffesymbol live; /* Live symbol. */ - ffesymbol symbol; /* Backup copy of symbol. */ - }; - -static ffebad ffesymbol_check_token_ (ffelexToken t, char *c); -static void ffesymbol_kill_manifest_ (void); -static ffesymbol ffesymbol_new_ (ffename n); -static ffesymbol ffesymbol_unhook_ (ffesymbol s); -static void ffesymbol_whine_state_ (ffebad bad, ffelexToken t, char c); - -/* Manifest names for unnamed things (as tokens) so we make them only - once. */ - -static ffelexToken ffesymbol_token_blank_common_ = NULL; -static ffelexToken ffesymbol_token_unnamed_main_ = NULL; -static ffelexToken ffesymbol_token_unnamed_blockdata_ = NULL; - -/* Name spaces currently in force. */ - -static ffenameSpace ffesymbol_global_ = NULL; -static ffenameSpace ffesymbol_local_ = NULL; -static ffenameSpace ffesymbol_sfunc_ = NULL; - -/* Keep track of retraction. */ - -static bool ffesymbol_retractable_ = FALSE; -static mallocPool ffesymbol_retract_pool_; -static ffesymbolRetract_ ffesymbol_retract_first_; -static ffesymbolRetract_ *ffesymbol_retract_list_; - -/* List of state names. */ - -static char *ffesymbol_state_name_[] = -{ - "?", - "@", - "&", - "$", -}; - -/* List of attribute names. */ - -static char *ffesymbol_attr_name_[] = -{ -#define DEFATTR(ATTR,ATTRS,NAME) NAME, -#include "symbol.def" -#undef DEFATTR -}; - - -/* Check whether the token text has any invalid characters. If not, - return FALSE. If so, if error messages inhibited, return TRUE - so caller knows to try again later, else report error and return - FALSE. */ - -static ffebad -ffesymbol_check_token_ (ffelexToken t, char *c) -{ - char *p = ffelex_token_text (t); - ffeTokenLength len = ffelex_token_length (t); - ffebad bad; - ffeTokenLength i = 0; - ffebad skip_me = ((ffe_case_symbol () == FFE_caseINITCAP) - ? FFEBAD_SYMBOL_NOLOWER_INITCAP : FFEBAD + 1); - ffebad stop_me = ((ffe_case_symbol () == FFE_caseINITCAP) - ? FFEBAD : FFEBAD + 1); - if (len == 0) - return FFEBAD; - - bad = ffesrc_bad_char_symbol_init (*p); - if (bad == FFEBAD) - { - for (++i, ++p; i < len; ++i, ++p) - { - bad = ffesrc_bad_char_symbol_noninit (*p); - if (bad == skip_me) - continue; /* Keep looking for good InitCap character. */ - if (bad == stop_me) - break; /* Found good InitCap character. */ - if (bad != FFEBAD) - break; /* Bad character found. */ - } - } - - if (bad != FFEBAD) - { - if (i >= len) - *c = *(ffelex_token_text (t)); - else - *c = *p; - } - - return bad; -} - -/* Kill manifest (g77-picked) names. */ - -static void -ffesymbol_kill_manifest_ () -{ - if (ffesymbol_token_blank_common_ != NULL) - ffelex_token_kill (ffesymbol_token_blank_common_); - if (ffesymbol_token_unnamed_main_ != NULL) - ffelex_token_kill (ffesymbol_token_unnamed_main_); - if (ffesymbol_token_unnamed_blockdata_ != NULL) - ffelex_token_kill (ffesymbol_token_unnamed_blockdata_); - - ffesymbol_token_blank_common_ = NULL; - ffesymbol_token_unnamed_main_ = NULL; - ffesymbol_token_unnamed_blockdata_ = NULL; -} - -/* Make new symbol. - - If the "retractable" flag is not set, just return the new symbol. - Else, add symbol to the "retract" list as a delete item, set - the "have_old" flag, and return the new symbol. */ - -static ffesymbol -ffesymbol_new_ (ffename n) -{ - ffesymbol s; - ffesymbolRetract_ r; - - assert (n != NULL); - - s = (ffesymbol) malloc_new_ks (FFESYMBOL_SPACE_POOL_, "FFESYMBOL", - sizeof (*s)); - s->name = n; - s->other_space_name = NULL; -#if FFEGLOBAL_ENABLED - s->global = NULL; -#endif - s->attrs = FFESYMBOL_attrsetNONE; - s->state = FFESYMBOL_stateNONE; - s->info = ffeinfo_new_null (); - s->dims = NULL; - s->extents = NULL; - s->dim_syms = NULL; - s->array_size = NULL; - s->init = NULL; - s->accretion = NULL; - s->accretes = 0; - s->dummy_args = NULL; - s->namelist = NULL; - s->common_list = NULL; - s->sfunc_expr = NULL; - s->list_bottom = NULL; - s->common = NULL; - s->equiv = NULL; - s->storage = NULL; -#ifdef FFECOM_symbolHOOK - s->hook = FFECOM_symbolNULL; -#endif - s->sfa_dummy_parent = NULL; - s->func_result = NULL; - s->value = 0; - s->check_state = FFESYMBOL_checkstateNONE_; - s->check_token = NULL; - s->max_entry_num = 0; - s->num_entries = 0; - s->generic = FFEINTRIN_genNONE; - s->specific = FFEINTRIN_specNONE; - s->implementation = FFEINTRIN_impNONE; - s->is_save = FALSE; - s->is_init = FALSE; - s->do_iter = FALSE; - s->reported = FALSE; - s->explicit_where = FALSE; - s->namelisted = FALSE; - - ffename_set_symbol (n, s); - - if (!ffesymbol_retractable_) - { - s->have_old = FALSE; - return s; - } - - r = (ffesymbolRetract_) malloc_new_kp (ffesymbol_retract_pool_, - "FFESYMBOL retract", sizeof (*r)); - r->next = NULL; - r->command = FFESYMBOL_retractcommandDELETE_; - r->live = s; - r->symbol = NULL; /* No backup copy. */ - - *ffesymbol_retract_list_ = r; - ffesymbol_retract_list_ = &r->next; - - s->have_old = TRUE; - return s; -} - -/* Unhook a symbol from its (soon-to-be-killed) name obj. - - NULLify the names to which this symbol points. Do other cleanup as - needed. */ - -static ffesymbol -ffesymbol_unhook_ (ffesymbol s) -{ - s->other_space_name = s->name = NULL; - if ((ffesymbol_attrs (s) & FFESYMBOL_attrsCBLOCK) - || (ffesymbol_kind (s) == FFEINFO_kindNAMELIST)) - ffebld_end_list (ffesymbol_ptr_to_listbottom (s)); - if (s->check_state == FFESYMBOL_checkstatePENDING_) - ffelex_token_kill (s->check_token); - - return s; -} - -/* Issue diagnostic about bad character in token representing user-defined - symbol name. */ - -static void -ffesymbol_whine_state_ (ffebad bad, ffelexToken t, char c) -{ - char badstr[2]; - - badstr[0] = c; - badstr[1] = '\0'; - - ffebad_start (bad); - ffebad_here (0, ffelex_token_where_line (t), - ffelex_token_where_column (t)); - ffebad_string (badstr); - ffebad_finish (); -} - -/* Returns a string representing the attributes set. */ - -char * -ffesymbol_attrs_string (ffesymbolAttrs attrs) -{ - static char string[FFESYMBOL_attr * 12 + 20]; - char *p; - ffesymbolAttr attr; - - p = &string[0]; - - if (attrs == FFESYMBOL_attrsetNONE) - { - strcpy (p, "NONE"); - return &string[0]; - } - - for (attr = 0; attr < FFESYMBOL_attr; ++attr) - { - if (attrs & ((ffesymbolAttrs) 1 << attr)) - { - attrs &= ~((ffesymbolAttrs) 1 << attr); - strcpy (p, ffesymbol_attr_name_[attr]); - while (*p) - ++p; - *(p++) = '|'; - } - } - if (attrs == FFESYMBOL_attrsetNONE) - *--p = '\0'; - else - sprintf (p, "?0x%" ffesymbolAttrs_f "x?", attrs); - assert (((size_t) (p - &string[0])) < ARRAY_SIZE (string)); - return &string[0]; -} - -/* Check symbol's name for validity, considering that it might actually - be an intrinsic and thus should not be complained about just yet. */ - -void -ffesymbol_check (ffesymbol s, ffelexToken t, bool maybe_intrin) -{ - char c; - ffebad bad; - ffeintrinGen gen; - ffeintrinSpec spec; - ffeintrinImp imp; - - if (!ffesrc_check_symbol () - || ((s->check_state != FFESYMBOL_checkstateNONE_) - && ((s->check_state != FFESYMBOL_checkstateINHIBITED_) - || ffebad_inhibit ()))) - return; - - bad = ffesymbol_check_token_ (t, &c); - - if (bad == FFEBAD) - { - s->check_state = FFESYMBOL_checkstateCHECKED_; - return; - } - - if (maybe_intrin - && ffeintrin_is_intrinsic (ffelex_token_text (t), NULL, FALSE, - &gen, &spec, &imp)) - { - s->check_state = FFESYMBOL_checkstatePENDING_; - s->check_token = ffelex_token_use (t); - return; - } - - if (ffebad_inhibit ()) - { - s->check_state = FFESYMBOL_checkstateINHIBITED_; - return; /* Don't complain now, do it later. */ - } - - s->check_state = FFESYMBOL_checkstateCHECKED_; - - ffesymbol_whine_state_ (bad, t, c); -} - -/* Declare a BLOCKDATA unit. - - Retrieves or creates the ffesymbol for the specified BLOCKDATA (unnamed - if t is NULL). Doesn't actually ensure the named item is a - BLOCKDATA; the caller must handle that. */ - -ffesymbol -ffesymbol_declare_blockdataunit (ffelexToken t, ffewhereLine wl, - ffewhereColumn wc) -{ - ffename n; - ffesymbol s; - bool user = (t != NULL); - - assert (!ffesymbol_retractable_); - - if (t == NULL) - { - if (ffesymbol_token_unnamed_blockdata_ == NULL) - ffesymbol_token_unnamed_blockdata_ - = ffelex_token_new_name (FFETARGET_nameUNNAMED_BLOCK_DATA, wl, wc); - t = ffesymbol_token_unnamed_blockdata_; - } - - n = ffename_lookup (ffesymbol_local_, t); - if (n != NULL) - return ffename_symbol (n); /* This will become an error. */ - - n = ffename_find (ffesymbol_global_, t); - s = ffename_symbol (n); - if (s != NULL) - { - if (user) - ffesymbol_check (s, t, FALSE); - return s; - } - - s = ffesymbol_new_ (n); - if (user) - ffesymbol_check (s, t, FALSE); - - /* A program unit name also is in the local name space. */ - - n = ffename_find (ffesymbol_local_, t); - ffename_set_symbol (n, s); - s->other_space_name = n; - - ffeglobal_new_blockdata (s, t); /* Detect conflicts, when - appropriate. */ - - return s; -} - -/* Declare a common block (named or unnamed). - - Retrieves or creates the ffesymbol for the specified common block (blank - common if t is NULL). Doesn't actually ensure the named item is a - common block; the caller must handle that. */ - -ffesymbol -ffesymbol_declare_cblock (ffelexToken t, ffewhereLine wl, ffewhereColumn wc) -{ - ffename n; - ffesymbol s; - bool blank; - - assert (!ffesymbol_retractable_); - - if (t == NULL) - { - blank = TRUE; - if (ffesymbol_token_blank_common_ == NULL) - ffesymbol_token_blank_common_ - = ffelex_token_new_name (FFETARGET_nameBLANK_COMMON, wl, wc); - t = ffesymbol_token_blank_common_; - } - else - blank = FALSE; - - n = ffename_find (ffesymbol_global_, t); - s = ffename_symbol (n); - if (s != NULL) - { - if (!blank) - ffesymbol_check (s, t, FALSE); - return s; - } - - s = ffesymbol_new_ (n); - if (!blank) - ffesymbol_check (s, t, FALSE); - - ffeglobal_new_common (s, t, blank); /* Detect conflicts. */ - - return s; -} - -/* Declare a FUNCTION program unit (with distinct RESULT() name). - - Retrieves or creates the ffesymbol for the specified function. Doesn't - actually ensure the named item is a function; the caller must handle - that. - - If FUNCTION with RESULT() is specified but the names are the same, - pretend as though RESULT() was not specified, and don't call this - function; use ffesymbol_declare_funcunit() instead. */ - -ffesymbol -ffesymbol_declare_funcnotresunit (ffelexToken t) -{ - ffename n; - ffesymbol s; - - assert (t != NULL); - assert (!ffesymbol_retractable_); - - n = ffename_lookup (ffesymbol_local_, t); - if (n != NULL) - return ffename_symbol (n); /* This will become an error. */ - - n = ffename_find (ffesymbol_global_, t); - s = ffename_symbol (n); - if (s != NULL) - { - ffesymbol_check (s, t, FALSE); - return s; - } - - s = ffesymbol_new_ (n); - ffesymbol_check (s, t, FALSE); - - /* A FUNCTION program unit name also is in the local name space; handle it - here since RESULT() is a different name and is handled separately. */ - - n = ffename_find (ffesymbol_local_, t); - ffename_set_symbol (n, s); - s->other_space_name = n; - - ffeglobal_new_function (s, t);/* Detect conflicts, when appropriate. */ - - return s; -} - -/* Declare a function result. - - Retrieves or creates the ffesymbol for the specified function result, - whether specified via a distinct RESULT() or by default in a FUNCTION or - ENTRY statement. */ - -ffesymbol -ffesymbol_declare_funcresult (ffelexToken t) -{ - ffename n; - ffesymbol s; - - assert (t != NULL); - assert (!ffesymbol_retractable_); - - n = ffename_find (ffesymbol_local_, t); - s = ffename_symbol (n); - if (s != NULL) - return s; - - return ffesymbol_new_ (n); -} - -/* Declare a FUNCTION program unit with no RESULT(). - - Retrieves or creates the ffesymbol for the specified function. Doesn't - actually ensure the named item is a function; the caller must handle - that. - - This is the function to call when the FUNCTION or ENTRY statement has - no separate and distinct name specified via RESULT(). That's because - this function enters the global name of the function in only the global - name space. ffesymbol_declare_funcresult() must still be called to - declare the name for the function result in the local name space. */ - -ffesymbol -ffesymbol_declare_funcunit (ffelexToken t) -{ - ffename n; - ffesymbol s; - - assert (t != NULL); - assert (!ffesymbol_retractable_); - - n = ffename_find (ffesymbol_global_, t); - s = ffename_symbol (n); - if (s != NULL) - { - ffesymbol_check (s, t, FALSE); - return s; - } - - s = ffesymbol_new_ (n); - ffesymbol_check (s, t, FALSE); - - ffeglobal_new_function (s, t);/* Detect conflicts. */ - - return s; -} - -/* Declare a local entity. - - Retrieves or creates the ffesymbol for the specified local entity. - Set maybe_intrin TRUE if this name might turn out to name an - intrinsic (legitimately); otherwise if the name doesn't meet the - requirements for a user-defined symbol name, a diagnostic will be - issued right away rather than waiting until the intrinsicness of the - symbol is determined. */ - -ffesymbol -ffesymbol_declare_local (ffelexToken t, bool maybe_intrin) -{ - ffename n; - ffesymbol s; - - assert (t != NULL); - - /* If we're parsing within a statement function definition, return the - symbol if already known (a dummy argument for the statement function). - Otherwise continue on, which means the symbol is declared within the - containing (local) program unit rather than the statement function - definition. */ - - if ((ffesymbol_sfunc_ != NULL) - && ((n = ffename_lookup (ffesymbol_sfunc_, t)) != NULL)) - return ffename_symbol (n); - - n = ffename_find (ffesymbol_local_, t); - s = ffename_symbol (n); - if (s != NULL) - { - ffesymbol_check (s, t, maybe_intrin); - return s; - } - - s = ffesymbol_new_ (n); - ffesymbol_check (s, t, maybe_intrin); - return s; -} - -/* Declare a main program unit. - - Retrieves or creates the ffesymbol for the specified main program unit - (unnamed main program unit if t is NULL). Doesn't actually ensure the - named item is a program; the caller must handle that. */ - -ffesymbol -ffesymbol_declare_programunit (ffelexToken t, ffewhereLine wl, - ffewhereColumn wc) -{ - ffename n; - ffesymbol s; - bool user = (t != NULL); - - assert (!ffesymbol_retractable_); - - if (t == NULL) - { - if (ffesymbol_token_unnamed_main_ == NULL) - ffesymbol_token_unnamed_main_ - = ffelex_token_new_name (FFETARGET_nameUNNAMED_MAIN, wl, wc); - t = ffesymbol_token_unnamed_main_; - } - - n = ffename_lookup (ffesymbol_local_, t); - if (n != NULL) - return ffename_symbol (n); /* This will become an error. */ - - n = ffename_find (ffesymbol_global_, t); - s = ffename_symbol (n); - if (s != NULL) - { - if (user) - ffesymbol_check (s, t, FALSE); - return s; - } - - s = ffesymbol_new_ (n); - if (user) - ffesymbol_check (s, t, FALSE); - - /* A program unit name also is in the local name space. */ - - n = ffename_find (ffesymbol_local_, t); - ffename_set_symbol (n, s); - s->other_space_name = n; - - ffeglobal_new_program (s, t); /* Detect conflicts. */ - - return s; -} - -/* Declare a statement-function dummy. - - Retrieves or creates the ffesymbol for the specified statement - function dummy. Also ensures that it has a link to the parent (local) - ffesymbol with the same name, creating it if necessary. */ - -ffesymbol -ffesymbol_declare_sfdummy (ffelexToken t) -{ - ffename n; - ffesymbol s; - ffesymbol sp; /* Parent symbol in local area. */ - - assert (t != NULL); - - n = ffename_find (ffesymbol_local_, t); - sp = ffename_symbol (n); - if (sp == NULL) - sp = ffesymbol_new_ (n); - ffesymbol_check (sp, t, FALSE); - - n = ffename_find (ffesymbol_sfunc_, t); - s = ffename_symbol (n); - if (s == NULL) - { - s = ffesymbol_new_ (n); - s->sfa_dummy_parent = sp; - } - else - assert (s->sfa_dummy_parent == sp); - - return s; -} - -/* Declare a subroutine program unit. - - Retrieves or creates the ffesymbol for the specified subroutine - Doesn't actually ensure the named item is a subroutine; the caller must - handle that. */ - -ffesymbol -ffesymbol_declare_subrunit (ffelexToken t) -{ - ffename n; - ffesymbol s; - - assert (!ffesymbol_retractable_); - assert (t != NULL); - - n = ffename_lookup (ffesymbol_local_, t); - if (n != NULL) - return ffename_symbol (n); /* This will become an error. */ - - n = ffename_find (ffesymbol_global_, t); - s = ffename_symbol (n); - if (s != NULL) - { - ffesymbol_check (s, t, FALSE); - return s; - } - - s = ffesymbol_new_ (n); - ffesymbol_check (s, t, FALSE); - - /* A program unit name also is in the local name space. */ - - n = ffename_find (ffesymbol_local_, t); - ffename_set_symbol (n, s); - s->other_space_name = n; - - ffeglobal_new_subroutine (s, t); /* Detect conflicts, when - appropriate. */ - - return s; -} - -/* Call given fn with all local/global symbols. - - ffesymbol (*fn) (ffesymbol s); - ffesymbol_drive (fn); */ - -void -ffesymbol_drive (ffesymbol (*fn) ()) -{ - assert (ffesymbol_sfunc_ == NULL); /* Might be ok, but not for current - uses. */ - ffename_space_drive_symbol (ffesymbol_local_, fn); - ffename_space_drive_symbol (ffesymbol_global_, fn); -} - -/* Call given fn with all sfunc-only symbols. - - ffesymbol (*fn) (ffesymbol s); - ffesymbol_drive_sfnames (fn); */ - -void -ffesymbol_drive_sfnames (ffesymbol (*fn) ()) -{ - ffename_space_drive_symbol (ffesymbol_sfunc_, fn); -} - -/* Dump info on the symbol for debugging purposes. */ - -#if FFECOM_targetCURRENT == FFECOM_targetFFE -void -ffesymbol_dump (ffesymbol s) -{ - ffeinfoKind k; - ffeinfoWhere w; - - assert (s != NULL); - - if (ffeinfo_size (s->info) != FFETARGET_charactersizeNONE) - fprintf (dmpout, "%s:%d%s%s*%" ffetargetCharacterSize_f "u", - ffesymbol_text (s), - (int) ffeinfo_rank (s->info), - ffeinfo_basictype_string (ffeinfo_basictype (s->info)), - ffeinfo_kindtype_string (ffeinfo_kindtype (s->info)), - ffeinfo_size (s->info)); - else - fprintf (dmpout, "%s:%d%s%s", - ffesymbol_text (s), - (int) ffeinfo_rank (s->info), - ffeinfo_basictype_string (ffeinfo_basictype (s->info)), - ffeinfo_kindtype_string (ffeinfo_kindtype (s->info))); - if ((k = ffeinfo_kind (s->info)) != FFEINFO_kindNONE) - fprintf (dmpout, "/%s", ffeinfo_kind_string (k)); - if ((w = ffeinfo_where (s->info)) != FFEINFO_whereNONE) - fprintf (dmpout, "@%s", ffeinfo_where_string (w)); - - if ((s->generic != FFEINTRIN_genNONE) - || (s->specific != FFEINTRIN_specNONE) - || (s->implementation != FFEINTRIN_impNONE)) - fprintf (dmpout, "{%s:%s:%s}", - ffeintrin_name_generic (s->generic), - ffeintrin_name_specific (s->specific), - ffeintrin_name_implementation (s->implementation)); -} -#endif - -/* Produce generic error message about a symbol. - - For now, just output error message using symbol's name and pointing to - the token. */ - -void -ffesymbol_error (ffesymbol s, ffelexToken t) -{ - if ((t != NULL) - && ffest_ffebad_start (FFEBAD_SYMERR)) - { - ffebad_string (ffesymbol_text (s)); - ffebad_here (0, ffelex_token_where_line (t), - ffelex_token_where_column (t)); - ffebad_here (1, ffesymbol_where_line (s), ffesymbol_where_column (s)); - ffebad_finish (); - } - - if (ffesymbol_attr (s, FFESYMBOL_attrANY)) - return; - - ffesymbol_signal_change (s); /* May need to back up to previous version. */ - if ((ffesymbol_attrs (s) & FFESYMBOL_attrsCBLOCK) - || (ffesymbol_kind (s) == FFEINFO_kindNAMELIST)) - ffebld_end_list (ffesymbol_ptr_to_listbottom (s)); - ffesymbol_set_attr (s, FFESYMBOL_attrANY); - ffesymbol_set_info (s, ffeinfo_new_any ()); - ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD); - if (s->check_state == FFESYMBOL_checkstatePENDING_) - ffelex_token_kill (s->check_token); - s->check_state = FFESYMBOL_checkstateCHECKED_; - s = ffecom_sym_learned (s); - ffesymbol_signal_unreported (s); -} - -void -ffesymbol_init_0 () -{ - ffesymbolAttrs attrs = FFESYMBOL_attrsetNONE; - - assert (FFESYMBOL_state == ARRAY_SIZE (ffesymbol_state_name_)); - assert (FFESYMBOL_attr == ARRAY_SIZE (ffesymbol_attr_name_)); - assert (attrs == FFESYMBOL_attrsetNONE); - attrs = ((ffesymbolAttrs) 1 << FFESYMBOL_attr); - assert (attrs != 0); -} - -void -ffesymbol_init_1 () -{ -#if FFESYMBOL_globalCURRENT_ == FFESYMBOL_globalFILE_ - ffesymbol_global_ = ffename_space_new (ffe_pool_file ()); -#endif -} - -void -ffesymbol_init_2 () -{ -} - -void -ffesymbol_init_3 () -{ -#if FFESYMBOL_globalCURRENT_ == FFESYMBOL_globalPROGUNIT_ - ffesymbol_global_ = ffename_space_new (ffe_pool_program_unit ()); -#endif - ffesymbol_local_ = ffename_space_new (ffe_pool_program_unit ()); -} - -void -ffesymbol_init_4 () -{ - ffesymbol_sfunc_ = ffename_space_new (ffe_pool_program_unit ()); -} - -/* Look up a local entity. - - Retrieves the ffesymbol for the specified local entity, or returns NULL - if no local entity by that name exists. */ - -ffesymbol -ffesymbol_lookup_local (ffelexToken t) -{ - ffename n; - ffesymbol s; - - assert (t != NULL); - - n = ffename_lookup (ffesymbol_local_, t); - if (n == NULL) - return NULL; - - s = ffename_symbol (n); - return s; /* May be NULL here, too. */ -} - -/* Registers the symbol as one that is referenced by the - current program unit. Currently applies only to - symbols known to have global interest (globals and - intrinsics). - - s is the (global/intrinsic) symbol referenced; t is the - referencing token; explicit is TRUE if the reference - is, e.g., INTRINSIC FOO. */ - -void -ffesymbol_reference (ffesymbol s, ffelexToken t, bool explicit) -{ - ffename gn; - ffesymbol gs = NULL; - ffeinfoKind kind; - ffeinfoWhere where; - bool okay; - - if (ffesymbol_retractable_) - return; - - if (t == NULL) - t = ffename_token (s->name); /* Use the first reference in this program unit. */ - - kind = ffesymbol_kind (s); - where = ffesymbol_where (s); - - if (where == FFEINFO_whereINTRINSIC) - { - ffeglobal_ref_intrinsic (s, t, - explicit - || s->explicit_where - || ffeintrin_is_standard (s->generic, s->specific)); - return; - } - - if ((where != FFEINFO_whereGLOBAL) - && ((where != FFEINFO_whereLOCAL) - || ((kind != FFEINFO_kindFUNCTION) - && (kind != FFEINFO_kindSUBROUTINE)))) - return; - - gn = ffename_lookup (ffesymbol_global_, t); - if (gn != NULL) - gs = ffename_symbol (gn); - if ((gs != NULL) && (gs != s)) - { - /* We have just discovered another global symbol with the same name - but a different `nature'. Complain. Note that COMMON /FOO/ can - coexist with local symbol FOO, e.g. local variable, just not with - CALL FOO, hence the separate namespaces. */ - - ffesymbol_error (gs, t); - ffesymbol_error (s, NULL); - return; - } - - switch (kind) - { - case FFEINFO_kindBLOCKDATA: - okay = ffeglobal_ref_blockdata (s, t); - break; - - case FFEINFO_kindSUBROUTINE: - okay = ffeglobal_ref_subroutine (s, t); - break; - - case FFEINFO_kindFUNCTION: - okay = ffeglobal_ref_function (s, t); - break; - - case FFEINFO_kindNONE: - okay = ffeglobal_ref_external (s, t); - break; - - default: - assert ("bad kind in global ref" == NULL); - return; - } - - if (! okay) - ffesymbol_error (s, NULL); -} - -/* Report info on the symbol for debugging purposes. */ - -#if FFECOM_targetCURRENT == FFECOM_targetFFE -ffesymbol -ffesymbol_report (ffesymbol s) -{ - ffeinfoKind k; - ffeinfoWhere w; - - assert (s != NULL); - - if (s->reported) - return s; - - s->reported = TRUE; - - if (ffeinfo_size (s->info) != FFETARGET_charactersizeNONE) - fprintf (dmpout, "\"%s\": %s %s %d%s%s*%" ffetargetCharacterSize_f "u", - ffesymbol_text (s), - ffesymbol_state_string (s->state), - ffesymbol_attrs_string (s->attrs), - (int) ffeinfo_rank (s->info), - ffeinfo_basictype_string (ffeinfo_basictype (s->info)), - ffeinfo_kindtype_string (ffeinfo_kindtype (s->info)), - ffeinfo_size (s->info)); - else - fprintf (dmpout, "\"%s\": %s %s %d%s%s", - ffesymbol_text (s), - ffesymbol_state_string (s->state), - ffesymbol_attrs_string (s->attrs), - (int) ffeinfo_rank (s->info), - ffeinfo_basictype_string (ffeinfo_basictype (s->info)), - ffeinfo_kindtype_string (ffeinfo_kindtype (s->info))); - if ((k = ffeinfo_kind (s->info)) != FFEINFO_kindNONE) - fprintf (dmpout, "/%s", ffeinfo_kind_string (k)); - if ((w = ffeinfo_where (s->info)) != FFEINFO_whereNONE) - fprintf (dmpout, "@%s", ffeinfo_where_string (w)); - fputc ('\n', dmpout); - - if (s->dims != NULL) - { - fprintf (dmpout, " dims: "); - ffebld_dump (s->dims); - fputs ("\n", dmpout); - } - - if (s->extents != NULL) - { - fprintf (dmpout, " extents: "); - ffebld_dump (s->extents); - fputs ("\n", dmpout); - } - - if (s->dim_syms != NULL) - { - fprintf (dmpout, " dim syms: "); - ffebld_dump (s->dim_syms); - fputs ("\n", dmpout); - } - - if (s->array_size != NULL) - { - fprintf (dmpout, " array size: "); - ffebld_dump (s->array_size); - fputs ("\n", dmpout); - } - - if (s->init != NULL) - { - fprintf (dmpout, " init-value: "); - if (ffebld_op (s->init) == FFEBLD_opANY) - fputs ("<any>\n", dmpout); - else - { - ffebld_dump (s->init); - fputs ("\n", dmpout); - } - } - - if (s->accretion != NULL) - { - fprintf (dmpout, " accretion (%" ffetargetOffset_f "d left): ", - s->accretes); - ffebld_dump (s->accretion); - fputs ("\n", dmpout); - } - else if (s->accretes != 0) - fprintf (dmpout, " accretes!! = %" ffetargetOffset_f "d left\n", - s->accretes); - - if (s->dummy_args != NULL) - { - fprintf (dmpout, " dummies: "); - ffebld_dump (s->dummy_args); - fputs ("\n", dmpout); - } - - if (s->namelist != NULL) - { - fprintf (dmpout, " namelist: "); - ffebld_dump (s->namelist); - fputs ("\n", dmpout); - } - - if (s->common_list != NULL) - { - fprintf (dmpout, " common-list: "); - ffebld_dump (s->common_list); - fputs ("\n", dmpout); - } - - if (s->sfunc_expr != NULL) - { - fprintf (dmpout, " sfunc expression: "); - ffebld_dump (s->sfunc_expr); - fputs ("\n", dmpout); - } - - if (s->is_save) - { - fprintf (dmpout, " SAVEd\n"); - } - - if (s->is_init) - { - fprintf (dmpout, " initialized\n"); - } - - if (s->do_iter) - { - fprintf (dmpout, " DO-loop iteration variable (currently)\n"); - } - - if (s->explicit_where) - { - fprintf (dmpout, " Explicit INTRINSIC/EXTERNAL\n"); - } - - if (s->namelisted) - { - fprintf (dmpout, " Namelisted\n"); - } - - if (s->common != NULL) - { - fprintf (dmpout, " COMMON area: %s\n", ffesymbol_text (s->common)); - } - - if (s->equiv != NULL) - { - fprintf (dmpout, " EQUIVALENCE information: "); - ffeequiv_dump (s->equiv); - fputs ("\n", dmpout); - } - - if (s->storage != NULL) - { - fprintf (dmpout, " Storage: "); - ffestorag_dump (s->storage); - fputs ("\n", dmpout); - } - - return s; -} -#endif - -/* Report info on the symbols. */ - -#if FFECOM_targetCURRENT == FFECOM_targetFFE -void -ffesymbol_report_all () -{ - ffename_space_drive_symbol (ffesymbol_sfunc_, ffesymbol_report); - ffename_space_drive_symbol (ffesymbol_local_, ffesymbol_report); - ffename_space_drive_symbol (ffesymbol_global_, ffesymbol_report); -} -#endif - -/* Resolve symbol that has become known intrinsic or non-intrinsic. */ - -void -ffesymbol_resolve_intrin (ffesymbol s) -{ - char c; - ffebad bad; - - if (!ffesrc_check_symbol ()) - return; - if (s->check_state != FFESYMBOL_checkstatePENDING_) - return; - if (ffebad_inhibit ()) - return; /* We'll get back to this later. */ - - if (ffesymbol_where (s) != FFEINFO_whereINTRINSIC) - { - bad = ffesymbol_check_token_ (s->check_token, &c); - assert (bad != FFEBAD); /* How did this suddenly become ok? */ - ffesymbol_whine_state_ (bad, s->check_token, c); - } - - s->check_state = FFESYMBOL_checkstateCHECKED_; - ffelex_token_kill (s->check_token); -} - -/* Retract or cancel retract list. */ - -void -ffesymbol_retract (bool retract) -{ - ffesymbolRetract_ r; - ffename name; - ffename other_space_name; - ffesymbol ls; - ffesymbol os; - - assert (ffesymbol_retractable_); - - ffesymbol_retractable_ = FALSE; - - for (r = ffesymbol_retract_first_; r != NULL; r = r->next) - { - ls = r->live; - os = r->symbol; - switch (r->command) - { - case FFESYMBOL_retractcommandDELETE_: - if (retract) - { - ffecom_sym_retract (ls); - name = ls->name; - other_space_name = ls->other_space_name; - ffesymbol_unhook_ (ls); - malloc_kill_ks (FFESYMBOL_SPACE_POOL_, ls, sizeof (*ls)); - if (name != NULL) - ffename_set_symbol (name, NULL); - if (other_space_name != NULL) - ffename_set_symbol (other_space_name, NULL); - } - else - { - ffecom_sym_commit (ls); - ls->have_old = FALSE; - } - break; - - case FFESYMBOL_retractcommandRETRACT_: - if (retract) - { - ffecom_sym_retract (ls); - ffesymbol_unhook_ (ls); - *ls = *os; - malloc_kill_ks (FFESYMBOL_SPACE_POOL_, os, sizeof (*os)); - } - else - { - ffecom_sym_commit (ls); - ffesymbol_unhook_ (os); - malloc_kill_ks (FFESYMBOL_SPACE_POOL_, os, sizeof (*os)); - ls->have_old = FALSE; - } - break; - - default: - assert ("bad command" == NULL); - break; - } - } -} - -/* Return retractable flag. */ - -bool -ffesymbol_retractable () -{ - return ffesymbol_retractable_; -} - -/* Set retractable flag, retract pool. - - Between this call and ffesymbol_retract, any changes made to existing - symbols cause the previous versions of those symbols to be saved, and any - newly created symbols to have their previous nonexistence saved. When - ffesymbol_retract is called, this information either is used to retract - the changes and new symbols, or is discarded. */ - -void -ffesymbol_set_retractable (mallocPool pool) -{ - assert (!ffesymbol_retractable_); - - ffesymbol_retractable_ = TRUE; - ffesymbol_retract_pool_ = pool; - ffesymbol_retract_list_ = &ffesymbol_retract_first_; - ffesymbol_retract_first_ = NULL; -} - -/* Existing symbol about to be changed; save? - - Call this function before changing a symbol if it is possible that - the current actions may need to be undone (i.e. one of several possible - statement forms are being used to analyze the current system). - - If the "retractable" flag is not set, just return. - Else, if the symbol's "have_old" flag is set, just return. - Else, make a copy of the symbol and add it to the "retract" list, set - the "have_old" flag, and return. */ - -void -ffesymbol_signal_change (ffesymbol s) -{ - ffesymbolRetract_ r; - ffesymbol sym; - - if (!ffesymbol_retractable_ || s->have_old) - return; - - r = (ffesymbolRetract_) malloc_new_kp (ffesymbol_retract_pool_, - "FFESYMBOL retract", sizeof (*r)); - r->next = NULL; - r->command = FFESYMBOL_retractcommandRETRACT_; - r->live = s; - r->symbol = sym = (ffesymbol) malloc_new_ks (FFESYMBOL_SPACE_POOL_, - "FFESYMBOL", sizeof (*sym)); - *sym = *s; /* Make an exact copy of the symbol in case - we need it back. */ - sym->info = ffeinfo_use (s->info); - if (s->check_state == FFESYMBOL_checkstatePENDING_) - sym->check_token = ffelex_token_use (s->check_token); - - *ffesymbol_retract_list_ = r; - ffesymbol_retract_list_ = &r->next; - - s->have_old = TRUE; -} - -/* Returns the string based on the state. */ - -char * -ffesymbol_state_string (ffesymbolState state) -{ - if (state >= ARRAY_SIZE (ffesymbol_state_name_)) - return "?\?\?"; - return ffesymbol_state_name_[state]; -} - -void -ffesymbol_terminate_0 () -{ -} - -void -ffesymbol_terminate_1 () -{ -#if FFESYMBOL_globalCURRENT_ == FFESYMBOL_globalFILE_ - ffename_space_drive_symbol (ffesymbol_global_, ffesymbol_unhook_); - ffename_space_kill (ffesymbol_global_); - ffesymbol_global_ = NULL; - - ffesymbol_kill_manifest_ (); -#endif -} - -void -ffesymbol_terminate_2 () -{ -#if FFESYMBOL_globalCURRENT_ == FFESYMBOL_globalPROGUNIT_ - ffesymbol_kill_manifest_ (); -#endif -} - -void -ffesymbol_terminate_3 () -{ -#if FFESYMBOL_globalCURRENT_ == FFESYMBOL_globalPROGUNIT_ - ffename_space_drive_symbol (ffesymbol_global_, ffesymbol_unhook_); - ffename_space_kill (ffesymbol_global_); -#endif - ffename_space_drive_symbol (ffesymbol_local_, ffesymbol_unhook_); - ffename_space_kill (ffesymbol_local_); -#if FFESYMBOL_globalCURRENT_ == FFESYMBOL_globalPROGUNIT_ - ffesymbol_global_ = NULL; -#endif - ffesymbol_local_ = NULL; -} - -void -ffesymbol_terminate_4 () -{ - ffename_space_drive_symbol (ffesymbol_sfunc_, ffesymbol_unhook_); - ffename_space_kill (ffesymbol_sfunc_); - ffesymbol_sfunc_ = NULL; -} - -/* Update INIT info to TRUE and all equiv/storage too. - - If INIT flag is TRUE, does nothing. Else sets it to TRUE and calls - on the ffeequiv and ffestorag modules to update their INIT flags if - the <s> symbol has those objects, and also updates the common area if - it exists. */ - -void -ffesymbol_update_init (ffesymbol s) -{ - ffebld item; - - if (s->is_init) - return; - - s->is_init = TRUE; - - if ((s->equiv != NULL) - && !ffeequiv_is_init (s->equiv)) - ffeequiv_update_init (s->equiv); - - if ((s->storage != NULL) - && !ffestorag_is_init (s->storage)) - ffestorag_update_init (s->storage); - - if ((s->common != NULL) - && (!ffesymbol_is_init (s->common))) - ffesymbol_update_init (s->common); - - for (item = s->common_list; item != NULL; item = ffebld_trail (item)) - { - if (!ffesymbol_is_init (ffebld_symter (ffebld_head (item)))) - ffesymbol_update_init (ffebld_symter (ffebld_head (item))); - } -} - -/* Update SAVE info to TRUE and all equiv/storage too. - - If SAVE flag is TRUE, does nothing. Else sets it to TRUE and calls - on the ffeequiv and ffestorag modules to update their SAVE flags if - the <s> symbol has those objects, and also updates the common area if - it exists. */ - -void -ffesymbol_update_save (ffesymbol s) -{ - ffebld item; - - if (s->is_save) - return; - - s->is_save = TRUE; - - if ((s->equiv != NULL) - && !ffeequiv_is_save (s->equiv)) - ffeequiv_update_save (s->equiv); - - if ((s->storage != NULL) - && !ffestorag_is_save (s->storage)) - ffestorag_update_save (s->storage); - - if ((s->common != NULL) - && (!ffesymbol_is_save (s->common))) - ffesymbol_update_save (s->common); - - for (item = s->common_list; item != NULL; item = ffebld_trail (item)) - { - if (!ffesymbol_is_save (ffebld_symter (ffebld_head (item)))) - ffesymbol_update_save (ffebld_symter (ffebld_head (item))); - } -} |