gcc/f/symbol.c

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