gcc/fortran/symbol.c

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