gcc/f/symbol.c

   1 /* Implementation of Fortran symbol manager
   2    Copyright (C) 1995, 1996, 1997 Free Software Foundation, Inc.
   3    Contributed by James Craig Burley.
   4
   5 This file is part of GNU Fortran.
   6
   7 GNU Fortran is free software; you can redistribute it and/or modify
   8 it under the terms of the GNU General Public License as published by
   9 the Free Software Foundation; either version 2, or (at your option)
  10 any later version.
  11
  12 GNU Fortran is distributed in the hope that it will be useful,
  13 but WITHOUT ANY WARRANTY; without even the implied warranty of
  14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15 GNU General Public License for more details.
  16
  17 You should have received a copy of the GNU General Public License
  18 along with GNU Fortran; see the file COPYING.  If not, write to
  19 the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA
  20 02111-1307, USA.  */
  21
  22 #include "proj.h"
  23 #include "symbol.h"
  24 #include "bad.h"
  25 #include "bld.h"
  26 #include "com.h"
  27 #include "equiv.h"
  28 #include "global.h"
  29 #include "info.h"
  30 #include "intrin.h"
  31 #include "lex.h"
  32 #include "malloc.h"
  33 #include "src.h"
  34 #include "st.h"
  35 #include "storag.h"
  36 #include "target.h"
  37 #include "where.h"
  38
  39 /* Choice of how to handle global symbols -- either global only within the
  40    program unit being defined or global within the entire source file.
  41    The former is appropriate for systems where an object file can
  42    easily be taken apart program unit by program unit, the latter is the
  43    UNIX/C model where the object file is essentially a monolith.  */
  44
  45 #define FFESYMBOL_globalPROGUNIT_ 1
  46 #define FFESYMBOL_globalFILE_ 2
  47
  48 /* Choose how to handle global symbols here.  */
  49
  50 #if FFECOM_targetCURRENT == FFECOM_targetFFE
  51 #define FFESYMBOL_globalCURRENT_ FFESYMBOL_globalPROGUNIT_
  52 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
  53 /* Would be good to understand why PROGUNIT in this case too.
  54    (1995-08-22).  */
  55 #define FFESYMBOL_globalCURRENT_ FFESYMBOL_globalPROGUNIT_
  56 #else
  57 #error
  58 #endif
  59
  60 /* Choose how to handle memory pools based on global symbol stuff.  */
  61
  62 #if FFESYMBOL_globalCURRENT_ == FFESYMBOL_globalPROGUNIT_
  63 #define FFESYMBOL_SPACE_POOL_ ffe_pool_program_unit()
  64 #elif FFESYMBOL_globalCURRENT_ == FFESYMBOL_globalFILE_
  65 #define FFESYMBOL_SPACE_POOL_ ffe_pool_file()
  66 #else
  67 #error
  68 #endif
  69
  70 /* What kind of retraction is needed for a symbol?  */
  71
  72 enum _ffesymbol_retractcommand_
  73   {
  74     FFESYMBOL_retractcommandDELETE_,
  75     FFESYMBOL_retractcommandRETRACT_,
  76     FFESYMBOL_retractcommand_
  77   };
  78 typedef enum _ffesymbol_retractcommand_ ffesymbolRetractCommand_;
  79
  80 /* This object keeps track of retraction for a symbol and links to the next
  81    such object.  */
  82
  83 typedef struct _ffesymbol_retract_ *ffesymbolRetract_;
  84 struct _ffesymbol_retract_
  85   {
  86     ffesymbolRetract_ next;
  87     ffesymbolRetractCommand_ command;
  88     ffesymbol live;             /* Live symbol. */
  89     ffesymbol symbol;           /* Backup copy of symbol. */
  90   };
  91
  92 static ffebad ffesymbol_check_token_ (ffelexToken t, char *c);
  93 static void ffesymbol_kill_manifest_ (void);
  94 static ffesymbol ffesymbol_new_ (ffename n);
  95 static ffesymbol ffesymbol_unhook_ (ffesymbol s);
  96 static void ffesymbol_whine_state_ (ffebad bad, ffelexToken t, char c);
  97
  98 /* Manifest names for unnamed things (as tokens) so we make them only
  99    once.  */
 100
 101 static ffelexToken ffesymbol_token_blank_common_ = NULL;
 102 static ffelexToken ffesymbol_token_unnamed_main_ = NULL;
 103 static ffelexToken ffesymbol_token_unnamed_blockdata_ = NULL;
 104
 105 /* Name spaces currently in force.  */
 106
 107 static ffenameSpace ffesymbol_global_ = NULL;
 108 static ffenameSpace ffesymbol_local_ = NULL;
 109 static ffenameSpace ffesymbol_sfunc_ = NULL;
 110
 111 /* Keep track of retraction.  */
 112
 113 static bool ffesymbol_retractable_ = FALSE;
 114 static mallocPool ffesymbol_retract_pool_;
 115 static ffesymbolRetract_ ffesymbol_retract_first_;
 116 static ffesymbolRetract_ *ffesymbol_retract_list_;
 117
 118 /* List of state names. */
 119
 120 static const char *ffesymbol_state_name_[] =
 121 {
 122   "?",
 123   "@",
 124   "&",
 125   "$",
 126 };
 127
 128 /* List of attribute names. */
 129
 130 static const char *ffesymbol_attr_name_[] =
 131 {
 132 #define DEFATTR(ATTR,ATTRS,NAME) NAME,
 133 #include "symbol.def"
 134 #undef DEFATTR
 135 };
 136 \f
 137
 138 /* Check whether the token text has any invalid characters.  If not,
 139    return FALSE.  If so, if error messages inhibited, return TRUE
 140    so caller knows to try again later, else report error and return
 141    FALSE.  */
 142
 143 static ffebad
 144 ffesymbol_check_token_ (ffelexToken t, char *c)
 145 {
 146   char *p = ffelex_token_text (t);
 147   ffeTokenLength len = ffelex_token_length (t);
 148   ffebad bad;
 149   ffeTokenLength i = 0;
 150   ffebad skip_me = ((ffe_case_symbol () == FFE_caseINITCAP)
 151                     ? FFEBAD_SYMBOL_NOLOWER_INITCAP : FFEBAD + 1);
 152   ffebad stop_me = ((ffe_case_symbol () == FFE_caseINITCAP)
 153                     ? FFEBAD : FFEBAD + 1);
 154   if (len == 0)
 155     return FFEBAD;
 156
 157   bad = ffesrc_bad_char_symbol_init (*p);
 158   if (bad == FFEBAD)
 159     {
 160       for (++i, ++p; i < len; ++i, ++p)
 161         {
 162           bad = ffesrc_bad_char_symbol_noninit (*p);
 163           if (bad == skip_me)
 164             continue;           /* Keep looking for good InitCap character. */
 165           if (bad == stop_me)
 166             break;              /* Found good InitCap character. */
 167           if (bad != FFEBAD)
 168             break;              /* Bad character found. */
 169         }
 170     }
 171
 172   if (bad != FFEBAD)
 173     {
 174       if (i >= len)
 175         *c = *(ffelex_token_text (t));
 176       else
 177         *c = *p;
 178     }
 179
 180   return bad;
 181 }
 182
 183 /* Kill manifest (g77-picked) names.  */
 184
 185 static void
 186 ffesymbol_kill_manifest_ ()
 187 {
 188   if (ffesymbol_token_blank_common_ != NULL)
 189     ffelex_token_kill (ffesymbol_token_blank_common_);
 190   if (ffesymbol_token_unnamed_main_ != NULL)
 191     ffelex_token_kill (ffesymbol_token_unnamed_main_);
 192   if (ffesymbol_token_unnamed_blockdata_ != NULL)
 193     ffelex_token_kill (ffesymbol_token_unnamed_blockdata_);
 194
 195   ffesymbol_token_blank_common_ = NULL;
 196   ffesymbol_token_unnamed_main_ = NULL;
 197   ffesymbol_token_unnamed_blockdata_ = NULL;
 198 }
 199
 200 /* Make new symbol.
 201
 202    If the "retractable" flag is not set, just return the new symbol.
 203    Else, add symbol to the "retract" list as a delete item, set
 204    the "have_old" flag, and return the new symbol.  */
 205
 206 static ffesymbol
 207 ffesymbol_new_ (ffename n)
 208 {
 209   ffesymbol s;
 210   ffesymbolRetract_ r;
 211
 212   assert (n != NULL);
 213
 214   s = (ffesymbol) malloc_new_ks (FFESYMBOL_SPACE_POOL_, "FFESYMBOL",
 215                                  sizeof (*s));
 216   s->name = n;
 217   s->other_space_name = NULL;
 218 #if FFEGLOBAL_ENABLED
 219   s->global = NULL;
 220 #endif
 221   s->attrs = FFESYMBOL_attrsetNONE;
 222   s->state = FFESYMBOL_stateNONE;
 223   s->info = ffeinfo_new_null ();
 224   s->dims = NULL;
 225   s->extents = NULL;
 226   s->dim_syms = NULL;
 227   s->array_size = NULL;
 228   s->init = NULL;
 229   s->accretion = NULL;
 230   s->accretes = 0;
 231   s->dummy_args = NULL;
 232   s->namelist = NULL;
 233   s->common_list = NULL;
 234   s->sfunc_expr = NULL;
 235   s->list_bottom = NULL;
 236   s->common = NULL;
 237   s->equiv = NULL;
 238   s->storage = NULL;
 239 #ifdef FFECOM_symbolHOOK
 240   s->hook = FFECOM_symbolNULL;
 241 #endif
 242   s->sfa_dummy_parent = NULL;
 243   s->func_result = NULL;
 244   s->value = 0;
 245   s->check_state = FFESYMBOL_checkstateNONE_;
 246   s->check_token = NULL;
 247   s->max_entry_num = 0;
 248   s->num_entries = 0;
 249   s->generic = FFEINTRIN_genNONE;
 250   s->specific = FFEINTRIN_specNONE;
 251   s->implementation = FFEINTRIN_impNONE;
 252   s->is_save = FALSE;
 253   s->is_init = FALSE;
 254   s->do_iter = FALSE;
 255   s->reported = FALSE;
 256   s->explicit_where = FALSE;
 257   s->namelisted = FALSE;
 258   s->assigned = FALSE;
 259
 260   ffename_set_symbol (n, s);
 261
 262   if (!ffesymbol_retractable_)
 263     {
 264       s->have_old = FALSE;
 265       return s;
 266     }
 267
 268   r = (ffesymbolRetract_) malloc_new_kp (ffesymbol_retract_pool_,
 269                                          "FFESYMBOL retract", sizeof (*r));
 270   r->next = NULL;
 271   r->command = FFESYMBOL_retractcommandDELETE_;
 272   r->live = s;
 273   r->symbol = NULL;             /* No backup copy. */
 274
 275   *ffesymbol_retract_list_ = r;
 276   ffesymbol_retract_list_ = &r->next;
 277
 278   s->have_old = TRUE;
 279   return s;
 280 }
 281
 282 /* Unhook a symbol from its (soon-to-be-killed) name obj.
 283
 284    NULLify the names to which this symbol points.  Do other cleanup as
 285    needed.  */
 286
 287 static ffesymbol
 288 ffesymbol_unhook_ (ffesymbol s)
 289 {
 290   s->other_space_name = s->name = NULL;
 291   if ((ffesymbol_attrs (s) & FFESYMBOL_attrsCBLOCK)
 292       || (ffesymbol_kind (s) == FFEINFO_kindNAMELIST))
 293     ffebld_end_list (ffesymbol_ptr_to_listbottom (s));
 294   if (s->check_state == FFESYMBOL_checkstatePENDING_)
 295     ffelex_token_kill (s->check_token);
 296
 297   return s;
 298 }
 299
 300 /* Issue diagnostic about bad character in token representing user-defined
 301    symbol name.  */
 302
 303 static void
 304 ffesymbol_whine_state_ (ffebad bad, ffelexToken t, char c)
 305 {
 306   char badstr[2];
 307
 308   badstr[0] = c;
 309   badstr[1] = '\0';
 310
 311   ffebad_start (bad);
 312   ffebad_here (0, ffelex_token_where_line (t),
 313                ffelex_token_where_column (t));
 314   ffebad_string (badstr);
 315   ffebad_finish ();
 316 }
 317
 318 /* Returns a string representing the attributes set.  */
 319
 320 const char *
 321 ffesymbol_attrs_string (ffesymbolAttrs attrs)
 322 {
 323   static char string[FFESYMBOL_attr * 12 + 20];
 324   char *p;
 325   ffesymbolAttr attr;
 326
 327   p = &string[0];
 328
 329   if (attrs == FFESYMBOL_attrsetNONE)
 330     {
 331       strcpy (p, "NONE");
 332       return &string[0];
 333     }
 334
 335   for (attr = 0; attr < FFESYMBOL_attr; ++attr)
 336     {
 337       if (attrs & ((ffesymbolAttrs) 1 << attr))
 338         {
 339           attrs &= ~((ffesymbolAttrs) 1 << attr);
 340           strcpy (p, ffesymbol_attr_name_[attr]);
 341           while (*p)
 342             ++p;
 343           *(p++) = '|';
 344         }
 345     }
 346   if (attrs == FFESYMBOL_attrsetNONE)
 347     *--p = '\0';
 348   else
 349     sprintf (p, "?0x%" ffesymbolAttrs_f "x?", attrs);
 350   assert (((size_t) (p - &string[0])) < ARRAY_SIZE (string));
 351   return &string[0];
 352 }
 353
 354 /* Check symbol's name for validity, considering that it might actually
 355    be an intrinsic and thus should not be complained about just yet.  */
 356
 357 void
 358 ffesymbol_check (ffesymbol s, ffelexToken t, bool maybe_intrin)
 359 {
 360   char c;
 361   ffebad bad;
 362   ffeintrinGen gen;
 363   ffeintrinSpec spec;
 364   ffeintrinImp imp;
 365
 366   if (!ffesrc_check_symbol ()
 367       || ((s->check_state != FFESYMBOL_checkstateNONE_)
 368           && ((s->check_state != FFESYMBOL_checkstateINHIBITED_)
 369               || ffebad_inhibit ())))
 370     return;
 371
 372   bad = ffesymbol_check_token_ (t, &c);
 373
 374   if (bad == FFEBAD)
 375     {
 376       s->check_state = FFESYMBOL_checkstateCHECKED_;
 377       return;
 378     }
 379
 380   if (maybe_intrin
 381       && ffeintrin_is_intrinsic (ffelex_token_text (t), NULL, FALSE,
 382                                  &gen, &spec, &imp))
 383     {
 384       s->check_state = FFESYMBOL_checkstatePENDING_;
 385       s->check_token = ffelex_token_use (t);
 386       return;
 387     }
 388
 389   if (ffebad_inhibit ())
 390     {
 391       s->check_state = FFESYMBOL_checkstateINHIBITED_;
 392       return;                   /* Don't complain now, do it later. */
 393     }
 394
 395   s->check_state = FFESYMBOL_checkstateCHECKED_;
 396
 397   ffesymbol_whine_state_ (bad, t, c);
 398 }
 399
 400 /* Declare a BLOCKDATA unit.
 401
 402    Retrieves or creates the ffesymbol for the specified BLOCKDATA (unnamed
 403    if t is NULL).  Doesn't actually ensure the named item is a
 404    BLOCKDATA; the caller must handle that.  */
 405
 406 ffesymbol
 407 ffesymbol_declare_blockdataunit (ffelexToken t, ffewhereLine wl,
 408                                  ffewhereColumn wc)
 409 {
 410   ffename n;
 411   ffesymbol s;
 412   bool user = (t != NULL);
 413
 414   assert (!ffesymbol_retractable_);
 415
 416   if (t == NULL)
 417     {
 418       if (ffesymbol_token_unnamed_blockdata_ == NULL)
 419         ffesymbol_token_unnamed_blockdata_
 420           = ffelex_token_new_name (FFETARGET_nameUNNAMED_BLOCK_DATA, wl, wc);
 421       t = ffesymbol_token_unnamed_blockdata_;
 422     }
 423
 424   n = ffename_lookup (ffesymbol_local_, t);
 425   if (n != NULL)
 426     return ffename_symbol (n);  /* This will become an error. */
 427
 428   n = ffename_find (ffesymbol_global_, t);
 429   s = ffename_symbol (n);
 430   if (s != NULL)
 431     {
 432       if (user)
 433         ffesymbol_check (s, t, FALSE);
 434       return s;
 435     }
 436
 437   s = ffesymbol_new_ (n);
 438   if (user)
 439     ffesymbol_check (s, t, FALSE);
 440
 441   /* A program unit name also is in the local name space. */
 442
 443   n = ffename_find (ffesymbol_local_, t);
 444   ffename_set_symbol (n, s);
 445   s->other_space_name = n;
 446
 447   ffeglobal_new_blockdata (s, t);       /* Detect conflicts, when
 448                                            appropriate. */
 449
 450   return s;
 451 }
 452
 453 /* Declare a common block (named or unnamed).
 454
 455    Retrieves or creates the ffesymbol for the specified common block (blank
 456    common if t is NULL).  Doesn't actually ensure the named item is a
 457    common block; the caller must handle that.  */
 458
 459 ffesymbol
 460 ffesymbol_declare_cblock (ffelexToken t, ffewhereLine wl, ffewhereColumn wc)
 461 {
 462   ffename n;
 463   ffesymbol s;
 464   bool blank;
 465
 466   assert (!ffesymbol_retractable_);
 467
 468   if (t == NULL)
 469     {
 470       blank = TRUE;
 471       if (ffesymbol_token_blank_common_ == NULL)
 472         ffesymbol_token_blank_common_
 473           = ffelex_token_new_name (FFETARGET_nameBLANK_COMMON, wl, wc);
 474       t = ffesymbol_token_blank_common_;
 475     }
 476   else
 477     blank = FALSE;
 478
 479   n = ffename_find (ffesymbol_global_, t);
 480   s = ffename_symbol (n);
 481   if (s != NULL)
 482     {
 483       if (!blank)
 484         ffesymbol_check (s, t, FALSE);
 485       return s;
 486     }
 487
 488   s = ffesymbol_new_ (n);
 489   if (!blank)
 490     ffesymbol_check (s, t, FALSE);
 491
 492   ffeglobal_new_common (s, t, blank);   /* Detect conflicts. */
 493
 494   return s;
 495 }
 496
 497 /* Declare a FUNCTION program unit (with distinct RESULT() name).
 498
 499    Retrieves or creates the ffesymbol for the specified function.  Doesn't
 500    actually ensure the named item is a function; the caller must handle
 501    that.
 502
 503    If FUNCTION with RESULT() is specified but the names are the same,
 504    pretend as though RESULT() was not specified, and don't call this
 505    function; use ffesymbol_declare_funcunit() instead.  */
 506
 507 ffesymbol
 508 ffesymbol_declare_funcnotresunit (ffelexToken t)
 509 {
 510   ffename n;
 511   ffesymbol s;
 512
 513   assert (t != NULL);
 514   assert (!ffesymbol_retractable_);
 515
 516   n = ffename_lookup (ffesymbol_local_, t);
 517   if (n != NULL)
 518     return ffename_symbol (n);  /* This will become an error. */
 519
 520   n = ffename_find (ffesymbol_global_, t);
 521   s = ffename_symbol (n);
 522   if (s != NULL)
 523     {
 524       ffesymbol_check (s, t, FALSE);
 525       return s;
 526     }
 527
 528   s = ffesymbol_new_ (n);
 529   ffesymbol_check (s, t, FALSE);
 530
 531   /* A FUNCTION program unit name also is in the local name space; handle it
 532      here since RESULT() is a different name and is handled separately. */
 533
 534   n = ffename_find (ffesymbol_local_, t);
 535   ffename_set_symbol (n, s);
 536   s->other_space_name = n;
 537
 538   ffeglobal_new_function (s, t);/* Detect conflicts, when appropriate. */
 539
 540   return s;
 541 }
 542
 543 /* Declare a function result.
 544
 545    Retrieves or creates the ffesymbol for the specified function result,
 546    whether specified via a distinct RESULT() or by default in a FUNCTION or
 547    ENTRY statement.  */
 548
 549 ffesymbol
 550 ffesymbol_declare_funcresult (ffelexToken t)
 551 {
 552   ffename n;
 553   ffesymbol s;
 554
 555   assert (t != NULL);
 556   assert (!ffesymbol_retractable_);
 557
 558   n = ffename_find (ffesymbol_local_, t);
 559   s = ffename_symbol (n);
 560   if (s != NULL)
 561     return s;
 562
 563   return ffesymbol_new_ (n);
 564 }
 565
 566 /* Declare a FUNCTION program unit with no RESULT().
 567
 568    Retrieves or creates the ffesymbol for the specified function.  Doesn't
 569    actually ensure the named item is a function; the caller must handle
 570    that.
 571
 572    This is the function to call when the FUNCTION or ENTRY statement has
 573    no separate and distinct name specified via RESULT().  That's because
 574    this function enters the global name of the function in only the global
 575    name space.  ffesymbol_declare_funcresult() must still be called to
 576    declare the name for the function result in the local name space.  */
 577
 578 ffesymbol
 579 ffesymbol_declare_funcunit (ffelexToken t)
 580 {
 581   ffename n;
 582   ffesymbol s;
 583
 584   assert (t != NULL);
 585   assert (!ffesymbol_retractable_);
 586
 587   n = ffename_find (ffesymbol_global_, t);
 588   s = ffename_symbol (n);
 589   if (s != NULL)
 590     {
 591       ffesymbol_check (s, t, FALSE);
 592       return s;
 593     }
 594
 595   s = ffesymbol_new_ (n);
 596   ffesymbol_check (s, t, FALSE);
 597
 598   ffeglobal_new_function (s, t);/* Detect conflicts. */
 599
 600   return s;
 601 }
 602
 603 /* Declare a local entity.
 604
 605    Retrieves or creates the ffesymbol for the specified local entity.
 606    Set maybe_intrin TRUE if this name might turn out to name an
 607    intrinsic (legitimately); otherwise if the name doesn't meet the
 608    requirements for a user-defined symbol name, a diagnostic will be
 609    issued right away rather than waiting until the intrinsicness of the
 610    symbol is determined.  */
 611
 612 ffesymbol
 613 ffesymbol_declare_local (ffelexToken t, bool maybe_intrin)
 614 {
 615   ffename n;
 616   ffesymbol s;
 617
 618   assert (t != NULL);
 619
 620   /* If we're parsing within a statement function definition, return the
 621      symbol if already known (a dummy argument for the statement function).
 622      Otherwise continue on, which means the symbol is declared within the
 623      containing (local) program unit rather than the statement function
 624      definition.  */
 625
 626   if ((ffesymbol_sfunc_ != NULL)
 627       && ((n = ffename_lookup (ffesymbol_sfunc_, t)) != NULL))
 628     return ffename_symbol (n);
 629
 630   n = ffename_find (ffesymbol_local_, t);
 631   s = ffename_symbol (n);
 632   if (s != NULL)
 633     {
 634       ffesymbol_check (s, t, maybe_intrin);
 635       return s;
 636     }
 637
 638   s = ffesymbol_new_ (n);
 639   ffesymbol_check (s, t, maybe_intrin);
 640   return s;
 641 }
 642
 643 /* Declare a main program unit.
 644
 645    Retrieves or creates the ffesymbol for the specified main program unit
 646    (unnamed main program unit if t is NULL).  Doesn't actually ensure the
 647    named item is a program; the caller must handle that.  */
 648
 649 ffesymbol
 650 ffesymbol_declare_programunit (ffelexToken t, ffewhereLine wl,
 651                                ffewhereColumn wc)
 652 {
 653   ffename n;
 654   ffesymbol s;
 655   bool user = (t != NULL);
 656
 657   assert (!ffesymbol_retractable_);
 658
 659   if (t == NULL)
 660     {
 661       if (ffesymbol_token_unnamed_main_ == NULL)
 662         ffesymbol_token_unnamed_main_
 663           = ffelex_token_new_name (FFETARGET_nameUNNAMED_MAIN, wl, wc);
 664       t = ffesymbol_token_unnamed_main_;
 665     }
 666
 667   n = ffename_lookup (ffesymbol_local_, t);
 668   if (n != NULL)
 669     return ffename_symbol (n);  /* This will become an error. */
 670
 671   n = ffename_find (ffesymbol_global_, t);
 672   s = ffename_symbol (n);
 673   if (s != NULL)
 674     {
 675       if (user)
 676         ffesymbol_check (s, t, FALSE);
 677       return s;
 678     }
 679
 680   s = ffesymbol_new_ (n);
 681   if (user)
 682     ffesymbol_check (s, t, FALSE);
 683
 684   /* A program unit name also is in the local name space. */
 685
 686   n = ffename_find (ffesymbol_local_, t);
 687   ffename_set_symbol (n, s);
 688   s->other_space_name = n;
 689
 690   ffeglobal_new_program (s, t); /* Detect conflicts. */
 691
 692   return s;
 693 }
 694
 695 /* Declare a statement-function dummy.
 696
 697    Retrieves or creates the ffesymbol for the specified statement
 698    function dummy.  Also ensures that it has a link to the parent (local)
 699    ffesymbol with the same name, creating it if necessary.  */
 700
 701 ffesymbol
 702 ffesymbol_declare_sfdummy (ffelexToken t)
 703 {
 704   ffename n;
 705   ffesymbol s;
 706   ffesymbol sp;                 /* Parent symbol in local area. */
 707
 708   assert (t != NULL);
 709
 710   n = ffename_find (ffesymbol_local_, t);
 711   sp = ffename_symbol (n);
 712   if (sp == NULL)
 713     sp = ffesymbol_new_ (n);
 714   ffesymbol_check (sp, t, FALSE);
 715
 716   n = ffename_find (ffesymbol_sfunc_, t);
 717   s = ffename_symbol (n);
 718   if (s == NULL)
 719     {
 720       s = ffesymbol_new_ (n);
 721       s->sfa_dummy_parent = sp;
 722     }
 723   else
 724     assert (s->sfa_dummy_parent == sp);
 725
 726   return s;
 727 }
 728
 729 /* Declare a subroutine program unit.
 730
 731    Retrieves or creates the ffesymbol for the specified subroutine
 732    Doesn't actually ensure the named item is a subroutine; the caller must
 733    handle that.  */
 734
 735 ffesymbol
 736 ffesymbol_declare_subrunit (ffelexToken t)
 737 {
 738   ffename n;
 739   ffesymbol s;
 740
 741   assert (!ffesymbol_retractable_);
 742   assert (t != NULL);
 743
 744   n = ffename_lookup (ffesymbol_local_, t);
 745   if (n != NULL)
 746     return ffename_symbol (n);  /* This will become an error. */
 747
 748   n = ffename_find (ffesymbol_global_, t);
 749   s = ffename_symbol (n);
 750   if (s != NULL)
 751     {
 752       ffesymbol_check (s, t, FALSE);
 753       return s;
 754     }
 755
 756   s = ffesymbol_new_ (n);
 757   ffesymbol_check (s, t, FALSE);
 758
 759   /* A program unit name also is in the local name space. */
 760
 761   n = ffename_find (ffesymbol_local_, t);
 762   ffename_set_symbol (n, s);
 763   s->other_space_name = n;
 764
 765   ffeglobal_new_subroutine (s, t);      /* Detect conflicts, when
 766                                            appropriate. */
 767
 768   return s;
 769 }
 770
 771 /* Call given fn with all local/global symbols.
 772
 773    ffesymbol (*fn) (ffesymbol s);
 774    ffesymbol_drive (fn);  */
 775
 776 void
 777 ffesymbol_drive (ffesymbol (*fn) (ffesymbol))
 778 {
 779   assert (ffesymbol_sfunc_ == NULL);    /* Might be ok, but not for current
 780                                            uses. */
 781   ffename_space_drive_symbol (ffesymbol_local_, fn);
 782   ffename_space_drive_symbol (ffesymbol_global_, fn);
 783 }
 784
 785 /* Call given fn with all sfunc-only symbols.
 786
 787    ffesymbol (*fn) (ffesymbol s);
 788    ffesymbol_drive_sfnames (fn);  */
 789
 790 void
 791 ffesymbol_drive_sfnames (ffesymbol (*fn) (ffesymbol))
 792 {
 793   ffename_space_drive_symbol (ffesymbol_sfunc_, fn);
 794 }
 795
 796 /* Dump info on the symbol for debugging purposes.  */
 797
 798 #if FFECOM_targetCURRENT == FFECOM_targetFFE
 799 void
 800 ffesymbol_dump (ffesymbol s)
 801 {
 802   ffeinfoKind k;
 803   ffeinfoWhere w;
 804
 805   assert (s != NULL);
 806
 807   if (ffeinfo_size (s->info) != FFETARGET_charactersizeNONE)
 808     fprintf (dmpout, "%s:%d%s%s*%" ffetargetCharacterSize_f "u",
 809              ffesymbol_text (s),
 810              (int) ffeinfo_rank (s->info),
 811              ffeinfo_basictype_string (ffeinfo_basictype (s->info)),
 812              ffeinfo_kindtype_string (ffeinfo_kindtype (s->info)),
 813              ffeinfo_size (s->info));
 814   else
 815     fprintf (dmpout, "%s:%d%s%s",
 816              ffesymbol_text (s),
 817              (int) ffeinfo_rank (s->info),
 818              ffeinfo_basictype_string (ffeinfo_basictype (s->info)),
 819              ffeinfo_kindtype_string (ffeinfo_kindtype (s->info)));
 820   if ((k = ffeinfo_kind (s->info)) != FFEINFO_kindNONE)
 821     fprintf (dmpout, "/%s", ffeinfo_kind_string (k));
 822   if ((w = ffeinfo_where (s->info)) != FFEINFO_whereNONE)
 823     fprintf (dmpout, "@%s", ffeinfo_where_string (w));
 824
 825   if ((s->generic != FFEINTRIN_genNONE)
 826       || (s->specific != FFEINTRIN_specNONE)
 827       || (s->implementation != FFEINTRIN_impNONE))
 828     fprintf (dmpout, "{%s:%s:%s}",
 829              ffeintrin_name_generic (s->generic),
 830              ffeintrin_name_specific (s->specific),
 831              ffeintrin_name_implementation (s->implementation));
 832 }
 833 #endif
 834
 835 /* Produce generic error message about a symbol.
 836
 837    For now, just output error message using symbol's name and pointing to
 838    the token.  */
 839
 840 void
 841 ffesymbol_error (ffesymbol s, ffelexToken t)
 842 {
 843   if ((t != NULL)
 844       && ffest_ffebad_start (FFEBAD_SYMERR))
 845     {
 846       ffebad_string (ffesymbol_text (s));
 847       ffebad_here (0, ffelex_token_where_line (t),
 848                    ffelex_token_where_column (t));
 849       ffebad_here (1, ffesymbol_where_line (s), ffesymbol_where_column (s));
 850       ffebad_finish ();
 851     }
 852
 853   if (ffesymbol_attr (s, FFESYMBOL_attrANY))
 854     return;
 855
 856   ffesymbol_signal_change (s);  /* May need to back up to previous version. */
 857   if ((ffesymbol_attrs (s) & FFESYMBOL_attrsCBLOCK)
 858       || (ffesymbol_kind (s) == FFEINFO_kindNAMELIST))
 859     ffebld_end_list (ffesymbol_ptr_to_listbottom (s));
 860   ffesymbol_set_attr (s, FFESYMBOL_attrANY);
 861   ffesymbol_set_info (s, ffeinfo_new_any ());
 862   ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
 863   if (s->check_state == FFESYMBOL_checkstatePENDING_)
 864     ffelex_token_kill (s->check_token);
 865   s->check_state = FFESYMBOL_checkstateCHECKED_;
 866   s = ffecom_sym_learned (s);
 867   ffesymbol_signal_unreported (s);
 868 }
 869
 870 void
 871 ffesymbol_init_0 ()
 872 {
 873   ffesymbolAttrs attrs = FFESYMBOL_attrsetNONE;
 874
 875   assert (FFESYMBOL_state == ARRAY_SIZE (ffesymbol_state_name_));
 876   assert (FFESYMBOL_attr == ARRAY_SIZE (ffesymbol_attr_name_));
 877   assert (attrs == FFESYMBOL_attrsetNONE);
 878   attrs = ((ffesymbolAttrs) 1 << FFESYMBOL_attr);
 879   assert (attrs != 0);
 880 }
 881
 882 void
 883 ffesymbol_init_1 ()
 884 {
 885 #if FFESYMBOL_globalCURRENT_ == FFESYMBOL_globalFILE_
 886   ffesymbol_global_ = ffename_space_new (ffe_pool_file ());
 887 #endif
 888 }
 889
 890 void
 891 ffesymbol_init_2 ()
 892 {
 893 }
 894
 895 void
 896 ffesymbol_init_3 ()
 897 {
 898 #if FFESYMBOL_globalCURRENT_ == FFESYMBOL_globalPROGUNIT_
 899   ffesymbol_global_ = ffename_space_new (ffe_pool_program_unit ());
 900 #endif
 901   ffesymbol_local_ = ffename_space_new (ffe_pool_program_unit ());
 902 }
 903
 904 void
 905 ffesymbol_init_4 ()
 906 {
 907   ffesymbol_sfunc_ = ffename_space_new (ffe_pool_program_unit ());
 908 }
 909
 910 /* Look up a local entity.
 911
 912    Retrieves the ffesymbol for the specified local entity, or returns NULL
 913    if no local entity by that name exists.  */
 914
 915 ffesymbol
 916 ffesymbol_lookup_local (ffelexToken t)
 917 {
 918   ffename n;
 919   ffesymbol s;
 920
 921   assert (t != NULL);
 922
 923   n = ffename_lookup (ffesymbol_local_, t);
 924   if (n == NULL)
 925     return NULL;
 926
 927   s = ffename_symbol (n);
 928   return s;                     /* May be NULL here, too. */
 929 }
 930
 931 /* Registers the symbol as one that is referenced by the
 932    current program unit.  Currently applies only to
 933    symbols known to have global interest (globals and
 934    intrinsics).
 935
 936    s is the (global/intrinsic) symbol referenced; t is the
 937    referencing token; explicit is TRUE if the reference
 938    is, e.g., INTRINSIC FOO.  */
 939
 940 void
 941 ffesymbol_reference (ffesymbol s, ffelexToken t, bool explicit)
 942 {
 943   ffename gn;
 944   ffesymbol gs = NULL;
 945   ffeinfoKind kind;
 946   ffeinfoWhere where;
 947   bool okay;
 948
 949   if (ffesymbol_retractable_)
 950     return;
 951
 952   if (t == NULL)
 953     t = ffename_token (s->name);        /* Use the first reference in this program unit. */
 954
 955   kind = ffesymbol_kind (s);
 956   where = ffesymbol_where (s);
 957
 958   if (where == FFEINFO_whereINTRINSIC)
 959     {
 960       ffeglobal_ref_intrinsic (s, t,
 961                                explicit
 962                                || s->explicit_where
 963                                || ffeintrin_is_standard (s->generic, s->specific));
 964       return;
 965     }
 966
 967   if ((where != FFEINFO_whereGLOBAL)
 968       && ((where != FFEINFO_whereLOCAL)
 969           || ((kind != FFEINFO_kindFUNCTION)
 970               && (kind != FFEINFO_kindSUBROUTINE))))
 971     return;
 972
 973   gn = ffename_lookup (ffesymbol_global_, t);
 974   if (gn != NULL)
 975     gs = ffename_symbol (gn);
 976   if ((gs != NULL) && (gs != s))
 977     {
 978       /* We have just discovered another global symbol with the same name
 979          but a different `nature'.  Complain.  Note that COMMON /FOO/ can
 980          coexist with local symbol FOO, e.g. local variable, just not with
 981          CALL FOO, hence the separate namespaces.  */
 982
 983       ffesymbol_error (gs, t);
 984       ffesymbol_error (s, NULL);
 985       return;
 986     }
 987
 988   switch (kind)
 989     {
 990     case FFEINFO_kindBLOCKDATA:
 991       okay = ffeglobal_ref_blockdata (s, t);
 992       break;
 993
 994     case FFEINFO_kindSUBROUTINE:
 995       okay = ffeglobal_ref_subroutine (s, t);
 996       break;
 997
 998     case FFEINFO_kindFUNCTION:
 999       okay = ffeglobal_ref_function (s, t);
1000       break;
1001
1002     case FFEINFO_kindNONE:
1003       okay = ffeglobal_ref_external (s, t);
1004       break;
1005
1006     default:
1007       assert ("bad kind in global ref" == NULL);
1008       return;
1009     }
1010
1011   if (! okay)
1012     ffesymbol_error (s, NULL);
1013 }
1014
1015 /* Report info on the symbol for debugging purposes.  */
1016
1017 #if FFECOM_targetCURRENT == FFECOM_targetFFE
1018 ffesymbol
1019 ffesymbol_report (ffesymbol s)
1020 {
1021   ffeinfoKind k;
1022   ffeinfoWhere w;
1023
1024   assert (s != NULL);
1025
1026   if (s->reported)
1027     return s;
1028
1029   s->reported = TRUE;
1030
1031   if (ffeinfo_size (s->info) != FFETARGET_charactersizeNONE)
1032     fprintf (dmpout, "\"%s\": %s %s %d%s%s*%" ffetargetCharacterSize_f "u",
1033              ffesymbol_text (s),
1034              ffesymbol_state_string (s->state),
1035              ffesymbol_attrs_string (s->attrs),
1036              (int) ffeinfo_rank (s->info),
1037              ffeinfo_basictype_string (ffeinfo_basictype (s->info)),
1038              ffeinfo_kindtype_string (ffeinfo_kindtype (s->info)),
1039              ffeinfo_size (s->info));
1040   else
1041     fprintf (dmpout, "\"%s\": %s %s %d%s%s",
1042              ffesymbol_text (s),
1043              ffesymbol_state_string (s->state),
1044              ffesymbol_attrs_string (s->attrs),
1045              (int) ffeinfo_rank (s->info),
1046              ffeinfo_basictype_string (ffeinfo_basictype (s->info)),
1047              ffeinfo_kindtype_string (ffeinfo_kindtype (s->info)));
1048   if ((k = ffeinfo_kind (s->info)) != FFEINFO_kindNONE)
1049     fprintf (dmpout, "/%s", ffeinfo_kind_string (k));
1050   if ((w = ffeinfo_where (s->info)) != FFEINFO_whereNONE)
1051     fprintf (dmpout, "@%s", ffeinfo_where_string (w));
1052   fputc ('\n', dmpout);
1053
1054   if (s->dims != NULL)
1055     {
1056       fprintf (dmpout, "  dims: ");
1057       ffebld_dump (s->dims);
1058       fputs ("\n", dmpout);
1059     }
1060
1061   if (s->extents != NULL)
1062     {
1063       fprintf (dmpout, "  extents: ");
1064       ffebld_dump (s->extents);
1065       fputs ("\n", dmpout);
1066     }
1067
1068   if (s->dim_syms != NULL)
1069     {
1070       fprintf (dmpout, "  dim syms: ");
1071       ffebld_dump (s->dim_syms);
1072       fputs ("\n", dmpout);
1073     }
1074
1075   if (s->array_size != NULL)
1076     {
1077       fprintf (dmpout, "  array size: ");
1078       ffebld_dump (s->array_size);
1079       fputs ("\n", dmpout);
1080     }
1081
1082   if (s->init != NULL)
1083     {
1084       fprintf (dmpout, "  init-value: ");
1085       if (ffebld_op (s->init) == FFEBLD_opANY)
1086         fputs ("<any>\n", dmpout);
1087       else
1088         {
1089           ffebld_dump (s->init);
1090           fputs ("\n", dmpout);
1091         }
1092     }
1093
1094   if (s->accretion != NULL)
1095     {
1096       fprintf (dmpout, "  accretion (%" ffetargetOffset_f "d left): ",
1097                s->accretes);
1098       ffebld_dump (s->accretion);
1099       fputs ("\n", dmpout);
1100     }
1101   else if (s->accretes != 0)
1102     fprintf (dmpout, "  accretes!! = %" ffetargetOffset_f "d left\n",
1103              s->accretes);
1104
1105   if (s->dummy_args != NULL)
1106     {
1107       fprintf (dmpout, "  dummies: ");
1108       ffebld_dump (s->dummy_args);
1109       fputs ("\n", dmpout);
1110     }
1111
1112   if (s->namelist != NULL)
1113     {
1114       fprintf (dmpout, "  namelist: ");
1115       ffebld_dump (s->namelist);
1116       fputs ("\n", dmpout);
1117     }
1118
1119   if (s->common_list != NULL)
1120     {
1121       fprintf (dmpout, "  common-list: ");
1122       ffebld_dump (s->common_list);
1123       fputs ("\n", dmpout);
1124     }
1125
1126   if (s->sfunc_expr != NULL)
1127     {
1128       fprintf (dmpout, "  sfunc expression: ");
1129       ffebld_dump (s->sfunc_expr);
1130       fputs ("\n", dmpout);
1131     }
1132
1133   if (s->is_save)
1134     {
1135       fprintf (dmpout, "  SAVEd\n");
1136     }
1137
1138   if (s->is_init)
1139     {
1140       fprintf (dmpout, "  initialized\n");
1141     }
1142
1143   if (s->do_iter)
1144     {
1145       fprintf (dmpout, "  DO-loop iteration variable (currently)\n");
1146     }
1147
1148   if (s->explicit_where)
1149     {
1150       fprintf (dmpout, "  Explicit INTRINSIC/EXTERNAL\n");
1151     }
1152
1153   if (s->namelisted)
1154     {
1155       fprintf (dmpout, "  Namelisted\n");
1156     }
1157
1158   if (s->common != NULL)
1159     {
1160       fprintf (dmpout, "  COMMON area: %s\n", ffesymbol_text (s->common));
1161     }
1162
1163   if (s->equiv != NULL)
1164     {
1165       fprintf (dmpout, "  EQUIVALENCE information: ");
1166       ffeequiv_dump (s->equiv);
1167       fputs ("\n", dmpout);
1168     }
1169
1170   if (s->storage != NULL)
1171     {
1172       fprintf (dmpout, "  Storage: ");
1173       ffestorag_dump (s->storage);
1174       fputs ("\n", dmpout);
1175     }
1176
1177   return s;
1178 }
1179 #endif
1180
1181 /* Report info on the symbols.  */
1182
1183 #if FFECOM_targetCURRENT == FFECOM_targetFFE
1184 void
1185 ffesymbol_report_all ()
1186 {
1187   ffename_space_drive_symbol (ffesymbol_sfunc_, ffesymbol_report);
1188   ffename_space_drive_symbol (ffesymbol_local_, ffesymbol_report);
1189   ffename_space_drive_symbol (ffesymbol_global_, ffesymbol_report);
1190 }
1191 #endif
1192
1193 /* Resolve symbol that has become known intrinsic or non-intrinsic.  */
1194
1195 void
1196 ffesymbol_resolve_intrin (ffesymbol s)
1197 {
1198   char c;
1199   ffebad bad;
1200
1201   if (!ffesrc_check_symbol ())
1202     return;
1203   if (s->check_state != FFESYMBOL_checkstatePENDING_)
1204     return;
1205   if (ffebad_inhibit ())
1206     return;                     /* We'll get back to this later. */
1207
1208   if (ffesymbol_where (s) != FFEINFO_whereINTRINSIC)
1209     {
1210       bad = ffesymbol_check_token_ (s->check_token, &c);
1211       assert (bad != FFEBAD);   /* How did this suddenly become ok? */
1212       ffesymbol_whine_state_ (bad, s->check_token, c);
1213     }
1214
1215   s->check_state = FFESYMBOL_checkstateCHECKED_;
1216   ffelex_token_kill (s->check_token);
1217 }
1218
1219 /* Retract or cancel retract list.  */
1220
1221 void
1222 ffesymbol_retract (bool retract)
1223 {
1224   ffesymbolRetract_ r;
1225   ffename name;
1226   ffename other_space_name;
1227   ffesymbol ls;
1228   ffesymbol os;
1229
1230   assert (ffesymbol_retractable_);
1231
1232   ffesymbol_retractable_ = FALSE;
1233
1234   for (r = ffesymbol_retract_first_; r != NULL; r = r->next)
1235     {
1236       ls = r->live;
1237       os = r->symbol;
1238       switch (r->command)
1239         {
1240         case FFESYMBOL_retractcommandDELETE_:
1241           if (retract)
1242             {
1243               ffecom_sym_retract (ls);
1244               name = ls->name;
1245               other_space_name = ls->other_space_name;
1246               ffesymbol_unhook_ (ls);
1247               malloc_kill_ks (FFESYMBOL_SPACE_POOL_, ls, sizeof (*ls));
1248               if (name != NULL)
1249                 ffename_set_symbol (name, NULL);
1250               if (other_space_name != NULL)
1251                 ffename_set_symbol (other_space_name, NULL);
1252             }
1253           else
1254             {
1255               ffecom_sym_commit (ls);
1256               ls->have_old = FALSE;
1257             }
1258           break;
1259
1260         case FFESYMBOL_retractcommandRETRACT_:
1261           if (retract)
1262             {
1263               ffecom_sym_retract (ls);
1264               ffesymbol_unhook_ (ls);
1265               *ls = *os;
1266               malloc_kill_ks (FFESYMBOL_SPACE_POOL_, os, sizeof (*os));
1267             }
1268           else
1269             {
1270               ffecom_sym_commit (ls);
1271               ffesymbol_unhook_ (os);
1272               malloc_kill_ks (FFESYMBOL_SPACE_POOL_, os, sizeof (*os));
1273               ls->have_old = FALSE;
1274             }
1275           break;
1276
1277         default:
1278           assert ("bad command" == NULL);
1279           break;
1280         }
1281     }
1282 }
1283
1284 /* Return retractable flag.  */
1285
1286 bool
1287 ffesymbol_retractable ()
1288 {
1289   return ffesymbol_retractable_;
1290 }
1291
1292 /* Set retractable flag, retract pool.
1293
1294    Between this call and ffesymbol_retract, any changes made to existing
1295    symbols cause the previous versions of those symbols to be saved, and any
1296    newly created symbols to have their previous nonexistence saved.  When
1297    ffesymbol_retract is called, this information either is used to retract
1298    the changes and new symbols, or is discarded.  */
1299
1300 void
1301 ffesymbol_set_retractable (mallocPool pool)
1302 {
1303   assert (!ffesymbol_retractable_);
1304
1305   ffesymbol_retractable_ = TRUE;
1306   ffesymbol_retract_pool_ = pool;
1307   ffesymbol_retract_list_ = &ffesymbol_retract_first_;
1308   ffesymbol_retract_first_ = NULL;
1309 }
1310
1311 /* Existing symbol about to be changed; save?
1312
1313    Call this function before changing a symbol if it is possible that
1314    the current actions may need to be undone (i.e. one of several possible
1315    statement forms are being used to analyze the current system).
1316
1317    If the "retractable" flag is not set, just return.
1318    Else, if the symbol's "have_old" flag is set, just return.
1319    Else, make a copy of the symbol and add it to the "retract" list, set
1320    the "have_old" flag, and return.  */
1321
1322 void
1323 ffesymbol_signal_change (ffesymbol s)
1324 {
1325   ffesymbolRetract_ r;
1326   ffesymbol sym;
1327
1328   if (!ffesymbol_retractable_ || s->have_old)
1329     return;
1330
1331   r = (ffesymbolRetract_) malloc_new_kp (ffesymbol_retract_pool_,
1332                                          "FFESYMBOL retract", sizeof (*r));
1333   r->next = NULL;
1334   r->command = FFESYMBOL_retractcommandRETRACT_;
1335   r->live = s;
1336   r->symbol = sym = (ffesymbol) malloc_new_ks (FFESYMBOL_SPACE_POOL_,
1337                                                "FFESYMBOL", sizeof (*sym));
1338   *sym = *s;                    /* Make an exact copy of the symbol in case
1339                                    we need it back. */
1340   sym->info = ffeinfo_use (s->info);
1341   if (s->check_state == FFESYMBOL_checkstatePENDING_)
1342     sym->check_token = ffelex_token_use (s->check_token);
1343
1344   *ffesymbol_retract_list_ = r;
1345   ffesymbol_retract_list_ = &r->next;
1346
1347   s->have_old = TRUE;
1348 }
1349
1350 /* Returns the string based on the state.  */
1351
1352 const char *
1353 ffesymbol_state_string (ffesymbolState state)
1354 {
1355   if (state >= ARRAY_SIZE (ffesymbol_state_name_))
1356     return "?\?\?";
1357   return ffesymbol_state_name_[state];
1358 }
1359
1360 void
1361 ffesymbol_terminate_0 ()
1362 {
1363 }
1364
1365 void
1366 ffesymbol_terminate_1 ()
1367 {
1368 #if FFESYMBOL_globalCURRENT_ == FFESYMBOL_globalFILE_
1369   ffename_space_drive_symbol (ffesymbol_global_, ffesymbol_unhook_);
1370   ffename_space_kill (ffesymbol_global_);
1371   ffesymbol_global_ = NULL;
1372
1373   ffesymbol_kill_manifest_ ();
1374 #endif
1375 }
1376
1377 void
1378 ffesymbol_terminate_2 ()
1379 {
1380 #if FFESYMBOL_globalCURRENT_ == FFESYMBOL_globalPROGUNIT_
1381   ffesymbol_kill_manifest_ ();
1382 #endif
1383 }
1384
1385 void
1386 ffesymbol_terminate_3 ()
1387 {
1388 #if FFESYMBOL_globalCURRENT_ == FFESYMBOL_globalPROGUNIT_
1389   ffename_space_drive_symbol (ffesymbol_global_, ffesymbol_unhook_);
1390   ffename_space_kill (ffesymbol_global_);
1391 #endif
1392   ffename_space_drive_symbol (ffesymbol_local_, ffesymbol_unhook_);
1393   ffename_space_kill (ffesymbol_local_);
1394 #if FFESYMBOL_globalCURRENT_ == FFESYMBOL_globalPROGUNIT_
1395   ffesymbol_global_ = NULL;
1396 #endif
1397   ffesymbol_local_ = NULL;
1398 }
1399
1400 void
1401 ffesymbol_terminate_4 ()
1402 {
1403   ffename_space_drive_symbol (ffesymbol_sfunc_, ffesymbol_unhook_);
1404   ffename_space_kill (ffesymbol_sfunc_);
1405   ffesymbol_sfunc_ = NULL;
1406 }
1407
1408 /* Update INIT info to TRUE and all equiv/storage too.
1409
1410    If INIT flag is TRUE, does nothing.  Else sets it to TRUE and calls
1411    on the ffeequiv and ffestorag modules to update their INIT flags if
1412    the <s> symbol has those objects, and also updates the common area if
1413    it exists.  */
1414
1415 void
1416 ffesymbol_update_init (ffesymbol s)
1417 {
1418   ffebld item;
1419
1420   if (s->is_init)
1421     return;
1422
1423   s->is_init = TRUE;
1424
1425   if ((s->equiv != NULL)
1426       && !ffeequiv_is_init (s->equiv))
1427     ffeequiv_update_init (s->equiv);
1428
1429   if ((s->storage != NULL)
1430       && !ffestorag_is_init (s->storage))
1431     ffestorag_update_init (s->storage);
1432
1433   if ((s->common != NULL)
1434       && (!ffesymbol_is_init (s->common)))
1435     ffesymbol_update_init (s->common);
1436
1437   for (item = s->common_list; item != NULL; item = ffebld_trail (item))
1438     {
1439       if (!ffesymbol_is_init (ffebld_symter (ffebld_head (item))))
1440         ffesymbol_update_init (ffebld_symter (ffebld_head (item)));
1441     }
1442 }
1443
1444 /* Update SAVE info to TRUE and all equiv/storage too.
1445
1446    If SAVE flag is TRUE, does nothing.  Else sets it to TRUE and calls
1447    on the ffeequiv and ffestorag modules to update their SAVE flags if
1448    the <s> symbol has those objects, and also updates the common area if
1449    it exists.  */
1450
1451 void
1452 ffesymbol_update_save (ffesymbol s)
1453 {
1454   ffebld item;
1455
1456   if (s->is_save)
1457     return;
1458
1459   s->is_save = TRUE;
1460
1461   if ((s->equiv != NULL)
1462       && !ffeequiv_is_save (s->equiv))
1463     ffeequiv_update_save (s->equiv);
1464
1465   if ((s->storage != NULL)
1466       && !ffestorag_is_save (s->storage))
1467     ffestorag_update_save (s->storage);
1468
1469   if ((s->common != NULL)
1470       && (!ffesymbol_is_save (s->common)))
1471     ffesymbol_update_save (s->common);
1472
1473   for (item = s->common_list; item != NULL; item = ffebld_trail (item))
1474     {
1475       if (!ffesymbol_is_save (ffebld_symter (ffebld_head (item))))
1476         ffesymbol_update_save (ffebld_symter (ffebld_head (item)));
1477     }
1478 }