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