gcc/fortran/symbol.c

   1 /* Maintain binary trees of symbols.
   2    Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006 Free Software
   3    Foundation, Inc.
   4    Contributed by Andy Vaught
   5
   6 This file is part of GCC.
   7
   8 GCC is free software; you can redistribute it and/or modify it under
   9 the terms of the GNU General Public License as published by the Free
  10 Software Foundation; either version 2, or (at your option) any later
  11 version.
  12
  13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
  14 WARRANTY; without even the implied warranty of MERCHANTABILITY or
  15 FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
  16 for more details.
  17
  18 You should have received a copy of the GNU General Public License
  19 along with GCC; see the file COPYING.  If not, write to the Free
  20 Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
  21 02110-1301, USA.  */
  22
  23
  24 #include "config.h"
  25 #include "system.h"
  26 #include "flags.h"
  27 #include "gfortran.h"
  28 #include "parse.h"
  29
  30 /* Strings for all symbol attributes.  We use these for dumping the
  31    parse tree, in error messages, and also when reading and writing
  32    modules.  */
  33
  34 const mstring flavors[] =
  35 {
  36   minit ("UNKNOWN-FL", FL_UNKNOWN), minit ("PROGRAM", FL_PROGRAM),
  37   minit ("BLOCK-DATA", FL_BLOCK_DATA), minit ("MODULE", FL_MODULE),
  38   minit ("VARIABLE", FL_VARIABLE), minit ("PARAMETER", FL_PARAMETER),
  39   minit ("LABEL", FL_LABEL), minit ("PROCEDURE", FL_PROCEDURE),
  40   minit ("DERIVED", FL_DERIVED), minit ("NAMELIST", FL_NAMELIST),
  41   minit (NULL, -1)
  42 };
  43
  44 const mstring procedures[] =
  45 {
  46     minit ("UNKNOWN-PROC", PROC_UNKNOWN),
  47     minit ("MODULE-PROC", PROC_MODULE),
  48     minit ("INTERNAL-PROC", PROC_INTERNAL),
  49     minit ("DUMMY-PROC", PROC_DUMMY),
  50     minit ("INTRINSIC-PROC", PROC_INTRINSIC),
  51     minit ("EXTERNAL-PROC", PROC_EXTERNAL),
  52     minit ("STATEMENT-PROC", PROC_ST_FUNCTION),
  53     minit (NULL, -1)
  54 };
  55
  56 const mstring intents[] =
  57 {
  58     minit ("UNKNOWN-INTENT", INTENT_UNKNOWN),
  59     minit ("IN", INTENT_IN),
  60     minit ("OUT", INTENT_OUT),
  61     minit ("INOUT", INTENT_INOUT),
  62     minit (NULL, -1)
  63 };
  64
  65 const mstring access_types[] =
  66 {
  67     minit ("UNKNOWN-ACCESS", ACCESS_UNKNOWN),
  68     minit ("PUBLIC", ACCESS_PUBLIC),
  69     minit ("PRIVATE", ACCESS_PRIVATE),
  70     minit (NULL, -1)
  71 };
  72
  73 const mstring ifsrc_types[] =
  74 {
  75     minit ("UNKNOWN", IFSRC_UNKNOWN),
  76     minit ("DECL", IFSRC_DECL),
  77     minit ("BODY", IFSRC_IFBODY),
  78     minit ("USAGE", IFSRC_USAGE)
  79 };
  80
  81
  82 /* This is to make sure the backend generates setup code in the correct
  83    order.  */
  84
  85 static int next_dummy_order = 1;
  86
  87
  88 gfc_namespace *gfc_current_ns;
  89
  90 gfc_gsymbol *gfc_gsym_root = NULL;
  91
  92 static gfc_symbol *changed_syms = NULL;
  93
  94
  95 /*********** IMPLICIT NONE and IMPLICIT statement handlers ***********/
  96
  97 /* The following static variable indicates whether a particular element has
  98    been explicitly set or not.  */
  99
 100 static int new_flag[GFC_LETTERS];
 101
 102
 103 /* Handle a correctly parsed IMPLICIT NONE.  */
 104
 105 void
 106 gfc_set_implicit_none (void)
 107 {
 108   int i;
 109
 110   if (gfc_current_ns->seen_implicit_none)
 111     {
 112       gfc_error ("Duplicate IMPLICIT NONE statement at %C");
 113       return;
 114     }
 115
 116   gfc_current_ns->seen_implicit_none = 1;
 117
 118   for (i = 0; i < GFC_LETTERS; i++)
 119     {
 120       gfc_clear_ts (&gfc_current_ns->default_type[i]);
 121       gfc_current_ns->set_flag[i] = 1;
 122     }
 123 }
 124
 125
 126 /* Reset the implicit range flags.  */
 127
 128 void
 129 gfc_clear_new_implicit (void)
 130 {
 131   int i;
 132
 133   for (i = 0; i < GFC_LETTERS; i++)
 134     new_flag[i] = 0;
 135 }
 136
 137
 138 /* Prepare for a new implicit range.  Sets flags in new_flag[].  */
 139
 140 try
 141 gfc_add_new_implicit_range (int c1, int c2)
 142 {
 143   int i;
 144
 145   c1 -= 'a';
 146   c2 -= 'a';
 147
 148   for (i = c1; i <= c2; i++)
 149     {
 150       if (new_flag[i])
 151         {
 152           gfc_error ("Letter '%c' already set in IMPLICIT statement at %C",
 153                      i + 'A');
 154           return FAILURE;
 155         }
 156
 157       new_flag[i] = 1;
 158     }
 159
 160   return SUCCESS;
 161 }
 162
 163
 164 /* Add a matched implicit range for gfc_set_implicit().  Check if merging
 165    the new implicit types back into the existing types will work.  */
 166
 167 try
 168 gfc_merge_new_implicit (gfc_typespec * ts)
 169 {
 170   int i;
 171
 172   if (gfc_current_ns->seen_implicit_none)
 173     {
 174       gfc_error ("Cannot specify IMPLICIT at %C after IMPLICIT NONE");
 175       return FAILURE;
 176     }
 177
 178   for (i = 0; i < GFC_LETTERS; i++)
 179     {
 180       if (new_flag[i])
 181         {
 182
 183           if (gfc_current_ns->set_flag[i])
 184             {
 185               gfc_error ("Letter %c already has an IMPLICIT type at %C",
 186                          i + 'A');
 187               return FAILURE;
 188             }
 189           gfc_current_ns->default_type[i] = *ts;
 190           gfc_current_ns->set_flag[i] = 1;
 191         }
 192     }
 193   return SUCCESS;
 194 }
 195
 196
 197 /* Given a symbol, return a pointer to the typespec for its default type.  */
 198
 199 gfc_typespec *
 200 gfc_get_default_type (gfc_symbol * sym, gfc_namespace * ns)
 201 {
 202   char letter;
 203
 204   letter = sym->name[0];
 205   if (letter < 'a' || letter > 'z')
 206     gfc_internal_error ("gfc_get_default_type(): Bad symbol");
 207
 208   if (ns == NULL)
 209     ns = gfc_current_ns;
 210
 211   return &ns->default_type[letter - 'a'];
 212 }
 213
 214
 215 /* Given a pointer to a symbol, set its type according to the first
 216    letter of its name.  Fails if the letter in question has no default
 217    type.  */
 218
 219 try
 220 gfc_set_default_type (gfc_symbol * sym, int error_flag, gfc_namespace * ns)
 221 {
 222   gfc_typespec *ts;
 223
 224   if (sym->ts.type != BT_UNKNOWN)
 225     gfc_internal_error ("gfc_set_default_type(): symbol already has a type");
 226
 227   ts = gfc_get_default_type (sym, ns);
 228
 229   if (ts->type == BT_UNKNOWN)
 230     {
 231       if (error_flag && !sym->attr.untyped)
 232         {
 233           gfc_error ("Symbol '%s' at %L has no IMPLICIT type",
 234                      sym->name, &sym->declared_at);
 235           sym->attr.untyped = 1; /* Ensure we only give an error once.  */
 236         }
 237
 238       return FAILURE;
 239     }
 240
 241   sym->ts = *ts;
 242   sym->attr.implicit_type = 1;
 243
 244   return SUCCESS;
 245 }
 246
 247
 248 /******************** Symbol attribute stuff *********************/
 249
 250 /* This is a generic conflict-checker.  We do this to avoid having a
 251    single conflict in two places.  */
 252
 253 #define conf(a, b) if (attr->a && attr->b) { a1 = a; a2 = b; goto conflict; }
 254 #define conf2(a) if (attr->a) { a2 = a; goto conflict; }
 255 #define conf_std(a, b, std) if (attr->a && attr->b)\
 256                               {\
 257                                 a1 = a;\
 258                                 a2 = b;\
 259                                 standard = std;\
 260                                 goto conflict_std;\
 261                               }
 262
 263 static try
 264 check_conflict (symbol_attribute * attr, const char * name, locus * where)
 265 {
 266   static const char *dummy = "DUMMY", *save = "SAVE", *pointer = "POINTER",
 267     *target = "TARGET", *external = "EXTERNAL", *intent = "INTENT",
 268     *intent_in = "INTENT(IN)", *intrinsic = "INTRINSIC",
 269     *intent_out = "INTENT(OUT)", *intent_inout = "INTENT(INOUT)",
 270     *allocatable = "ALLOCATABLE", *elemental = "ELEMENTAL",
 271     *private = "PRIVATE", *recursive = "RECURSIVE",
 272     *in_common = "COMMON", *result = "RESULT", *in_namelist = "NAMELIST",
 273     *public = "PUBLIC", *optional = "OPTIONAL", *entry = "ENTRY",
 274     *function = "FUNCTION", *subroutine = "SUBROUTINE",
 275     *dimension = "DIMENSION", *in_equivalence = "EQUIVALENCE",
 276     *use_assoc = "USE ASSOCIATED", *cray_pointer = "CRAY POINTER",
 277     *cray_pointee = "CRAY POINTEE", *data = "DATA", *value = "VALUE",
 278     *volatile_ = "VOLATILE";
 279   static const char *threadprivate = "THREADPRIVATE";
 280
 281   const char *a1, *a2;
 282   int standard;
 283
 284   if (where == NULL)
 285     where = &gfc_current_locus;
 286
 287   if (attr->pointer && attr->intent != INTENT_UNKNOWN)
 288     {
 289       a1 = pointer;
 290       a2 = intent;
 291       goto conflict;
 292     }
 293
 294   /* Check for attributes not allowed in a BLOCK DATA.  */
 295   if (gfc_current_state () == COMP_BLOCK_DATA)
 296     {
 297       a1 = NULL;
 298
 299       if (attr->in_namelist)
 300         a1 = in_namelist;
 301       if (attr->allocatable)
 302         a1 = allocatable;
 303       if (attr->external)
 304         a1 = external;
 305       if (attr->optional)
 306         a1 = optional;
 307       if (attr->access == ACCESS_PRIVATE)
 308         a1 = private;
 309       if (attr->access == ACCESS_PUBLIC)
 310         a1 = public;
 311       if (attr->intent != INTENT_UNKNOWN)
 312         a1 = intent;
 313
 314       if (a1 != NULL)
 315         {
 316           gfc_error
 317             ("%s attribute not allowed in BLOCK DATA program unit at %L", a1,
 318              where);
 319           return FAILURE;
 320         }
 321     }
 322
 323   conf (dummy, entry);
 324   conf (dummy, intrinsic);
 325   conf (dummy, save);
 326   conf (dummy, threadprivate);
 327   conf (pointer, target);
 328   conf (pointer, external);
 329   conf (pointer, intrinsic);
 330   conf (pointer, elemental);
 331   conf (allocatable, elemental);
 332
 333   conf (target, external);
 334   conf (target, intrinsic);
 335   conf (external, dimension);   /* See Fortran 95's R504.  */
 336
 337   conf (external, intrinsic);
 338
 339   if (attr->if_source || attr->contained)
 340     {
 341       conf (external, subroutine);
 342       conf (external, function);
 343     }
 344
 345   conf (allocatable, pointer);
 346   conf_std (allocatable, dummy, GFC_STD_F2003);
 347   conf_std (allocatable, function, GFC_STD_F2003);
 348   conf_std (allocatable, result, GFC_STD_F2003);
 349   conf (elemental, recursive);
 350
 351   conf (in_common, dummy);
 352   conf (in_common, allocatable);
 353   conf (in_common, result);
 354   conf (in_common, save);
 355   conf (result, save);
 356
 357   conf (dummy, result);
 358
 359   conf (in_equivalence, use_assoc);
 360   conf (in_equivalence, dummy);
 361   conf (in_equivalence, target);
 362   conf (in_equivalence, pointer);
 363   conf (in_equivalence, function);
 364   conf (in_equivalence, result);
 365   conf (in_equivalence, entry);
 366   conf (in_equivalence, allocatable);
 367   conf (in_equivalence, threadprivate);
 368
 369   conf (in_namelist, pointer);
 370   conf (in_namelist, allocatable);
 371
 372   conf (entry, result);
 373
 374   conf (function, subroutine);
 375
 376   /* Cray pointer/pointee conflicts.  */
 377   conf (cray_pointer, cray_pointee);
 378   conf (cray_pointer, dimension);
 379   conf (cray_pointer, pointer);
 380   conf (cray_pointer, target);
 381   conf (cray_pointer, allocatable);
 382   conf (cray_pointer, external);
 383   conf (cray_pointer, intrinsic);
 384   conf (cray_pointer, in_namelist);
 385   conf (cray_pointer, function);
 386   conf (cray_pointer, subroutine);
 387   conf (cray_pointer, entry);
 388
 389   conf (cray_pointee, allocatable);
 390   conf (cray_pointee, intent);
 391   conf (cray_pointee, optional);
 392   conf (cray_pointee, dummy);
 393   conf (cray_pointee, target);
 394   conf (cray_pointee, intrinsic);
 395   conf (cray_pointee, pointer);
 396   conf (cray_pointee, entry);
 397   conf (cray_pointee, in_common);
 398   conf (cray_pointee, in_equivalence);
 399   conf (cray_pointee, threadprivate);
 400
 401   conf (data, dummy);
 402   conf (data, function);
 403   conf (data, result);
 404   conf (data, allocatable);
 405   conf (data, use_assoc);
 406
 407   conf (value, pointer)
 408   conf (value, allocatable)
 409   conf (value, subroutine)
 410   conf (value, function)
 411   conf (value, volatile_)
 412   conf (value, dimension)
 413   conf (value, external)
 414
 415   if (attr->value && (attr->intent == INTENT_OUT || attr->intent == INTENT_INOUT))
 416     {
 417       a1 = value;
 418       a2 = attr->intent == INTENT_OUT ? intent_out : intent_inout;
 419       goto conflict;
 420     }
 421
 422   conf (volatile_, intrinsic)
 423   conf (volatile_, external)
 424
 425   if (attr->volatile_ && attr->intent == INTENT_IN)
 426     {
 427       a1 = volatile_;
 428       a2 = intent_in;
 429       goto conflict;
 430     }
 431
 432   a1 = gfc_code2string (flavors, attr->flavor);
 433
 434   if (attr->in_namelist
 435       && attr->flavor != FL_VARIABLE
 436       && attr->flavor != FL_UNKNOWN)
 437     {
 438
 439       a2 = in_namelist;
 440       goto conflict;
 441     }
 442
 443   switch (attr->flavor)
 444     {
 445     case FL_PROGRAM:
 446     case FL_BLOCK_DATA:
 447     case FL_MODULE:
 448     case FL_LABEL:
 449       conf2 (dimension);
 450       conf2 (dummy);
 451       conf2 (save);
 452       conf2 (volatile_);
 453       conf2 (pointer);
 454       conf2 (target);
 455       conf2 (external);
 456       conf2 (intrinsic);
 457       conf2 (allocatable);
 458       conf2 (result);
 459       conf2 (in_namelist);
 460       conf2 (optional);
 461       conf2 (function);
 462       conf2 (subroutine);
 463       conf2 (threadprivate);
 464       break;
 465
 466     case FL_VARIABLE:
 467     case FL_NAMELIST:
 468       break;
 469
 470     case FL_PROCEDURE:
 471       conf2 (intent);
 472       conf2(save);
 473
 474       if (attr->subroutine)
 475         {
 476           conf2(pointer);
 477           conf2(target);
 478           conf2(allocatable);
 479           conf2(result);
 480           conf2(in_namelist);
 481           conf2(dimension);
 482           conf2(function);
 483           conf2(threadprivate);
 484         }
 485
 486       switch (attr->proc)
 487         {
 488         case PROC_ST_FUNCTION:
 489           conf2 (in_common);
 490           conf2 (dummy);
 491           break;
 492
 493         case PROC_MODULE:
 494           conf2 (dummy);
 495           break;
 496
 497         case PROC_DUMMY:
 498           conf2 (result);
 499           conf2 (in_common);
 500           conf2 (save);
 501           conf2 (threadprivate);
 502           break;
 503
 504         default:
 505           break;
 506         }
 507
 508       break;
 509
 510     case FL_DERIVED:
 511       conf2 (dummy);
 512       conf2 (save);
 513       conf2 (pointer);
 514       conf2 (target);
 515       conf2 (external);
 516       conf2 (intrinsic);
 517       conf2 (allocatable);
 518       conf2 (optional);
 519       conf2 (entry);
 520       conf2 (function);
 521       conf2 (subroutine);
 522       conf2 (threadprivate);
 523
 524       if (attr->intent != INTENT_UNKNOWN)
 525         {
 526           a2 = intent;
 527           goto conflict;
 528         }
 529       break;
 530
 531     case FL_PARAMETER:
 532       conf2 (external);
 533       conf2 (intrinsic);
 534       conf2 (optional);
 535       conf2 (allocatable);
 536       conf2 (function);
 537       conf2 (subroutine);
 538       conf2 (entry);
 539       conf2 (pointer);
 540       conf2 (target);
 541       conf2 (dummy);
 542       conf2 (in_common);
 543       conf2 (save);
 544       conf2 (value);
 545       conf2 (volatile_);
 546       conf2 (threadprivate);
 547       break;
 548
 549     default:
 550       break;
 551     }
 552
 553   return SUCCESS;
 554
 555 conflict:
 556   if (name == NULL)
 557     gfc_error ("%s attribute conflicts with %s attribute at %L",
 558                a1, a2, where);
 559   else
 560     gfc_error ("%s attribute conflicts with %s attribute in '%s' at %L",
 561                a1, a2, name, where);
 562
 563   return FAILURE;
 564
 565 conflict_std:
 566   if (name == NULL)
 567     {
 568       return gfc_notify_std (standard, "In the selected standard, %s attribute "
 569                              "conflicts with %s attribute at %L", a1, a2,
 570                              where);
 571     }
 572   else
 573     {
 574       return gfc_notify_std (standard, "In the selected standard, %s attribute "
 575                              "conflicts with %s attribute in '%s' at %L",
 576                              a1, a2, name, where);
 577     }
 578 }
 579
 580 #undef conf
 581 #undef conf2
 582 #undef conf_std
 583
 584
 585 /* Mark a symbol as referenced.  */
 586
 587 void
 588 gfc_set_sym_referenced (gfc_symbol * sym)
 589 {
 590   if (sym->attr.referenced)
 591     return;
 592
 593   sym->attr.referenced = 1;
 594
 595   /* Remember which order dummy variables are accessed in.  */
 596   if (sym->attr.dummy)
 597     sym->dummy_order = next_dummy_order++;
 598 }
 599
 600
 601 /* Common subroutine called by attribute changing subroutines in order
 602    to prevent them from changing a symbol that has been
 603    use-associated.  Returns zero if it is OK to change the symbol,
 604    nonzero if not.  */
 605
 606 static int
 607 check_used (symbol_attribute * attr, const char * name, locus * where)
 608 {
 609
 610   if (attr->use_assoc == 0)
 611     return 0;
 612
 613   if (where == NULL)
 614     where = &gfc_current_locus;
 615
 616   if (name == NULL)
 617     gfc_error ("Cannot change attributes of USE-associated symbol at %L",
 618                where);
 619   else
 620     gfc_error ("Cannot change attributes of USE-associated symbol %s at %L",
 621                name, where);
 622
 623   return 1;
 624 }
 625
 626
 627 /* Generate an error because of a duplicate attribute.  */
 628
 629 static void
 630 duplicate_attr (const char *attr, locus * where)
 631 {
 632
 633   if (where == NULL)
 634     where = &gfc_current_locus;
 635
 636   gfc_error ("Duplicate %s attribute specified at %L", attr, where);
 637 }
 638
 639 /* Called from decl.c (attr_decl1) to check attributes, when declared separately.  */
 640
 641 try
 642 gfc_add_attribute (symbol_attribute * attr, locus * where)
 643 {
 644   if (check_used (attr, NULL, where))
 645     return FAILURE;
 646
 647   return check_conflict (attr, NULL, where);
 648 }
 649
 650 try
 651 gfc_add_allocatable (symbol_attribute * attr, locus * where)
 652 {
 653
 654   if (check_used (attr, NULL, where))
 655     return FAILURE;
 656
 657   if (attr->allocatable)
 658     {
 659       duplicate_attr ("ALLOCATABLE", where);
 660       return FAILURE;
 661     }
 662
 663   attr->allocatable = 1;
 664   return check_conflict (attr, NULL, where);
 665 }
 666
 667
 668 try
 669 gfc_add_dimension (symbol_attribute * attr, const char *name, locus * where)
 670 {
 671
 672   if (check_used (attr, name, where))
 673     return FAILURE;
 674
 675   if (attr->dimension)
 676     {
 677       duplicate_attr ("DIMENSION", where);
 678       return FAILURE;
 679     }
 680
 681   attr->dimension = 1;
 682   return check_conflict (attr, name, where);
 683 }
 684
 685
 686 try
 687 gfc_add_external (symbol_attribute * attr, locus * where)
 688 {
 689
 690   if (check_used (attr, NULL, where))
 691     return FAILURE;
 692
 693   if (attr->external)
 694     {
 695       duplicate_attr ("EXTERNAL", where);
 696       return FAILURE;
 697     }
 698
 699   attr->external = 1;
 700
 701   return check_conflict (attr, NULL, where);
 702 }
 703
 704
 705 try
 706 gfc_add_intrinsic (symbol_attribute * attr, locus * where)
 707 {
 708
 709   if (check_used (attr, NULL, where))
 710     return FAILURE;
 711
 712   if (attr->intrinsic)
 713     {
 714       duplicate_attr ("INTRINSIC", where);
 715       return FAILURE;
 716     }
 717
 718   attr->intrinsic = 1;
 719
 720   return check_conflict (attr, NULL, where);
 721 }
 722
 723
 724 try
 725 gfc_add_optional (symbol_attribute * attr, locus * where)
 726 {
 727
 728   if (check_used (attr, NULL, where))
 729     return FAILURE;
 730
 731   if (attr->optional)
 732     {
 733       duplicate_attr ("OPTIONAL", where);
 734       return FAILURE;
 735     }
 736
 737   attr->optional = 1;
 738   return check_conflict (attr, NULL, where);
 739 }
 740
 741
 742 try
 743 gfc_add_pointer (symbol_attribute * attr, locus * where)
 744 {
 745
 746   if (check_used (attr, NULL, where))
 747     return FAILURE;
 748
 749   attr->pointer = 1;
 750   return check_conflict (attr, NULL, where);
 751 }
 752
 753
 754 try
 755 gfc_add_cray_pointer (symbol_attribute * attr, locus * where)
 756 {
 757
 758   if (check_used (attr, NULL, where))
 759     return FAILURE;
 760
 761   attr->cray_pointer = 1;
 762   return check_conflict (attr, NULL, where);
 763 }
 764
 765
 766 try
 767 gfc_add_cray_pointee (symbol_attribute * attr, locus * where)
 768 {
 769
 770   if (check_used (attr, NULL, where))
 771     return FAILURE;
 772
 773   if (attr->cray_pointee)
 774     {
 775       gfc_error ("Cray Pointee at %L appears in multiple pointer()"
 776                  " statements", where);
 777       return FAILURE;
 778     }
 779
 780   attr->cray_pointee = 1;
 781   return check_conflict (attr, NULL, where);
 782 }
 783
 784
 785 try
 786 gfc_add_result (symbol_attribute * attr, const char *name, locus * where)
 787 {
 788
 789   if (check_used (attr, name, where))
 790     return FAILURE;
 791
 792   attr->result = 1;
 793   return check_conflict (attr, name, where);
 794 }
 795
 796
 797 try
 798 gfc_add_save (symbol_attribute * attr, const char *name, locus * where)
 799 {
 800
 801   if (check_used (attr, name, where))
 802     return FAILURE;
 803
 804   if (gfc_pure (NULL))
 805     {
 806       gfc_error
 807         ("SAVE attribute at %L cannot be specified in a PURE procedure",
 808          where);
 809       return FAILURE;
 810     }
 811
 812   if (attr->save)
 813     {
 814         if (gfc_notify_std (GFC_STD_LEGACY,
 815                             "Duplicate SAVE attribute specified at %L",
 816                             where)
 817             == FAILURE)
 818           return FAILURE;
 819     }
 820
 821   attr->save = 1;
 822   return check_conflict (attr, name, where);
 823 }
 824
 825 try
 826 gfc_add_value (symbol_attribute * attr, const char *name, locus * where)
 827 {
 828
 829   if (check_used (attr, name, where))
 830     return FAILURE;
 831
 832   if (attr->value)
 833     {
 834         if (gfc_notify_std (GFC_STD_LEGACY,
 835                             "Duplicate VALUE attribute specified at %L",
 836                             where)
 837             == FAILURE)
 838           return FAILURE;
 839     }
 840
 841   attr->value = 1;
 842   return check_conflict (attr, name, where);
 843 }
 844
 845 try
 846 gfc_add_volatile (symbol_attribute * attr, const char *name, locus * where)
 847 {
 848
 849   if (check_used (attr, name, where))
 850     return FAILURE;
 851
 852   if (attr->volatile_)
 853     {
 854         if (gfc_notify_std (GFC_STD_LEGACY,
 855                             "Duplicate VOLATILE attribute specified at %L",
 856                             where)
 857             == FAILURE)
 858           return FAILURE;
 859     }
 860
 861   attr->volatile_ = 1;
 862   return check_conflict (attr, name, where);
 863 }
 864
 865
 866 try
 867 gfc_add_threadprivate (symbol_attribute * attr, const char *name, locus * where)
 868 {
 869   if (check_used (attr, name, where))
 870     return FAILURE;
 871
 872   if (attr->threadprivate)
 873     {
 874       duplicate_attr ("THREADPRIVATE", where);
 875       return FAILURE;
 876     }
 877
 878   attr->threadprivate = 1;
 879   return check_conflict (attr, name, where);
 880 }
 881
 882
 883 try
 884 gfc_add_target (symbol_attribute * attr, locus * where)
 885 {
 886
 887   if (check_used (attr, NULL, where))
 888     return FAILURE;
 889
 890   if (attr->target)
 891     {
 892       duplicate_attr ("TARGET", where);
 893       return FAILURE;
 894     }
 895
 896   attr->target = 1;
 897   return check_conflict (attr, NULL, where);
 898 }
 899
 900
 901 try
 902 gfc_add_dummy (symbol_attribute * attr, const char *name, locus * where)
 903 {
 904
 905   if (check_used (attr, name, where))
 906     return FAILURE;
 907
 908   /* Duplicate dummy arguments are allowed due to ENTRY statements.  */
 909   attr->dummy = 1;
 910   return check_conflict (attr, name, where);
 911 }
 912
 913
 914 try
 915 gfc_add_in_common (symbol_attribute * attr, const char *name, locus * where)
 916 {
 917
 918   if (check_used (attr, name, where))
 919     return FAILURE;
 920
 921   /* Duplicate attribute already checked for.  */
 922   attr->in_common = 1;
 923   if (check_conflict (attr, name, where) == FAILURE)
 924     return FAILURE;
 925
 926   if (attr->flavor == FL_VARIABLE)
 927     return SUCCESS;
 928
 929   return gfc_add_flavor (attr, FL_VARIABLE, name, where);
 930 }
 931
 932 try
 933 gfc_add_in_equivalence (symbol_attribute * attr, const char *name, locus * where)
 934 {
 935
 936   /* Duplicate attribute already checked for.  */
 937   attr->in_equivalence = 1;
 938   if (check_conflict (attr, name, where) == FAILURE)
 939     return FAILURE;
 940
 941   if (attr->flavor == FL_VARIABLE)
 942     return SUCCESS;
 943
 944   return gfc_add_flavor (attr, FL_VARIABLE, name, where);
 945 }
 946
 947
 948 try
 949 gfc_add_data (symbol_attribute *attr, const char *name, locus *where)
 950 {
 951
 952   if (check_used (attr, name, where))
 953     return FAILURE;
 954
 955   attr->data = 1;
 956   return check_conflict (attr, name, where);
 957 }
 958
 959
 960 try
 961 gfc_add_in_namelist (symbol_attribute * attr, const char *name,
 962                      locus * where)
 963 {
 964
 965   attr->in_namelist = 1;
 966   return check_conflict (attr, name, where);
 967 }
 968
 969
 970 try
 971 gfc_add_sequence (symbol_attribute * attr, const char *name, locus * where)
 972 {
 973
 974   if (check_used (attr, name, where))
 975     return FAILURE;
 976
 977   attr->sequence = 1;
 978   return check_conflict (attr, name, where);
 979 }
 980
 981
 982 try
 983 gfc_add_elemental (symbol_attribute * attr, locus * where)
 984 {
 985
 986   if (check_used (attr, NULL, where))
 987     return FAILURE;
 988
 989   attr->elemental = 1;
 990   return check_conflict (attr, NULL, where);
 991 }
 992
 993
 994 try
 995 gfc_add_pure (symbol_attribute * attr, locus * where)
 996 {
 997
 998   if (check_used (attr, NULL, where))
 999     return FAILURE;
1000
1001   attr->pure = 1;
1002   return check_conflict (attr, NULL, where);
1003 }
1004
1005
1006 try
1007 gfc_add_recursive (symbol_attribute * attr, locus * where)
1008 {
1009
1010   if (check_used (attr, NULL, where))
1011     return FAILURE;
1012
1013   attr->recursive = 1;
1014   return check_conflict (attr, NULL, where);
1015 }
1016
1017
1018 try
1019 gfc_add_entry (symbol_attribute * attr, const char *name, locus * where)
1020 {
1021
1022   if (check_used (attr, name, where))
1023     return FAILURE;
1024
1025   if (attr->entry)
1026     {
1027       duplicate_attr ("ENTRY", where);
1028       return FAILURE;
1029     }
1030
1031   attr->entry = 1;
1032   return check_conflict (attr, name, where);
1033 }
1034
1035
1036 try
1037 gfc_add_function (symbol_attribute * attr, const char *name, locus * where)
1038 {
1039
1040   if (attr->flavor != FL_PROCEDURE
1041       && gfc_add_flavor (attr, FL_PROCEDURE, name, where) == FAILURE)
1042     return FAILURE;
1043
1044   attr->function = 1;
1045   return check_conflict (attr, name, where);
1046 }
1047
1048
1049 try
1050 gfc_add_subroutine (symbol_attribute * attr, const char *name, locus * where)
1051 {
1052
1053   if (attr->flavor != FL_PROCEDURE
1054       && gfc_add_flavor (attr, FL_PROCEDURE, name, where) == FAILURE)
1055     return FAILURE;
1056
1057   attr->subroutine = 1;
1058   return check_conflict (attr, name, where);
1059 }
1060
1061
1062 try
1063 gfc_add_generic (symbol_attribute * attr, const char *name, locus * where)
1064 {
1065
1066   if (attr->flavor != FL_PROCEDURE
1067       && gfc_add_flavor (attr, FL_PROCEDURE, name, where) == FAILURE)
1068     return FAILURE;
1069
1070   attr->generic = 1;
1071   return check_conflict (attr, name, where);
1072 }
1073
1074
1075 /* Flavors are special because some flavors are not what Fortran
1076    considers attributes and can be reaffirmed multiple times.  */
1077
1078 try
1079 gfc_add_flavor (symbol_attribute * attr, sym_flavor f, const char *name,
1080                 locus * where)
1081 {
1082
1083   if ((f == FL_PROGRAM || f == FL_BLOCK_DATA || f == FL_MODULE
1084        || f == FL_PARAMETER || f == FL_LABEL || f == FL_DERIVED
1085        || f == FL_NAMELIST) && check_used (attr, name, where))
1086     return FAILURE;
1087
1088   if (attr->flavor == f && f == FL_VARIABLE)
1089     return SUCCESS;
1090
1091   if (attr->flavor != FL_UNKNOWN)
1092     {
1093       if (where == NULL)
1094         where = &gfc_current_locus;
1095
1096       gfc_error ("%s attribute conflicts with %s attribute at %L",
1097                  gfc_code2string (flavors, attr->flavor),
1098                  gfc_code2string (flavors, f), where);
1099
1100       return FAILURE;
1101     }
1102
1103   attr->flavor = f;
1104
1105   return check_conflict (attr, name, where);
1106 }
1107
1108
1109 try
1110 gfc_add_procedure (symbol_attribute * attr, procedure_type t,
1111                    const char *name, locus * where)
1112 {
1113
1114   if (check_used (attr, name, where))
1115     return FAILURE;
1116
1117   if (attr->flavor != FL_PROCEDURE
1118       && gfc_add_flavor (attr, FL_PROCEDURE, name, where) == FAILURE)
1119     return FAILURE;
1120
1121   if (where == NULL)
1122     where = &gfc_current_locus;
1123
1124   if (attr->proc != PROC_UNKNOWN)
1125     {
1126       gfc_error ("%s procedure at %L is already declared as %s procedure",
1127                  gfc_code2string (procedures, t), where,
1128                  gfc_code2string (procedures, attr->proc));
1129
1130       return FAILURE;
1131     }
1132
1133   attr->proc = t;
1134
1135   /* Statement functions are always scalar and functions.  */
1136   if (t == PROC_ST_FUNCTION
1137       && ((!attr->function && gfc_add_function (attr, name, where) == FAILURE)
1138           || attr->dimension))
1139     return FAILURE;
1140
1141   return check_conflict (attr, name, where);
1142 }
1143
1144
1145 try
1146 gfc_add_intent (symbol_attribute * attr, sym_intent intent, locus * where)
1147 {
1148
1149   if (check_used (attr, NULL, where))
1150     return FAILURE;
1151
1152   if (attr->intent == INTENT_UNKNOWN)
1153     {
1154       attr->intent = intent;
1155       return check_conflict (attr, NULL, where);
1156     }
1157
1158   if (where == NULL)
1159     where = &gfc_current_locus;
1160
1161   gfc_error ("INTENT (%s) conflicts with INTENT(%s) at %L",
1162              gfc_intent_string (attr->intent),
1163              gfc_intent_string (intent), where);
1164
1165   return FAILURE;
1166 }
1167
1168
1169 /* No checks for use-association in public and private statements.  */
1170
1171 try
1172 gfc_add_access (symbol_attribute * attr, gfc_access access,
1173                 const char *name, locus * where)
1174 {
1175
1176   if (attr->access == ACCESS_UNKNOWN)
1177     {
1178       attr->access = access;
1179       return check_conflict (attr, name, where);
1180     }
1181
1182   if (where == NULL)
1183     where = &gfc_current_locus;
1184   gfc_error ("ACCESS specification at %L was already specified", where);
1185
1186   return FAILURE;
1187 }
1188
1189
1190 try
1191 gfc_add_explicit_interface (gfc_symbol * sym, ifsrc source,
1192                             gfc_formal_arglist * formal, locus * where)
1193 {
1194
1195   if (check_used (&sym->attr, sym->name, where))
1196     return FAILURE;
1197
1198   if (where == NULL)
1199     where = &gfc_current_locus;
1200
1201   if (sym->attr.if_source != IFSRC_UNKNOWN
1202       && sym->attr.if_source != IFSRC_DECL)
1203     {
1204       gfc_error ("Symbol '%s' at %L already has an explicit interface",
1205                  sym->name, where);
1206       return FAILURE;
1207     }
1208
1209   sym->formal = formal;
1210   sym->attr.if_source = source;
1211
1212   return SUCCESS;
1213 }
1214
1215
1216 /* Add a type to a symbol.  */
1217
1218 try
1219 gfc_add_type (gfc_symbol * sym, gfc_typespec * ts, locus * where)
1220 {
1221   sym_flavor flavor;
1222
1223   if (where == NULL)
1224     where = &gfc_current_locus;
1225
1226   if (sym->ts.type != BT_UNKNOWN)
1227     {
1228       const char *msg = "Symbol '%s' at %L already has basic type of %s";
1229       if (!(sym->ts.type == ts->type
1230              && (sym->attr.flavor == FL_PROCEDURE || sym->attr.result))
1231            || gfc_notification_std (GFC_STD_GNU) == ERROR
1232            || pedantic)
1233         {
1234           gfc_error (msg, sym->name, where, gfc_basic_typename (sym->ts.type));
1235           return FAILURE;
1236         }
1237       else if (gfc_notify_std (GFC_STD_GNU, msg, sym->name, where,
1238                                gfc_basic_typename (sym->ts.type)) == FAILURE)
1239           return FAILURE;
1240     }
1241
1242   flavor = sym->attr.flavor;
1243
1244   if (flavor == FL_PROGRAM || flavor == FL_BLOCK_DATA || flavor == FL_MODULE
1245       || flavor == FL_LABEL || (flavor == FL_PROCEDURE
1246                                 && sym->attr.subroutine)
1247       || flavor == FL_DERIVED || flavor == FL_NAMELIST)
1248     {
1249       gfc_error ("Symbol '%s' at %L cannot have a type", sym->name, where);
1250       return FAILURE;
1251     }
1252
1253   sym->ts = *ts;
1254   return SUCCESS;
1255 }
1256
1257
1258 /* Clears all attributes.  */
1259
1260 void
1261 gfc_clear_attr (symbol_attribute * attr)
1262 {
1263   memset (attr, 0, sizeof(symbol_attribute));
1264 }
1265
1266
1267 /* Check for missing attributes in the new symbol.  Currently does
1268    nothing, but it's not clear that it is unnecessary yet.  */
1269
1270 try
1271 gfc_missing_attr (symbol_attribute * attr ATTRIBUTE_UNUSED,
1272                   locus * where ATTRIBUTE_UNUSED)
1273 {
1274
1275   return SUCCESS;
1276 }
1277
1278
1279 /* Copy an attribute to a symbol attribute, bit by bit.  Some
1280    attributes have a lot of side-effects but cannot be present given
1281    where we are called from, so we ignore some bits.  */
1282
1283 try
1284 gfc_copy_attr (symbol_attribute * dest, symbol_attribute * src, locus * where)
1285 {
1286
1287   if (src->allocatable && gfc_add_allocatable (dest, where) == FAILURE)
1288     goto fail;
1289
1290   if (src->dimension && gfc_add_dimension (dest, NULL, where) == FAILURE)
1291     goto fail;
1292   if (src->optional && gfc_add_optional (dest, where) == FAILURE)
1293     goto fail;
1294   if (src->pointer && gfc_add_pointer (dest, where) == FAILURE)
1295     goto fail;
1296   if (src->save && gfc_add_save (dest, NULL, where) == FAILURE)
1297     goto fail;
1298   if (src->value && gfc_add_value (dest, NULL, where) == FAILURE)
1299     goto fail;
1300   if (src->volatile_ && gfc_add_volatile (dest, NULL, where) == FAILURE)
1301     goto fail;
1302   if (src->threadprivate && gfc_add_threadprivate (dest, NULL, where) == FAILURE)
1303     goto fail;
1304   if (src->target && gfc_add_target (dest, where) == FAILURE)
1305     goto fail;
1306   if (src->dummy && gfc_add_dummy (dest, NULL, where) == FAILURE)
1307     goto fail;
1308   if (src->result && gfc_add_result (dest, NULL, where) == FAILURE)
1309     goto fail;
1310   if (src->entry)
1311     dest->entry = 1;
1312
1313   if (src->in_namelist && gfc_add_in_namelist (dest, NULL, where) == FAILURE)
1314     goto fail;
1315
1316   if (src->in_common && gfc_add_in_common (dest, NULL, where) == FAILURE)
1317     goto fail;
1318
1319   if (src->generic && gfc_add_generic (dest, NULL, where) == FAILURE)
1320     goto fail;
1321   if (src->function && gfc_add_function (dest, NULL, where) == FAILURE)
1322     goto fail;
1323   if (src->subroutine && gfc_add_subroutine (dest, NULL, where) == FAILURE)
1324     goto fail;
1325
1326   if (src->sequence && gfc_add_sequence (dest, NULL, where) == FAILURE)
1327     goto fail;
1328   if (src->elemental && gfc_add_elemental (dest, where) == FAILURE)
1329     goto fail;
1330   if (src->pure && gfc_add_pure (dest, where) == FAILURE)
1331     goto fail;
1332   if (src->recursive && gfc_add_recursive (dest, where) == FAILURE)
1333     goto fail;
1334
1335   if (src->flavor != FL_UNKNOWN
1336       && gfc_add_flavor (dest, src->flavor, NULL, where) == FAILURE)
1337     goto fail;
1338
1339   if (src->intent != INTENT_UNKNOWN
1340       && gfc_add_intent (dest, src->intent, where) == FAILURE)
1341     goto fail;
1342
1343   if (src->access != ACCESS_UNKNOWN
1344       && gfc_add_access (dest, src->access, NULL, where) == FAILURE)
1345     goto fail;
1346
1347   if (gfc_missing_attr (dest, where) == FAILURE)
1348     goto fail;
1349
1350   if (src->cray_pointer && gfc_add_cray_pointer (dest, where) == FAILURE)
1351     goto fail;
1352   if (src->cray_pointee && gfc_add_cray_pointee (dest, where) == FAILURE)
1353     goto fail;
1354
1355   /* The subroutines that set these bits also cause flavors to be set,
1356      and that has already happened in the original, so don't let it
1357      happen again.  */
1358   if (src->external)
1359     dest->external = 1;
1360   if (src->intrinsic)
1361     dest->intrinsic = 1;
1362
1363   return SUCCESS;
1364
1365 fail:
1366   return FAILURE;
1367 }
1368
1369
1370 /************** Component name management ************/
1371
1372 /* Component names of a derived type form their own little namespaces
1373    that are separate from all other spaces.  The space is composed of
1374    a singly linked list of gfc_component structures whose head is
1375    located in the parent symbol.  */
1376
1377
1378 /* Add a component name to a symbol.  The call fails if the name is
1379    already present.  On success, the component pointer is modified to
1380    point to the additional component structure.  */
1381
1382 try
1383 gfc_add_component (gfc_symbol * sym, const char *name, gfc_component ** component)
1384 {
1385   gfc_component *p, *tail;
1386
1387   tail = NULL;
1388
1389   for (p = sym->components; p; p = p->next)
1390     {
1391       if (strcmp (p->name, name) == 0)
1392         {
1393           gfc_error ("Component '%s' at %C already declared at %L",
1394                      name, &p->loc);
1395           return FAILURE;
1396         }
1397
1398       tail = p;
1399     }
1400
1401   /* Allocate a new component.  */
1402   p = gfc_get_component ();
1403
1404   if (tail == NULL)
1405     sym->components = p;
1406   else
1407     tail->next = p;
1408
1409   p->name = gfc_get_string (name);
1410   p->loc = gfc_current_locus;
1411
1412   *component = p;
1413   return SUCCESS;
1414 }
1415
1416
1417 /* Recursive function to switch derived types of all symbol in a
1418    namespace.  */
1419
1420 static void
1421 switch_types (gfc_symtree * st, gfc_symbol * from, gfc_symbol * to)
1422 {
1423   gfc_symbol *sym;
1424
1425   if (st == NULL)
1426     return;
1427
1428   sym = st->n.sym;
1429   if (sym->ts.type == BT_DERIVED && sym->ts.derived == from)
1430     sym->ts.derived = to;
1431
1432   switch_types (st->left, from, to);
1433   switch_types (st->right, from, to);
1434 }
1435
1436
1437 /* This subroutine is called when a derived type is used in order to
1438    make the final determination about which version to use.  The
1439    standard requires that a type be defined before it is 'used', but
1440    such types can appear in IMPLICIT statements before the actual
1441    definition.  'Using' in this context means declaring a variable to
1442    be that type or using the type constructor.
1443
1444    If a type is used and the components haven't been defined, then we
1445    have to have a derived type in a parent unit.  We find the node in
1446    the other namespace and point the symtree node in this namespace to
1447    that node.  Further reference to this name point to the correct
1448    node.  If we can't find the node in a parent namespace, then we have
1449    an error.
1450
1451    This subroutine takes a pointer to a symbol node and returns a
1452    pointer to the translated node or NULL for an error.  Usually there
1453    is no translation and we return the node we were passed.  */
1454
1455 gfc_symbol *
1456 gfc_use_derived (gfc_symbol * sym)
1457 {
1458   gfc_symbol *s;
1459   gfc_typespec *t;
1460   gfc_symtree *st;
1461   int i;
1462
1463   if (sym->components != NULL)
1464     return sym;               /* Already defined.  */
1465
1466   if (sym->ns->parent == NULL)
1467     goto bad;
1468
1469   if (gfc_find_symbol (sym->name, sym->ns->parent, 1, &s))
1470     {
1471       gfc_error ("Symbol '%s' at %C is ambiguous", sym->name);
1472       return NULL;
1473     }
1474
1475   if (s == NULL || s->attr.flavor != FL_DERIVED)
1476     goto bad;
1477
1478   /* Get rid of symbol sym, translating all references to s.  */
1479   for (i = 0; i < GFC_LETTERS; i++)
1480     {
1481       t = &sym->ns->default_type[i];
1482       if (t->derived == sym)
1483         t->derived = s;
1484     }
1485
1486   st = gfc_find_symtree (sym->ns->sym_root, sym->name);
1487   st->n.sym = s;
1488
1489   s->refs++;
1490
1491   /* Unlink from list of modified symbols.  */
1492   gfc_commit_symbol (sym);
1493
1494   switch_types (sym->ns->sym_root, sym, s);
1495
1496   /* TODO: Also have to replace sym -> s in other lists like
1497      namelists, common lists and interface lists.  */
1498   gfc_free_symbol (sym);
1499
1500   return s;
1501
1502 bad:
1503   gfc_error ("Derived type '%s' at %C is being used before it is defined",
1504              sym->name);
1505   return NULL;
1506 }
1507
1508
1509 /* Given a derived type node and a component name, try to locate the
1510    component structure.  Returns the NULL pointer if the component is
1511    not found or the components are private.  */
1512
1513 gfc_component *
1514 gfc_find_component (gfc_symbol * sym, const char *name)
1515 {
1516   gfc_component *p;
1517
1518   if (name == NULL)
1519     return NULL;
1520
1521   sym = gfc_use_derived (sym);
1522
1523   if (sym == NULL)
1524     return NULL;
1525
1526   for (p = sym->components; p; p = p->next)
1527     if (strcmp (p->name, name) == 0)
1528       break;
1529
1530   if (p == NULL)
1531     gfc_error ("'%s' at %C is not a member of the '%s' structure",
1532                name, sym->name);
1533   else
1534     {
1535       if (sym->attr.use_assoc && sym->component_access == ACCESS_PRIVATE)
1536         {
1537           gfc_error ("Component '%s' at %C is a PRIVATE component of '%s'",
1538                      name, sym->name);
1539           p = NULL;
1540         }
1541     }
1542
1543   return p;
1544 }
1545
1546
1547 /* Given a symbol, free all of the component structures and everything
1548    they point to.  */
1549
1550 static void
1551 free_components (gfc_component * p)
1552 {
1553   gfc_component *q;
1554
1555   for (; p; p = q)
1556     {
1557       q = p->next;
1558
1559       gfc_free_array_spec (p->as);
1560       gfc_free_expr (p->initializer);
1561
1562       gfc_free (p);
1563     }
1564 }
1565
1566
1567 /* Set component attributes from a standard symbol attribute
1568    structure.  */
1569
1570 void
1571 gfc_set_component_attr (gfc_component * c, symbol_attribute * attr)
1572 {
1573
1574   c->dimension = attr->dimension;
1575   c->pointer = attr->pointer;
1576   c->allocatable = attr->allocatable;
1577 }
1578
1579
1580 /* Get a standard symbol attribute structure given the component
1581    structure.  */
1582
1583 void
1584 gfc_get_component_attr (symbol_attribute * attr, gfc_component * c)
1585 {
1586
1587   gfc_clear_attr (attr);
1588   attr->dimension = c->dimension;
1589   attr->pointer = c->pointer;
1590   attr->allocatable = c->allocatable;
1591 }
1592
1593
1594 /******************** Statement label management ********************/
1595
1596 /* Comparison function for statement labels, used for managing the
1597    binary tree.  */
1598
1599 static int
1600 compare_st_labels (void * a1, void * b1)
1601 {
1602   int a = ((gfc_st_label *)a1)->value;
1603   int b = ((gfc_st_label *)b1)->value;
1604
1605   return (b - a);
1606 }
1607
1608
1609 /* Free a single gfc_st_label structure, making sure the tree is not
1610    messed up.  This function is called only when some parse error
1611    occurs.  */
1612
1613 void
1614 gfc_free_st_label (gfc_st_label * label)
1615 {
1616   if (label == NULL)
1617     return;
1618
1619   gfc_delete_bbt (&gfc_current_ns->st_labels, label, compare_st_labels);
1620
1621   if (label->format != NULL)
1622     gfc_free_expr (label->format);
1623
1624   gfc_free (label);
1625 }
1626
1627 /* Free a whole tree of gfc_st_label structures.  */
1628
1629 static void
1630 free_st_labels (gfc_st_label * label)
1631 {
1632   if (label == NULL)
1633     return;
1634
1635   free_st_labels (label->left);
1636   free_st_labels (label->right);
1637
1638   if (label->format != NULL)
1639     gfc_free_expr (label->format);
1640   gfc_free (label);
1641 }
1642
1643
1644 /* Given a label number, search for and return a pointer to the label
1645    structure, creating it if it does not exist.  */
1646
1647 gfc_st_label *
1648 gfc_get_st_label (int labelno)
1649 {
1650   gfc_st_label *lp;
1651
1652   /* First see if the label is already in this namespace.  */
1653   lp = gfc_current_ns->st_labels;
1654   while (lp)
1655     {
1656       if (lp->value == labelno)
1657         return lp;
1658
1659       if (lp->value < labelno)
1660         lp = lp->left;
1661       else
1662         lp = lp->right;
1663     }
1664
1665   lp = gfc_getmem (sizeof (gfc_st_label));
1666
1667   lp->value = labelno;
1668   lp->defined = ST_LABEL_UNKNOWN;
1669   lp->referenced = ST_LABEL_UNKNOWN;
1670
1671   gfc_insert_bbt (&gfc_current_ns->st_labels, lp, compare_st_labels);
1672
1673   return lp;
1674 }
1675
1676
1677 /* Called when a statement with a statement label is about to be
1678    accepted.  We add the label to the list of the current namespace,
1679    making sure it hasn't been defined previously and referenced
1680    correctly.  */
1681
1682 void
1683 gfc_define_st_label (gfc_st_label * lp, gfc_sl_type type, locus * label_locus)
1684 {
1685   int labelno;
1686
1687   labelno = lp->value;
1688
1689   if (lp->defined != ST_LABEL_UNKNOWN)
1690     gfc_error ("Duplicate statement label %d at %L and %L", labelno,
1691                &lp->where, label_locus);
1692   else
1693     {
1694       lp->where = *label_locus;
1695
1696       switch (type)
1697         {
1698         case ST_LABEL_FORMAT:
1699           if (lp->referenced == ST_LABEL_TARGET)
1700             gfc_error ("Label %d at %C already referenced as branch target",
1701                        labelno);
1702           else
1703             lp->defined = ST_LABEL_FORMAT;
1704
1705           break;
1706
1707         case ST_LABEL_TARGET:
1708           if (lp->referenced == ST_LABEL_FORMAT)
1709             gfc_error ("Label %d at %C already referenced as a format label",
1710                        labelno);
1711           else
1712             lp->defined = ST_LABEL_TARGET;
1713
1714           break;
1715
1716         default:
1717           lp->defined = ST_LABEL_BAD_TARGET;
1718           lp->referenced = ST_LABEL_BAD_TARGET;
1719         }
1720     }
1721 }
1722
1723
1724 /* Reference a label.  Given a label and its type, see if that
1725    reference is consistent with what is known about that label,
1726    updating the unknown state.  Returns FAILURE if something goes
1727    wrong.  */
1728
1729 try
1730 gfc_reference_st_label (gfc_st_label * lp, gfc_sl_type type)
1731 {
1732   gfc_sl_type label_type;
1733   int labelno;
1734   try rc;
1735
1736   if (lp == NULL)
1737     return SUCCESS;
1738
1739   labelno = lp->value;
1740
1741   if (lp->defined != ST_LABEL_UNKNOWN)
1742     label_type = lp->defined;
1743   else
1744     {
1745       label_type = lp->referenced;
1746       lp->where = gfc_current_locus;
1747     }
1748
1749   if (label_type == ST_LABEL_FORMAT && type == ST_LABEL_TARGET)
1750     {
1751       gfc_error ("Label %d at %C previously used as a FORMAT label", labelno);
1752       rc = FAILURE;
1753       goto done;
1754     }
1755
1756   if ((label_type == ST_LABEL_TARGET || label_type == ST_LABEL_BAD_TARGET)
1757       && type == ST_LABEL_FORMAT)
1758     {
1759       gfc_error ("Label %d at %C previously used as branch target", labelno);
1760       rc = FAILURE;
1761       goto done;
1762     }
1763
1764   lp->referenced = type;
1765   rc = SUCCESS;
1766
1767 done:
1768   return rc;
1769 }
1770
1771
1772 /************** Symbol table management subroutines ****************/
1773
1774 /* Basic details: Fortran 95 requires a potentially unlimited number
1775    of distinct namespaces when compiling a program unit.  This case
1776    occurs during a compilation of internal subprograms because all of
1777    the internal subprograms must be read before we can start
1778    generating code for the host.
1779
1780    Given the tricky nature of the Fortran grammar, we must be able to
1781    undo changes made to a symbol table if the current interpretation
1782    of a statement is found to be incorrect.  Whenever a symbol is
1783    looked up, we make a copy of it and link to it.  All of these
1784    symbols are kept in a singly linked list so that we can commit or
1785    undo the changes at a later time.
1786
1787    A symtree may point to a symbol node outside of its namespace.  In
1788    this case, that symbol has been used as a host associated variable
1789    at some previous time.  */
1790
1791 /* Allocate a new namespace structure.  Copies the implicit types from
1792    PARENT if PARENT_TYPES is set.  */
1793
1794 gfc_namespace *
1795 gfc_get_namespace (gfc_namespace * parent, int parent_types)
1796 {
1797   gfc_namespace *ns;
1798   gfc_typespec *ts;
1799   gfc_intrinsic_op in;
1800   int i;
1801
1802   ns = gfc_getmem (sizeof (gfc_namespace));
1803   ns->sym_root = NULL;
1804   ns->uop_root = NULL;
1805   ns->default_access = ACCESS_UNKNOWN;
1806   ns->parent = parent;
1807
1808   for (in = GFC_INTRINSIC_BEGIN; in != GFC_INTRINSIC_END; in++)
1809     ns->operator_access[in] = ACCESS_UNKNOWN;
1810
1811   /* Initialize default implicit types.  */
1812   for (i = 'a'; i <= 'z'; i++)
1813     {
1814       ns->set_flag[i - 'a'] = 0;
1815       ts = &ns->default_type[i - 'a'];
1816
1817       if (parent_types && ns->parent != NULL)
1818         {
1819           /* Copy parent settings */
1820           *ts = ns->parent->default_type[i - 'a'];
1821           continue;
1822         }
1823
1824       if (gfc_option.flag_implicit_none != 0)
1825         {
1826           gfc_clear_ts (ts);
1827           continue;
1828         }
1829
1830       if ('i' <= i && i <= 'n')
1831         {
1832           ts->type = BT_INTEGER;
1833           ts->kind = gfc_default_integer_kind;
1834         }
1835       else
1836         {
1837           ts->type = BT_REAL;
1838           ts->kind = gfc_default_real_kind;
1839         }
1840     }
1841
1842   ns->refs = 1;
1843
1844   return ns;
1845 }
1846
1847
1848 /* Comparison function for symtree nodes.  */
1849
1850 static int
1851 compare_symtree (void * _st1, void * _st2)
1852 {
1853   gfc_symtree *st1, *st2;
1854
1855   st1 = (gfc_symtree *) _st1;
1856   st2 = (gfc_symtree *) _st2;
1857
1858   return strcmp (st1->name, st2->name);
1859 }
1860
1861
1862 /* Allocate a new symtree node and associate it with the new symbol.  */
1863
1864 gfc_symtree *
1865 gfc_new_symtree (gfc_symtree ** root, const char *name)
1866 {
1867   gfc_symtree *st;
1868
1869   st = gfc_getmem (sizeof (gfc_symtree));
1870   st->name = gfc_get_string (name);
1871
1872   gfc_insert_bbt (root, st, compare_symtree);
1873   return st;
1874 }
1875
1876
1877 /* Delete a symbol from the tree.  Does not free the symbol itself!  */
1878
1879 static void
1880 delete_symtree (gfc_symtree ** root, const char *name)
1881 {
1882   gfc_symtree st, *st0;
1883
1884   st0 = gfc_find_symtree (*root, name);
1885
1886   st.name = gfc_get_string (name);
1887   gfc_delete_bbt (root, &st, compare_symtree);
1888
1889   gfc_free (st0);
1890 }
1891
1892
1893 /* Given a root symtree node and a name, try to find the symbol within
1894    the namespace.  Returns NULL if the symbol is not found.  */
1895
1896 gfc_symtree *
1897 gfc_find_symtree (gfc_symtree * st, const char *name)
1898 {
1899   int c;
1900
1901   while (st != NULL)
1902     {
1903       c = strcmp (name, st->name);
1904       if (c == 0)
1905         return st;
1906
1907       st = (c < 0) ? st->left : st->right;
1908     }
1909
1910   return NULL;
1911 }
1912
1913
1914 /* Given a name find a user operator node, creating it if it doesn't
1915    exist.  These are much simpler than symbols because they can't be
1916    ambiguous with one another.  */
1917
1918 gfc_user_op *
1919 gfc_get_uop (const char *name)
1920 {
1921   gfc_user_op *uop;
1922   gfc_symtree *st;
1923
1924   st = gfc_find_symtree (gfc_current_ns->uop_root, name);
1925   if (st != NULL)
1926     return st->n.uop;
1927
1928   st = gfc_new_symtree (&gfc_current_ns->uop_root, name);
1929
1930   uop = st->n.uop = gfc_getmem (sizeof (gfc_user_op));
1931   uop->name = gfc_get_string (name);
1932   uop->access = ACCESS_UNKNOWN;
1933   uop->ns = gfc_current_ns;
1934
1935   return uop;
1936 }
1937
1938
1939 /* Given a name find the user operator node.  Returns NULL if it does
1940    not exist.  */
1941
1942 gfc_user_op *
1943 gfc_find_uop (const char *name, gfc_namespace * ns)
1944 {
1945   gfc_symtree *st;
1946
1947   if (ns == NULL)
1948     ns = gfc_current_ns;
1949
1950   st = gfc_find_symtree (ns->uop_root, name);
1951   return (st == NULL) ? NULL : st->n.uop;
1952 }
1953
1954
1955 /* Remove a gfc_symbol structure and everything it points to.  */
1956
1957 void
1958 gfc_free_symbol (gfc_symbol * sym)
1959 {
1960
1961   if (sym == NULL)
1962     return;
1963
1964   gfc_free_array_spec (sym->as);
1965
1966   free_components (sym->components);
1967
1968   gfc_free_expr (sym->value);
1969
1970   gfc_free_namelist (sym->namelist);
1971
1972   gfc_free_namespace (sym->formal_ns);
1973
1974   if (!sym->attr.generic_copy)
1975     gfc_free_interface (sym->generic);
1976
1977   gfc_free_formal_arglist (sym->formal);
1978
1979   gfc_free (sym);
1980 }
1981
1982
1983 /* Allocate and initialize a new symbol node.  */
1984
1985 gfc_symbol *
1986 gfc_new_symbol (const char *name, gfc_namespace * ns)
1987 {
1988   gfc_symbol *p;
1989
1990   p = gfc_getmem (sizeof (gfc_symbol));
1991
1992   gfc_clear_ts (&p->ts);
1993   gfc_clear_attr (&p->attr);
1994   p->ns = ns;
1995
1996   p->declared_at = gfc_current_locus;
1997
1998   if (strlen (name) > GFC_MAX_SYMBOL_LEN)
1999     gfc_internal_error ("new_symbol(): Symbol name too long");
2000
2001   p->name = gfc_get_string (name);
2002   return p;
2003 }
2004
2005
2006 /* Generate an error if a symbol is ambiguous.  */
2007
2008 static void
2009 ambiguous_symbol (const char *name, gfc_symtree * st)
2010 {
2011
2012   if (st->n.sym->module)
2013     gfc_error ("Name '%s' at %C is an ambiguous reference to '%s' "
2014                "from module '%s'", name, st->n.sym->name, st->n.sym->module);
2015   else
2016     gfc_error ("Name '%s' at %C is an ambiguous reference to '%s' "
2017                "from current program unit", name, st->n.sym->name);
2018 }
2019
2020
2021 /* Search for a symtree starting in the current namespace, resorting to
2022    any parent namespaces if requested by a nonzero parent_flag.
2023    Returns nonzero if the name is ambiguous.  */
2024
2025 int
2026 gfc_find_sym_tree (const char *name, gfc_namespace * ns, int parent_flag,
2027                    gfc_symtree ** result)
2028 {
2029   gfc_symtree *st;
2030
2031   if (ns == NULL)
2032     ns = gfc_current_ns;
2033
2034   do
2035     {
2036       st = gfc_find_symtree (ns->sym_root, name);
2037       if (st != NULL)
2038         {
2039           *result = st;
2040           if (st->ambiguous)
2041             {
2042               ambiguous_symbol (name, st);
2043               return 1;
2044             }
2045
2046           return 0;
2047         }
2048
2049       if (!parent_flag)
2050         break;
2051
2052       ns = ns->parent;
2053     }
2054   while (ns != NULL);
2055
2056   *result = NULL;
2057   return 0;
2058 }
2059
2060
2061 /* Same, but returns the symbol instead.  */
2062
2063 int
2064 gfc_find_symbol (const char *name, gfc_namespace * ns, int parent_flag,
2065                  gfc_symbol ** result)
2066 {
2067   gfc_symtree *st;
2068   int i;
2069
2070   i = gfc_find_sym_tree (name, ns, parent_flag, &st);
2071
2072   if (st == NULL)
2073     *result = NULL;
2074   else
2075     *result = st->n.sym;
2076
2077   return i;
2078 }
2079
2080
2081 /* Save symbol with the information necessary to back it out.  */
2082
2083 static void
2084 save_symbol_data (gfc_symbol * sym)
2085 {
2086
2087   if (sym->new || sym->old_symbol != NULL)
2088     return;
2089
2090   sym->old_symbol = gfc_getmem (sizeof (gfc_symbol));
2091   *(sym->old_symbol) = *sym;
2092
2093   sym->tlink = changed_syms;
2094   changed_syms = sym;
2095 }
2096
2097
2098 /* Given a name, find a symbol, or create it if it does not exist yet
2099    in the current namespace.  If the symbol is found we make sure that
2100    it's OK.
2101
2102    The integer return code indicates
2103      0   All OK
2104      1   The symbol name was ambiguous
2105      2   The name meant to be established was already host associated.
2106
2107    So if the return value is nonzero, then an error was issued.  */
2108
2109 int
2110 gfc_get_sym_tree (const char *name, gfc_namespace * ns, gfc_symtree ** result)
2111 {
2112   gfc_symtree *st;
2113   gfc_symbol *p;
2114
2115   /* This doesn't usually happen during resolution.  */
2116   if (ns == NULL)
2117     ns = gfc_current_ns;
2118
2119   /* Try to find the symbol in ns.  */
2120   st = gfc_find_symtree (ns->sym_root, name);
2121
2122   if (st == NULL)
2123     {
2124       /* If not there, create a new symbol.  */
2125       p = gfc_new_symbol (name, ns);
2126
2127       /* Add to the list of tentative symbols.  */
2128       p->old_symbol = NULL;
2129       p->tlink = changed_syms;
2130       p->mark = 1;
2131       p->new = 1;
2132       changed_syms = p;
2133
2134       st = gfc_new_symtree (&ns->sym_root, name);
2135       st->n.sym = p;
2136       p->refs++;
2137
2138     }
2139   else
2140     {
2141       /* Make sure the existing symbol is OK.  */
2142       if (st->ambiguous)
2143         {
2144           ambiguous_symbol (name, st);
2145           return 1;
2146         }
2147
2148       p = st->n.sym;
2149
2150       if (p->ns != ns && (!p->attr.function || ns->proc_name != p))
2151         {
2152           /* Symbol is from another namespace.  */
2153           gfc_error ("Symbol '%s' at %C has already been host associated",
2154                      name);
2155           return 2;
2156         }
2157
2158       p->mark = 1;
2159
2160       /* Copy in case this symbol is changed.  */
2161       save_symbol_data (p);
2162     }
2163
2164   *result = st;
2165   return 0;
2166 }
2167
2168
2169 int
2170 gfc_get_symbol (const char *name, gfc_namespace * ns, gfc_symbol ** result)
2171 {
2172   gfc_symtree *st;
2173   int i;
2174
2175
2176   i = gfc_get_sym_tree (name, ns, &st);
2177   if (i != 0)
2178     return i;
2179
2180   if (st)
2181     *result = st->n.sym;
2182   else
2183     *result = NULL;
2184   return i;
2185 }
2186
2187
2188 /* Subroutine that searches for a symbol, creating it if it doesn't
2189    exist, but tries to host-associate the symbol if possible.  */
2190
2191 int
2192 gfc_get_ha_sym_tree (const char *name, gfc_symtree ** result)
2193 {
2194   gfc_symtree *st;
2195   int i;
2196
2197   i = gfc_find_sym_tree (name, gfc_current_ns, 0, &st);
2198   if (st != NULL)
2199     {
2200       save_symbol_data (st->n.sym);
2201
2202       *result = st;
2203       return i;
2204     }
2205
2206   if (gfc_current_ns->parent != NULL)
2207     {
2208       i = gfc_find_sym_tree (name, gfc_current_ns->parent, 1, &st);
2209       if (i)
2210         return i;
2211
2212       if (st != NULL)
2213         {
2214           *result = st;
2215           return 0;
2216         }
2217     }
2218
2219   return gfc_get_sym_tree (name, gfc_current_ns, result);
2220 }
2221
2222
2223 int
2224 gfc_get_ha_symbol (const char *name, gfc_symbol ** result)
2225 {
2226   int i;
2227   gfc_symtree *st;
2228
2229   i = gfc_get_ha_sym_tree (name, &st);
2230
2231   if (st)
2232     *result = st->n.sym;
2233   else
2234     *result = NULL;
2235
2236   return i;
2237 }
2238
2239 /* Return true if both symbols could refer to the same data object.  Does
2240    not take account of aliasing due to equivalence statements.  */
2241
2242 int
2243 gfc_symbols_could_alias (gfc_symbol * lsym, gfc_symbol * rsym)
2244 {
2245   /* Aliasing isn't possible if the symbols have different base types.  */
2246   if (gfc_compare_types (&lsym->ts, &rsym->ts) == 0)
2247     return 0;
2248
2249   /* Pointers can point to other pointers, target objects and allocatable
2250      objects.  Two allocatable objects cannot share the same storage.  */
2251   if (lsym->attr.pointer
2252       && (rsym->attr.pointer || rsym->attr.allocatable || rsym->attr.target))
2253     return 1;
2254   if (lsym->attr.target && rsym->attr.pointer)
2255     return 1;
2256   if (lsym->attr.allocatable && rsym->attr.pointer)
2257     return 1;
2258
2259   return 0;
2260 }
2261
2262
2263 /* Undoes all the changes made to symbols in the current statement.
2264    This subroutine is made simpler due to the fact that attributes are
2265    never removed once added.  */
2266
2267 void
2268 gfc_undo_symbols (void)
2269 {
2270   gfc_symbol *p, *q, *old;
2271
2272   for (p = changed_syms; p; p = q)
2273     {
2274       q = p->tlink;
2275
2276       if (p->new)
2277         {
2278           /* Symbol was new.  */
2279           delete_symtree (&p->ns->sym_root, p->name);
2280
2281           p->refs--;
2282           if (p->refs < 0)
2283             gfc_internal_error ("gfc_undo_symbols(): Negative refs");
2284           if (p->refs == 0)
2285             gfc_free_symbol (p);
2286           continue;
2287         }
2288
2289       /* Restore previous state of symbol.  Just copy simple stuff.  */
2290       p->mark = 0;
2291       old = p->old_symbol;
2292
2293       p->ts.type = old->ts.type;
2294       p->ts.kind = old->ts.kind;
2295
2296       p->attr = old->attr;
2297
2298       if (p->value != old->value)
2299         {
2300           gfc_free_expr (old->value);
2301           p->value = NULL;
2302         }
2303
2304       if (p->as != old->as)
2305         {
2306           if (p->as)
2307             gfc_free_array_spec (p->as);
2308           p->as = old->as;
2309         }
2310
2311       p->generic = old->generic;
2312       p->component_access = old->component_access;
2313
2314       if (p->namelist != NULL && old->namelist == NULL)
2315         {
2316           gfc_free_namelist (p->namelist);
2317           p->namelist = NULL;
2318         }
2319       else
2320         {
2321
2322           if (p->namelist_tail != old->namelist_tail)
2323             {
2324               gfc_free_namelist (old->namelist_tail);
2325               old->namelist_tail->next = NULL;
2326             }
2327         }
2328
2329       p->namelist_tail = old->namelist_tail;
2330
2331       if (p->formal != old->formal)
2332         {
2333           gfc_free_formal_arglist (p->formal);
2334           p->formal = old->formal;
2335         }
2336
2337       gfc_free (p->old_symbol);
2338       p->old_symbol = NULL;
2339       p->tlink = NULL;
2340     }
2341
2342   changed_syms = NULL;
2343 }
2344
2345
2346 /* Free sym->old_symbol. sym->old_symbol is mostly a shallow copy of sym; the
2347    components of old_symbol that might need deallocation are the "allocatables"
2348    that are restored in gfc_undo_symbols(), with two exceptions: namelist and
2349    namelist_tail.  In case these differ between old_symbol and sym, it's just
2350    because sym->namelist has gotten a few more items.  */
2351
2352 static void
2353 free_old_symbol (gfc_symbol * sym)
2354 {
2355   if (sym->old_symbol == NULL)
2356     return;
2357
2358   if (sym->old_symbol->as != sym->as)
2359     gfc_free_array_spec (sym->old_symbol->as);
2360
2361   if (sym->old_symbol->value != sym->value)
2362     gfc_free_expr (sym->old_symbol->value);
2363
2364   if (sym->old_symbol->formal != sym->formal)
2365     gfc_free_formal_arglist (sym->old_symbol->formal);
2366
2367   gfc_free (sym->old_symbol);
2368   sym->old_symbol = NULL;
2369 }
2370
2371
2372 /* Makes the changes made in the current statement permanent-- gets
2373    rid of undo information.  */
2374
2375 void
2376 gfc_commit_symbols (void)
2377 {
2378   gfc_symbol *p, *q;
2379
2380   for (p = changed_syms; p; p = q)
2381     {
2382       q = p->tlink;
2383       p->tlink = NULL;
2384       p->mark = 0;
2385       p->new = 0;
2386
2387       free_old_symbol (p);
2388     }
2389   changed_syms = NULL;
2390 }
2391
2392
2393 /* Makes the changes made in one symbol permanent -- gets rid of undo
2394    information.  */
2395
2396 void
2397 gfc_commit_symbol (gfc_symbol * sym)
2398 {
2399   gfc_symbol *p;
2400
2401   if (changed_syms == sym)
2402     changed_syms = sym->tlink;
2403   else
2404     {
2405       for (p = changed_syms; p; p = p->tlink)
2406         if (p->tlink == sym)
2407           {
2408             p->tlink = sym->tlink;
2409             break;
2410           }
2411     }
2412
2413   sym->tlink = NULL;
2414   sym->mark = 0;
2415   sym->new = 0;
2416
2417   free_old_symbol (sym);
2418 }
2419
2420
2421 /* Recursive function that deletes an entire tree and all the common
2422    head structures it points to.  */
2423
2424 static void
2425 free_common_tree (gfc_symtree * common_tree)
2426 {
2427   if (common_tree == NULL)
2428     return;
2429
2430   free_common_tree (common_tree->left);
2431   free_common_tree (common_tree->right);
2432
2433   gfc_free (common_tree);
2434 }
2435
2436
2437 /* Recursive function that deletes an entire tree and all the user
2438    operator nodes that it contains.  */
2439
2440 static void
2441 free_uop_tree (gfc_symtree * uop_tree)
2442 {
2443
2444   if (uop_tree == NULL)
2445     return;
2446
2447   free_uop_tree (uop_tree->left);
2448   free_uop_tree (uop_tree->right);
2449
2450   gfc_free_interface (uop_tree->n.uop->operator);
2451
2452   gfc_free (uop_tree->n.uop);
2453   gfc_free (uop_tree);
2454 }
2455
2456
2457 /* Recursive function that deletes an entire tree and all the symbols
2458    that it contains.  */
2459
2460 static void
2461 free_sym_tree (gfc_symtree * sym_tree)
2462 {
2463   gfc_namespace *ns;
2464   gfc_symbol *sym;
2465
2466   if (sym_tree == NULL)
2467     return;
2468
2469   free_sym_tree (sym_tree->left);
2470   free_sym_tree (sym_tree->right);
2471
2472   sym = sym_tree->n.sym;
2473
2474   sym->refs--;
2475   if (sym->refs < 0)
2476     gfc_internal_error ("free_sym_tree(): Negative refs");
2477
2478   if (sym->formal_ns != NULL && sym->refs == 1)
2479     {
2480       /* As formal_ns contains a reference to sym, delete formal_ns just
2481          before the deletion of sym.  */
2482       ns = sym->formal_ns;
2483       sym->formal_ns = NULL;
2484       gfc_free_namespace (ns);
2485     }
2486   else if (sym->refs == 0)
2487     {
2488       /* Go ahead and delete the symbol.  */
2489       gfc_free_symbol (sym);
2490     }
2491
2492   gfc_free (sym_tree);
2493 }
2494
2495
2496 /* Free a derived type list.  */
2497
2498 static void
2499 gfc_free_dt_list (gfc_dt_list * dt)
2500 {
2501   gfc_dt_list *n;
2502
2503   for (; dt; dt = n)
2504     {
2505       n = dt->next;
2506       gfc_free (dt);
2507     }
2508 }
2509
2510
2511 /* Free the gfc_equiv_info's.  */
2512
2513 static void
2514 gfc_free_equiv_infos (gfc_equiv_info * s)
2515 {
2516   if (s == NULL)
2517     return;
2518   gfc_free_equiv_infos (s->next);
2519   gfc_free (s);
2520 }
2521
2522
2523 /* Free the gfc_equiv_lists.  */
2524
2525 static void
2526 gfc_free_equiv_lists (gfc_equiv_list * l)
2527 {
2528   if (l == NULL)
2529     return;
2530   gfc_free_equiv_lists (l->next);
2531   gfc_free_equiv_infos (l->equiv);
2532   gfc_free (l);
2533 }
2534
2535
2536 /* Free a namespace structure and everything below it.  Interface
2537    lists associated with intrinsic operators are not freed.  These are
2538    taken care of when a specific name is freed.  */
2539
2540 void
2541 gfc_free_namespace (gfc_namespace * ns)
2542 {
2543   gfc_charlen *cl, *cl2;
2544   gfc_namespace *p, *q;
2545   gfc_intrinsic_op i;
2546
2547   if (ns == NULL)
2548     return;
2549
2550   ns->refs--;
2551   if (ns->refs > 0)
2552     return;
2553   gcc_assert (ns->refs == 0);
2554
2555   gfc_free_statements (ns->code);
2556
2557   free_sym_tree (ns->sym_root);
2558   free_uop_tree (ns->uop_root);
2559   free_common_tree (ns->common_root);
2560
2561   for (cl = ns->cl_list; cl; cl = cl2)
2562     {
2563       cl2 = cl->next;
2564       gfc_free_expr (cl->length);
2565       gfc_free (cl);
2566     }
2567
2568   free_st_labels (ns->st_labels);
2569
2570   gfc_free_equiv (ns->equiv);
2571   gfc_free_equiv_lists (ns->equiv_lists);
2572
2573   gfc_free_dt_list (ns->derived_types);
2574
2575   for (i = GFC_INTRINSIC_BEGIN; i != GFC_INTRINSIC_END; i++)
2576     gfc_free_interface (ns->operator[i]);
2577
2578   gfc_free_data (ns->data);
2579   p = ns->contained;
2580   gfc_free (ns);
2581
2582   /* Recursively free any contained namespaces.  */
2583   while (p != NULL)
2584     {
2585       q = p;
2586       p = p->sibling;
2587
2588       gfc_free_namespace (q);
2589     }
2590 }
2591
2592
2593 void
2594 gfc_symbol_init_2 (void)
2595 {
2596
2597   gfc_current_ns = gfc_get_namespace (NULL, 0);
2598 }
2599
2600
2601 void
2602 gfc_symbol_done_2 (void)
2603 {
2604
2605   gfc_free_namespace (gfc_current_ns);
2606   gfc_current_ns = NULL;
2607 }
2608
2609
2610 /* Clear mark bits from symbol nodes associated with a symtree node.  */
2611
2612 static void
2613 clear_sym_mark (gfc_symtree * st)
2614 {
2615
2616   st->n.sym->mark = 0;
2617 }
2618
2619
2620 /* Recursively traverse the symtree nodes.  */
2621
2622 void
2623 gfc_traverse_symtree (gfc_symtree * st, void (*func) (gfc_symtree *))
2624 {
2625   if (st != NULL)
2626     {
2627       (*func) (st);
2628
2629       gfc_traverse_symtree (st->left, func);
2630       gfc_traverse_symtree (st->right, func);
2631     }
2632 }
2633
2634
2635 /* Recursive namespace traversal function.  */
2636
2637 static void
2638 traverse_ns (gfc_symtree * st, void (*func) (gfc_symbol *))
2639 {
2640
2641   if (st == NULL)
2642     return;
2643
2644   if (st->n.sym->mark == 0)
2645     (*func) (st->n.sym);
2646   st->n.sym->mark = 1;
2647
2648   traverse_ns (st->left, func);
2649   traverse_ns (st->right, func);
2650 }
2651
2652
2653 /* Call a given function for all symbols in the namespace.  We take
2654    care that each gfc_symbol node is called exactly once.  */
2655
2656 void
2657 gfc_traverse_ns (gfc_namespace * ns, void (*func) (gfc_symbol *))
2658 {
2659
2660   gfc_traverse_symtree (ns->sym_root, clear_sym_mark);
2661
2662   traverse_ns (ns->sym_root, func);
2663 }
2664
2665
2666 /* Return TRUE if the symbol is an automatic variable.  */
2667 static bool
2668 gfc_is_var_automatic (gfc_symbol * sym)
2669 {
2670   /* Pointer and allocatable variables are never automatic.  */
2671   if (sym->attr.pointer || sym->attr.allocatable)
2672     return false;
2673   /* Check for arrays with non-constant size.  */
2674   if (sym->attr.dimension && sym->as
2675       && !gfc_is_compile_time_shape (sym->as))
2676     return true;
2677   /* Check for non-constant length character variables.  */
2678   if (sym->ts.type == BT_CHARACTER
2679       && sym->ts.cl
2680       && !gfc_is_constant_expr (sym->ts.cl->length))
2681     return true;
2682   return false;
2683 }
2684
2685 /* Given a symbol, mark it as SAVEd if it is allowed.  */
2686
2687 static void
2688 save_symbol (gfc_symbol * sym)
2689 {
2690
2691   if (sym->attr.use_assoc)
2692     return;
2693
2694   if (sym->attr.in_common
2695       || sym->attr.dummy
2696       || sym->attr.flavor != FL_VARIABLE)
2697     return;
2698   /* Automatic objects are not saved.  */
2699   if (gfc_is_var_automatic (sym))
2700     return;
2701   gfc_add_save (&sym->attr, sym->name, &sym->declared_at);
2702 }
2703
2704
2705 /* Mark those symbols which can be SAVEd as such.  */
2706
2707 void
2708 gfc_save_all (gfc_namespace * ns)
2709 {
2710
2711   gfc_traverse_ns (ns, save_symbol);
2712 }
2713
2714
2715 #ifdef GFC_DEBUG
2716 /* Make sure that no changes to symbols are pending.  */
2717
2718 void
2719 gfc_symbol_state(void) {
2720
2721   if (changed_syms != NULL)
2722     gfc_internal_error("Symbol changes still pending!");
2723 }
2724 #endif
2725
2726
2727 /************** Global symbol handling ************/
2728
2729
2730 /* Search a tree for the global symbol.  */
2731
2732 gfc_gsymbol *
2733 gfc_find_gsymbol (gfc_gsymbol *symbol, const char *name)
2734 {
2735   gfc_gsymbol *s;
2736
2737   if (symbol == NULL)
2738     return NULL;
2739   if (strcmp (symbol->name, name) == 0)
2740     return symbol;
2741
2742   s = gfc_find_gsymbol (symbol->left, name);
2743   if (s != NULL)
2744     return s;
2745
2746   s = gfc_find_gsymbol (symbol->right, name);
2747   if (s != NULL)
2748     return s;
2749
2750   return NULL;
2751 }
2752
2753
2754 /* Compare two global symbols. Used for managing the BB tree.  */
2755
2756 static int
2757 gsym_compare (void * _s1, void * _s2)
2758 {
2759   gfc_gsymbol *s1, *s2;
2760
2761   s1 = (gfc_gsymbol *)_s1;
2762   s2 = (gfc_gsymbol *)_s2;
2763   return strcmp(s1->name, s2->name);
2764 }
2765
2766
2767 /* Get a global symbol, creating it if it doesn't exist.  */
2768
2769 gfc_gsymbol *
2770 gfc_get_gsymbol (const char *name)
2771 {
2772   gfc_gsymbol *s;
2773
2774   s = gfc_find_gsymbol (gfc_gsym_root, name);
2775   if (s != NULL)
2776     return s;
2777
2778   s = gfc_getmem (sizeof (gfc_gsymbol));
2779   s->type = GSYM_UNKNOWN;
2780   s->name = gfc_get_string (name);
2781
2782   gfc_insert_bbt (&gfc_gsym_root, s, gsym_compare);
2783
2784   return s;
2785 }