old-autovect-branch/gcc/fortran/symbol.c

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