diff options
Diffstat (limited to 'gcc/f/symbol.c')
| -rw-r--r-- | gcc/f/symbol.c | 1469 |
1 files changed, 1469 insertions, 0 deletions
diff --git a/gcc/f/symbol.c b/gcc/f/symbol.c new file mode 100644 index 0000000..7199cdb --- /dev/null +++ b/gcc/f/symbol.c @@ -0,0 +1,1469 @@ +/* Implementation of Fortran symbol manager + Copyright (C) 1995, 1996 Free Software Foundation, Inc. + Contributed by James Craig Burley (burley@gnu.ai.mit.edu). + +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. */ + +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)); +} + +/* 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. */ + +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; +} + +/* Report info on the symbols. */ + +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); +} + +/* 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))); + } +} |