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