/* Implementation of Fortran symbol manager Copyright (C) 1995, 1996, 1997 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. */ #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 const char *ffesymbol_state_name_[] = { "?", "@", "&", "$", }; /* List of attribute names. */ static const 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; s->assigned = 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. */ const 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) (ffesymbol)) { 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) (ffesymbol)) { 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 ("\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. */ const 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 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 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))); } }