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