+++ /dev/null
-/* 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. */
-
-/* Would be good to understand why PROGUNIT in this case too.
- (1995-08-22). */
-#define FFESYMBOL_globalCURRENT_ FFESYMBOL_globalPROGUNIT_
-
-/* 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 *const ffesymbol_state_name_[] =
-{
- "?",
- "@",
- "&",
- "$",
-};
-
-/* List of attribute names. */
-
-static const char *const ffesymbol_attr_name_[] =
-{
-#define DEFATTR(ATTR,ATTRS,NAME) NAME,
-#include "symbol.def"
-#undef DEFATTR
-};
-\f
-
-/* 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);
-}
-
-/* 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);
-}
-
-/* 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 <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)));
- }
-}
projects / msp430-gcc.git / blobdiff