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
  31 /* Strings for all symbol attributes.  We use these for dumping the
  32    parse tree, in error messages, and also when reading and writing
  33    modules.  */
  34
  35 const mstring flavors[] =
  36 {
  37   minit ("UNKNOWN-FL", FL_UNKNOWN), minit ("PROGRAM", FL_PROGRAM),
  38   minit ("BLOCK-DATA", FL_BLOCK_DATA), minit ("MODULE", FL_MODULE),
  39   minit ("VARIABLE", FL_VARIABLE), minit ("PARAMETER", FL_PARAMETER),
  40   minit ("LABEL", FL_LABEL), minit ("PROCEDURE", FL_PROCEDURE),
  41   minit ("DERIVED", FL_DERIVED), minit ("NAMELIST", FL_NAMELIST),
  42   minit (NULL, -1)
  43 };
  44
  45 const mstring procedures[] =
  46 {
  47     minit ("UNKNOWN-PROC", PROC_UNKNOWN),
  48     minit ("MODULE-PROC", PROC_MODULE),
  49     minit ("INTERNAL-PROC", PROC_INTERNAL),
  50     minit ("DUMMY-PROC", PROC_DUMMY),
  51     minit ("INTRINSIC-PROC", PROC_INTRINSIC),
  52     minit ("EXTERNAL-PROC", PROC_EXTERNAL),
  53     minit ("STATEMENT-PROC", PROC_ST_FUNCTION),
  54     minit (NULL, -1)
  55 };
  56
  57 const mstring intents[] =
  58 {
  59     minit ("UNKNOWN-INTENT", INTENT_UNKNOWN),
  60     minit ("IN", INTENT_IN),
  61     minit ("OUT", INTENT_OUT),
  62     minit ("INOUT", INTENT_INOUT),
  63     minit (NULL, -1)
  64 };
  65
  66 const mstring access_types[] =
  67 {
  68     minit ("UNKNOWN-ACCESS", ACCESS_UNKNOWN),
  69     minit ("PUBLIC", ACCESS_PUBLIC),
  70     minit ("PRIVATE", ACCESS_PRIVATE),
  71     minit (NULL, -1)
  72 };
  73
  74 const mstring ifsrc_types[] =
  75 {
  76     minit ("UNKNOWN", IFSRC_UNKNOWN),
  77     minit ("DECL", IFSRC_DECL),
  78     minit ("BODY", IFSRC_IFBODY),
  79     minit ("USAGE", IFSRC_USAGE)
  80 };
  81
  82 const mstring save_status[] =
  83 {
  84     minit ("UNKNOWN", SAVE_NONE),
  85     minit ("EXPLICIT-SAVE", SAVE_EXPLICIT),
  86     minit ("IMPLICIT-SAVE", SAVE_IMPLICIT),
  87 };
  88
  89 /* This is to make sure the backend generates setup code in the correct
  90    order.  */
  91
  92 static int next_dummy_order = 1;
  93
  94
  95 gfc_namespace *gfc_current_ns;
  96
  97 gfc_gsymbol *gfc_gsym_root = NULL;
  98
  99 static gfc_symbol *changed_syms = NULL;
 100
 101 gfc_dt_list *gfc_derived_types;
 102
 103
 104 /*********** IMPLICIT NONE and IMPLICIT statement handlers ***********/
 105
 106 /* The following static variable indicates whether a particular element has
 107    been explicitly set or not.  */
 108
 109 static int new_flag[GFC_LETTERS];
 110
 111
 112 /* Handle a correctly parsed IMPLICIT NONE.  */
 113
 114 void
 115 gfc_set_implicit_none (void)
 116 {
 117   int i;
 118
 119   if (gfc_current_ns->seen_implicit_none)
 120     {
 121       gfc_error ("Duplicate IMPLICIT NONE statement at %C");
 122       return;
 123     }
 124
 125   gfc_current_ns->seen_implicit_none = 1;
 126
 127   for (i = 0; i < GFC_LETTERS; i++)
 128     {
 129       gfc_clear_ts (&gfc_current_ns->default_type[i]);
 130       gfc_current_ns->set_flag[i] = 1;
 131     }
 132 }
 133
 134
 135 /* Reset the implicit range flags.  */
 136
 137 void
 138 gfc_clear_new_implicit (void)
 139 {
 140   int i;
 141
 142   for (i = 0; i < GFC_LETTERS; i++)
 143     new_flag[i] = 0;
 144 }
 145
 146
 147 /* Prepare for a new implicit range.  Sets flags in new_flag[].  */
 148
 149 try
 150 gfc_add_new_implicit_range (int c1, int c2)
 151 {
 152   int i;
 153
 154   c1 -= 'a';
 155   c2 -= 'a';
 156
 157   for (i = c1; i <= c2; i++)
 158     {
 159       if (new_flag[i])
 160         {
 161           gfc_error ("Letter '%c' already set in IMPLICIT statement at %C",
 162                      i + 'A');
 163           return FAILURE;
 164         }
 165
 166       new_flag[i] = 1;
 167     }
 168
 169   return SUCCESS;
 170 }
 171
 172
 173 /* Add a matched implicit range for gfc_set_implicit().  Check if merging
 174    the new implicit types back into the existing types will work.  */
 175
 176 try
 177 gfc_merge_new_implicit (gfc_typespec *ts)
 178 {
 179   int i;
 180
 181   if (gfc_current_ns->seen_implicit_none)
 182     {
 183       gfc_error ("Cannot specify IMPLICIT at %C after IMPLICIT NONE");
 184       return FAILURE;
 185     }
 186
 187   for (i = 0; i < GFC_LETTERS; i++)
 188     {
 189       if (new_flag[i])
 190         {
 191
 192           if (gfc_current_ns->set_flag[i])
 193             {
 194               gfc_error ("Letter %c already has an IMPLICIT type at %C",
 195                          i + 'A');
 196               return FAILURE;
 197             }
 198           gfc_current_ns->default_type[i] = *ts;
 199           gfc_current_ns->set_flag[i] = 1;
 200         }
 201     }
 202   return SUCCESS;
 203 }
 204
 205
 206 /* Given a symbol, return a pointer to the typespec for its default type.  */
 207
 208 gfc_typespec *
 209 gfc_get_default_type (gfc_symbol *sym, gfc_namespace *ns)
 210 {
 211   char letter;
 212
 213   letter = sym->name[0];
 214
 215   if (gfc_option.flag_allow_leading_underscore && letter == '_')
 216     gfc_internal_error ("Option -fallow_leading_underscore is for use only by "
 217                         "gfortran developers, and should not be used for "
 218                         "implicitly typed variables");
 219
 220   if (letter < 'a' || letter > 'z')
 221     gfc_internal_error ("gfc_get_default_type(): Bad symbol");
 222
 223   if (ns == NULL)
 224     ns = gfc_current_ns;
 225
 226   return &ns->default_type[letter - 'a'];
 227 }
 228
 229
 230 /* Given a pointer to a symbol, set its type according to the first
 231    letter of its name.  Fails if the letter in question has no default
 232    type.  */
 233
 234 try
 235 gfc_set_default_type (gfc_symbol *sym, int error_flag, gfc_namespace *ns)
 236 {
 237   gfc_typespec *ts;
 238
 239   if (sym->ts.type != BT_UNKNOWN)
 240     gfc_internal_error ("gfc_set_default_type(): symbol already has a type");
 241
 242   ts = gfc_get_default_type (sym, ns);
 243
 244   if (ts->type == BT_UNKNOWN)
 245     {
 246       if (error_flag && !sym->attr.untyped)
 247         {
 248           gfc_error ("Symbol '%s' at %L has no IMPLICIT type",
 249                      sym->name, &sym->declared_at);
 250           sym->attr.untyped = 1; /* Ensure we only give an error once.  */
 251         }
 252
 253       return FAILURE;
 254     }
 255
 256   sym->ts = *ts;
 257   sym->attr.implicit_type = 1;
 258
 259   if (sym->attr.is_bind_c == 1)
 260     {
 261       /* BIND(C) variables should not be implicitly declared.  */
 262       gfc_warning_now ("Implicitly declared BIND(C) variable '%s' at %L may "
 263                        "not be C interoperable", sym->name, &sym->declared_at);
 264       sym->ts.f90_type = sym->ts.type;
 265     }
 266
 267   if (sym->attr.dummy != 0)
 268     {
 269       if (sym->ns->proc_name != NULL
 270           && (sym->ns->proc_name->attr.subroutine != 0
 271               || sym->ns->proc_name->attr.function != 0)
 272           && sym->ns->proc_name->attr.is_bind_c != 0)
 273         {
 274           /* Dummy args to a BIND(C) routine may not be interoperable if
 275              they are implicitly typed.  */
 276           gfc_warning_now ("Implicity declared variable '%s' at %L may not "
 277                            "be C interoperable but it is a dummy argument to "
 278                            "the BIND(C) procedure '%s' at %L", sym->name,
 279                            &(sym->declared_at), sym->ns->proc_name->name,
 280                            &(sym->ns->proc_name->declared_at));
 281           sym->ts.f90_type = sym->ts.type;
 282         }
 283     }
 284
 285   return SUCCESS;
 286 }
 287
 288
 289 /* This function is called from parse.c(parse_progunit) to check the
 290    type of the function is not implicitly typed in the host namespace
 291    and to implicitly type the function result, if necessary.  */
 292
 293 void
 294 gfc_check_function_type (gfc_namespace *ns)
 295 {
 296   gfc_symbol *proc = ns->proc_name;
 297
 298   if (!proc->attr.contained || proc->result->attr.implicit_type)
 299     return;
 300
 301   if (proc->result->ts.type == BT_UNKNOWN)
 302     {
 303       if (gfc_set_default_type (proc->result, 0, gfc_current_ns)
 304                 == SUCCESS)
 305         {
 306           if (proc->result != proc)
 307             {
 308               proc->ts = proc->result->ts;
 309               proc->as = gfc_copy_array_spec (proc->result->as);
 310               proc->attr.dimension = proc->result->attr.dimension;
 311               proc->attr.pointer = proc->result->attr.pointer;
 312               proc->attr.allocatable = proc->result->attr.allocatable;
 313             }
 314         }
 315       else
 316         {
 317           gfc_error ("Function result '%s' at %L has no IMPLICIT type",
 318                      proc->result->name, &proc->result->declared_at);
 319           proc->result->attr.untyped = 1;
 320         }
 321     }
 322 }
 323
 324
 325 /******************** Symbol attribute stuff *********************/
 326
 327 /* This is a generic conflict-checker.  We do this to avoid having a
 328    single conflict in two places.  */
 329
 330 #define conf(a, b) if (attr->a && attr->b) { a1 = a; a2 = b; goto conflict; }
 331 #define conf2(a) if (attr->a) { a2 = a; goto conflict; }
 332 #define conf_std(a, b, std) if (attr->a && attr->b)\
 333                               {\
 334                                 a1 = a;\
 335                                 a2 = b;\
 336                                 standard = std;\
 337                                 goto conflict_std;\
 338                               }
 339
 340 static try
 341 check_conflict (symbol_attribute *attr, const char *name, locus *where)
 342 {
 343   static const char *dummy = "DUMMY", *save = "SAVE", *pointer = "POINTER",
 344     *target = "TARGET", *external = "EXTERNAL", *intent = "INTENT",
 345     *intent_in = "INTENT(IN)", *intrinsic = "INTRINSIC",
 346     *intent_out = "INTENT(OUT)", *intent_inout = "INTENT(INOUT)",
 347     *allocatable = "ALLOCATABLE", *elemental = "ELEMENTAL",
 348     *private = "PRIVATE", *recursive = "RECURSIVE",
 349     *in_common = "COMMON", *result = "RESULT", *in_namelist = "NAMELIST",
 350     *public = "PUBLIC", *optional = "OPTIONAL", *entry = "ENTRY",
 351     *function = "FUNCTION", *subroutine = "SUBROUTINE",
 352     *dimension = "DIMENSION", *in_equivalence = "EQUIVALENCE",
 353     *use_assoc = "USE ASSOCIATED", *cray_pointer = "CRAY POINTER",
 354     *cray_pointee = "CRAY POINTEE", *data = "DATA", *value = "VALUE",
 355     *volatile_ = "VOLATILE", *protected = "PROTECTED",
 356     *is_bind_c = "BIND(C)";
 357   static const char *threadprivate = "THREADPRIVATE";
 358
 359   const char *a1, *a2;
 360   int standard;
 361
 362   if (where == NULL)
 363     where = &gfc_current_locus;
 364
 365   if (attr->pointer && attr->intent != INTENT_UNKNOWN)
 366     {
 367       a1 = pointer;
 368       a2 = intent;
 369       standard = GFC_STD_F2003;
 370       goto conflict_std;
 371     }
 372
 373   /* Check for attributes not allowed in a BLOCK DATA.  */
 374   if (gfc_current_state () == COMP_BLOCK_DATA)
 375     {
 376       a1 = NULL;
 377
 378       if (attr->in_namelist)
 379         a1 = in_namelist;
 380       if (attr->allocatable)
 381         a1 = allocatable;
 382       if (attr->external)
 383         a1 = external;
 384       if (attr->optional)
 385         a1 = optional;
 386       if (attr->access == ACCESS_PRIVATE)
 387         a1 = private;
 388       if (attr->access == ACCESS_PUBLIC)
 389         a1 = public;
 390       if (attr->intent != INTENT_UNKNOWN)
 391         a1 = intent;
 392
 393       if (a1 != NULL)
 394         {
 395           gfc_error
 396             ("%s attribute not allowed in BLOCK DATA program unit at %L",
 397              a1, where);
 398           return FAILURE;
 399         }
 400     }
 401
 402   if (attr->save == SAVE_EXPLICIT)
 403     {
 404       conf (dummy, save);
 405       conf (in_common, save);
 406       conf (result, save);
 407
 408       switch (attr->flavor)
 409         {
 410           case FL_PROGRAM:
 411           case FL_BLOCK_DATA:
 412           case FL_MODULE:
 413           case FL_LABEL:
 414           case FL_PROCEDURE:
 415           case FL_DERIVED:
 416           case FL_PARAMETER:
 417             a1 = gfc_code2string (flavors, attr->flavor);
 418             a2 = save;
 419             goto conflict;
 420
 421           case FL_VARIABLE:
 422           case FL_NAMELIST:
 423           default:
 424             break;
 425         }
 426     }
 427
 428   conf (dummy, entry);
 429   conf (dummy, intrinsic);
 430   conf (dummy, threadprivate);
 431   conf (pointer, target);
 432   conf (pointer, intrinsic);
 433   conf (pointer, elemental);
 434   conf (allocatable, elemental);
 435
 436   conf (target, external);
 437   conf (target, intrinsic);
 438   conf (external, dimension);   /* See Fortran 95's R504.  */
 439
 440   conf (external, intrinsic);
 441
 442   if (attr->if_source || attr->contained)
 443     {
 444       conf (external, subroutine);
 445       conf (external, function);
 446     }
 447
 448   conf (allocatable, pointer);
 449   conf_std (allocatable, dummy, GFC_STD_F2003);
 450   conf_std (allocatable, function, GFC_STD_F2003);
 451   conf_std (allocatable, result, GFC_STD_F2003);
 452   conf (elemental, recursive);
 453
 454   conf (in_common, dummy);
 455   conf (in_common, allocatable);
 456   conf (in_common, result);
 457
 458   conf (dummy, result);
 459
 460   conf (in_equivalence, use_assoc);
 461   conf (in_equivalence, dummy);
 462   conf (in_equivalence, target);
 463   conf (in_equivalence, pointer);
 464   conf (in_equivalence, function);
 465   conf (in_equivalence, result);
 466   conf (in_equivalence, entry);
 467   conf (in_equivalence, allocatable);
 468   conf (in_equivalence, threadprivate);
 469
 470   conf (in_namelist, pointer);
 471   conf (in_namelist, allocatable);
 472
 473   conf (entry, result);
 474
 475   conf (function, subroutine);
 476
 477   if (!function && !subroutine)
 478     conf (is_bind_c, dummy);
 479
 480   conf (is_bind_c, cray_pointer);
 481   conf (is_bind_c, cray_pointee);
 482   conf (is_bind_c, allocatable);
 483
 484   /* Need to also get volatile attr, according to 5.1 of F2003 draft.
 485      Parameter conflict caught below.  Also, value cannot be specified
 486      for a dummy procedure.  */
 487
 488   /* Cray pointer/pointee conflicts.  */
 489   conf (cray_pointer, cray_pointee);
 490   conf (cray_pointer, dimension);
 491   conf (cray_pointer, pointer);
 492   conf (cray_pointer, target);
 493   conf (cray_pointer, allocatable);
 494   conf (cray_pointer, external);
 495   conf (cray_pointer, intrinsic);
 496   conf (cray_pointer, in_namelist);
 497   conf (cray_pointer, function);
 498   conf (cray_pointer, subroutine);
 499   conf (cray_pointer, entry);
 500
 501   conf (cray_pointee, allocatable);
 502   conf (cray_pointee, intent);
 503   conf (cray_pointee, optional);
 504   conf (cray_pointee, dummy);
 505   conf (cray_pointee, target);
 506   conf (cray_pointee, intrinsic);
 507   conf (cray_pointee, pointer);
 508   conf (cray_pointee, entry);
 509   conf (cray_pointee, in_common);
 510   conf (cray_pointee, in_equivalence);
 511   conf (cray_pointee, threadprivate);
 512
 513   conf (data, dummy);
 514   conf (data, function);
 515   conf (data, result);
 516   conf (data, allocatable);
 517   conf (data, use_assoc);
 518
 519   conf (value, pointer)
 520   conf (value, allocatable)
 521   conf (value, subroutine)
 522   conf (value, function)
 523   conf (value, volatile_)
 524   conf (value, dimension)
 525   conf (value, external)
 526
 527   if (attr->value
 528       && (attr->intent == INTENT_OUT || attr->intent == INTENT_INOUT))
 529     {
 530       a1 = value;
 531       a2 = attr->intent == INTENT_OUT ? intent_out : intent_inout;
 532       goto conflict;
 533     }
 534
 535   conf (protected, intrinsic)
 536   conf (protected, external)
 537   conf (protected, in_common)
 538
 539   conf (volatile_, intrinsic)
 540   conf (volatile_, external)
 541
 542   if (attr->volatile_ && attr->intent == INTENT_IN)
 543     {
 544       a1 = volatile_;
 545       a2 = intent_in;
 546       goto conflict;
 547     }
 548
 549   a1 = gfc_code2string (flavors, attr->flavor);
 550
 551   if (attr->in_namelist
 552       && attr->flavor != FL_VARIABLE
 553       && attr->flavor != FL_PROCEDURE
 554       && attr->flavor != FL_UNKNOWN)
 555     {
 556       a2 = in_namelist;
 557       goto conflict;
 558     }
 559
 560   switch (attr->flavor)
 561     {
 562     case FL_PROGRAM:
 563     case FL_BLOCK_DATA:
 564     case FL_MODULE:
 565     case FL_LABEL:
 566       conf2 (dimension);
 567       conf2 (dummy);
 568       conf2 (volatile_);
 569       conf2 (pointer);
 570       conf2 (protected);
 571       conf2 (target);
 572       conf2 (external);
 573       conf2 (intrinsic);
 574       conf2 (allocatable);
 575       conf2 (result);
 576       conf2 (in_namelist);
 577       conf2 (optional);
 578       conf2 (function);
 579       conf2 (subroutine);
 580       conf2 (threadprivate);
 581       break;
 582
 583     case FL_VARIABLE:
 584     case FL_NAMELIST:
 585       break;
 586
 587     case FL_PROCEDURE:
 588       conf2 (intent);
 589
 590       if (attr->subroutine)
 591         {
 592           conf2 (pointer);
 593           conf2 (target);
 594           conf2 (allocatable);
 595           conf2 (result);
 596           conf2 (in_namelist);
 597           conf2 (dimension);
 598           conf2 (function);
 599           conf2 (threadprivate);
 600         }
 601
 602       switch (attr->proc)
 603         {
 604         case PROC_ST_FUNCTION:
 605           conf2 (in_common);
 606           conf2 (dummy);
 607           break;
 608
 609         case PROC_MODULE:
 610           conf2 (dummy);
 611           break;
 612
 613         case PROC_DUMMY:
 614           conf2 (result);
 615           conf2 (in_common);
 616           conf2 (threadprivate);
 617           break;
 618
 619         default:
 620           break;
 621         }
 622
 623       break;
 624
 625     case FL_DERIVED:
 626       conf2 (dummy);
 627       conf2 (pointer);
 628       conf2 (target);
 629       conf2 (external);
 630       conf2 (intrinsic);
 631       conf2 (allocatable);
 632       conf2 (optional);
 633       conf2 (entry);
 634       conf2 (function);
 635       conf2 (subroutine);
 636       conf2 (threadprivate);
 637
 638       if (attr->intent != INTENT_UNKNOWN)
 639         {
 640           a2 = intent;
 641           goto conflict;
 642         }
 643       break;
 644
 645     case FL_PARAMETER:
 646       conf2 (external);
 647       conf2 (intrinsic);
 648       conf2 (optional);
 649       conf2 (allocatable);
 650       conf2 (function);
 651       conf2 (subroutine);
 652       conf2 (entry);
 653       conf2 (pointer);
 654       conf2 (protected);
 655       conf2 (target);
 656       conf2 (dummy);
 657       conf2 (in_common);
 658       conf2 (value);
 659       conf2 (volatile_);
 660       conf2 (threadprivate);
 661       /* TODO: hmm, double check this.  */
 662       conf2 (value);
 663       break;
 664
 665     default:
 666       break;
 667     }
 668
 669   return SUCCESS;
 670
 671 conflict:
 672   if (name == NULL)
 673     gfc_error ("%s attribute conflicts with %s attribute at %L",
 674                a1, a2, where);
 675   else
 676     gfc_error ("%s attribute conflicts with %s attribute in '%s' at %L",
 677                a1, a2, name, where);
 678
 679   return FAILURE;
 680
 681 conflict_std:
 682   if (name == NULL)
 683     {
 684       return gfc_notify_std (standard, "Fortran 2003: %s attribute "
 685                              "with %s attribute at %L", a1, a2,
 686                              where);
 687     }
 688   else
 689     {
 690       return gfc_notify_std (standard, "Fortran 2003: %s attribute "
 691                              "with %s attribute in '%s' at %L",
 692                              a1, a2, name, where);
 693     }
 694 }
 695
 696 #undef conf
 697 #undef conf2
 698 #undef conf_std
 699
 700
 701 /* Mark a symbol as referenced.  */
 702
 703 void
 704 gfc_set_sym_referenced (gfc_symbol *sym)
 705 {
 706
 707   if (sym->attr.referenced)
 708     return;
 709
 710   sym->attr.referenced = 1;
 711
 712   /* Remember which order dummy variables are accessed in.  */
 713   if (sym->attr.dummy)
 714     sym->dummy_order = next_dummy_order++;
 715 }
 716
 717
 718 /* Common subroutine called by attribute changing subroutines in order
 719    to prevent them from changing a symbol that has been
 720    use-associated.  Returns zero if it is OK to change the symbol,
 721    nonzero if not.  */
 722
 723 static int
 724 check_used (symbol_attribute *attr, const char *name, locus *where)
 725 {
 726
 727   if (attr->use_assoc == 0)
 728     return 0;
 729
 730   if (where == NULL)
 731     where = &gfc_current_locus;
 732
 733   if (name == NULL)
 734     gfc_error ("Cannot change attributes of USE-associated symbol at %L",
 735                where);
 736   else
 737     gfc_error ("Cannot change attributes of USE-associated symbol %s at %L",
 738                name, where);
 739
 740   return 1;
 741 }
 742
 743
 744 /* Generate an error because of a duplicate attribute.  */
 745
 746 static void
 747 duplicate_attr (const char *attr, locus *where)
 748 {
 749
 750   if (where == NULL)
 751     where = &gfc_current_locus;
 752
 753   gfc_error ("Duplicate %s attribute specified at %L", attr, where);
 754 }
 755
 756
 757 /* Called from decl.c (attr_decl1) to check attributes, when declared
 758    separately.  */
 759
 760 try
 761 gfc_add_attribute (symbol_attribute *attr, locus *where)
 762 {
 763
 764   if (check_used (attr, NULL, where))
 765     return FAILURE;
 766
 767   return check_conflict (attr, NULL, where);
 768 }
 769
 770 try
 771 gfc_add_allocatable (symbol_attribute *attr, locus *where)
 772 {
 773
 774   if (check_used (attr, NULL, where))
 775     return FAILURE;
 776
 777   if (attr->allocatable)
 778     {
 779       duplicate_attr ("ALLOCATABLE", where);
 780       return FAILURE;
 781     }
 782
 783   attr->allocatable = 1;
 784   return check_conflict (attr, NULL, where);
 785 }
 786
 787
 788 try
 789 gfc_add_dimension (symbol_attribute *attr, const char *name, locus *where)
 790 {
 791
 792   if (check_used (attr, name, where))
 793     return FAILURE;
 794
 795   if (attr->dimension)
 796     {
 797       duplicate_attr ("DIMENSION", where);
 798       return FAILURE;
 799     }
 800
 801   attr->dimension = 1;
 802   return check_conflict (attr, name, where);
 803 }
 804
 805
 806 try
 807 gfc_add_external (symbol_attribute *attr, locus *where)
 808 {
 809
 810   if (check_used (attr, NULL, where))
 811     return FAILURE;
 812
 813   if (attr->external)
 814     {
 815       duplicate_attr ("EXTERNAL", where);
 816       return FAILURE;
 817     }
 818
 819   attr->external = 1;
 820
 821   return check_conflict (attr, NULL, where);
 822 }
 823
 824
 825 try
 826 gfc_add_intrinsic (symbol_attribute *attr, locus *where)
 827 {
 828
 829   if (check_used (attr, NULL, where))
 830     return FAILURE;
 831
 832   if (attr->intrinsic)
 833     {
 834       duplicate_attr ("INTRINSIC", where);
 835       return FAILURE;
 836     }
 837
 838   attr->intrinsic = 1;
 839
 840   return check_conflict (attr, NULL, where);
 841 }
 842
 843
 844 try
 845 gfc_add_optional (symbol_attribute *attr, locus *where)
 846 {
 847
 848   if (check_used (attr, NULL, where))
 849     return FAILURE;
 850
 851   if (attr->optional)
 852     {
 853       duplicate_attr ("OPTIONAL", where);
 854       return FAILURE;
 855     }
 856
 857   attr->optional = 1;
 858   return check_conflict (attr, NULL, where);
 859 }
 860
 861
 862 try
 863 gfc_add_pointer (symbol_attribute *attr, locus *where)
 864 {
 865
 866   if (check_used (attr, NULL, where))
 867     return FAILURE;
 868
 869   attr->pointer = 1;
 870   return check_conflict (attr, NULL, where);
 871 }
 872
 873
 874 try
 875 gfc_add_cray_pointer (symbol_attribute *attr, locus *where)
 876 {
 877
 878   if (check_used (attr, NULL, where))
 879     return FAILURE;
 880
 881   attr->cray_pointer = 1;
 882   return check_conflict (attr, NULL, where);
 883 }
 884
 885
 886 try
 887 gfc_add_cray_pointee (symbol_attribute *attr, locus *where)
 888 {
 889
 890   if (check_used (attr, NULL, where))
 891     return FAILURE;
 892
 893   if (attr->cray_pointee)
 894     {
 895       gfc_error ("Cray Pointee at %L appears in multiple pointer()"
 896                  " statements", where);
 897       return FAILURE;
 898     }
 899
 900   attr->cray_pointee = 1;
 901   return check_conflict (attr, NULL, where);
 902 }
 903
 904
 905 try
 906 gfc_add_protected (symbol_attribute *attr, const char *name, locus *where)
 907 {
 908   if (check_used (attr, name, where))
 909     return FAILURE;
 910
 911   if (attr->protected)
 912     {
 913         if (gfc_notify_std (GFC_STD_LEGACY,
 914                             "Duplicate PROTECTED attribute specified at %L",
 915                             where)
 916             == FAILURE)
 917           return FAILURE;
 918     }
 919
 920   attr->protected = 1;
 921   return check_conflict (attr, name, where);
 922 }
 923
 924
 925 try
 926 gfc_add_result (symbol_attribute *attr, const char *name, locus *where)
 927 {
 928
 929   if (check_used (attr, name, where))
 930     return FAILURE;
 931
 932   attr->result = 1;
 933   return check_conflict (attr, name, where);
 934 }
 935
 936
 937 try
 938 gfc_add_save (symbol_attribute *attr, const char *name, locus *where)
 939 {
 940
 941   if (check_used (attr, name, where))
 942     return FAILURE;
 943
 944   if (gfc_pure (NULL))
 945     {
 946       gfc_error
 947         ("SAVE attribute at %L cannot be specified in a PURE procedure",
 948          where);
 949       return FAILURE;
 950     }
 951
 952   if (attr->save == SAVE_EXPLICIT)
 953     {
 954         if (gfc_notify_std (GFC_STD_LEGACY,
 955                             "Duplicate SAVE attribute specified at %L",
 956                             where)
 957             == FAILURE)
 958           return FAILURE;
 959     }
 960
 961   attr->save = SAVE_EXPLICIT;
 962   return check_conflict (attr, name, where);
 963 }
 964
 965
 966 try
 967 gfc_add_value (symbol_attribute *attr, const char *name, locus *where)
 968 {
 969
 970   if (check_used (attr, name, where))
 971     return FAILURE;
 972
 973   if (attr->value)
 974     {
 975         if (gfc_notify_std (GFC_STD_LEGACY,
 976                             "Duplicate VALUE attribute specified at %L",
 977                             where)
 978             == FAILURE)
 979           return FAILURE;
 980     }
 981
 982   attr->value = 1;
 983   return check_conflict (attr, name, where);
 984 }
 985
 986
 987 try
 988 gfc_add_volatile (symbol_attribute *attr, const char *name, locus *where)
 989 {
 990   /* No check_used needed as 11.2.1 of the F2003 standard allows
 991      that the local identifier made accessible by a use statement can be
 992      given a VOLATILE attribute.  */
 993
 994   if (attr->volatile_ && attr->volatile_ns == gfc_current_ns)
 995     if (gfc_notify_std (GFC_STD_LEGACY,
 996                         "Duplicate VOLATILE attribute specified at %L", where)
 997         == FAILURE)
 998       return FAILURE;
 999
1000   attr->volatile_ = 1;
1001   attr->volatile_ns = gfc_current_ns;
1002   return check_conflict (attr, name, where);
1003 }
1004
1005
1006 try
1007 gfc_add_threadprivate (symbol_attribute *attr, const char *name, locus *where)
1008 {
1009
1010   if (check_used (attr, name, where))
1011     return FAILURE;
1012
1013   if (attr->threadprivate)
1014     {
1015       duplicate_attr ("THREADPRIVATE", where);
1016       return FAILURE;
1017     }
1018
1019   attr->threadprivate = 1;
1020   return check_conflict (attr, name, where);
1021 }
1022
1023
1024 try
1025 gfc_add_target (symbol_attribute *attr, locus *where)
1026 {
1027
1028   if (check_used (attr, NULL, where))
1029     return FAILURE;
1030
1031   if (attr->target)
1032     {
1033       duplicate_attr ("TARGET", where);
1034       return FAILURE;
1035     }
1036
1037   attr->target = 1;
1038   return check_conflict (attr, NULL, where);
1039 }
1040
1041
1042 try
1043 gfc_add_dummy (symbol_attribute *attr, const char *name, locus *where)
1044 {
1045
1046   if (check_used (attr, name, where))
1047     return FAILURE;
1048
1049   /* Duplicate dummy arguments are allowed due to ENTRY statements.  */
1050   attr->dummy = 1;
1051   return check_conflict (attr, name, where);
1052 }
1053
1054
1055 try
1056 gfc_add_in_common (symbol_attribute *attr, const char *name, locus *where)
1057 {
1058
1059   if (check_used (attr, name, where))
1060     return FAILURE;
1061
1062   /* Duplicate attribute already checked for.  */
1063   attr->in_common = 1;
1064   if (check_conflict (attr, name, where) == FAILURE)
1065     return FAILURE;
1066
1067   if (attr->flavor == FL_VARIABLE)
1068     return SUCCESS;
1069
1070   return gfc_add_flavor (attr, FL_VARIABLE, name, where);
1071 }
1072
1073
1074 try
1075 gfc_add_in_equivalence (symbol_attribute *attr, const char *name, locus *where)
1076 {
1077
1078   /* Duplicate attribute already checked for.  */
1079   attr->in_equivalence = 1;
1080   if (check_conflict (attr, name, where) == FAILURE)
1081     return FAILURE;
1082
1083   if (attr->flavor == FL_VARIABLE)
1084     return SUCCESS;
1085
1086   return gfc_add_flavor (attr, FL_VARIABLE, name, where);
1087 }
1088
1089
1090 try
1091 gfc_add_data (symbol_attribute *attr, const char *name, locus *where)
1092 {
1093
1094   if (check_used (attr, name, where))
1095     return FAILURE;
1096
1097   attr->data = 1;
1098   return check_conflict (attr, name, where);
1099 }
1100
1101
1102 try
1103 gfc_add_in_namelist (symbol_attribute *attr, const char *name, locus *where)
1104 {
1105
1106   attr->in_namelist = 1;
1107   return check_conflict (attr, name, where);
1108 }
1109
1110
1111 try
1112 gfc_add_sequence (symbol_attribute *attr, const char *name, locus *where)
1113 {
1114
1115   if (check_used (attr, name, where))
1116     return FAILURE;
1117
1118   attr->sequence = 1;
1119   return check_conflict (attr, name, where);
1120 }
1121
1122
1123 try
1124 gfc_add_elemental (symbol_attribute *attr, locus *where)
1125 {
1126
1127   if (check_used (attr, NULL, where))
1128     return FAILURE;
1129
1130   attr->elemental = 1;
1131   return check_conflict (attr, NULL, where);
1132 }
1133
1134
1135 try
1136 gfc_add_pure (symbol_attribute *attr, locus *where)
1137 {
1138
1139   if (check_used (attr, NULL, where))
1140     return FAILURE;
1141
1142   attr->pure = 1;
1143   return check_conflict (attr, NULL, where);
1144 }
1145
1146
1147 try
1148 gfc_add_recursive (symbol_attribute *attr, locus *where)
1149 {
1150
1151   if (check_used (attr, NULL, where))
1152     return FAILURE;
1153
1154   attr->recursive = 1;
1155   return check_conflict (attr, NULL, where);
1156 }
1157
1158
1159 try
1160 gfc_add_entry (symbol_attribute *attr, const char *name, locus *where)
1161 {
1162
1163   if (check_used (attr, name, where))
1164     return FAILURE;
1165
1166   if (attr->entry)
1167     {
1168       duplicate_attr ("ENTRY", where);
1169       return FAILURE;
1170     }
1171
1172   attr->entry = 1;
1173   return check_conflict (attr, name, where);
1174 }
1175
1176
1177 try
1178 gfc_add_function (symbol_attribute *attr, const char *name, locus *where)
1179 {
1180
1181   if (attr->flavor != FL_PROCEDURE
1182       && gfc_add_flavor (attr, FL_PROCEDURE, name, where) == FAILURE)
1183     return FAILURE;
1184
1185   attr->function = 1;
1186   return check_conflict (attr, name, where);
1187 }
1188
1189
1190 try
1191 gfc_add_subroutine (symbol_attribute *attr, const char *name, locus *where)
1192 {
1193
1194   if (attr->flavor != FL_PROCEDURE
1195       && gfc_add_flavor (attr, FL_PROCEDURE, name, where) == FAILURE)
1196     return FAILURE;
1197
1198   attr->subroutine = 1;
1199   return check_conflict (attr, name, where);
1200 }
1201
1202
1203 try
1204 gfc_add_generic (symbol_attribute *attr, const char *name, locus *where)
1205 {
1206
1207   if (attr->flavor != FL_PROCEDURE
1208       && gfc_add_flavor (attr, FL_PROCEDURE, name, where) == FAILURE)
1209     return FAILURE;
1210
1211   attr->generic = 1;
1212   return check_conflict (attr, name, where);
1213 }
1214
1215
1216 /* Flavors are special because some flavors are not what Fortran
1217    considers attributes and can be reaffirmed multiple times.  */
1218
1219 try
1220 gfc_add_flavor (symbol_attribute *attr, sym_flavor f, const char *name,
1221                 locus *where)
1222 {
1223
1224   if ((f == FL_PROGRAM || f == FL_BLOCK_DATA || f == FL_MODULE
1225        || f == FL_PARAMETER || f == FL_LABEL || f == FL_DERIVED
1226        || f == FL_NAMELIST) && check_used (attr, name, where))
1227     return FAILURE;
1228
1229   if (attr->flavor == f && f == FL_VARIABLE)
1230     return SUCCESS;
1231
1232   if (attr->flavor != FL_UNKNOWN)
1233     {
1234       if (where == NULL)
1235         where = &gfc_current_locus;
1236
1237       if (name)
1238         gfc_error ("%s attribute of '%s' conflicts with %s attribute at %L",
1239                    gfc_code2string (flavors, attr->flavor), name,
1240                    gfc_code2string (flavors, f), where);
1241       else
1242         gfc_error ("%s attribute conflicts with %s attribute at %L",
1243                    gfc_code2string (flavors, attr->flavor),
1244                    gfc_code2string (flavors, f), where);
1245
1246       return FAILURE;
1247     }
1248
1249   attr->flavor = f;
1250
1251   return check_conflict (attr, name, where);
1252 }
1253
1254
1255 try
1256 gfc_add_procedure (symbol_attribute *attr, procedure_type t,
1257                    const char *name, locus *where)
1258 {
1259
1260   if (check_used (attr, name, where))
1261     return FAILURE;
1262
1263   if (attr->flavor != FL_PROCEDURE
1264       && gfc_add_flavor (attr, FL_PROCEDURE, name, where) == FAILURE)
1265     return FAILURE;
1266
1267   if (where == NULL)
1268     where = &gfc_current_locus;
1269
1270   if (attr->proc != PROC_UNKNOWN)
1271     {
1272       gfc_error ("%s procedure at %L is already declared as %s procedure",
1273                  gfc_code2string (procedures, t), where,
1274                  gfc_code2string (procedures, attr->proc));
1275
1276       return FAILURE;
1277     }
1278
1279   attr->proc = t;
1280
1281   /* Statement functions are always scalar and functions.  */
1282   if (t == PROC_ST_FUNCTION
1283       && ((!attr->function && gfc_add_function (attr, name, where) == FAILURE)
1284           || attr->dimension))
1285     return FAILURE;
1286
1287   return check_conflict (attr, name, where);
1288 }
1289
1290
1291 try
1292 gfc_add_intent (symbol_attribute *attr, sym_intent intent, locus *where)
1293 {
1294
1295   if (check_used (attr, NULL, where))
1296     return FAILURE;
1297
1298   if (attr->intent == INTENT_UNKNOWN)
1299     {
1300       attr->intent = intent;
1301       return check_conflict (attr, NULL, where);
1302     }
1303
1304   if (where == NULL)
1305     where = &gfc_current_locus;
1306
1307   gfc_error ("INTENT (%s) conflicts with INTENT(%s) at %L",
1308              gfc_intent_string (attr->intent),
1309              gfc_intent_string (intent), where);
1310
1311   return FAILURE;
1312 }
1313
1314
1315 /* No checks for use-association in public and private statements.  */
1316
1317 try
1318 gfc_add_access (symbol_attribute *attr, gfc_access access,
1319                 const char *name, locus *where)
1320 {
1321
1322   if (attr->access == ACCESS_UNKNOWN)
1323     {
1324       attr->access = access;
1325       return check_conflict (attr, name, where);
1326     }
1327
1328   if (where == NULL)
1329     where = &gfc_current_locus;
1330   gfc_error ("ACCESS specification at %L was already specified", where);
1331
1332   return FAILURE;
1333 }
1334
1335
1336 /* Set the is_bind_c field for the given symbol_attribute.  */
1337
1338 try
1339 gfc_add_is_bind_c (symbol_attribute *attr, const char *name, locus *where,
1340                    int is_proc_lang_bind_spec)
1341 {
1342
1343   if (is_proc_lang_bind_spec == 0 && attr->flavor == FL_PROCEDURE)
1344     gfc_error_now ("BIND(C) attribute at %L can only be used for "
1345                    "variables or common blocks", where);
1346   else if (attr->is_bind_c)
1347     gfc_error_now ("Duplicate BIND attribute specified at %L", where);
1348   else
1349     attr->is_bind_c = 1;
1350
1351   if (where == NULL)
1352     where = &gfc_current_locus;
1353
1354   if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: BIND(C) at %L", where)
1355       == FAILURE)
1356     return FAILURE;
1357
1358   return check_conflict (attr, name, where);
1359 }
1360
1361
1362 try
1363 gfc_add_explicit_interface (gfc_symbol *sym, ifsrc source,
1364                             gfc_formal_arglist * formal, locus *where)
1365 {
1366
1367   if (check_used (&sym->attr, sym->name, where))
1368     return FAILURE;
1369
1370   if (where == NULL)
1371     where = &gfc_current_locus;
1372
1373   if (sym->attr.if_source != IFSRC_UNKNOWN
1374       && sym->attr.if_source != IFSRC_DECL)
1375     {
1376       gfc_error ("Symbol '%s' at %L already has an explicit interface",
1377                  sym->name, where);
1378       return FAILURE;
1379     }
1380
1381   sym->formal = formal;
1382   sym->attr.if_source = source;
1383
1384   return SUCCESS;
1385 }
1386
1387
1388 /* Add a type to a symbol.  */
1389
1390 try
1391 gfc_add_type (gfc_symbol *sym, gfc_typespec *ts, locus *where)
1392 {
1393   sym_flavor flavor;
1394
1395   if (where == NULL)
1396     where = &gfc_current_locus;
1397
1398   if (sym->ts.type != BT_UNKNOWN)
1399     {
1400       const char *msg = "Symbol '%s' at %L already has basic type of %s";
1401       if (!(sym->ts.type == ts->type
1402             && (sym->attr.flavor == FL_PROCEDURE || sym->attr.result))
1403           || gfc_notification_std (GFC_STD_GNU) == ERROR
1404           || pedantic)
1405         {
1406           gfc_error (msg, sym->name, where, gfc_basic_typename (sym->ts.type));
1407           return FAILURE;
1408         }
1409       else if (gfc_notify_std (GFC_STD_GNU, msg, sym->name, where,
1410                                gfc_basic_typename (sym->ts.type)) == FAILURE)
1411         return FAILURE;
1412     }
1413
1414   flavor = sym->attr.flavor;
1415
1416   if (flavor == FL_PROGRAM || flavor == FL_BLOCK_DATA || flavor == FL_MODULE
1417       || flavor == FL_LABEL
1418       || (flavor == FL_PROCEDURE && sym->attr.subroutine)
1419       || flavor == FL_DERIVED || flavor == FL_NAMELIST)
1420     {
1421       gfc_error ("Symbol '%s' at %L cannot have a type", sym->name, where);
1422       return FAILURE;
1423     }
1424
1425   sym->ts = *ts;
1426   return SUCCESS;
1427 }
1428
1429
1430 /* Clears all attributes.  */
1431
1432 void
1433 gfc_clear_attr (symbol_attribute *attr)
1434 {
1435   memset (attr, 0, sizeof (symbol_attribute));
1436 }
1437
1438
1439 /* Check for missing attributes in the new symbol.  Currently does
1440    nothing, but it's not clear that it is unnecessary yet.  */
1441
1442 try
1443 gfc_missing_attr (symbol_attribute *attr ATTRIBUTE_UNUSED,
1444                   locus *where ATTRIBUTE_UNUSED)
1445 {
1446
1447   return SUCCESS;
1448 }
1449
1450
1451 /* Copy an attribute to a symbol attribute, bit by bit.  Some
1452    attributes have a lot of side-effects but cannot be present given
1453    where we are called from, so we ignore some bits.  */
1454
1455 try
1456 gfc_copy_attr (symbol_attribute *dest, symbol_attribute *src, locus *where)
1457 {
1458   int is_proc_lang_bind_spec;
1459
1460   if (src->allocatable && gfc_add_allocatable (dest, where) == FAILURE)
1461     goto fail;
1462
1463   if (src->dimension && gfc_add_dimension (dest, NULL, where) == FAILURE)
1464     goto fail;
1465   if (src->optional && gfc_add_optional (dest, where) == FAILURE)
1466     goto fail;
1467   if (src->pointer && gfc_add_pointer (dest, where) == FAILURE)
1468     goto fail;
1469   if (src->protected && gfc_add_protected (dest, NULL, where) == FAILURE)
1470     goto fail;
1471   if (src->save && gfc_add_save (dest, NULL, where) == FAILURE)
1472     goto fail;
1473   if (src->value && gfc_add_value (dest, NULL, where) == FAILURE)
1474     goto fail;
1475   if (src->volatile_ && gfc_add_volatile (dest, NULL, where) == FAILURE)
1476     goto fail;
1477   if (src->threadprivate
1478       && gfc_add_threadprivate (dest, NULL, where) == FAILURE)
1479     goto fail;
1480   if (src->target && gfc_add_target (dest, where) == FAILURE)
1481     goto fail;
1482   if (src->dummy && gfc_add_dummy (dest, NULL, where) == FAILURE)
1483     goto fail;
1484   if (src->result && gfc_add_result (dest, NULL, where) == FAILURE)
1485     goto fail;
1486   if (src->entry)
1487     dest->entry = 1;
1488
1489   if (src->in_namelist && gfc_add_in_namelist (dest, NULL, where) == FAILURE)
1490     goto fail;
1491
1492   if (src->in_common && gfc_add_in_common (dest, NULL, where) == FAILURE)
1493     goto fail;
1494
1495   if (src->generic && gfc_add_generic (dest, NULL, where) == FAILURE)
1496     goto fail;
1497   if (src->function && gfc_add_function (dest, NULL, where) == FAILURE)
1498     goto fail;
1499   if (src->subroutine && gfc_add_subroutine (dest, NULL, where) == FAILURE)
1500     goto fail;
1501
1502   if (src->sequence && gfc_add_sequence (dest, NULL, where) == FAILURE)
1503     goto fail;
1504   if (src->elemental && gfc_add_elemental (dest, where) == FAILURE)
1505     goto fail;
1506   if (src->pure && gfc_add_pure (dest, where) == FAILURE)
1507     goto fail;
1508   if (src->recursive && gfc_add_recursive (dest, where) == FAILURE)
1509     goto fail;
1510
1511   if (src->flavor != FL_UNKNOWN
1512       && gfc_add_flavor (dest, src->flavor, NULL, where) == FAILURE)
1513     goto fail;
1514
1515   if (src->intent != INTENT_UNKNOWN
1516       && gfc_add_intent (dest, src->intent, where) == FAILURE)
1517     goto fail;
1518
1519   if (src->access != ACCESS_UNKNOWN
1520       && gfc_add_access (dest, src->access, NULL, where) == FAILURE)
1521     goto fail;
1522
1523   if (gfc_missing_attr (dest, where) == FAILURE)
1524     goto fail;
1525
1526   if (src->cray_pointer && gfc_add_cray_pointer (dest, where) == FAILURE)
1527     goto fail;
1528   if (src->cray_pointee && gfc_add_cray_pointee (dest, where) == FAILURE)
1529     goto fail;
1530
1531   is_proc_lang_bind_spec = (src->flavor == FL_PROCEDURE ? 1 : 0);
1532   if (src->is_bind_c
1533       && gfc_add_is_bind_c (dest, NULL, where, is_proc_lang_bind_spec)
1534          != SUCCESS)
1535     return FAILURE;
1536
1537   if (src->is_c_interop)
1538     dest->is_c_interop = 1;
1539   if (src->is_iso_c)
1540     dest->is_iso_c = 1;
1541
1542   if (src->external && gfc_add_external (dest, where) == FAILURE)
1543     goto fail;
1544   if (src->intrinsic && gfc_add_intrinsic (dest, where) == FAILURE)
1545     goto fail;
1546
1547   return SUCCESS;
1548
1549 fail:
1550   return FAILURE;
1551 }
1552
1553
1554 /************** Component name management ************/
1555
1556 /* Component names of a derived type form their own little namespaces
1557    that are separate from all other spaces.  The space is composed of
1558    a singly linked list of gfc_component structures whose head is
1559    located in the parent symbol.  */
1560
1561
1562 /* Add a component name to a symbol.  The call fails if the name is
1563    already present.  On success, the component pointer is modified to
1564    point to the additional component structure.  */
1565
1566 try
1567 gfc_add_component (gfc_symbol *sym, const char *name,
1568                    gfc_component **component)
1569 {
1570   gfc_component *p, *tail;
1571
1572   tail = NULL;
1573
1574   for (p = sym->components; p; p = p->next)
1575     {
1576       if (strcmp (p->name, name) == 0)
1577         {
1578           gfc_error ("Component '%s' at %C already declared at %L",
1579                      name, &p->loc);
1580           return FAILURE;
1581         }
1582
1583       tail = p;
1584     }
1585
1586   /* Allocate a new component.  */
1587   p = gfc_get_component ();
1588
1589   if (tail == NULL)
1590     sym->components = p;
1591   else
1592     tail->next = p;
1593
1594   p->name = gfc_get_string (name);
1595   p->loc = gfc_current_locus;
1596
1597   *component = p;
1598   return SUCCESS;
1599 }
1600
1601
1602 /* Recursive function to switch derived types of all symbol in a
1603    namespace.  */
1604
1605 static void
1606 switch_types (gfc_symtree *st, gfc_symbol *from, gfc_symbol *to)
1607 {
1608   gfc_symbol *sym;
1609
1610   if (st == NULL)
1611     return;
1612
1613   sym = st->n.sym;
1614   if (sym->ts.type == BT_DERIVED && sym->ts.derived == from)
1615     sym->ts.derived = to;
1616
1617   switch_types (st->left, from, to);
1618   switch_types (st->right, from, to);
1619 }
1620
1621
1622 /* This subroutine is called when a derived type is used in order to
1623    make the final determination about which version to use.  The
1624    standard requires that a type be defined before it is 'used', but
1625    such types can appear in IMPLICIT statements before the actual
1626    definition.  'Using' in this context means declaring a variable to
1627    be that type or using the type constructor.
1628
1629    If a type is used and the components haven't been defined, then we
1630    have to have a derived type in a parent unit.  We find the node in
1631    the other namespace and point the symtree node in this namespace to
1632    that node.  Further reference to this name point to the correct
1633    node.  If we can't find the node in a parent namespace, then we have
1634    an error.
1635
1636    This subroutine takes a pointer to a symbol node and returns a
1637    pointer to the translated node or NULL for an error.  Usually there
1638    is no translation and we return the node we were passed.  */
1639
1640 gfc_symbol *
1641 gfc_use_derived (gfc_symbol *sym)
1642 {
1643   gfc_symbol *s;
1644   gfc_typespec *t;
1645   gfc_symtree *st;
1646   int i;
1647
1648   if (sym->components != NULL)
1649     return sym;               /* Already defined.  */
1650
1651   if (sym->ns->parent == NULL)
1652     goto bad;
1653
1654   if (gfc_find_symbol (sym->name, sym->ns->parent, 1, &s))
1655     {
1656       gfc_error ("Symbol '%s' at %C is ambiguous", sym->name);
1657       return NULL;
1658     }
1659
1660   if (s == NULL || s->attr.flavor != FL_DERIVED)
1661     goto bad;
1662
1663   /* Get rid of symbol sym, translating all references to s.  */
1664   for (i = 0; i < GFC_LETTERS; i++)
1665     {
1666       t = &sym->ns->default_type[i];
1667       if (t->derived == sym)
1668         t->derived = s;
1669     }
1670
1671   st = gfc_find_symtree (sym->ns->sym_root, sym->name);
1672   st->n.sym = s;
1673
1674   s->refs++;
1675
1676   /* Unlink from list of modified symbols.  */
1677   gfc_commit_symbol (sym);
1678
1679   switch_types (sym->ns->sym_root, sym, s);
1680
1681   /* TODO: Also have to replace sym -> s in other lists like
1682      namelists, common lists and interface lists.  */
1683   gfc_free_symbol (sym);
1684
1685   return s;
1686
1687 bad:
1688   gfc_error ("Derived type '%s' at %C is being used before it is defined",
1689              sym->name);
1690   return NULL;
1691 }
1692
1693
1694 /* Given a derived type node and a component name, try to locate the
1695    component structure.  Returns the NULL pointer if the component is
1696    not found or the components are private.  */
1697
1698 gfc_component *
1699 gfc_find_component (gfc_symbol *sym, const char *name)
1700 {
1701   gfc_component *p;
1702
1703   if (name == NULL)
1704     return NULL;
1705
1706   sym = gfc_use_derived (sym);
1707
1708   if (sym == NULL)
1709     return NULL;
1710
1711   for (p = sym->components; p; p = p->next)
1712     if (strcmp (p->name, name) == 0)
1713       break;
1714
1715   if (p == NULL)
1716     gfc_error ("'%s' at %C is not a member of the '%s' structure",
1717                name, sym->name);
1718   else
1719     {
1720       if (sym->attr.use_assoc && (sym->component_access == ACCESS_PRIVATE
1721                                   || p->access == ACCESS_PRIVATE))
1722         {
1723           gfc_error ("Component '%s' at %C is a PRIVATE component of '%s'",
1724                      name, sym->name);
1725           p = NULL;
1726         }
1727     }
1728
1729   return p;
1730 }
1731
1732
1733 /* Given a symbol, free all of the component structures and everything
1734    they point to.  */
1735
1736 static void
1737 free_components (gfc_component *p)
1738 {
1739   gfc_component *q;
1740
1741   for (; p; p = q)
1742     {
1743       q = p->next;
1744
1745       gfc_free_array_spec (p->as);
1746       gfc_free_expr (p->initializer);
1747
1748       gfc_free (p);
1749     }
1750 }
1751
1752
1753 /* Set component attributes from a standard symbol attribute structure.  */
1754
1755 void
1756 gfc_set_component_attr (gfc_component *c, symbol_attribute *attr)
1757 {
1758
1759   c->dimension = attr->dimension;
1760   c->pointer = attr->pointer;
1761   c->allocatable = attr->allocatable;
1762   c->access = attr->access;
1763 }
1764
1765
1766 /* Get a standard symbol attribute structure given the component
1767    structure.  */
1768
1769 void
1770 gfc_get_component_attr (symbol_attribute *attr, gfc_component *c)
1771 {
1772
1773   gfc_clear_attr (attr);
1774   attr->dimension = c->dimension;
1775   attr->pointer = c->pointer;
1776   attr->allocatable = c->allocatable;
1777   attr->access = c->access;
1778 }
1779
1780
1781 /******************** Statement label management ********************/
1782
1783 /* Comparison function for statement labels, used for managing the
1784    binary tree.  */
1785
1786 static int
1787 compare_st_labels (void *a1, void *b1)
1788 {
1789   int a = ((gfc_st_label *) a1)->value;
1790   int b = ((gfc_st_label *) b1)->value;
1791
1792   return (b - a);
1793 }
1794
1795
1796 /* Free a single gfc_st_label structure, making sure the tree is not
1797    messed up.  This function is called only when some parse error
1798    occurs.  */
1799
1800 void
1801 gfc_free_st_label (gfc_st_label *label)
1802 {
1803
1804   if (label == NULL)
1805     return;
1806
1807   gfc_delete_bbt (&gfc_current_ns->st_labels, label, compare_st_labels);
1808
1809   if (label->format != NULL)
1810     gfc_free_expr (label->format);
1811
1812   gfc_free (label);
1813 }
1814
1815
1816 /* Free a whole tree of gfc_st_label structures.  */
1817
1818 static void
1819 free_st_labels (gfc_st_label *label)
1820 {
1821
1822   if (label == NULL)
1823     return;
1824
1825   free_st_labels (label->left);
1826   free_st_labels (label->right);
1827
1828   if (label->format != NULL)
1829     gfc_free_expr (label->format);
1830   gfc_free (label);
1831 }
1832
1833
1834 /* Given a label number, search for and return a pointer to the label
1835    structure, creating it if it does not exist.  */
1836
1837 gfc_st_label *
1838 gfc_get_st_label (int labelno)
1839 {
1840   gfc_st_label *lp;
1841
1842   /* First see if the label is already in this namespace.  */
1843   lp = gfc_current_ns->st_labels;
1844   while (lp)
1845     {
1846       if (lp->value == labelno)
1847         return lp;
1848
1849       if (lp->value < labelno)
1850         lp = lp->left;
1851       else
1852         lp = lp->right;
1853     }
1854
1855   lp = gfc_getmem (sizeof (gfc_st_label));
1856
1857   lp->value = labelno;
1858   lp->defined = ST_LABEL_UNKNOWN;
1859   lp->referenced = ST_LABEL_UNKNOWN;
1860
1861   gfc_insert_bbt (&gfc_current_ns->st_labels, lp, compare_st_labels);
1862
1863   return lp;
1864 }
1865
1866
1867 /* Called when a statement with a statement label is about to be
1868    accepted.  We add the label to the list of the current namespace,
1869    making sure it hasn't been defined previously and referenced
1870    correctly.  */
1871
1872 void
1873 gfc_define_st_label (gfc_st_label *lp, gfc_sl_type type, locus *label_locus)
1874 {
1875   int labelno;
1876
1877   labelno = lp->value;
1878
1879   if (lp->defined != ST_LABEL_UNKNOWN)
1880     gfc_error ("Duplicate statement label %d at %L and %L", labelno,
1881                &lp->where, label_locus);
1882   else
1883     {
1884       lp->where = *label_locus;
1885
1886       switch (type)
1887         {
1888         case ST_LABEL_FORMAT:
1889           if (lp->referenced == ST_LABEL_TARGET)
1890             gfc_error ("Label %d at %C already referenced as branch target",
1891                        labelno);
1892           else
1893             lp->defined = ST_LABEL_FORMAT;
1894
1895           break;
1896
1897         case ST_LABEL_TARGET:
1898           if (lp->referenced == ST_LABEL_FORMAT)
1899             gfc_error ("Label %d at %C already referenced as a format label",
1900                        labelno);
1901           else
1902             lp->defined = ST_LABEL_TARGET;
1903
1904           break;
1905
1906         default:
1907           lp->defined = ST_LABEL_BAD_TARGET;
1908           lp->referenced = ST_LABEL_BAD_TARGET;
1909         }
1910     }
1911 }
1912
1913
1914 /* Reference a label.  Given a label and its type, see if that
1915    reference is consistent with what is known about that label,
1916    updating the unknown state.  Returns FAILURE if something goes
1917    wrong.  */
1918
1919 try
1920 gfc_reference_st_label (gfc_st_label *lp, gfc_sl_type type)
1921 {
1922   gfc_sl_type label_type;
1923   int labelno;
1924   try rc;
1925
1926   if (lp == NULL)
1927     return SUCCESS;
1928
1929   labelno = lp->value;
1930
1931   if (lp->defined != ST_LABEL_UNKNOWN)
1932     label_type = lp->defined;
1933   else
1934     {
1935       label_type = lp->referenced;
1936       lp->where = gfc_current_locus;
1937     }
1938
1939   if (label_type == ST_LABEL_FORMAT && type == ST_LABEL_TARGET)
1940     {
1941       gfc_error ("Label %d at %C previously used as a FORMAT label", labelno);
1942       rc = FAILURE;
1943       goto done;
1944     }
1945
1946   if ((label_type == ST_LABEL_TARGET || label_type == ST_LABEL_BAD_TARGET)
1947       && type == ST_LABEL_FORMAT)
1948     {
1949       gfc_error ("Label %d at %C previously used as branch target", labelno);
1950       rc = FAILURE;
1951       goto done;
1952     }
1953
1954   lp->referenced = type;
1955   rc = SUCCESS;
1956
1957 done:
1958   return rc;
1959 }
1960
1961
1962 /************** Symbol table management subroutines ****************/
1963
1964 /* Basic details: Fortran 95 requires a potentially unlimited number
1965    of distinct namespaces when compiling a program unit.  This case
1966    occurs during a compilation of internal subprograms because all of
1967    the internal subprograms must be read before we can start
1968    generating code for the host.
1969
1970    Given the tricky nature of the Fortran grammar, we must be able to
1971    undo changes made to a symbol table if the current interpretation
1972    of a statement is found to be incorrect.  Whenever a symbol is
1973    looked up, we make a copy of it and link to it.  All of these
1974    symbols are kept in a singly linked list so that we can commit or
1975    undo the changes at a later time.
1976
1977    A symtree may point to a symbol node outside of its namespace.  In
1978    this case, that symbol has been used as a host associated variable
1979    at some previous time.  */
1980
1981 /* Allocate a new namespace structure.  Copies the implicit types from
1982    PARENT if PARENT_TYPES is set.  */
1983
1984 gfc_namespace *
1985 gfc_get_namespace (gfc_namespace *parent, int parent_types)
1986 {
1987   gfc_namespace *ns;
1988   gfc_typespec *ts;
1989   gfc_intrinsic_op in;
1990   int i;
1991
1992   ns = gfc_getmem (sizeof (gfc_namespace));
1993   ns->sym_root = NULL;
1994   ns->uop_root = NULL;
1995   ns->default_access = ACCESS_UNKNOWN;
1996   ns->parent = parent;
1997
1998   for (in = GFC_INTRINSIC_BEGIN; in != GFC_INTRINSIC_END; in++)
1999     ns->operator_access[in] = ACCESS_UNKNOWN;
2000
2001   /* Initialize default implicit types.  */
2002   for (i = 'a'; i <= 'z'; i++)
2003     {
2004       ns->set_flag[i - 'a'] = 0;
2005       ts = &ns->default_type[i - 'a'];
2006
2007       if (parent_types && ns->parent != NULL)
2008         {
2009           /* Copy parent settings.  */
2010           *ts = ns->parent->default_type[i - 'a'];
2011           continue;
2012         }
2013
2014       if (gfc_option.flag_implicit_none != 0)
2015         {
2016           gfc_clear_ts (ts);
2017           continue;
2018         }
2019
2020       if ('i' <= i && i <= 'n')
2021         {
2022           ts->type = BT_INTEGER;
2023           ts->kind = gfc_default_integer_kind;
2024         }
2025       else
2026         {
2027           ts->type = BT_REAL;
2028           ts->kind = gfc_default_real_kind;
2029         }
2030     }
2031
2032   ns->refs = 1;
2033
2034   return ns;
2035 }
2036
2037
2038 /* Comparison function for symtree nodes.  */
2039
2040 static int
2041 compare_symtree (void *_st1, void *_st2)
2042 {
2043   gfc_symtree *st1, *st2;
2044
2045   st1 = (gfc_symtree *) _st1;
2046   st2 = (gfc_symtree *) _st2;
2047
2048   return strcmp (st1->name, st2->name);
2049 }
2050
2051
2052 /* Allocate a new symtree node and associate it with the new symbol.  */
2053
2054 gfc_symtree *
2055 gfc_new_symtree (gfc_symtree **root, const char *name)
2056 {
2057   gfc_symtree *st;
2058
2059   st = gfc_getmem (sizeof (gfc_symtree));
2060   st->name = gfc_get_string (name);
2061
2062   gfc_insert_bbt (root, st, compare_symtree);
2063   return st;
2064 }
2065
2066
2067 /* Delete a symbol from the tree.  Does not free the symbol itself!  */
2068
2069 static void
2070 delete_symtree (gfc_symtree **root, const char *name)
2071 {
2072   gfc_symtree st, *st0;
2073
2074   st0 = gfc_find_symtree (*root, name);
2075
2076   st.name = gfc_get_string (name);
2077   gfc_delete_bbt (root, &st, compare_symtree);
2078
2079   gfc_free (st0);
2080 }
2081
2082
2083 /* Given a root symtree node and a name, try to find the symbol within
2084    the namespace.  Returns NULL if the symbol is not found.  */
2085
2086 gfc_symtree *
2087 gfc_find_symtree (gfc_symtree *st, const char *name)
2088 {
2089   int c;
2090
2091   while (st != NULL)
2092     {
2093       c = strcmp (name, st->name);
2094       if (c == 0)
2095         return st;
2096
2097       st = (c < 0) ? st->left : st->right;
2098     }
2099
2100   return NULL;
2101 }
2102
2103
2104 /* Given a name find a user operator node, creating it if it doesn't
2105    exist.  These are much simpler than symbols because they can't be
2106    ambiguous with one another.  */
2107
2108 gfc_user_op *
2109 gfc_get_uop (const char *name)
2110 {
2111   gfc_user_op *uop;
2112   gfc_symtree *st;
2113
2114   st = gfc_find_symtree (gfc_current_ns->uop_root, name);
2115   if (st != NULL)
2116     return st->n.uop;
2117
2118   st = gfc_new_symtree (&gfc_current_ns->uop_root, name);
2119
2120   uop = st->n.uop = gfc_getmem (sizeof (gfc_user_op));
2121   uop->name = gfc_get_string (name);
2122   uop->access = ACCESS_UNKNOWN;
2123   uop->ns = gfc_current_ns;
2124
2125   return uop;
2126 }
2127
2128
2129 /* Given a name find the user operator node.  Returns NULL if it does
2130    not exist.  */
2131
2132 gfc_user_op *
2133 gfc_find_uop (const char *name, gfc_namespace *ns)
2134 {
2135   gfc_symtree *st;
2136
2137   if (ns == NULL)
2138     ns = gfc_current_ns;
2139
2140   st = gfc_find_symtree (ns->uop_root, name);
2141   return (st == NULL) ? NULL : st->n.uop;
2142 }
2143
2144
2145 /* Remove a gfc_symbol structure and everything it points to.  */
2146
2147 void
2148 gfc_free_symbol (gfc_symbol *sym)
2149 {
2150
2151   if (sym == NULL)
2152     return;
2153
2154   gfc_free_array_spec (sym->as);
2155
2156   free_components (sym->components);
2157
2158   gfc_free_expr (sym->value);
2159
2160   gfc_free_namelist (sym->namelist);
2161
2162   gfc_free_namespace (sym->formal_ns);
2163
2164   if (!sym->attr.generic_copy)
2165     gfc_free_interface (sym->generic);
2166
2167   gfc_free_formal_arglist (sym->formal);
2168
2169   gfc_free (sym);
2170 }
2171
2172
2173 /* Allocate and initialize a new symbol node.  */
2174
2175 gfc_symbol *
2176 gfc_new_symbol (const char *name, gfc_namespace *ns)
2177 {
2178   gfc_symbol *p;
2179
2180   p = gfc_getmem (sizeof (gfc_symbol));
2181
2182   gfc_clear_ts (&p->ts);
2183   gfc_clear_attr (&p->attr);
2184   p->ns = ns;
2185
2186   p->declared_at = gfc_current_locus;
2187
2188   if (strlen (name) > GFC_MAX_SYMBOL_LEN)
2189     gfc_internal_error ("new_symbol(): Symbol name too long");
2190
2191   p->name = gfc_get_string (name);
2192
2193   /* Make sure flags for symbol being C bound are clear initially.  */
2194   p->attr.is_bind_c = 0;
2195   p->attr.is_iso_c = 0;
2196   /* Make sure the binding label field has a Nul char to start.  */
2197   p->binding_label[0] = '\0';
2198
2199   /* Clear the ptrs we may need.  */
2200   p->common_block = NULL;
2201
2202   return p;
2203 }
2204
2205
2206 /* Generate an error if a symbol is ambiguous.  */
2207
2208 static void
2209 ambiguous_symbol (const char *name, gfc_symtree *st)
2210 {
2211
2212   if (st->n.sym->module)
2213     gfc_error ("Name '%s' at %C is an ambiguous reference to '%s' "
2214                "from module '%s'", name, st->n.sym->name, st->n.sym->module);
2215   else
2216     gfc_error ("Name '%s' at %C is an ambiguous reference to '%s' "
2217                "from current program unit", name, st->n.sym->name);
2218 }
2219
2220
2221 /* Search for a symtree starting in the current namespace, resorting to
2222    any parent namespaces if requested by a nonzero parent_flag.
2223    Returns nonzero if the name is ambiguous.  */
2224
2225 int
2226 gfc_find_sym_tree (const char *name, gfc_namespace *ns, int parent_flag,
2227                    gfc_symtree **result)
2228 {
2229   gfc_symtree *st;
2230
2231   if (ns == NULL)
2232     ns = gfc_current_ns;
2233
2234   do
2235     {
2236       st = gfc_find_symtree (ns->sym_root, name);
2237       if (st != NULL)
2238         {
2239           *result = st;
2240           /* Ambiguous generic interfaces are permitted, as long
2241              as the specific interfaces are different.  */
2242           if (st->ambiguous && !st->n.sym->attr.generic)
2243             {
2244               ambiguous_symbol (name, st);
2245               return 1;
2246             }
2247
2248           return 0;
2249         }
2250
2251       if (!parent_flag)
2252         break;
2253
2254       ns = ns->parent;
2255     }
2256   while (ns != NULL);
2257
2258   *result = NULL;
2259   return 0;
2260 }
2261
2262
2263 /* Same, but returns the symbol instead.  */
2264
2265 int
2266 gfc_find_symbol (const char *name, gfc_namespace *ns, int parent_flag,
2267                  gfc_symbol **result)
2268 {
2269   gfc_symtree *st;
2270   int i;
2271
2272   i = gfc_find_sym_tree (name, ns, parent_flag, &st);
2273
2274   if (st == NULL)
2275     *result = NULL;
2276   else
2277     *result = st->n.sym;
2278
2279   return i;
2280 }
2281
2282
2283 /* Save symbol with the information necessary to back it out.  */
2284
2285 static void
2286 save_symbol_data (gfc_symbol *sym)
2287 {
2288
2289   if (sym->new || sym->old_symbol != NULL)
2290     return;
2291
2292   sym->old_symbol = gfc_getmem (sizeof (gfc_symbol));
2293   *(sym->old_symbol) = *sym;
2294
2295   sym->tlink = changed_syms;
2296   changed_syms = sym;
2297 }
2298
2299
2300 /* Given a name, find a symbol, or create it if it does not exist yet
2301    in the current namespace.  If the symbol is found we make sure that
2302    it's OK.
2303
2304    The integer return code indicates
2305      0   All OK
2306      1   The symbol name was ambiguous
2307      2   The name meant to be established was already host associated.
2308
2309    So if the return value is nonzero, then an error was issued.  */
2310
2311 int
2312 gfc_get_sym_tree (const char *name, gfc_namespace *ns, gfc_symtree **result)
2313 {
2314   gfc_symtree *st;
2315   gfc_symbol *p;
2316
2317   /* This doesn't usually happen during resolution.  */
2318   if (ns == NULL)
2319     ns = gfc_current_ns;
2320
2321   /* Try to find the symbol in ns.  */
2322   st = gfc_find_symtree (ns->sym_root, name);
2323
2324   if (st == NULL)
2325     {
2326       /* If not there, create a new symbol.  */
2327       p = gfc_new_symbol (name, ns);
2328
2329       /* Add to the list of tentative symbols.  */
2330       p->old_symbol = NULL;
2331       p->tlink = changed_syms;
2332       p->mark = 1;
2333       p->new = 1;
2334       changed_syms = p;
2335
2336       st = gfc_new_symtree (&ns->sym_root, name);
2337       st->n.sym = p;
2338       p->refs++;
2339
2340     }
2341   else
2342     {
2343       /* Make sure the existing symbol is OK.  Ambiguous
2344          generic interfaces are permitted, as long as the
2345          specific interfaces are different.  */
2346       if (st->ambiguous && !st->n.sym->attr.generic)
2347         {
2348           ambiguous_symbol (name, st);
2349           return 1;
2350         }
2351
2352       p = st->n.sym;
2353
2354       if (p->ns != ns && (!p->attr.function || ns->proc_name != p))
2355         {
2356           /* Symbol is from another namespace.  */
2357           gfc_error ("Symbol '%s' at %C has already been host associated",
2358                      name);
2359           return 2;
2360         }
2361
2362       p->mark = 1;
2363
2364       /* Copy in case this symbol is changed.  */
2365       save_symbol_data (p);
2366     }
2367
2368   *result = st;
2369   return 0;
2370 }
2371
2372
2373 int
2374 gfc_get_symbol (const char *name, gfc_namespace *ns, gfc_symbol **result)
2375 {
2376   gfc_symtree *st;
2377   int i;
2378
2379   i = gfc_get_sym_tree (name, ns, &st);
2380   if (i != 0)
2381     return i;
2382
2383   if (st)
2384     *result = st->n.sym;
2385   else
2386     *result = NULL;
2387   return i;
2388 }
2389
2390
2391 /* Subroutine that searches for a symbol, creating it if it doesn't
2392    exist, but tries to host-associate the symbol if possible.  */
2393
2394 int
2395 gfc_get_ha_sym_tree (const char *name, gfc_symtree **result)
2396 {
2397   gfc_symtree *st;
2398   int i;
2399
2400   i = gfc_find_sym_tree (name, gfc_current_ns, 0, &st);
2401   if (st != NULL)
2402     {
2403       save_symbol_data (st->n.sym);
2404       *result = st;
2405       return i;
2406     }
2407
2408   if (gfc_current_ns->parent != NULL)
2409     {
2410       i = gfc_find_sym_tree (name, gfc_current_ns->parent, 1, &st);
2411       if (i)
2412         return i;
2413
2414       if (st != NULL)
2415         {
2416           *result = st;
2417           return 0;
2418         }
2419     }
2420
2421   return gfc_get_sym_tree (name, gfc_current_ns, result);
2422 }
2423
2424
2425 int
2426 gfc_get_ha_symbol (const char *name, gfc_symbol **result)
2427 {
2428   int i;
2429   gfc_symtree *st;
2430
2431   i = gfc_get_ha_sym_tree (name, &st);
2432
2433   if (st)
2434     *result = st->n.sym;
2435   else
2436     *result = NULL;
2437
2438   return i;
2439 }
2440
2441 /* Return true if both symbols could refer to the same data object.  Does
2442    not take account of aliasing due to equivalence statements.  */
2443
2444 int
2445 gfc_symbols_could_alias (gfc_symbol *lsym, gfc_symbol *rsym)
2446 {
2447   /* Aliasing isn't possible if the symbols have different base types.  */
2448   if (gfc_compare_types (&lsym->ts, &rsym->ts) == 0)
2449     return 0;
2450
2451   /* Pointers can point to other pointers, target objects and allocatable
2452      objects.  Two allocatable objects cannot share the same storage.  */
2453   if (lsym->attr.pointer
2454       && (rsym->attr.pointer || rsym->attr.allocatable || rsym->attr.target))
2455     return 1;
2456   if (lsym->attr.target && rsym->attr.pointer)
2457     return 1;
2458   if (lsym->attr.allocatable && rsym->attr.pointer)
2459     return 1;
2460
2461   return 0;
2462 }
2463
2464
2465 /* Undoes all the changes made to symbols in the current statement.
2466    This subroutine is made simpler due to the fact that attributes are
2467    never removed once added.  */
2468
2469 void
2470 gfc_undo_symbols (void)
2471 {
2472   gfc_symbol *p, *q, *old;
2473
2474   for (p = changed_syms; p; p = q)
2475     {
2476       q = p->tlink;
2477
2478       if (p->new)
2479         {
2480           /* Symbol was new.  */
2481           delete_symtree (&p->ns->sym_root, p->name);
2482
2483           p->refs--;
2484           if (p->refs < 0)
2485             gfc_internal_error ("gfc_undo_symbols(): Negative refs");
2486           if (p->refs == 0)
2487             gfc_free_symbol (p);
2488           continue;
2489         }
2490
2491       /* Restore previous state of symbol.  Just copy simple stuff.  */
2492       p->mark = 0;
2493       old = p->old_symbol;
2494
2495       p->ts.type = old->ts.type;
2496       p->ts.kind = old->ts.kind;
2497
2498       p->attr = old->attr;
2499
2500       if (p->value != old->value)
2501         {
2502           gfc_free_expr (old->value);
2503           p->value = NULL;
2504         }
2505
2506       if (p->as != old->as)
2507         {
2508           if (p->as)
2509             gfc_free_array_spec (p->as);
2510           p->as = old->as;
2511         }
2512
2513       p->generic = old->generic;
2514       p->component_access = old->component_access;
2515
2516       if (p->namelist != NULL && old->namelist == NULL)
2517         {
2518           gfc_free_namelist (p->namelist);
2519           p->namelist = NULL;
2520         }
2521       else
2522         {
2523           if (p->namelist_tail != old->namelist_tail)
2524             {
2525               gfc_free_namelist (old->namelist_tail);
2526               old->namelist_tail->next = NULL;
2527             }
2528         }
2529
2530       p->namelist_tail = old->namelist_tail;
2531
2532       if (p->formal != old->formal)
2533         {
2534           gfc_free_formal_arglist (p->formal);
2535           p->formal = old->formal;
2536         }
2537
2538       gfc_free (p->old_symbol);
2539       p->old_symbol = NULL;
2540       p->tlink = NULL;
2541     }
2542
2543   changed_syms = NULL;
2544 }
2545
2546
2547 /* Free sym->old_symbol. sym->old_symbol is mostly a shallow copy of sym; the
2548    components of old_symbol that might need deallocation are the "allocatables"
2549    that are restored in gfc_undo_symbols(), with two exceptions: namelist and
2550    namelist_tail.  In case these differ between old_symbol and sym, it's just
2551    because sym->namelist has gotten a few more items.  */
2552
2553 static void
2554 free_old_symbol (gfc_symbol *sym)
2555 {
2556
2557   if (sym->old_symbol == NULL)
2558     return;
2559
2560   if (sym->old_symbol->as != sym->as)
2561     gfc_free_array_spec (sym->old_symbol->as);
2562
2563   if (sym->old_symbol->value != sym->value)
2564     gfc_free_expr (sym->old_symbol->value);
2565
2566   if (sym->old_symbol->formal != sym->formal)
2567     gfc_free_formal_arglist (sym->old_symbol->formal);
2568
2569   gfc_free (sym->old_symbol);
2570   sym->old_symbol = NULL;
2571 }
2572
2573
2574 /* Makes the changes made in the current statement permanent-- gets
2575    rid of undo information.  */
2576
2577 void
2578 gfc_commit_symbols (void)
2579 {
2580   gfc_symbol *p, *q;
2581
2582   for (p = changed_syms; p; p = q)
2583     {
2584       q = p->tlink;
2585       p->tlink = NULL;
2586       p->mark = 0;
2587       p->new = 0;
2588       free_old_symbol (p);
2589     }
2590   changed_syms = NULL;
2591 }
2592
2593
2594 /* Makes the changes made in one symbol permanent -- gets rid of undo
2595    information.  */
2596
2597 void
2598 gfc_commit_symbol (gfc_symbol *sym)
2599 {
2600   gfc_symbol *p;
2601
2602   if (changed_syms == sym)
2603     changed_syms = sym->tlink;
2604   else
2605     {
2606       for (p = changed_syms; p; p = p->tlink)
2607         if (p->tlink == sym)
2608           {
2609             p->tlink = sym->tlink;
2610             break;
2611           }
2612     }
2613
2614   sym->tlink = NULL;
2615   sym->mark = 0;
2616   sym->new = 0;
2617
2618   free_old_symbol (sym);
2619 }
2620
2621
2622 /* Recursive function that deletes an entire tree and all the common
2623    head structures it points to.  */
2624
2625 static void
2626 free_common_tree (gfc_symtree * common_tree)
2627 {
2628   if (common_tree == NULL)
2629     return;
2630
2631   free_common_tree (common_tree->left);
2632   free_common_tree (common_tree->right);
2633
2634   gfc_free (common_tree);
2635 }
2636
2637
2638 /* Recursive function that deletes an entire tree and all the user
2639    operator nodes that it contains.  */
2640
2641 static void
2642 free_uop_tree (gfc_symtree *uop_tree)
2643 {
2644
2645   if (uop_tree == NULL)
2646     return;
2647
2648   free_uop_tree (uop_tree->left);
2649   free_uop_tree (uop_tree->right);
2650
2651   gfc_free_interface (uop_tree->n.uop->operator);
2652
2653   gfc_free (uop_tree->n.uop);
2654   gfc_free (uop_tree);
2655 }
2656
2657
2658 /* Recursive function that deletes an entire tree and all the symbols
2659    that it contains.  */
2660
2661 static void
2662 free_sym_tree (gfc_symtree *sym_tree)
2663 {
2664   gfc_namespace *ns;
2665   gfc_symbol *sym;
2666
2667   if (sym_tree == NULL)
2668     return;
2669
2670   free_sym_tree (sym_tree->left);
2671   free_sym_tree (sym_tree->right);
2672
2673   sym = sym_tree->n.sym;
2674
2675   sym->refs--;
2676   if (sym->refs < 0)
2677     gfc_internal_error ("free_sym_tree(): Negative refs");
2678
2679   if (sym->formal_ns != NULL && sym->refs == 1)
2680     {
2681       /* As formal_ns contains a reference to sym, delete formal_ns just
2682          before the deletion of sym.  */
2683       ns = sym->formal_ns;
2684       sym->formal_ns = NULL;
2685       gfc_free_namespace (ns);
2686     }
2687   else if (sym->refs == 0)
2688     {
2689       /* Go ahead and delete the symbol.  */
2690       gfc_free_symbol (sym);
2691     }
2692
2693   gfc_free (sym_tree);
2694 }
2695
2696
2697 /* Free the derived type list.  */
2698
2699 static void
2700 gfc_free_dt_list (void)
2701 {
2702   gfc_dt_list *dt, *n;
2703
2704   for (dt = gfc_derived_types; dt; dt = n)
2705     {
2706       n = dt->next;
2707       gfc_free (dt);
2708     }
2709
2710   gfc_derived_types = NULL;
2711 }
2712
2713
2714 /* Free the gfc_equiv_info's.  */
2715
2716 static void
2717 gfc_free_equiv_infos (gfc_equiv_info *s)
2718 {
2719   if (s == NULL)
2720     return;
2721   gfc_free_equiv_infos (s->next);
2722   gfc_free (s);
2723 }
2724
2725
2726 /* Free the gfc_equiv_lists.  */
2727
2728 static void
2729 gfc_free_equiv_lists (gfc_equiv_list *l)
2730 {
2731   if (l == NULL)
2732     return;
2733   gfc_free_equiv_lists (l->next);
2734   gfc_free_equiv_infos (l->equiv);
2735   gfc_free (l);
2736 }
2737
2738
2739 /* Free a namespace structure and everything below it.  Interface
2740    lists associated with intrinsic operators are not freed.  These are
2741    taken care of when a specific name is freed.  */
2742
2743 void
2744 gfc_free_namespace (gfc_namespace *ns)
2745 {
2746   gfc_charlen *cl, *cl2;
2747   gfc_namespace *p, *q;
2748   gfc_intrinsic_op i;
2749
2750   if (ns == NULL)
2751     return;
2752
2753   ns->refs--;
2754   if (ns->refs > 0)
2755     return;
2756   gcc_assert (ns->refs == 0);
2757
2758   gfc_free_statements (ns->code);
2759
2760   free_sym_tree (ns->sym_root);
2761   free_uop_tree (ns->uop_root);
2762   free_common_tree (ns->common_root);
2763
2764   for (cl = ns->cl_list; cl; cl = cl2)
2765     {
2766       cl2 = cl->next;
2767       gfc_free_expr (cl->length);
2768       gfc_free (cl);
2769     }
2770
2771   free_st_labels (ns->st_labels);
2772
2773   gfc_free_equiv (ns->equiv);
2774   gfc_free_equiv_lists (ns->equiv_lists);
2775
2776   for (i = GFC_INTRINSIC_BEGIN; i != GFC_INTRINSIC_END; i++)
2777     gfc_free_interface (ns->operator[i]);
2778
2779   gfc_free_data (ns->data);
2780   p = ns->contained;
2781   gfc_free (ns);
2782
2783   /* Recursively free any contained namespaces.  */
2784   while (p != NULL)
2785     {
2786       q = p;
2787       p = p->sibling;
2788       gfc_free_namespace (q);
2789     }
2790 }
2791
2792
2793 void
2794 gfc_symbol_init_2 (void)
2795 {
2796
2797   gfc_current_ns = gfc_get_namespace (NULL, 0);
2798 }
2799
2800
2801 void
2802 gfc_symbol_done_2 (void)
2803 {
2804
2805   gfc_free_namespace (gfc_current_ns);
2806   gfc_current_ns = NULL;
2807   gfc_free_dt_list ();
2808 }
2809
2810
2811 /* Clear mark bits from symbol nodes associated with a symtree node.  */
2812
2813 static void
2814 clear_sym_mark (gfc_symtree *st)
2815 {
2816
2817   st->n.sym->mark = 0;
2818 }
2819
2820
2821 /* Recursively traverse the symtree nodes.  */
2822
2823 void
2824 gfc_traverse_symtree (gfc_symtree *st, void (*func) (gfc_symtree *))
2825 {
2826   if (st != NULL)
2827     {
2828       (*func) (st);
2829
2830       gfc_traverse_symtree (st->left, func);
2831       gfc_traverse_symtree (st->right, func);
2832     }
2833 }
2834
2835
2836 /* Recursive namespace traversal function.  */
2837
2838 static void
2839 traverse_ns (gfc_symtree *st, void (*func) (gfc_symbol *))
2840 {
2841
2842   if (st == NULL)
2843     return;
2844
2845   if (st->n.sym->mark == 0)
2846     (*func) (st->n.sym);
2847   st->n.sym->mark = 1;
2848
2849   traverse_ns (st->left, func);
2850   traverse_ns (st->right, func);
2851 }
2852
2853
2854 /* Call a given function for all symbols in the namespace.  We take
2855    care that each gfc_symbol node is called exactly once.  */
2856
2857 void
2858 gfc_traverse_ns (gfc_namespace *ns, void (*func) (gfc_symbol *))
2859 {
2860
2861   gfc_traverse_symtree (ns->sym_root, clear_sym_mark);
2862
2863   traverse_ns (ns->sym_root, func);
2864 }
2865
2866
2867 /* Return TRUE if the symbol is an automatic variable.  */
2868
2869 static bool
2870 gfc_is_var_automatic (gfc_symbol *sym)
2871 {
2872   /* Pointer and allocatable variables are never automatic.  */
2873   if (sym->attr.pointer || sym->attr.allocatable)
2874     return false;
2875   /* Check for arrays with non-constant size.  */
2876   if (sym->attr.dimension && sym->as
2877       && !gfc_is_compile_time_shape (sym->as))
2878     return true;
2879   /* Check for non-constant length character variables.  */
2880   if (sym->ts.type == BT_CHARACTER
2881       && sym->ts.cl
2882       && !gfc_is_constant_expr (sym->ts.cl->length))
2883     return true;
2884   return false;
2885 }
2886
2887 /* Given a symbol, mark it as SAVEd if it is allowed.  */
2888
2889 static void
2890 save_symbol (gfc_symbol *sym)
2891 {
2892
2893   if (sym->attr.use_assoc)
2894     return;
2895
2896   if (sym->attr.in_common
2897       || sym->attr.dummy
2898       || sym->attr.flavor != FL_VARIABLE)
2899     return;
2900   /* Automatic objects are not saved.  */
2901   if (gfc_is_var_automatic (sym))
2902     return;
2903   gfc_add_save (&sym->attr, sym->name, &sym->declared_at);
2904 }
2905
2906
2907 /* Mark those symbols which can be SAVEd as such.  */
2908
2909 void
2910 gfc_save_all (gfc_namespace *ns)
2911 {
2912
2913   gfc_traverse_ns (ns, save_symbol);
2914 }
2915
2916
2917 #ifdef GFC_DEBUG
2918 /* Make sure that no changes to symbols are pending.  */
2919
2920 void
2921 gfc_symbol_state(void) {
2922
2923   if (changed_syms != NULL)
2924     gfc_internal_error("Symbol changes still pending!");
2925 }
2926 #endif
2927
2928
2929 /************** Global symbol handling ************/
2930
2931
2932 /* Search a tree for the global symbol.  */
2933
2934 gfc_gsymbol *
2935 gfc_find_gsymbol (gfc_gsymbol *symbol, const char *name)
2936 {
2937   int c;
2938
2939   if (symbol == NULL)
2940     return NULL;
2941
2942   while (symbol)
2943     {
2944       c = strcmp (name, symbol->name);
2945       if (!c)
2946         return symbol;
2947
2948       symbol = (c < 0) ? symbol->left : symbol->right;
2949     }
2950
2951   return NULL;
2952 }
2953
2954
2955 /* Compare two global symbols. Used for managing the BB tree.  */
2956
2957 static int
2958 gsym_compare (void *_s1, void *_s2)
2959 {
2960   gfc_gsymbol *s1, *s2;
2961
2962   s1 = (gfc_gsymbol *) _s1;
2963   s2 = (gfc_gsymbol *) _s2;
2964   return strcmp (s1->name, s2->name);
2965 }
2966
2967
2968 /* Get a global symbol, creating it if it doesn't exist.  */
2969
2970 gfc_gsymbol *
2971 gfc_get_gsymbol (const char *name)
2972 {
2973   gfc_gsymbol *s;
2974
2975   s = gfc_find_gsymbol (gfc_gsym_root, name);
2976   if (s != NULL)
2977     return s;
2978
2979   s = gfc_getmem (sizeof (gfc_gsymbol));
2980   s->type = GSYM_UNKNOWN;
2981   s->name = gfc_get_string (name);
2982
2983   gfc_insert_bbt (&gfc_gsym_root, s, gsym_compare);
2984
2985   return s;
2986 }
2987
2988
2989 static gfc_symbol *
2990 get_iso_c_binding_dt (int sym_id)
2991 {
2992   gfc_dt_list *dt_list;
2993
2994   dt_list = gfc_derived_types;
2995
2996   /* Loop through the derived types in the name list, searching for
2997      the desired symbol from iso_c_binding.  Search the parent namespaces
2998      if necessary and requested to (parent_flag).  */
2999   while (dt_list != NULL)
3000     {
3001       if (dt_list->derived->from_intmod != INTMOD_NONE
3002           && dt_list->derived->intmod_sym_id == sym_id)
3003         return dt_list->derived;
3004
3005       dt_list = dt_list->next;
3006     }
3007
3008   return NULL;
3009 }
3010
3011
3012 /* Verifies that the given derived type symbol, derived_sym, is interoperable
3013    with C.  This is necessary for any derived type that is BIND(C) and for
3014    derived types that are parameters to functions that are BIND(C).  All
3015    fields of the derived type are required to be interoperable, and are tested
3016    for such.  If an error occurs, the errors are reported here, allowing for
3017    multiple errors to be handled for a single derived type.  */
3018
3019 try
3020 verify_bind_c_derived_type (gfc_symbol *derived_sym)
3021 {
3022   gfc_component *curr_comp = NULL;
3023   try is_c_interop = FAILURE;
3024   try retval = SUCCESS;
3025
3026   if (derived_sym == NULL)
3027     gfc_internal_error ("verify_bind_c_derived_type(): Given symbol is "
3028                         "unexpectedly NULL");
3029
3030   /* If we've already looked at this derived symbol, do not look at it again
3031      so we don't repeat warnings/errors.  */
3032   if (derived_sym->ts.is_c_interop)
3033     return SUCCESS;
3034
3035   /* The derived type must have the BIND attribute to be interoperable
3036      J3/04-007, Section 15.2.3.  */
3037   if (derived_sym->attr.is_bind_c != 1)
3038     {
3039       derived_sym->ts.is_c_interop = 0;
3040       gfc_error_now ("Derived type '%s' declared at %L must have the BIND "
3041                      "attribute to be C interoperable", derived_sym->name,
3042                      &(derived_sym->declared_at));
3043       retval = FAILURE;
3044     }
3045
3046   curr_comp = derived_sym->components;
3047
3048   /* TODO: is this really an error?  */
3049   if (curr_comp == NULL)
3050     {
3051       gfc_error ("Derived type '%s' at %L is empty",
3052                  derived_sym->name, &(derived_sym->declared_at));
3053       return FAILURE;
3054     }
3055
3056   /* Initialize the derived type as being C interoperable.
3057      If we find an error in the components, this will be set false.  */
3058   derived_sym->ts.is_c_interop = 1;
3059
3060   /* Loop through the list of components to verify that the kind of
3061      each is a C interoperable type.  */
3062   do
3063     {
3064       /* The components cannot be pointers (fortran sense).
3065          J3/04-007, Section 15.2.3, C1505.      */
3066       if (curr_comp->pointer != 0)
3067         {
3068           gfc_error ("Component '%s' at %L cannot have the "
3069                      "POINTER attribute because it is a member "
3070                      "of the BIND(C) derived type '%s' at %L",
3071                      curr_comp->name, &(curr_comp->loc),
3072                      derived_sym->name, &(derived_sym->declared_at));
3073           retval = FAILURE;
3074         }
3075
3076       /* The components cannot be allocatable.
3077          J3/04-007, Section 15.2.3, C1505.      */
3078       if (curr_comp->allocatable != 0)
3079         {
3080           gfc_error ("Component '%s' at %L cannot have the "
3081                      "ALLOCATABLE attribute because it is a member "
3082                      "of the BIND(C) derived type '%s' at %L",
3083                      curr_comp->name, &(curr_comp->loc),
3084                      derived_sym->name, &(derived_sym->declared_at));
3085           retval = FAILURE;
3086         }
3087
3088       /* BIND(C) derived types must have interoperable components.  */
3089       if (curr_comp->ts.type == BT_DERIVED
3090           && curr_comp->ts.derived->ts.is_iso_c != 1
3091           && curr_comp->ts.derived != derived_sym)
3092         {
3093           /* This should be allowed; the draft says a derived-type can not
3094              have type parameters if it is has the BIND attribute.  Type
3095              parameters seem to be for making parameterized derived types.
3096              There's no need to verify the type if it is c_ptr/c_funptr.  */
3097           retval = verify_bind_c_derived_type (curr_comp->ts.derived);
3098         }
3099       else
3100         {
3101           /* Grab the typespec for the given component and test the kind.  */
3102           is_c_interop = verify_c_interop (&(curr_comp->ts), curr_comp->name,
3103                                            &(curr_comp->loc));
3104
3105           if (is_c_interop != SUCCESS)
3106             {
3107               /* Report warning and continue since not fatal.  The
3108                  draft does specify a constraint that requires all fields
3109                  to interoperate, but if the user says real(4), etc., it
3110                  may interoperate with *something* in C, but the compiler
3111                  most likely won't know exactly what.  Further, it may not
3112                  interoperate with the same data type(s) in C if the user
3113                  recompiles with different flags (e.g., -m32 and -m64 on
3114                  x86_64 and using integer(4) to claim interop with a
3115                  C_LONG).  */
3116               if (derived_sym->attr.is_bind_c == 1)
3117                 /* If the derived type is bind(c), all fields must be
3118                    interop.  */
3119                 gfc_warning ("Component '%s' in derived type '%s' at %L "
3120                              "may not be C interoperable, even though "
3121                              "derived type '%s' is BIND(C)",
3122                              curr_comp->name, derived_sym->name,
3123                              &(curr_comp->loc), derived_sym->name);
3124               else
3125                 /* If derived type is param to bind(c) routine, or to one
3126                    of the iso_c_binding procs, it must be interoperable, so
3127                    all fields must interop too.  */
3128                 gfc_warning ("Component '%s' in derived type '%s' at %L "
3129                              "may not be C interoperable",
3130                              curr_comp->name, derived_sym->name,
3131                              &(curr_comp->loc));
3132             }
3133         }
3134
3135       curr_comp = curr_comp->next;
3136     } while (curr_comp != NULL);
3137
3138
3139   /* Make sure we don't have conflicts with the attributes.  */
3140   if (derived_sym->attr.access == ACCESS_PRIVATE)
3141     {
3142       gfc_error ("Derived type '%s' at %L cannot be declared with both "
3143                  "PRIVATE and BIND(C) attributes", derived_sym->name,
3144                  &(derived_sym->declared_at));
3145       retval = FAILURE;
3146     }
3147
3148   if (derived_sym->attr.sequence != 0)
3149     {
3150       gfc_error ("Derived type '%s' at %L cannot have the SEQUENCE "
3151                  "attribute because it is BIND(C)", derived_sym->name,
3152                  &(derived_sym->declared_at));
3153       retval = FAILURE;
3154     }
3155
3156   /* Mark the derived type as not being C interoperable if we found an
3157      error.  If there were only warnings, proceed with the assumption
3158      it's interoperable.  */
3159   if (retval == FAILURE)
3160     derived_sym->ts.is_c_interop = 0;
3161
3162   return retval;
3163 }
3164
3165
3166 /* Generate symbols for the named constants c_null_ptr and c_null_funptr.  */
3167
3168 static try
3169 gen_special_c_interop_ptr (int ptr_id, const char *ptr_name,
3170                            const char *module_name)
3171 {
3172   gfc_symtree *tmp_symtree;
3173   gfc_symbol *tmp_sym;
3174
3175   tmp_symtree = gfc_find_symtree (gfc_current_ns->sym_root, ptr_name);
3176
3177   if (tmp_symtree != NULL)
3178     tmp_sym = tmp_symtree->n.sym;
3179   else
3180     {
3181       tmp_sym = NULL;
3182       gfc_internal_error ("gen_special_c_interop_ptr(): Unable to "
3183                           "create symbol for %s", ptr_name);
3184     }
3185
3186   /* Set up the symbol's important fields.  Save attr required so we can
3187      initialize the ptr to NULL.  */
3188   tmp_sym->attr.save = SAVE_EXPLICIT;
3189   tmp_sym->ts.is_c_interop = 1;
3190   tmp_sym->attr.is_c_interop = 1;
3191   tmp_sym->ts.is_iso_c = 1;
3192   tmp_sym->ts.type = BT_DERIVED;
3193
3194   /* The c_ptr and c_funptr derived types will provide the
3195      definition for c_null_ptr and c_null_funptr, respectively.  */
3196   if (ptr_id == ISOCBINDING_NULL_PTR)
3197     tmp_sym->ts.derived = get_iso_c_binding_dt (ISOCBINDING_PTR);
3198   else
3199     tmp_sym->ts.derived = get_iso_c_binding_dt (ISOCBINDING_FUNPTR);
3200   if (tmp_sym->ts.derived == NULL)
3201     {
3202       /* This can occur if the user forgot to declare c_ptr or
3203          c_funptr and they're trying to use one of the procedures
3204          that has arg(s) of the missing type.  In this case, a
3205          regular version of the thing should have been put in the
3206          current ns.  */
3207       generate_isocbinding_symbol (module_name, ptr_id == ISOCBINDING_NULL_PTR
3208                                    ? ISOCBINDING_PTR : ISOCBINDING_FUNPTR,
3209                                    (char *) (ptr_id == ISOCBINDING_NULL_PTR
3210                                    ? "_gfortran_iso_c_binding_c_ptr"
3211                                    : "_gfortran_iso_c_binding_c_funptr"));
3212
3213       tmp_sym->ts.derived =
3214         get_iso_c_binding_dt (ptr_id == ISOCBINDING_NULL_PTR
3215                               ? ISOCBINDING_PTR : ISOCBINDING_FUNPTR);
3216     }
3217
3218   /* Module name is some mangled version of iso_c_binding.  */
3219   tmp_sym->module = gfc_get_string (module_name);
3220
3221   /* Say it's from the iso_c_binding module.  */
3222   tmp_sym->attr.is_iso_c = 1;
3223
3224   tmp_sym->attr.use_assoc = 1;
3225   tmp_sym->attr.is_bind_c = 1;
3226   /* Set the binding_label.  */
3227   sprintf (tmp_sym->binding_label, "%s_%s", module_name, tmp_sym->name);
3228
3229   /* Set the c_address field of c_null_ptr and c_null_funptr to
3230      the value of NULL.  */
3231   tmp_sym->value = gfc_get_expr ();
3232   tmp_sym->value->expr_type = EXPR_STRUCTURE;
3233   tmp_sym->value->ts.type = BT_DERIVED;
3234   tmp_sym->value->ts.derived = tmp_sym->ts.derived;
3235   tmp_sym->value->value.constructor = gfc_get_constructor ();
3236   /* This line will initialize the c_null_ptr/c_null_funptr
3237      c_address field to NULL.  */
3238   tmp_sym->value->value.constructor->expr = gfc_int_expr (0);
3239   /* Must declare c_null_ptr and c_null_funptr as having the
3240      PARAMETER attribute so they can be used in init expressions.  */
3241   tmp_sym->attr.flavor = FL_PARAMETER;
3242
3243   return SUCCESS;
3244 }
3245
3246
3247 /* Add a formal argument, gfc_formal_arglist, to the
3248    end of the given list of arguments.  Set the reference to the
3249    provided symbol, param_sym, in the argument.  */
3250
3251 static void
3252 add_formal_arg (gfc_formal_arglist **head,
3253                 gfc_formal_arglist **tail,
3254                 gfc_formal_arglist *formal_arg,
3255                 gfc_symbol *param_sym)
3256 {
3257   /* Put in list, either as first arg or at the tail (curr arg).  */
3258   if (*head == NULL)
3259     *head = *tail = formal_arg;
3260   else
3261     {
3262       (*tail)->next = formal_arg;
3263       (*tail) = formal_arg;
3264     }
3265
3266   (*tail)->sym = param_sym;
3267   (*tail)->next = NULL;
3268
3269   return;
3270 }
3271
3272
3273 /* Generates a symbol representing the CPTR argument to an
3274    iso_c_binding procedure.  Also, create a gfc_formal_arglist for the
3275    CPTR and add it to the provided argument list.  */
3276
3277 static void
3278 gen_cptr_param (gfc_formal_arglist **head,
3279                 gfc_formal_arglist **tail,
3280                 const char *module_name,
3281                 gfc_namespace *ns, const char *c_ptr_name,
3282                 int iso_c_sym_id)
3283 {
3284   gfc_symbol *param_sym = NULL;
3285   gfc_symbol *c_ptr_sym = NULL;
3286   gfc_symtree *param_symtree = NULL;
3287   gfc_formal_arglist *formal_arg = NULL;
3288   const char *c_ptr_in;
3289   const char *c_ptr_type = NULL;
3290
3291   if (iso_c_sym_id == ISOCBINDING_F_PROCPOINTER)
3292     c_ptr_type = "_gfortran_iso_c_binding_c_funptr";
3293   else
3294     c_ptr_type = "_gfortran_iso_c_binding_c_ptr";
3295
3296   if(c_ptr_name == NULL)
3297     c_ptr_in = "gfc_cptr__";
3298   else
3299     c_ptr_in = c_ptr_name;
3300   gfc_get_sym_tree (c_ptr_in, ns, &param_symtree);
3301   if (param_symtree != NULL)
3302     param_sym = param_symtree->n.sym;
3303   else
3304     gfc_internal_error ("gen_cptr_param(): Unable to "
3305                         "create symbol for %s", c_ptr_in);
3306
3307   /* Set up the appropriate fields for the new c_ptr param sym.  */
3308   param_sym->refs++;
3309   param_sym->attr.flavor = FL_DERIVED;
3310   param_sym->ts.type = BT_DERIVED;
3311   param_sym->attr.intent = INTENT_IN;
3312   param_sym->attr.dummy = 1;
3313
3314   /* This will pass the ptr to the iso_c routines as a (void *).  */
3315   param_sym->attr.value = 1;
3316   param_sym->attr.use_assoc = 1;
3317
3318   /* Get the symbol for c_ptr or c_funptr, no matter what it's name is
3319      (user renamed).  */
3320   if (iso_c_sym_id == ISOCBINDING_F_PROCPOINTER)
3321     c_ptr_sym = get_iso_c_binding_dt (ISOCBINDING_FUNPTR);
3322   else
3323     c_ptr_sym = get_iso_c_binding_dt (ISOCBINDING_PTR);
3324   if (c_ptr_sym == NULL)
3325     {
3326       /* This can happen if the user did not define c_ptr but they are
3327          trying to use one of the iso_c_binding functions that need it.  */
3328       if (iso_c_sym_id == ISOCBINDING_F_PROCPOINTER)
3329         generate_isocbinding_symbol (module_name, ISOCBINDING_FUNPTR,
3330                                      (char *)c_ptr_type);
3331       else
3332         generate_isocbinding_symbol (module_name, ISOCBINDING_PTR,
3333                                      (char *)c_ptr_type);
3334
3335       gfc_get_ha_symbol (c_ptr_type, &(c_ptr_sym));
3336     }
3337
3338   param_sym->ts.derived = c_ptr_sym;
3339   param_sym->module = gfc_get_string (module_name);
3340
3341   /* Make new formal arg.  */
3342   formal_arg = gfc_get_formal_arglist ();
3343   /* Add arg to list of formal args (the CPTR arg).  */
3344   add_formal_arg (head, tail, formal_arg, param_sym);
3345 }
3346
3347
3348 /* Generates a symbol representing the FPTR argument to an
3349    iso_c_binding procedure.  Also, create a gfc_formal_arglist for the
3350    FPTR and add it to the provided argument list.  */
3351
3352 static void
3353 gen_fptr_param (gfc_formal_arglist **head,
3354                 gfc_formal_arglist **tail,
3355                 const char *module_name,
3356                 gfc_namespace *ns, const char *f_ptr_name)
3357 {
3358   gfc_symbol *param_sym = NULL;
3359   gfc_symtree *param_symtree = NULL;
3360   gfc_formal_arglist *formal_arg = NULL;
3361   const char *f_ptr_out = "gfc_fptr__";
3362
3363   if (f_ptr_name != NULL)
3364     f_ptr_out = f_ptr_name;
3365
3366   gfc_get_sym_tree (f_ptr_out, ns, &param_symtree);
3367   if (param_symtree != NULL)
3368     param_sym = param_symtree->n.sym;
3369   else
3370     gfc_internal_error ("generateFPtrParam(): Unable to "
3371                         "create symbol for %s", f_ptr_out);
3372
3373   /* Set up the necessary fields for the fptr output param sym.  */
3374   param_sym->refs++;
3375   param_sym->attr.pointer = 1;
3376   param_sym->attr.dummy = 1;
3377   param_sym->attr.use_assoc = 1;
3378
3379   /* ISO C Binding type to allow any pointer type as actual param.  */
3380   param_sym->ts.type = BT_VOID;
3381   param_sym->module = gfc_get_string (module_name);
3382
3383   /* Make the arg.  */
3384   formal_arg = gfc_get_formal_arglist ();
3385   /* Add arg to list of formal args.  */
3386   add_formal_arg (head, tail, formal_arg, param_sym);
3387 }
3388
3389
3390 /* Generates a symbol representing the optional SHAPE argument for the
3391    iso_c_binding c_f_pointer() procedure.  Also, create a
3392    gfc_formal_arglist for the SHAPE and add it to the provided
3393    argument list.  */
3394
3395 static void
3396 gen_shape_param (gfc_formal_arglist **head,
3397                  gfc_formal_arglist **tail,
3398                  const char *module_name,
3399                  gfc_namespace *ns, const char *shape_param_name)
3400 {
3401   gfc_symbol *param_sym = NULL;
3402   gfc_symtree *param_symtree = NULL;
3403   gfc_formal_arglist *formal_arg = NULL;
3404   const char *shape_param = "gfc_shape_array__";
3405   int i;
3406
3407   if (shape_param_name != NULL)
3408     shape_param = shape_param_name;
3409
3410   gfc_get_sym_tree (shape_param, ns, &param_symtree);
3411   if (param_symtree != NULL)
3412     param_sym = param_symtree->n.sym;
3413   else
3414     gfc_internal_error ("generateShapeParam(): Unable to "
3415                         "create symbol for %s", shape_param);
3416
3417   /* Set up the necessary fields for the shape input param sym.  */
3418   param_sym->refs++;
3419   param_sym->attr.dummy = 1;
3420   param_sym->attr.use_assoc = 1;
3421
3422   /* Integer array, rank 1, describing the shape of the object.  */
3423   param_sym->ts.type = BT_INTEGER;
3424   /* Initialize the kind to default integer.  However, it will be overriden
3425      during resolution to match the kind of the SHAPE parameter given as
3426      the actual argument (to allow for any valid integer kind).  */
3427   param_sym->ts.kind = gfc_default_integer_kind;
3428   param_sym->as = gfc_get_array_spec ();
3429
3430   /* Clear out the dimension info for the array.  */
3431   for (i = 0; i < GFC_MAX_DIMENSIONS; i++)
3432     {
3433       param_sym->as->lower[i] = NULL;
3434       param_sym->as->upper[i] = NULL;
3435     }
3436   param_sym->as->rank = 1;
3437   param_sym->as->lower[0] = gfc_int_expr (1);
3438
3439   /* The extent is unknown until we get it.  The length give us
3440      the rank the incoming pointer.  */
3441   param_sym->as->type = AS_ASSUMED_SHAPE;
3442
3443   /* The arg is also optional; it is required iff the second arg
3444      (fptr) is to an array, otherwise, it's ignored.  */
3445   param_sym->attr.optional = 1;
3446   param_sym->attr.intent = INTENT_IN;
3447   param_sym->attr.dimension = 1;
3448   param_sym->module = gfc_get_string (module_name);
3449
3450   /* Make the arg.  */
3451   formal_arg = gfc_get_formal_arglist ();
3452   /* Add arg to list of formal args.  */
3453   add_formal_arg (head, tail, formal_arg, param_sym);
3454 }
3455
3456 /* Add a procedure interface to the given symbol (i.e., store a
3457    reference to the list of formal arguments).  */
3458
3459 static void
3460 add_proc_interface (gfc_symbol *sym, ifsrc source,
3461                     gfc_formal_arglist *formal)
3462 {
3463
3464   sym->formal = formal;
3465   sym->attr.if_source = source;
3466 }
3467
3468
3469 /* Builds the parameter list for the iso_c_binding procedure
3470    c_f_pointer or c_f_procpointer.  The old_sym typically refers to a
3471    generic version of either the c_f_pointer or c_f_procpointer
3472    functions.  The new_proc_sym represents a "resolved" version of the
3473    symbol.  The functions are resolved to match the types of their
3474    parameters; for example, c_f_pointer(cptr, fptr) would resolve to
3475    something similar to c_f_pointer_i4 if the type of data object fptr
3476    pointed to was a default integer.  The actual name of the resolved
3477    procedure symbol is further mangled with the module name, etc., but
3478    the idea holds true.  */
3479
3480 static void
3481 build_formal_args (gfc_symbol *new_proc_sym,
3482                    gfc_symbol *old_sym, int add_optional_arg)
3483 {
3484   gfc_formal_arglist *head = NULL, *tail = NULL;
3485   gfc_namespace *parent_ns = NULL;
3486
3487   parent_ns = gfc_current_ns;
3488   /* Create a new namespace, which will be the formal ns (namespace
3489      of the formal args).  */
3490   gfc_current_ns = gfc_get_namespace(parent_ns, 0);
3491   gfc_current_ns->proc_name = new_proc_sym;
3492
3493   /* Generate the params.  */
3494   if ((old_sym->intmod_sym_id == ISOCBINDING_F_POINTER) ||
3495       (old_sym->intmod_sym_id == ISOCBINDING_F_PROCPOINTER))
3496     {
3497       gen_cptr_param (&head, &tail, (const char *) new_proc_sym->module,
3498                       gfc_current_ns, "cptr", old_sym->intmod_sym_id);
3499       gen_fptr_param (&head, &tail, (const char *) new_proc_sym->module,
3500                       gfc_current_ns, "fptr");
3501
3502       /* If we're dealing with c_f_pointer, it has an optional third arg.  */
3503       if (old_sym->intmod_sym_id == ISOCBINDING_F_POINTER)
3504         {
3505           gen_shape_param (&head, &tail,
3506                            (const char *) new_proc_sym->module,
3507                            gfc_current_ns, "shape");
3508         }
3509     }
3510   else if (old_sym->intmod_sym_id == ISOCBINDING_ASSOCIATED)
3511     {
3512       /* c_associated has one required arg and one optional; both
3513          are c_ptrs.  */
3514       gen_cptr_param (&head, &tail, (const char *) new_proc_sym->module,
3515                       gfc_current_ns, "c_ptr_1", ISOCBINDING_ASSOCIATED);
3516       if (add_optional_arg)
3517         {
3518           gen_cptr_param (&head, &tail, (const char *) new_proc_sym->module,
3519                           gfc_current_ns, "c_ptr_2", ISOCBINDING_ASSOCIATED);
3520           /* The last param is optional so mark it as such.  */
3521           tail->sym->attr.optional = 1;
3522         }
3523     }
3524
3525   /* Add the interface (store formal args to new_proc_sym).  */
3526   add_proc_interface (new_proc_sym, IFSRC_DECL, head);
3527
3528   /* Set up the formal_ns pointer to the one created for the
3529      new procedure so it'll get cleaned up during gfc_free_symbol().  */
3530   new_proc_sym->formal_ns = gfc_current_ns;
3531
3532   gfc_current_ns = parent_ns;
3533 }
3534
3535
3536 /* Generate the given set of C interoperable kind objects, or all
3537    interoperable kinds.  This function will only be given kind objects
3538    for valid iso_c_binding defined types because this is verified when
3539    the 'use' statement is parsed.  If the user gives an 'only' clause,
3540    the specific kinds are looked up; if they don't exist, an error is
3541    reported.  If the user does not give an 'only' clause, all
3542    iso_c_binding symbols are generated.  If a list of specific kinds
3543    is given, it must have a NULL in the first empty spot to mark the
3544    end of the list.  */
3545
3546
3547 void
3548 generate_isocbinding_symbol (const char *mod_name, iso_c_binding_symbol s,
3549                              char *local_name)
3550 {
3551   char *name = (local_name && local_name[0]) ? local_name
3552                                              : c_interop_kinds_table[s].name;
3553   gfc_symtree *tmp_symtree = NULL;
3554   gfc_symbol *tmp_sym = NULL;
3555   gfc_dt_list **dt_list_ptr = NULL;
3556   gfc_component *tmp_comp = NULL;
3557   char comp_name[(GFC_MAX_SYMBOL_LEN * 2) + 1];
3558   int index;
3559
3560   tmp_symtree = gfc_find_symtree (gfc_current_ns->sym_root, name);
3561
3562   /* Already exists in this scope so don't re-add it.
3563      TODO: we should probably check that it's really the same symbol.  */
3564   if (tmp_symtree != NULL)
3565     return;
3566
3567   /* Create the sym tree in the current ns.  */
3568   gfc_get_sym_tree (name, gfc_current_ns, &tmp_symtree);
3569   if (tmp_symtree)
3570     tmp_sym = tmp_symtree->n.sym;
3571   else
3572     gfc_internal_error ("generate_isocbinding_symbol(): Unable to "
3573                         "create symbol");
3574
3575   /* Say what module this symbol belongs to.  */
3576   tmp_sym->module = gfc_get_string (mod_name);
3577   tmp_sym->from_intmod = INTMOD_ISO_C_BINDING;
3578   tmp_sym->intmod_sym_id = s;
3579
3580   switch (s)
3581     {
3582
3583 #define NAMED_INTCST(a,b,c) case a :
3584 #define NAMED_REALCST(a,b,c) case a :
3585 #define NAMED_CMPXCST(a,b,c) case a :
3586 #define NAMED_LOGCST(a,b,c) case a :
3587 #define NAMED_CHARKNDCST(a,b,c) case a :
3588 #include "iso-c-binding.def"
3589
3590         tmp_sym->value = gfc_int_expr (c_interop_kinds_table[s].value);
3591
3592         /* Initialize an integer constant expression node.  */
3593         tmp_sym->attr.flavor = FL_PARAMETER;
3594         tmp_sym->ts.type = BT_INTEGER;
3595         tmp_sym->ts.kind = gfc_default_integer_kind;
3596
3597         /* Mark this type as a C interoperable one.  */
3598         tmp_sym->ts.is_c_interop = 1;
3599         tmp_sym->ts.is_iso_c = 1;
3600         tmp_sym->value->ts.is_c_interop = 1;
3601         tmp_sym->value->ts.is_iso_c = 1;
3602         tmp_sym->attr.is_c_interop = 1;
3603
3604         /* Tell what f90 type this c interop kind is valid.  */
3605         tmp_sym->ts.f90_type = c_interop_kinds_table[s].f90_type;
3606
3607         /* Say it's from the iso_c_binding module.  */
3608         tmp_sym->attr.is_iso_c = 1;
3609
3610         /* Make it use associated.  */
3611         tmp_sym->attr.use_assoc = 1;
3612         break;
3613
3614
3615 #define NAMED_CHARCST(a,b,c) case a :
3616 #include "iso-c-binding.def"
3617
3618         /* Initialize an integer constant expression node for the
3619            length of the character.  */
3620         tmp_sym->value = gfc_get_expr ();
3621         tmp_sym->value->expr_type = EXPR_CONSTANT;
3622         tmp_sym->value->ts.type = BT_CHARACTER;
3623         tmp_sym->value->ts.kind = gfc_default_character_kind;
3624         tmp_sym->value->where = gfc_current_locus;
3625         tmp_sym->value->ts.is_c_interop = 1;
3626         tmp_sym->value->ts.is_iso_c = 1;
3627         tmp_sym->value->value.character.length = 1;
3628         tmp_sym->value->value.character.string = gfc_getmem (2);
3629         tmp_sym->value->value.character.string[0]
3630           = (char) c_interop_kinds_table[s].value;
3631         tmp_sym->value->value.character.string[1] = '\0';
3632
3633         /* May not need this in both attr and ts, but do need in
3634            attr for writing module file.  */
3635         tmp_sym->attr.is_c_interop = 1;
3636
3637         tmp_sym->attr.flavor = FL_PARAMETER;
3638         tmp_sym->ts.type = BT_CHARACTER;
3639
3640         /* Need to set it to the C_CHAR kind.  */
3641         tmp_sym->ts.kind = gfc_default_character_kind;
3642
3643         /* Mark this type as a C interoperable one.  */
3644         tmp_sym->ts.is_c_interop = 1;
3645         tmp_sym->ts.is_iso_c = 1;
3646
3647         /* Tell what f90 type this c interop kind is valid.  */
3648         tmp_sym->ts.f90_type = BT_CHARACTER;
3649
3650         /* Say it's from the iso_c_binding module.  */
3651         tmp_sym->attr.is_iso_c = 1;
3652
3653         /* Make it use associated.  */
3654         tmp_sym->attr.use_assoc = 1;
3655         break;
3656
3657       case ISOCBINDING_PTR:
3658       case ISOCBINDING_FUNPTR:
3659
3660         /* Initialize an integer constant expression node.  */
3661         tmp_sym->attr.flavor = FL_DERIVED;
3662         tmp_sym->ts.is_c_interop = 1;
3663         tmp_sym->attr.is_c_interop = 1;
3664         tmp_sym->attr.is_iso_c = 1;
3665         tmp_sym->ts.is_iso_c = 1;
3666         tmp_sym->ts.type = BT_DERIVED;
3667
3668         /* A derived type must have the bind attribute to be
3669            interoperable (J3/04-007, Section 15.2.3), even though
3670            the binding label is not used.  */
3671         tmp_sym->attr.is_bind_c = 1;
3672
3673         tmp_sym->attr.referenced = 1;
3674
3675         tmp_sym->ts.derived = tmp_sym;
3676
3677         /* Add the symbol created for the derived type to the current ns.  */
3678         dt_list_ptr = &(gfc_derived_types);
3679         while (*dt_list_ptr != NULL && (*dt_list_ptr)->next != NULL)
3680           dt_list_ptr = &((*dt_list_ptr)->next);
3681
3682         /* There is already at least one derived type in the list, so append
3683            the one we're currently building for c_ptr or c_funptr.  */
3684         if (*dt_list_ptr != NULL)
3685           dt_list_ptr = &((*dt_list_ptr)->next);
3686         (*dt_list_ptr) = gfc_get_dt_list ();
3687         (*dt_list_ptr)->derived = tmp_sym;
3688         (*dt_list_ptr)->next = NULL;
3689
3690         /* Set up the component of the derived type, which will be
3691            an integer with kind equal to c_ptr_size.  Mangle the name of
3692            the field for the c_address to prevent the curious user from
3693            trying to access it from Fortran.  */
3694         sprintf (comp_name, "__%s_%s", tmp_sym->name, "c_address");
3695         gfc_add_component (tmp_sym, comp_name, &tmp_comp);
3696         if (tmp_comp == NULL)
3697           gfc_internal_error ("generate_isocbinding_symbol(): Unable to "
3698                               "create component for c_address");
3699
3700         tmp_comp->ts.type = BT_INTEGER;
3701
3702         /* Set this because the module will need to read/write this field.  */
3703         tmp_comp->ts.f90_type = BT_INTEGER;
3704
3705         /* The kinds for c_ptr and c_funptr are the same.  */
3706         index = get_c_kind ("c_ptr", c_interop_kinds_table);
3707         tmp_comp->ts.kind = c_interop_kinds_table[index].value;
3708
3709         tmp_comp->pointer = 0;
3710         tmp_comp->dimension = 0;
3711
3712         /* Mark the component as C interoperable.  */
3713         tmp_comp->ts.is_c_interop = 1;
3714
3715         /* Make it use associated (iso_c_binding module).  */
3716         tmp_sym->attr.use_assoc = 1;
3717         break;
3718
3719       case ISOCBINDING_NULL_PTR:
3720       case ISOCBINDING_NULL_FUNPTR:
3721         gen_special_c_interop_ptr (s, name, mod_name);
3722         break;
3723
3724       case ISOCBINDING_F_POINTER:
3725       case ISOCBINDING_ASSOCIATED:
3726       case ISOCBINDING_LOC:
3727       case ISOCBINDING_FUNLOC:
3728       case ISOCBINDING_F_PROCPOINTER:
3729
3730         tmp_sym->attr.proc = PROC_MODULE;
3731
3732         /* Use the procedure's name as it is in the iso_c_binding module for
3733            setting the binding label in case the user renamed the symbol.  */
3734         sprintf (tmp_sym->binding_label, "%s_%s", mod_name,
3735                  c_interop_kinds_table[s].name);
3736         tmp_sym->attr.is_iso_c = 1;
3737         if (s == ISOCBINDING_F_POINTER || s == ISOCBINDING_F_PROCPOINTER)
3738           tmp_sym->attr.subroutine = 1;
3739         else
3740           {
3741             /* TODO!  This needs to be finished more for the expr of the
3742                function or something!
3743                This may not need to be here, because trying to do c_loc
3744                as an external.  */
3745             if (s == ISOCBINDING_ASSOCIATED)
3746               {
3747                 tmp_sym->attr.function = 1;
3748                 tmp_sym->ts.type = BT_LOGICAL;
3749                 tmp_sym->ts.kind = gfc_default_logical_kind;
3750                 tmp_sym->result = tmp_sym;
3751               }
3752             else
3753               {
3754                /* Here, we're taking the simple approach.  We're defining
3755                   c_loc as an external identifier so the compiler will put
3756                   what we expect on the stack for the address we want the
3757                   C address of.  */
3758                 tmp_sym->ts.type = BT_DERIVED;
3759                 if (s == ISOCBINDING_LOC)
3760                   tmp_sym->ts.derived =
3761                     get_iso_c_binding_dt (ISOCBINDING_PTR);
3762                 else
3763                   tmp_sym->ts.derived =
3764                     get_iso_c_binding_dt (ISOCBINDING_FUNPTR);
3765
3766                 if (tmp_sym->ts.derived == NULL)
3767                   {
3768                     /* Create the necessary derived type so we can continue
3769                        processing the file.  */
3770                     generate_isocbinding_symbol
3771                       (mod_name, s == ISOCBINDING_FUNLOC
3772                                  ? ISOCBINDING_FUNPTR : ISOCBINDING_PTR,
3773                        (char *)(s == ISOCBINDING_FUNLOC
3774                                 ? "_gfortran_iso_c_binding_c_funptr"
3775                                 : "_gfortran_iso_c_binding_c_ptr"));
3776                     tmp_sym->ts.derived =
3777                       get_iso_c_binding_dt (s == ISOCBINDING_FUNLOC
3778                                             ? ISOCBINDING_FUNPTR
3779                                             : ISOCBINDING_PTR);
3780                   }
3781
3782                 /* The function result is itself (no result clause).  */
3783                 tmp_sym->result = tmp_sym;
3784                 tmp_sym->attr.external = 1;
3785                 tmp_sym->attr.use_assoc = 0;
3786                 tmp_sym->attr.if_source = IFSRC_UNKNOWN;
3787                 tmp_sym->attr.proc = PROC_UNKNOWN;
3788               }
3789           }
3790
3791         tmp_sym->attr.flavor = FL_PROCEDURE;
3792         tmp_sym->attr.contained = 0;
3793
3794        /* Try using this builder routine, with the new and old symbols
3795           both being the generic iso_c proc sym being created.  This
3796           will create the formal args (and the new namespace for them).
3797           Don't build an arg list for c_loc because we're going to treat
3798           c_loc as an external procedure.  */
3799         if (s != ISOCBINDING_LOC && s != ISOCBINDING_FUNLOC)
3800           /* The 1 says to add any optional args, if applicable.  */
3801           build_formal_args (tmp_sym, tmp_sym, 1);
3802
3803         /* Set this after setting up the symbol, to prevent error messages.  */
3804         tmp_sym->attr.use_assoc = 1;
3805
3806         /* This symbol will not be referenced directly.  It will be
3807            resolved to the implementation for the given f90 kind.  */
3808         tmp_sym->attr.referenced = 0;
3809
3810         break;
3811
3812       default:
3813         gcc_unreachable ();
3814     }
3815 }
3816
3817
3818 /* Creates a new symbol based off of an old iso_c symbol, with a new
3819    binding label.  This function can be used to create a new,
3820    resolved, version of a procedure symbol for c_f_pointer or
3821    c_f_procpointer that is based on the generic symbols.  A new
3822    parameter list is created for the new symbol using
3823    build_formal_args().  The add_optional_flag specifies whether the
3824    to add the optional SHAPE argument.  The new symbol is
3825    returned.  */
3826
3827 gfc_symbol *
3828 get_iso_c_sym (gfc_symbol *old_sym, char *new_name,
3829                char *new_binding_label, int add_optional_arg)
3830 {
3831   gfc_symtree *new_symtree = NULL;
3832
3833   /* See if we have a symbol by that name already available, looking
3834      through any parent namespaces.  */
3835   gfc_find_sym_tree (new_name, gfc_current_ns, 1, &new_symtree);
3836   if (new_symtree != NULL)
3837     /* Return the existing symbol.  */
3838     return new_symtree->n.sym;
3839
3840   /* Create the symtree/symbol, with attempted host association.  */
3841   gfc_get_ha_sym_tree (new_name, &new_symtree);
3842   if (new_symtree == NULL)
3843     gfc_internal_error ("get_iso_c_sym(): Unable to create "
3844                         "symtree for '%s'", new_name);
3845
3846   /* Now fill in the fields of the resolved symbol with the old sym.  */
3847   strcpy (new_symtree->n.sym->binding_label, new_binding_label);
3848   new_symtree->n.sym->attr = old_sym->attr;
3849   new_symtree->n.sym->ts = old_sym->ts;
3850   new_symtree->n.sym->module = gfc_get_string (old_sym->module);
3851   /* Build the formal arg list.  */
3852   build_formal_args (new_symtree->n.sym, old_sym, add_optional_arg);
3853
3854   gfc_commit_symbol (new_symtree->n.sym);
3855
3856   return new_symtree->n.sym;
3857 }
3858