gcc/fortran/symbol.c

   1 /* Maintain binary trees of symbols.
   2    Copyright (C) 2000-2013 Free Software Foundation, Inc.
   3    Contributed by Andy Vaught
   4
   5 This file is part of GCC.
   6
   7 GCC is free software; you can redistribute it and/or modify it under
   8 the terms of the GNU General Public License as published by the Free
   9 Software Foundation; either version 3, or (at your option) any later
  10 version.
  11
  12 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
  13 WARRANTY; without even the implied warranty of MERCHANTABILITY or
  14 FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
  15 for more details.
  16
  17 You should have received a copy of the GNU General Public License
  18 along with GCC; see the file COPYING3.  If not see
  19 <http://www.gnu.org/licenses/>.  */
  20
  21
  22 #include "config.h"
  23 #include "system.h"
  24 #include "coretypes.h"
  25 #include "flags.h"
  26 #include "gfortran.h"
  27 #include "parse.h"
  28 #include "match.h"
  29 #include "constructor.h"
  30
  31
  32 /* Strings for all symbol attributes.  We use these for dumping the
  33    parse tree, in error messages, and also when reading and writing
  34    modules.  */
  35
  36 const mstring flavors[] =
  37 {
  38   minit ("UNKNOWN-FL", FL_UNKNOWN), minit ("PROGRAM", FL_PROGRAM),
  39   minit ("BLOCK-DATA", FL_BLOCK_DATA), minit ("MODULE", FL_MODULE),
  40   minit ("VARIABLE", FL_VARIABLE), minit ("PARAMETER", FL_PARAMETER),
  41   minit ("LABEL", FL_LABEL), minit ("PROCEDURE", FL_PROCEDURE),
  42   minit ("DERIVED", FL_DERIVED), minit ("NAMELIST", FL_NAMELIST),
  43   minit (NULL, -1)
  44 };
  45
  46 const mstring procedures[] =
  47 {
  48     minit ("UNKNOWN-PROC", PROC_UNKNOWN),
  49     minit ("MODULE-PROC", PROC_MODULE),
  50     minit ("INTERNAL-PROC", PROC_INTERNAL),
  51     minit ("DUMMY-PROC", PROC_DUMMY),
  52     minit ("INTRINSIC-PROC", PROC_INTRINSIC),
  53     minit ("EXTERNAL-PROC", PROC_EXTERNAL),
  54     minit ("STATEMENT-PROC", PROC_ST_FUNCTION),
  55     minit (NULL, -1)
  56 };
  57
  58 const mstring intents[] =
  59 {
  60     minit ("UNKNOWN-INTENT", INTENT_UNKNOWN),
  61     minit ("IN", INTENT_IN),
  62     minit ("OUT", INTENT_OUT),
  63     minit ("INOUT", INTENT_INOUT),
  64     minit (NULL, -1)
  65 };
  66
  67 const mstring access_types[] =
  68 {
  69     minit ("UNKNOWN-ACCESS", ACCESS_UNKNOWN),
  70     minit ("PUBLIC", ACCESS_PUBLIC),
  71     minit ("PRIVATE", ACCESS_PRIVATE),
  72     minit (NULL, -1)
  73 };
  74
  75 const mstring ifsrc_types[] =
  76 {
  77     minit ("UNKNOWN", IFSRC_UNKNOWN),
  78     minit ("DECL", IFSRC_DECL),
  79     minit ("BODY", IFSRC_IFBODY)
  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 gfc_namespace *gfc_global_ns_list;
  97
  98 gfc_gsymbol *gfc_gsym_root = NULL;
  99
 100 gfc_dt_list *gfc_derived_types;
 101
 102 static gfc_undo_change_set default_undo_chgset_var = { vNULL, vNULL };
 103 static gfc_undo_change_set *latest_undo_chgset = &default_undo_chgset_var;
 104
 105
 106 /*********** IMPLICIT NONE and IMPLICIT statement handlers ***********/
 107
 108 /* The following static variable indicates whether a particular element has
 109    been explicitly set or not.  */
 110
 111 static int new_flag[GFC_LETTERS];
 112
 113
 114 /* Handle a correctly parsed IMPLICIT NONE.  */
 115
 116 void
 117 gfc_set_implicit_none (void)
 118 {
 119   int i;
 120
 121   if (gfc_current_ns->seen_implicit_none)
 122     {
 123       gfc_error ("Duplicate IMPLICIT NONE statement at %C");
 124       return;
 125     }
 126
 127   gfc_current_ns->seen_implicit_none = 1;
 128
 129   for (i = 0; i < GFC_LETTERS; i++)
 130     {
 131       gfc_clear_ts (&gfc_current_ns->default_type[i]);
 132       gfc_current_ns->set_flag[i] = 1;
 133     }
 134 }
 135
 136
 137 /* Reset the implicit range flags.  */
 138
 139 void
 140 gfc_clear_new_implicit (void)
 141 {
 142   int i;
 143
 144   for (i = 0; i < GFC_LETTERS; i++)
 145     new_flag[i] = 0;
 146 }
 147
 148
 149 /* Prepare for a new implicit range.  Sets flags in new_flag[].  */
 150
 151 gfc_try
 152 gfc_add_new_implicit_range (int c1, int c2)
 153 {
 154   int i;
 155
 156   c1 -= 'a';
 157   c2 -= 'a';
 158
 159   for (i = c1; i <= c2; i++)
 160     {
 161       if (new_flag[i])
 162         {
 163           gfc_error ("Letter '%c' already set in IMPLICIT statement at %C",
 164                      i + 'A');
 165           return FAILURE;
 166         }
 167
 168       new_flag[i] = 1;
 169     }
 170
 171   return SUCCESS;
 172 }
 173
 174
 175 /* Add a matched implicit range for gfc_set_implicit().  Check if merging
 176    the new implicit types back into the existing types will work.  */
 177
 178 gfc_try
 179 gfc_merge_new_implicit (gfc_typespec *ts)
 180 {
 181   int i;
 182
 183   if (gfc_current_ns->seen_implicit_none)
 184     {
 185       gfc_error ("Cannot specify IMPLICIT at %C after IMPLICIT NONE");
 186       return FAILURE;
 187     }
 188
 189   for (i = 0; i < GFC_LETTERS; i++)
 190     {
 191       if (new_flag[i])
 192         {
 193           if (gfc_current_ns->set_flag[i])
 194             {
 195               gfc_error ("Letter %c already has an IMPLICIT type at %C",
 196                          i + 'A');
 197               return FAILURE;
 198             }
 199
 200           gfc_current_ns->default_type[i] = *ts;
 201           gfc_current_ns->implicit_loc[i] = gfc_current_locus;
 202           gfc_current_ns->set_flag[i] = 1;
 203         }
 204     }
 205   return SUCCESS;
 206 }
 207
 208
 209 /* Given a symbol, return a pointer to the typespec for its default type.  */
 210
 211 gfc_typespec *
 212 gfc_get_default_type (const char *name, gfc_namespace *ns)
 213 {
 214   char letter;
 215
 216   letter = name[0];
 217
 218   if (gfc_option.flag_allow_leading_underscore && letter == '_')
 219     gfc_internal_error ("Option -fallow-leading-underscore is for use only by "
 220                         "gfortran developers, and should not be used for "
 221                         "implicitly typed variables");
 222
 223   if (letter < 'a' || letter > 'z')
 224     gfc_internal_error ("gfc_get_default_type(): Bad symbol '%s'", name);
 225
 226   if (ns == NULL)
 227     ns = gfc_current_ns;
 228
 229   return &ns->default_type[letter - 'a'];
 230 }
 231
 232
 233 /* Given a pointer to a symbol, set its type according to the first
 234    letter of its name.  Fails if the letter in question has no default
 235    type.  */
 236
 237 gfc_try
 238 gfc_set_default_type (gfc_symbol *sym, int error_flag, gfc_namespace *ns)
 239 {
 240   gfc_typespec *ts;
 241
 242   if (sym->ts.type != BT_UNKNOWN)
 243     gfc_internal_error ("gfc_set_default_type(): symbol already has a type");
 244
 245   ts = gfc_get_default_type (sym->name, ns);
 246
 247   if (ts->type == BT_UNKNOWN)
 248     {
 249       if (error_flag && !sym->attr.untyped)
 250         {
 251           gfc_error ("Symbol '%s' at %L has no IMPLICIT type",
 252                      sym->name, &sym->declared_at);
 253           sym->attr.untyped = 1; /* Ensure we only give an error once.  */
 254         }
 255
 256       return FAILURE;
 257     }
 258
 259   sym->ts = *ts;
 260   sym->attr.implicit_type = 1;
 261
 262   if (ts->type == BT_CHARACTER && ts->u.cl)
 263     sym->ts.u.cl = gfc_new_charlen (sym->ns, ts->u.cl);
 264
 265   if (sym->attr.is_bind_c == 1 && gfc_option.warn_c_binding_type)
 266     {
 267       /* BIND(C) variables should not be implicitly declared.  */
 268       gfc_warning_now ("Implicitly declared BIND(C) variable '%s' at %L may "
 269                        "not be C interoperable", sym->name, &sym->declared_at);
 270       sym->ts.f90_type = sym->ts.type;
 271     }
 272
 273   if (sym->attr.dummy != 0)
 274     {
 275       if (sym->ns->proc_name != NULL
 276           && (sym->ns->proc_name->attr.subroutine != 0
 277               || sym->ns->proc_name->attr.function != 0)
 278           && sym->ns->proc_name->attr.is_bind_c != 0
 279           && gfc_option.warn_c_binding_type)
 280         {
 281           /* Dummy args to a BIND(C) routine may not be interoperable if
 282              they are implicitly typed.  */
 283           gfc_warning_now ("Implicitly declared variable '%s' at %L may not "
 284                            "be C interoperable but it is a dummy argument to "
 285                            "the BIND(C) procedure '%s' at %L", sym->name,
 286                            &(sym->declared_at), sym->ns->proc_name->name,
 287                            &(sym->ns->proc_name->declared_at));
 288           sym->ts.f90_type = sym->ts.type;
 289         }
 290     }
 291
 292   return SUCCESS;
 293 }
 294
 295
 296 /* This function is called from parse.c(parse_progunit) to check the
 297    type of the function is not implicitly typed in the host namespace
 298    and to implicitly type the function result, if necessary.  */
 299
 300 void
 301 gfc_check_function_type (gfc_namespace *ns)
 302 {
 303   gfc_symbol *proc = ns->proc_name;
 304
 305   if (!proc->attr.contained || proc->result->attr.implicit_type)
 306     return;
 307
 308   if (proc->result->ts.type == BT_UNKNOWN && proc->result->ts.interface == NULL)
 309     {
 310       if (gfc_set_default_type (proc->result, 0, gfc_current_ns)
 311                 == SUCCESS)
 312         {
 313           if (proc->result != proc)
 314             {
 315               proc->ts = proc->result->ts;
 316               proc->as = gfc_copy_array_spec (proc->result->as);
 317               proc->attr.dimension = proc->result->attr.dimension;
 318               proc->attr.pointer = proc->result->attr.pointer;
 319               proc->attr.allocatable = proc->result->attr.allocatable;
 320             }
 321         }
 322       else if (!proc->result->attr.proc_pointer)
 323         {
 324           gfc_error ("Function result '%s' at %L has no IMPLICIT type",
 325                      proc->result->name, &proc->result->declared_at);
 326           proc->result->attr.untyped = 1;
 327         }
 328     }
 329 }
 330
 331
 332 /******************** Symbol attribute stuff *********************/
 333
 334 /* This is a generic conflict-checker.  We do this to avoid having a
 335    single conflict in two places.  */
 336
 337 #define conf(a, b) if (attr->a && attr->b) { a1 = a; a2 = b; goto conflict; }
 338 #define conf2(a) if (attr->a) { a2 = a; goto conflict; }
 339 #define conf_std(a, b, std) if (attr->a && attr->b)\
 340                               {\
 341                                 a1 = a;\
 342                                 a2 = b;\
 343                                 standard = std;\
 344                                 goto conflict_std;\
 345                               }
 346
 347 static gfc_try
 348 check_conflict (symbol_attribute *attr, const char *name, locus *where)
 349 {
 350   static const char *dummy = "DUMMY", *save = "SAVE", *pointer = "POINTER",
 351     *target = "TARGET", *external = "EXTERNAL", *intent = "INTENT",
 352     *intent_in = "INTENT(IN)", *intrinsic = "INTRINSIC",
 353     *intent_out = "INTENT(OUT)", *intent_inout = "INTENT(INOUT)",
 354     *allocatable = "ALLOCATABLE", *elemental = "ELEMENTAL",
 355     *privat = "PRIVATE", *recursive = "RECURSIVE",
 356     *in_common = "COMMON", *result = "RESULT", *in_namelist = "NAMELIST",
 357     *publik = "PUBLIC", *optional = "OPTIONAL", *entry = "ENTRY",
 358     *function = "FUNCTION", *subroutine = "SUBROUTINE",
 359     *dimension = "DIMENSION", *in_equivalence = "EQUIVALENCE",
 360     *use_assoc = "USE ASSOCIATED", *cray_pointer = "CRAY POINTER",
 361     *cray_pointee = "CRAY POINTEE", *data = "DATA", *value = "VALUE",
 362     *volatile_ = "VOLATILE", *is_protected = "PROTECTED",
 363     *is_bind_c = "BIND(C)", *procedure = "PROCEDURE",
 364     *asynchronous = "ASYNCHRONOUS", *codimension = "CODIMENSION",
 365     *contiguous = "CONTIGUOUS", *generic = "GENERIC";
 366   static const char *threadprivate = "THREADPRIVATE";
 367
 368   const char *a1, *a2;
 369   int standard;
 370
 371   if (where == NULL)
 372     where = &gfc_current_locus;
 373
 374   if (attr->pointer && attr->intent != INTENT_UNKNOWN)
 375     {
 376       a1 = pointer;
 377       a2 = intent;
 378       standard = GFC_STD_F2003;
 379       goto conflict_std;
 380     }
 381
 382   if (attr->in_namelist && (attr->allocatable || attr->pointer))
 383     {
 384       a1 = in_namelist;
 385       a2 = attr->allocatable ? allocatable : pointer;
 386       standard = GFC_STD_F2003;
 387       goto conflict_std;
 388     }
 389
 390   /* Check for attributes not allowed in a BLOCK DATA.  */
 391   if (gfc_current_state () == COMP_BLOCK_DATA)
 392     {
 393       a1 = NULL;
 394
 395       if (attr->in_namelist)
 396         a1 = in_namelist;
 397       if (attr->allocatable)
 398         a1 = allocatable;
 399       if (attr->external)
 400         a1 = external;
 401       if (attr->optional)
 402         a1 = optional;
 403       if (attr->access == ACCESS_PRIVATE)
 404         a1 = privat;
 405       if (attr->access == ACCESS_PUBLIC)
 406         a1 = publik;
 407       if (attr->intent != INTENT_UNKNOWN)
 408         a1 = intent;
 409
 410       if (a1 != NULL)
 411         {
 412           gfc_error
 413             ("%s attribute not allowed in BLOCK DATA program unit at %L",
 414              a1, where);
 415           return FAILURE;
 416         }
 417     }
 418
 419   if (attr->save == SAVE_EXPLICIT)
 420     {
 421       conf (dummy, save);
 422       conf (in_common, save);
 423       conf (result, save);
 424
 425       switch (attr->flavor)
 426         {
 427           case FL_PROGRAM:
 428           case FL_BLOCK_DATA:
 429           case FL_MODULE:
 430           case FL_LABEL:
 431           case FL_DERIVED:
 432           case FL_PARAMETER:
 433             a1 = gfc_code2string (flavors, attr->flavor);
 434             a2 = save;
 435             goto conflict;
 436           case FL_NAMELIST:
 437             gfc_error ("Namelist group name at %L cannot have the "
 438                        "SAVE attribute", where);
 439             return FAILURE;
 440             break;
 441           case FL_PROCEDURE:
 442             /* Conflicts between SAVE and PROCEDURE will be checked at
 443                resolution stage, see "resolve_fl_procedure".  */
 444           case FL_VARIABLE:
 445           default:
 446             break;
 447         }
 448     }
 449
 450   conf (dummy, entry);
 451   conf (dummy, intrinsic);
 452   conf (dummy, threadprivate);
 453   conf (pointer, target);
 454   conf (pointer, intrinsic);
 455   conf (pointer, elemental);
 456   conf (allocatable, elemental);
 457
 458   conf (target, external);
 459   conf (target, intrinsic);
 460
 461   if (!attr->if_source)
 462     conf (external, dimension);   /* See Fortran 95's R504.  */
 463
 464   conf (external, intrinsic);
 465   conf (entry, intrinsic);
 466
 467   if ((attr->if_source == IFSRC_DECL && !attr->procedure) || attr->contained)
 468     conf (external, subroutine);
 469
 470   if (attr->proc_pointer && gfc_notify_std (GFC_STD_F2003,
 471                             "Procedure pointer at %C") == FAILURE)
 472     return FAILURE;
 473
 474   conf (allocatable, pointer);
 475   conf_std (allocatable, dummy, GFC_STD_F2003);
 476   conf_std (allocatable, function, GFC_STD_F2003);
 477   conf_std (allocatable, result, GFC_STD_F2003);
 478   conf (elemental, recursive);
 479
 480   conf (in_common, dummy);
 481   conf (in_common, allocatable);
 482   conf (in_common, codimension);
 483   conf (in_common, result);
 484
 485   conf (in_equivalence, use_assoc);
 486   conf (in_equivalence, codimension);
 487   conf (in_equivalence, dummy);
 488   conf (in_equivalence, target);
 489   conf (in_equivalence, pointer);
 490   conf (in_equivalence, function);
 491   conf (in_equivalence, result);
 492   conf (in_equivalence, entry);
 493   conf (in_equivalence, allocatable);
 494   conf (in_equivalence, threadprivate);
 495
 496   conf (dummy, result);
 497   conf (entry, result);
 498   conf (generic, result);
 499
 500   conf (function, subroutine);
 501
 502   if (!function && !subroutine)
 503     conf (is_bind_c, dummy);
 504
 505   conf (is_bind_c, cray_pointer);
 506   conf (is_bind_c, cray_pointee);
 507   conf (is_bind_c, codimension);
 508   conf (is_bind_c, allocatable);
 509   conf (is_bind_c, elemental);
 510
 511   /* Need to also get volatile attr, according to 5.1 of F2003 draft.
 512      Parameter conflict caught below.  Also, value cannot be specified
 513      for a dummy procedure.  */
 514
 515   /* Cray pointer/pointee conflicts.  */
 516   conf (cray_pointer, cray_pointee);
 517   conf (cray_pointer, dimension);
 518   conf (cray_pointer, codimension);
 519   conf (cray_pointer, contiguous);
 520   conf (cray_pointer, pointer);
 521   conf (cray_pointer, target);
 522   conf (cray_pointer, allocatable);
 523   conf (cray_pointer, external);
 524   conf (cray_pointer, intrinsic);
 525   conf (cray_pointer, in_namelist);
 526   conf (cray_pointer, function);
 527   conf (cray_pointer, subroutine);
 528   conf (cray_pointer, entry);
 529
 530   conf (cray_pointee, allocatable);
 531   conf (cray_pointer, contiguous);
 532   conf (cray_pointer, codimension);
 533   conf (cray_pointee, intent);
 534   conf (cray_pointee, optional);
 535   conf (cray_pointee, dummy);
 536   conf (cray_pointee, target);
 537   conf (cray_pointee, intrinsic);
 538   conf (cray_pointee, pointer);
 539   conf (cray_pointee, entry);
 540   conf (cray_pointee, in_common);
 541   conf (cray_pointee, in_equivalence);
 542   conf (cray_pointee, threadprivate);
 543
 544   conf (data, dummy);
 545   conf (data, function);
 546   conf (data, result);
 547   conf (data, allocatable);
 548
 549   conf (value, pointer)
 550   conf (value, allocatable)
 551   conf (value, subroutine)
 552   conf (value, function)
 553   conf (value, volatile_)
 554   conf (value, dimension)
 555   conf (value, codimension)
 556   conf (value, external)
 557
 558   conf (codimension, result)
 559
 560   if (attr->value
 561       && (attr->intent == INTENT_OUT || attr->intent == INTENT_INOUT))
 562     {
 563       a1 = value;
 564       a2 = attr->intent == INTENT_OUT ? intent_out : intent_inout;
 565       goto conflict;
 566     }
 567
 568   conf (is_protected, intrinsic)
 569   conf (is_protected, in_common)
 570
 571   conf (asynchronous, intrinsic)
 572   conf (asynchronous, external)
 573
 574   conf (volatile_, intrinsic)
 575   conf (volatile_, external)
 576
 577   if (attr->volatile_ && attr->intent == INTENT_IN)
 578     {
 579       a1 = volatile_;
 580       a2 = intent_in;
 581       goto conflict;
 582     }
 583
 584   conf (procedure, allocatable)
 585   conf (procedure, dimension)
 586   conf (procedure, codimension)
 587   conf (procedure, intrinsic)
 588   conf (procedure, target)
 589   conf (procedure, value)
 590   conf (procedure, volatile_)
 591   conf (procedure, asynchronous)
 592   conf (procedure, entry)
 593
 594   a1 = gfc_code2string (flavors, attr->flavor);
 595
 596   if (attr->in_namelist
 597       && attr->flavor != FL_VARIABLE
 598       && attr->flavor != FL_PROCEDURE
 599       && attr->flavor != FL_UNKNOWN)
 600     {
 601       a2 = in_namelist;
 602       goto conflict;
 603     }
 604
 605   switch (attr->flavor)
 606     {
 607     case FL_PROGRAM:
 608     case FL_BLOCK_DATA:
 609     case FL_MODULE:
 610     case FL_LABEL:
 611       conf2 (codimension);
 612       conf2 (dimension);
 613       conf2 (dummy);
 614       conf2 (volatile_);
 615       conf2 (asynchronous);
 616       conf2 (contiguous);
 617       conf2 (pointer);
 618       conf2 (is_protected);
 619       conf2 (target);
 620       conf2 (external);
 621       conf2 (intrinsic);
 622       conf2 (allocatable);
 623       conf2 (result);
 624       conf2 (in_namelist);
 625       conf2 (optional);
 626       conf2 (function);
 627       conf2 (subroutine);
 628       conf2 (threadprivate);
 629
 630       if (attr->access == ACCESS_PUBLIC || attr->access == ACCESS_PRIVATE)
 631         {
 632           a2 = attr->access == ACCESS_PUBLIC ? publik : privat;
 633           gfc_error ("%s attribute applied to %s %s at %L", a2, a1,
 634             name, where);
 635           return FAILURE;
 636         }
 637
 638       if (attr->is_bind_c)
 639         {
 640           gfc_error_now ("BIND(C) applied to %s %s at %L", a1, name, where);
 641           return FAILURE;
 642         }
 643
 644       break;
 645
 646     case FL_VARIABLE:
 647       break;
 648
 649     case FL_NAMELIST:
 650       conf2 (result);
 651       break;
 652
 653     case FL_PROCEDURE:
 654       /* Conflicts with INTENT, SAVE and RESULT will be checked
 655          at resolution stage, see "resolve_fl_procedure".  */
 656
 657       if (attr->subroutine)
 658         {
 659           a1 = subroutine;
 660           conf2 (target);
 661           conf2 (allocatable);
 662           conf2 (volatile_);
 663           conf2 (asynchronous);
 664           conf2 (in_namelist);
 665           conf2 (codimension);
 666           conf2 (dimension);
 667           conf2 (function);
 668           if (!attr->proc_pointer)
 669             conf2 (threadprivate);
 670         }
 671
 672       if (!attr->proc_pointer)
 673         conf2 (in_common);
 674
 675       switch (attr->proc)
 676         {
 677         case PROC_ST_FUNCTION:
 678           conf2 (dummy);
 679           conf2 (target);
 680           break;
 681
 682         case PROC_MODULE:
 683           conf2 (dummy);
 684           break;
 685
 686         case PROC_DUMMY:
 687           conf2 (result);
 688           conf2 (threadprivate);
 689           break;
 690
 691         default:
 692           break;
 693         }
 694
 695       break;
 696
 697     case FL_DERIVED:
 698       conf2 (dummy);
 699       conf2 (pointer);
 700       conf2 (target);
 701       conf2 (external);
 702       conf2 (intrinsic);
 703       conf2 (allocatable);
 704       conf2 (optional);
 705       conf2 (entry);
 706       conf2 (function);
 707       conf2 (subroutine);
 708       conf2 (threadprivate);
 709       conf2 (result);
 710
 711       if (attr->intent != INTENT_UNKNOWN)
 712         {
 713           a2 = intent;
 714           goto conflict;
 715         }
 716       break;
 717
 718     case FL_PARAMETER:
 719       conf2 (external);
 720       conf2 (intrinsic);
 721       conf2 (optional);
 722       conf2 (allocatable);
 723       conf2 (function);
 724       conf2 (subroutine);
 725       conf2 (entry);
 726       conf2 (contiguous);
 727       conf2 (pointer);
 728       conf2 (is_protected);
 729       conf2 (target);
 730       conf2 (dummy);
 731       conf2 (in_common);
 732       conf2 (value);
 733       conf2 (volatile_);
 734       conf2 (asynchronous);
 735       conf2 (threadprivate);
 736       conf2 (value);
 737       conf2 (codimension);
 738       conf2 (result);
 739       if (!attr->is_iso_c)
 740         conf2 (is_bind_c);
 741       break;
 742
 743     default:
 744       break;
 745     }
 746
 747   return SUCCESS;
 748
 749 conflict:
 750   if (name == NULL)
 751     gfc_error ("%s attribute conflicts with %s attribute at %L",
 752                a1, a2, where);
 753   else
 754     gfc_error ("%s attribute conflicts with %s attribute in '%s' at %L",
 755                a1, a2, name, where);
 756
 757   return FAILURE;
 758
 759 conflict_std:
 760   if (name == NULL)
 761     {
 762       return gfc_notify_std (standard, "%s attribute "
 763                              "with %s attribute at %L", a1, a2,
 764                              where);
 765     }
 766   else
 767     {
 768       return gfc_notify_std (standard, "%s attribute "
 769                              "with %s attribute in '%s' at %L",
 770                              a1, a2, name, where);
 771     }
 772 }
 773
 774 #undef conf
 775 #undef conf2
 776 #undef conf_std
 777
 778
 779 /* Mark a symbol as referenced.  */
 780
 781 void
 782 gfc_set_sym_referenced (gfc_symbol *sym)
 783 {
 784
 785   if (sym->attr.referenced)
 786     return;
 787
 788   sym->attr.referenced = 1;
 789
 790   /* Remember which order dummy variables are accessed in.  */
 791   if (sym->attr.dummy)
 792     sym->dummy_order = next_dummy_order++;
 793 }
 794
 795
 796 /* Common subroutine called by attribute changing subroutines in order
 797    to prevent them from changing a symbol that has been
 798    use-associated.  Returns zero if it is OK to change the symbol,
 799    nonzero if not.  */
 800
 801 static int
 802 check_used (symbol_attribute *attr, const char *name, locus *where)
 803 {
 804
 805   if (attr->use_assoc == 0)
 806     return 0;
 807
 808   if (where == NULL)
 809     where = &gfc_current_locus;
 810
 811   if (name == NULL)
 812     gfc_error ("Cannot change attributes of USE-associated symbol at %L",
 813                where);
 814   else
 815     gfc_error ("Cannot change attributes of USE-associated symbol %s at %L",
 816                name, where);
 817
 818   return 1;
 819 }
 820
 821
 822 /* Generate an error because of a duplicate attribute.  */
 823
 824 static void
 825 duplicate_attr (const char *attr, locus *where)
 826 {
 827
 828   if (where == NULL)
 829     where = &gfc_current_locus;
 830
 831   gfc_error ("Duplicate %s attribute specified at %L", attr, where);
 832 }
 833
 834
 835 gfc_try
 836 gfc_add_ext_attribute (symbol_attribute *attr, ext_attr_id_t ext_attr,
 837                        locus *where ATTRIBUTE_UNUSED)
 838 {
 839   attr->ext_attr |= 1 << ext_attr;
 840   return SUCCESS;
 841 }
 842
 843
 844 /* Called from decl.c (attr_decl1) to check attributes, when declared
 845    separately.  */
 846
 847 gfc_try
 848 gfc_add_attribute (symbol_attribute *attr, locus *where)
 849 {
 850   if (check_used (attr, NULL, where))
 851     return FAILURE;
 852
 853   return check_conflict (attr, NULL, where);
 854 }
 855
 856
 857 gfc_try
 858 gfc_add_allocatable (symbol_attribute *attr, locus *where)
 859 {
 860
 861   if (check_used (attr, NULL, where))
 862     return FAILURE;
 863
 864   if (attr->allocatable)
 865     {
 866       duplicate_attr ("ALLOCATABLE", where);
 867       return FAILURE;
 868     }
 869
 870   if (attr->flavor == FL_PROCEDURE && attr->if_source == IFSRC_IFBODY
 871       && gfc_find_state (COMP_INTERFACE) == FAILURE)
 872     {
 873       gfc_error ("ALLOCATABLE specified outside of INTERFACE body at %L",
 874                  where);
 875       return FAILURE;
 876     }
 877
 878   attr->allocatable = 1;
 879   return check_conflict (attr, NULL, where);
 880 }
 881
 882
 883 gfc_try
 884 gfc_add_codimension (symbol_attribute *attr, const char *name, locus *where)
 885 {
 886
 887   if (check_used (attr, name, where))
 888     return FAILURE;
 889
 890   if (attr->codimension)
 891     {
 892       duplicate_attr ("CODIMENSION", where);
 893       return FAILURE;
 894     }
 895
 896   if (attr->flavor == FL_PROCEDURE && attr->if_source == IFSRC_IFBODY
 897       && gfc_find_state (COMP_INTERFACE) == FAILURE)
 898     {
 899       gfc_error ("CODIMENSION specified for '%s' outside its INTERFACE body "
 900                  "at %L", name, where);
 901       return FAILURE;
 902     }
 903
 904   attr->codimension = 1;
 905   return check_conflict (attr, name, where);
 906 }
 907
 908
 909 gfc_try
 910 gfc_add_dimension (symbol_attribute *attr, const char *name, locus *where)
 911 {
 912
 913   if (check_used (attr, name, where))
 914     return FAILURE;
 915
 916   if (attr->dimension)
 917     {
 918       duplicate_attr ("DIMENSION", where);
 919       return FAILURE;
 920     }
 921
 922   if (attr->flavor == FL_PROCEDURE && attr->if_source == IFSRC_IFBODY
 923       && gfc_find_state (COMP_INTERFACE) == FAILURE)
 924     {
 925       gfc_error ("DIMENSION specified for '%s' outside its INTERFACE body "
 926                  "at %L", name, where);
 927       return FAILURE;
 928     }
 929
 930   attr->dimension = 1;
 931   return check_conflict (attr, name, where);
 932 }
 933
 934
 935 gfc_try
 936 gfc_add_contiguous (symbol_attribute *attr, const char *name, locus *where)
 937 {
 938
 939   if (check_used (attr, name, where))
 940     return FAILURE;
 941
 942   attr->contiguous = 1;
 943   return check_conflict (attr, name, where);
 944 }
 945
 946
 947 gfc_try
 948 gfc_add_external (symbol_attribute *attr, locus *where)
 949 {
 950
 951   if (check_used (attr, NULL, where))
 952     return FAILURE;
 953
 954   if (attr->external)
 955     {
 956       duplicate_attr ("EXTERNAL", where);
 957       return FAILURE;
 958     }
 959
 960   if (attr->pointer && attr->if_source != IFSRC_IFBODY)
 961     {
 962       attr->pointer = 0;
 963       attr->proc_pointer = 1;
 964     }
 965
 966   attr->external = 1;
 967
 968   return check_conflict (attr, NULL, where);
 969 }
 970
 971
 972 gfc_try
 973 gfc_add_intrinsic (symbol_attribute *attr, locus *where)
 974 {
 975
 976   if (check_used (attr, NULL, where))
 977     return FAILURE;
 978
 979   if (attr->intrinsic)
 980     {
 981       duplicate_attr ("INTRINSIC", where);
 982       return FAILURE;
 983     }
 984
 985   attr->intrinsic = 1;
 986
 987   return check_conflict (attr, NULL, where);
 988 }
 989
 990
 991 gfc_try
 992 gfc_add_optional (symbol_attribute *attr, locus *where)
 993 {
 994
 995   if (check_used (attr, NULL, where))
 996     return FAILURE;
 997
 998   if (attr->optional)
 999     {
1000       duplicate_attr ("OPTIONAL", where);
1001       return FAILURE;
1002     }
1003
1004   attr->optional = 1;
1005   return check_conflict (attr, NULL, where);
1006 }
1007
1008
1009 gfc_try
1010 gfc_add_pointer (symbol_attribute *attr, locus *where)
1011 {
1012
1013   if (check_used (attr, NULL, where))
1014     return FAILURE;
1015
1016   if (attr->pointer && !(attr->if_source == IFSRC_IFBODY
1017       && gfc_find_state (COMP_INTERFACE) == FAILURE))
1018     {
1019       duplicate_attr ("POINTER", where);
1020       return FAILURE;
1021     }
1022
1023   if (attr->procedure || (attr->external && attr->if_source != IFSRC_IFBODY)
1024       || (attr->if_source == IFSRC_IFBODY
1025       && gfc_find_state (COMP_INTERFACE) == FAILURE))
1026     attr->proc_pointer = 1;
1027   else
1028     attr->pointer = 1;
1029
1030   return check_conflict (attr, NULL, where);
1031 }
1032
1033
1034 gfc_try
1035 gfc_add_cray_pointer (symbol_attribute *attr, locus *where)
1036 {
1037
1038   if (check_used (attr, NULL, where))
1039     return FAILURE;
1040
1041   attr->cray_pointer = 1;
1042   return check_conflict (attr, NULL, where);
1043 }
1044
1045
1046 gfc_try
1047 gfc_add_cray_pointee (symbol_attribute *attr, locus *where)
1048 {
1049
1050   if (check_used (attr, NULL, where))
1051     return FAILURE;
1052
1053   if (attr->cray_pointee)
1054     {
1055       gfc_error ("Cray Pointee at %L appears in multiple pointer()"
1056                  " statements", where);
1057       return FAILURE;
1058     }
1059
1060   attr->cray_pointee = 1;
1061   return check_conflict (attr, NULL, where);
1062 }
1063
1064
1065 gfc_try
1066 gfc_add_protected (symbol_attribute *attr, const char *name, locus *where)
1067 {
1068   if (check_used (attr, name, where))
1069     return FAILURE;
1070
1071   if (attr->is_protected)
1072     {
1073         if (gfc_notify_std (GFC_STD_LEGACY,
1074                             "Duplicate PROTECTED attribute specified at %L",
1075                             where)
1076             == FAILURE)
1077           return FAILURE;
1078     }
1079
1080   attr->is_protected = 1;
1081   return check_conflict (attr, name, where);
1082 }
1083
1084
1085 gfc_try
1086 gfc_add_result (symbol_attribute *attr, const char *name, locus *where)
1087 {
1088
1089   if (check_used (attr, name, where))
1090     return FAILURE;
1091
1092   attr->result = 1;
1093   return check_conflict (attr, name, where);
1094 }
1095
1096
1097 gfc_try
1098 gfc_add_save (symbol_attribute *attr, save_state s, const char *name,
1099               locus *where)
1100 {
1101
1102   if (check_used (attr, name, where))
1103     return FAILURE;
1104
1105   if (s == SAVE_EXPLICIT && gfc_pure (NULL))
1106     {
1107       gfc_error
1108         ("SAVE attribute at %L cannot be specified in a PURE procedure",
1109          where);
1110       return FAILURE;
1111     }
1112
1113   if (s == SAVE_EXPLICIT && gfc_implicit_pure (NULL))
1114     gfc_current_ns->proc_name->attr.implicit_pure = 0;
1115
1116   if (s == SAVE_EXPLICIT && attr->save == SAVE_EXPLICIT)
1117     {
1118         if (gfc_notify_std (GFC_STD_LEGACY,
1119                             "Duplicate SAVE attribute specified at %L",
1120                             where)
1121             == FAILURE)
1122           return FAILURE;
1123     }
1124
1125   attr->save = s;
1126   return check_conflict (attr, name, where);
1127 }
1128
1129
1130 gfc_try
1131 gfc_add_value (symbol_attribute *attr, const char *name, locus *where)
1132 {
1133
1134   if (check_used (attr, name, where))
1135     return FAILURE;
1136
1137   if (attr->value)
1138     {
1139         if (gfc_notify_std (GFC_STD_LEGACY,
1140                             "Duplicate VALUE attribute specified at %L",
1141                             where)
1142             == FAILURE)
1143           return FAILURE;
1144     }
1145
1146   attr->value = 1;
1147   return check_conflict (attr, name, where);
1148 }
1149
1150
1151 gfc_try
1152 gfc_add_volatile (symbol_attribute *attr, const char *name, locus *where)
1153 {
1154   /* No check_used needed as 11.2.1 of the F2003 standard allows
1155      that the local identifier made accessible by a use statement can be
1156      given a VOLATILE attribute - unless it is a coarray (F2008, C560).  */
1157
1158   if (attr->volatile_ && attr->volatile_ns == gfc_current_ns)
1159     if (gfc_notify_std (GFC_STD_LEGACY,
1160                         "Duplicate VOLATILE attribute specified at %L", where)
1161         == FAILURE)
1162       return FAILURE;
1163
1164   attr->volatile_ = 1;
1165   attr->volatile_ns = gfc_current_ns;
1166   return check_conflict (attr, name, where);
1167 }
1168
1169
1170 gfc_try
1171 gfc_add_asynchronous (symbol_attribute *attr, const char *name, locus *where)
1172 {
1173   /* No check_used needed as 11.2.1 of the F2003 standard allows
1174      that the local identifier made accessible by a use statement can be
1175      given a ASYNCHRONOUS attribute.  */
1176
1177   if (attr->asynchronous && attr->asynchronous_ns == gfc_current_ns)
1178     if (gfc_notify_std (GFC_STD_LEGACY,
1179                         "Duplicate ASYNCHRONOUS attribute specified at %L",
1180                         where) == FAILURE)
1181       return FAILURE;
1182
1183   attr->asynchronous = 1;
1184   attr->asynchronous_ns = gfc_current_ns;
1185   return check_conflict (attr, name, where);
1186 }
1187
1188
1189 gfc_try
1190 gfc_add_threadprivate (symbol_attribute *attr, const char *name, locus *where)
1191 {
1192
1193   if (check_used (attr, name, where))
1194     return FAILURE;
1195
1196   if (attr->threadprivate)
1197     {
1198       duplicate_attr ("THREADPRIVATE", where);
1199       return FAILURE;
1200     }
1201
1202   attr->threadprivate = 1;
1203   return check_conflict (attr, name, where);
1204 }
1205
1206
1207 gfc_try
1208 gfc_add_target (symbol_attribute *attr, locus *where)
1209 {
1210
1211   if (check_used (attr, NULL, where))
1212     return FAILURE;
1213
1214   if (attr->target)
1215     {
1216       duplicate_attr ("TARGET", where);
1217       return FAILURE;
1218     }
1219
1220   attr->target = 1;
1221   return check_conflict (attr, NULL, where);
1222 }
1223
1224
1225 gfc_try
1226 gfc_add_dummy (symbol_attribute *attr, const char *name, locus *where)
1227 {
1228
1229   if (check_used (attr, name, where))
1230     return FAILURE;
1231
1232   /* Duplicate dummy arguments are allowed due to ENTRY statements.  */
1233   attr->dummy = 1;
1234   return check_conflict (attr, name, where);
1235 }
1236
1237
1238 gfc_try
1239 gfc_add_in_common (symbol_attribute *attr, const char *name, locus *where)
1240 {
1241
1242   if (check_used (attr, name, where))
1243     return FAILURE;
1244
1245   /* Duplicate attribute already checked for.  */
1246   attr->in_common = 1;
1247   return check_conflict (attr, name, where);
1248 }
1249
1250
1251 gfc_try
1252 gfc_add_in_equivalence (symbol_attribute *attr, const char *name, locus *where)
1253 {
1254
1255   /* Duplicate attribute already checked for.  */
1256   attr->in_equivalence = 1;
1257   if (check_conflict (attr, name, where) == FAILURE)
1258     return FAILURE;
1259
1260   if (attr->flavor == FL_VARIABLE)
1261     return SUCCESS;
1262
1263   return gfc_add_flavor (attr, FL_VARIABLE, name, where);
1264 }
1265
1266
1267 gfc_try
1268 gfc_add_data (symbol_attribute *attr, const char *name, locus *where)
1269 {
1270
1271   if (check_used (attr, name, where))
1272     return FAILURE;
1273
1274   attr->data = 1;
1275   return check_conflict (attr, name, where);
1276 }
1277
1278
1279 gfc_try
1280 gfc_add_in_namelist (symbol_attribute *attr, const char *name, locus *where)
1281 {
1282
1283   attr->in_namelist = 1;
1284   return check_conflict (attr, name, where);
1285 }
1286
1287
1288 gfc_try
1289 gfc_add_sequence (symbol_attribute *attr, const char *name, locus *where)
1290 {
1291
1292   if (check_used (attr, name, where))
1293     return FAILURE;
1294
1295   attr->sequence = 1;
1296   return check_conflict (attr, name, where);
1297 }
1298
1299
1300 gfc_try
1301 gfc_add_elemental (symbol_attribute *attr, locus *where)
1302 {
1303
1304   if (check_used (attr, NULL, where))
1305     return FAILURE;
1306
1307   if (attr->elemental)
1308     {
1309       duplicate_attr ("ELEMENTAL", where);
1310       return FAILURE;
1311     }
1312
1313   attr->elemental = 1;
1314   return check_conflict (attr, NULL, where);
1315 }
1316
1317
1318 gfc_try
1319 gfc_add_pure (symbol_attribute *attr, locus *where)
1320 {
1321
1322   if (check_used (attr, NULL, where))
1323     return FAILURE;
1324
1325   if (attr->pure)
1326     {
1327       duplicate_attr ("PURE", where);
1328       return FAILURE;
1329     }
1330
1331   attr->pure = 1;
1332   return check_conflict (attr, NULL, where);
1333 }
1334
1335
1336 gfc_try
1337 gfc_add_recursive (symbol_attribute *attr, locus *where)
1338 {
1339
1340   if (check_used (attr, NULL, where))
1341     return FAILURE;
1342
1343   if (attr->recursive)
1344     {
1345       duplicate_attr ("RECURSIVE", where);
1346       return FAILURE;
1347     }
1348
1349   attr->recursive = 1;
1350   return check_conflict (attr, NULL, where);
1351 }
1352
1353
1354 gfc_try
1355 gfc_add_entry (symbol_attribute *attr, const char *name, locus *where)
1356 {
1357
1358   if (check_used (attr, name, where))
1359     return FAILURE;
1360
1361   if (attr->entry)
1362     {
1363       duplicate_attr ("ENTRY", where);
1364       return FAILURE;
1365     }
1366
1367   attr->entry = 1;
1368   return check_conflict (attr, name, where);
1369 }
1370
1371
1372 gfc_try
1373 gfc_add_function (symbol_attribute *attr, const char *name, locus *where)
1374 {
1375
1376   if (attr->flavor != FL_PROCEDURE
1377       && gfc_add_flavor (attr, FL_PROCEDURE, name, where) == FAILURE)
1378     return FAILURE;
1379
1380   attr->function = 1;
1381   return check_conflict (attr, name, where);
1382 }
1383
1384
1385 gfc_try
1386 gfc_add_subroutine (symbol_attribute *attr, const char *name, locus *where)
1387 {
1388
1389   if (attr->flavor != FL_PROCEDURE
1390       && gfc_add_flavor (attr, FL_PROCEDURE, name, where) == FAILURE)
1391     return FAILURE;
1392
1393   attr->subroutine = 1;
1394   return check_conflict (attr, name, where);
1395 }
1396
1397
1398 gfc_try
1399 gfc_add_generic (symbol_attribute *attr, const char *name, locus *where)
1400 {
1401
1402   if (attr->flavor != FL_PROCEDURE
1403       && gfc_add_flavor (attr, FL_PROCEDURE, name, where) == FAILURE)
1404     return FAILURE;
1405
1406   attr->generic = 1;
1407   return check_conflict (attr, name, where);
1408 }
1409
1410
1411 gfc_try
1412 gfc_add_proc (symbol_attribute *attr, const char *name, locus *where)
1413 {
1414
1415   if (check_used (attr, NULL, where))
1416     return FAILURE;
1417
1418   if (attr->flavor != FL_PROCEDURE
1419       && gfc_add_flavor (attr, FL_PROCEDURE, name, where) == FAILURE)
1420     return FAILURE;
1421
1422   if (attr->procedure)
1423     {
1424       duplicate_attr ("PROCEDURE", where);
1425       return FAILURE;
1426     }
1427
1428   attr->procedure = 1;
1429
1430   return check_conflict (attr, NULL, where);
1431 }
1432
1433
1434 gfc_try
1435 gfc_add_abstract (symbol_attribute* attr, locus* where)
1436 {
1437   if (attr->abstract)
1438     {
1439       duplicate_attr ("ABSTRACT", where);
1440       return FAILURE;
1441     }
1442
1443   attr->abstract = 1;
1444   return SUCCESS;
1445 }
1446
1447
1448 /* Flavors are special because some flavors are not what Fortran
1449    considers attributes and can be reaffirmed multiple times.  */
1450
1451 gfc_try
1452 gfc_add_flavor (symbol_attribute *attr, sym_flavor f, const char *name,
1453                 locus *where)
1454 {
1455
1456   if ((f == FL_PROGRAM || f == FL_BLOCK_DATA || f == FL_MODULE
1457        || f == FL_PARAMETER || f == FL_LABEL || f == FL_DERIVED
1458        || f == FL_NAMELIST) && check_used (attr, name, where))
1459     return FAILURE;
1460
1461   if (attr->flavor == f && f == FL_VARIABLE)
1462     return SUCCESS;
1463
1464   if (attr->flavor != FL_UNKNOWN)
1465     {
1466       if (where == NULL)
1467         where = &gfc_current_locus;
1468
1469       if (name)
1470         gfc_error ("%s attribute of '%s' conflicts with %s attribute at %L",
1471                    gfc_code2string (flavors, attr->flavor), name,
1472                    gfc_code2string (flavors, f), where);
1473       else
1474         gfc_error ("%s attribute conflicts with %s attribute at %L",
1475                    gfc_code2string (flavors, attr->flavor),
1476                    gfc_code2string (flavors, f), where);
1477
1478       return FAILURE;
1479     }
1480
1481   attr->flavor = f;
1482
1483   return check_conflict (attr, name, where);
1484 }
1485
1486
1487 gfc_try
1488 gfc_add_procedure (symbol_attribute *attr, procedure_type t,
1489                    const char *name, locus *where)
1490 {
1491
1492   if (check_used (attr, name, where))
1493     return FAILURE;
1494
1495   if (attr->flavor != FL_PROCEDURE
1496       && gfc_add_flavor (attr, FL_PROCEDURE, name, where) == FAILURE)
1497     return FAILURE;
1498
1499   if (where == NULL)
1500     where = &gfc_current_locus;
1501
1502   if (attr->proc != PROC_UNKNOWN)
1503     {
1504       gfc_error ("%s procedure at %L is already declared as %s procedure",
1505                  gfc_code2string (procedures, t), where,
1506                  gfc_code2string (procedures, attr->proc));
1507
1508       return FAILURE;
1509     }
1510
1511   attr->proc = t;
1512
1513   /* Statement functions are always scalar and functions.  */
1514   if (t == PROC_ST_FUNCTION
1515       && ((!attr->function && gfc_add_function (attr, name, where) == FAILURE)
1516           || attr->dimension))
1517     return FAILURE;
1518
1519   return check_conflict (attr, name, where);
1520 }
1521
1522
1523 gfc_try
1524 gfc_add_intent (symbol_attribute *attr, sym_intent intent, locus *where)
1525 {
1526
1527   if (check_used (attr, NULL, where))
1528     return FAILURE;
1529
1530   if (attr->intent == INTENT_UNKNOWN)
1531     {
1532       attr->intent = intent;
1533       return check_conflict (attr, NULL, where);
1534     }
1535
1536   if (where == NULL)
1537     where = &gfc_current_locus;
1538
1539   gfc_error ("INTENT (%s) conflicts with INTENT(%s) at %L",
1540              gfc_intent_string (attr->intent),
1541              gfc_intent_string (intent), where);
1542
1543   return FAILURE;
1544 }
1545
1546
1547 /* No checks for use-association in public and private statements.  */
1548
1549 gfc_try
1550 gfc_add_access (symbol_attribute *attr, gfc_access access,
1551                 const char *name, locus *where)
1552 {
1553
1554   if (attr->access == ACCESS_UNKNOWN
1555         || (attr->use_assoc && attr->access != ACCESS_PRIVATE))
1556     {
1557       attr->access = access;
1558       return check_conflict (attr, name, where);
1559     }
1560
1561   if (where == NULL)
1562     where = &gfc_current_locus;
1563   gfc_error ("ACCESS specification at %L was already specified", where);
1564
1565   return FAILURE;
1566 }
1567
1568
1569 /* Set the is_bind_c field for the given symbol_attribute.  */
1570
1571 gfc_try
1572 gfc_add_is_bind_c (symbol_attribute *attr, const char *name, locus *where,
1573                    int is_proc_lang_bind_spec)
1574 {
1575
1576   if (is_proc_lang_bind_spec == 0 && attr->flavor == FL_PROCEDURE)
1577     gfc_error_now ("BIND(C) attribute at %L can only be used for "
1578                    "variables or common blocks", where);
1579   else if (attr->is_bind_c)
1580     gfc_error_now ("Duplicate BIND attribute specified at %L", where);
1581   else
1582     attr->is_bind_c = 1;
1583
1584   if (where == NULL)
1585     where = &gfc_current_locus;
1586
1587   if (gfc_notify_std (GFC_STD_F2003, "BIND(C) at %L", where)
1588       == FAILURE)
1589     return FAILURE;
1590
1591   return check_conflict (attr, name, where);
1592 }
1593
1594
1595 /* Set the extension field for the given symbol_attribute.  */
1596
1597 gfc_try
1598 gfc_add_extension (symbol_attribute *attr, locus *where)
1599 {
1600   if (where == NULL)
1601     where = &gfc_current_locus;
1602
1603   if (attr->extension)
1604     gfc_error_now ("Duplicate EXTENDS attribute specified at %L", where);
1605   else
1606     attr->extension = 1;
1607
1608   if (gfc_notify_std (GFC_STD_F2003, "EXTENDS at %L", where)
1609         == FAILURE)
1610     return FAILURE;
1611
1612   return SUCCESS;
1613 }
1614
1615
1616 gfc_try
1617 gfc_add_explicit_interface (gfc_symbol *sym, ifsrc source,
1618                             gfc_formal_arglist * formal, locus *where)
1619 {
1620
1621   if (check_used (&sym->attr, sym->name, where))
1622     return FAILURE;
1623
1624   if (where == NULL)
1625     where = &gfc_current_locus;
1626
1627   if (sym->attr.if_source != IFSRC_UNKNOWN
1628       && sym->attr.if_source != IFSRC_DECL)
1629     {
1630       gfc_error ("Symbol '%s' at %L already has an explicit interface",
1631                  sym->name, where);
1632       return FAILURE;
1633     }
1634
1635   if (source == IFSRC_IFBODY && (sym->attr.dimension || sym->attr.allocatable))
1636     {
1637       gfc_error ("'%s' at %L has attributes specified outside its INTERFACE "
1638                  "body", sym->name, where);
1639       return FAILURE;
1640     }
1641
1642   sym->formal = formal;
1643   sym->attr.if_source = source;
1644
1645   return SUCCESS;
1646 }
1647
1648
1649 /* Add a type to a symbol.  */
1650
1651 gfc_try
1652 gfc_add_type (gfc_symbol *sym, gfc_typespec *ts, locus *where)
1653 {
1654   sym_flavor flavor;
1655   bt type;
1656
1657   if (where == NULL)
1658     where = &gfc_current_locus;
1659
1660   if (sym->result)
1661     type = sym->result->ts.type;
1662   else
1663     type = sym->ts.type;
1664
1665   if (sym->attr.result && type == BT_UNKNOWN && sym->ns->proc_name)
1666     type = sym->ns->proc_name->ts.type;
1667
1668   if (type != BT_UNKNOWN && !(sym->attr.function && sym->attr.implicit_type))
1669     {
1670       if (sym->attr.use_assoc)
1671         gfc_error ("Symbol '%s' at %L conflicts with symbol from module '%s', "
1672                    "use-associated at %L", sym->name, where, sym->module,
1673                    &sym->declared_at);
1674       else
1675         gfc_error ("Symbol '%s' at %L already has basic type of %s", sym->name,
1676                  where, gfc_basic_typename (type));
1677       return FAILURE;
1678     }
1679
1680   if (sym->attr.procedure && sym->ts.interface)
1681     {
1682       gfc_error ("Procedure '%s' at %L may not have basic type of %s",
1683                  sym->name, where, gfc_basic_typename (ts->type));
1684       return FAILURE;
1685     }
1686
1687   flavor = sym->attr.flavor;
1688
1689   if (flavor == FL_PROGRAM || flavor == FL_BLOCK_DATA || flavor == FL_MODULE
1690       || flavor == FL_LABEL
1691       || (flavor == FL_PROCEDURE && sym->attr.subroutine)
1692       || flavor == FL_DERIVED || flavor == FL_NAMELIST)
1693     {
1694       gfc_error ("Symbol '%s' at %L cannot have a type", sym->name, where);
1695       return FAILURE;
1696     }
1697
1698   sym->ts = *ts;
1699   return SUCCESS;
1700 }
1701
1702
1703 /* Clears all attributes.  */
1704
1705 void
1706 gfc_clear_attr (symbol_attribute *attr)
1707 {
1708   memset (attr, 0, sizeof (symbol_attribute));
1709 }
1710
1711
1712 /* Check for missing attributes in the new symbol.  Currently does
1713    nothing, but it's not clear that it is unnecessary yet.  */
1714
1715 gfc_try
1716 gfc_missing_attr (symbol_attribute *attr ATTRIBUTE_UNUSED,
1717                   locus *where ATTRIBUTE_UNUSED)
1718 {
1719
1720   return SUCCESS;
1721 }
1722
1723
1724 /* Copy an attribute to a symbol attribute, bit by bit.  Some
1725    attributes have a lot of side-effects but cannot be present given
1726    where we are called from, so we ignore some bits.  */
1727
1728 gfc_try
1729 gfc_copy_attr (symbol_attribute *dest, symbol_attribute *src, locus *where)
1730 {
1731   int is_proc_lang_bind_spec;
1732
1733   /* In line with the other attributes, we only add bits but do not remove
1734      them; cf. also PR 41034.  */
1735   dest->ext_attr |= src->ext_attr;
1736
1737   if (src->allocatable && gfc_add_allocatable (dest, where) == FAILURE)
1738     goto fail;
1739
1740   if (src->dimension && gfc_add_dimension (dest, NULL, where) == FAILURE)
1741     goto fail;
1742   if (src->codimension && gfc_add_codimension (dest, NULL, where) == FAILURE)
1743     goto fail;
1744   if (src->contiguous && gfc_add_contiguous (dest, NULL, where) == FAILURE)
1745     goto fail;
1746   if (src->optional && gfc_add_optional (dest, where) == FAILURE)
1747     goto fail;
1748   if (src->pointer && gfc_add_pointer (dest, where) == FAILURE)
1749     goto fail;
1750   if (src->is_protected && gfc_add_protected (dest, NULL, where) == FAILURE)
1751     goto fail;
1752   if (src->save && gfc_add_save (dest, src->save, NULL, where) == FAILURE)
1753     goto fail;
1754   if (src->value && gfc_add_value (dest, NULL, where) == FAILURE)
1755     goto fail;
1756   if (src->volatile_ && gfc_add_volatile (dest, NULL, where) == FAILURE)
1757     goto fail;
1758   if (src->asynchronous && gfc_add_asynchronous (dest, NULL, where) == FAILURE)
1759     goto fail;
1760   if (src->threadprivate
1761       && gfc_add_threadprivate (dest, NULL, where) == FAILURE)
1762     goto fail;
1763   if (src->target && gfc_add_target (dest, where) == FAILURE)
1764     goto fail;
1765   if (src->dummy && gfc_add_dummy (dest, NULL, where) == FAILURE)
1766     goto fail;
1767   if (src->result && gfc_add_result (dest, NULL, where) == FAILURE)
1768     goto fail;
1769   if (src->entry)
1770     dest->entry = 1;
1771
1772   if (src->in_namelist && gfc_add_in_namelist (dest, NULL, where) == FAILURE)
1773     goto fail;
1774
1775   if (src->in_common && gfc_add_in_common (dest, NULL, where) == FAILURE)
1776     goto fail;
1777
1778   if (src->generic && gfc_add_generic (dest, NULL, where) == FAILURE)
1779     goto fail;
1780   if (src->function && gfc_add_function (dest, NULL, where) == FAILURE)
1781     goto fail;
1782   if (src->subroutine && gfc_add_subroutine (dest, NULL, where) == FAILURE)
1783     goto fail;
1784
1785   if (src->sequence && gfc_add_sequence (dest, NULL, where) == FAILURE)
1786     goto fail;
1787   if (src->elemental && gfc_add_elemental (dest, where) == FAILURE)
1788     goto fail;
1789   if (src->pure && gfc_add_pure (dest, where) == FAILURE)
1790     goto fail;
1791   if (src->recursive && gfc_add_recursive (dest, where) == FAILURE)
1792     goto fail;
1793
1794   if (src->flavor != FL_UNKNOWN
1795       && gfc_add_flavor (dest, src->flavor, NULL, where) == FAILURE)
1796     goto fail;
1797
1798   if (src->intent != INTENT_UNKNOWN
1799       && gfc_add_intent (dest, src->intent, where) == FAILURE)
1800     goto fail;
1801
1802   if (src->access != ACCESS_UNKNOWN
1803       && gfc_add_access (dest, src->access, NULL, where) == FAILURE)
1804     goto fail;
1805
1806   if (gfc_missing_attr (dest, where) == FAILURE)
1807     goto fail;
1808
1809   if (src->cray_pointer && gfc_add_cray_pointer (dest, where) == FAILURE)
1810     goto fail;
1811   if (src->cray_pointee && gfc_add_cray_pointee (dest, where) == FAILURE)
1812     goto fail;
1813
1814   is_proc_lang_bind_spec = (src->flavor == FL_PROCEDURE ? 1 : 0);
1815   if (src->is_bind_c
1816       && gfc_add_is_bind_c (dest, NULL, where, is_proc_lang_bind_spec)
1817          != SUCCESS)
1818     return FAILURE;
1819
1820   if (src->is_c_interop)
1821     dest->is_c_interop = 1;
1822   if (src->is_iso_c)
1823     dest->is_iso_c = 1;
1824
1825   if (src->external && gfc_add_external (dest, where) == FAILURE)
1826     goto fail;
1827   if (src->intrinsic && gfc_add_intrinsic (dest, where) == FAILURE)
1828     goto fail;
1829   if (src->proc_pointer)
1830     dest->proc_pointer = 1;
1831
1832   return SUCCESS;
1833
1834 fail:
1835   return FAILURE;
1836 }
1837
1838
1839 /************** Component name management ************/
1840
1841 /* Component names of a derived type form their own little namespaces
1842    that are separate from all other spaces.  The space is composed of
1843    a singly linked list of gfc_component structures whose head is
1844    located in the parent symbol.  */
1845
1846
1847 /* Add a component name to a symbol.  The call fails if the name is
1848    already present.  On success, the component pointer is modified to
1849    point to the additional component structure.  */
1850
1851 gfc_try
1852 gfc_add_component (gfc_symbol *sym, const char *name,
1853                    gfc_component **component)
1854 {
1855   gfc_component *p, *tail;
1856
1857   tail = NULL;
1858
1859   for (p = sym->components; p; p = p->next)
1860     {
1861       if (strcmp (p->name, name) == 0)
1862         {
1863           gfc_error ("Component '%s' at %C already declared at %L",
1864                      name, &p->loc);
1865           return FAILURE;
1866         }
1867
1868       tail = p;
1869     }
1870
1871   if (sym->attr.extension
1872         && gfc_find_component (sym->components->ts.u.derived, name, true, true))
1873     {
1874       gfc_error ("Component '%s' at %C already in the parent type "
1875                  "at %L", name, &sym->components->ts.u.derived->declared_at);
1876       return FAILURE;
1877     }
1878
1879   /* Allocate a new component.  */
1880   p = gfc_get_component ();
1881
1882   if (tail == NULL)
1883     sym->components = p;
1884   else
1885     tail->next = p;
1886
1887   p->name = gfc_get_string (name);
1888   p->loc = gfc_current_locus;
1889   p->ts.type = BT_UNKNOWN;
1890
1891   *component = p;
1892   return SUCCESS;
1893 }
1894
1895
1896 /* Recursive function to switch derived types of all symbol in a
1897    namespace.  */
1898
1899 static void
1900 switch_types (gfc_symtree *st, gfc_symbol *from, gfc_symbol *to)
1901 {
1902   gfc_symbol *sym;
1903
1904   if (st == NULL)
1905     return;
1906
1907   sym = st->n.sym;
1908   if (sym->ts.type == BT_DERIVED && sym->ts.u.derived == from)
1909     sym->ts.u.derived = to;
1910
1911   switch_types (st->left, from, to);
1912   switch_types (st->right, from, to);
1913 }
1914
1915
1916 /* This subroutine is called when a derived type is used in order to
1917    make the final determination about which version to use.  The
1918    standard requires that a type be defined before it is 'used', but
1919    such types can appear in IMPLICIT statements before the actual
1920    definition.  'Using' in this context means declaring a variable to
1921    be that type or using the type constructor.
1922
1923    If a type is used and the components haven't been defined, then we
1924    have to have a derived type in a parent unit.  We find the node in
1925    the other namespace and point the symtree node in this namespace to
1926    that node.  Further reference to this name point to the correct
1927    node.  If we can't find the node in a parent namespace, then we have
1928    an error.
1929
1930    This subroutine takes a pointer to a symbol node and returns a
1931    pointer to the translated node or NULL for an error.  Usually there
1932    is no translation and we return the node we were passed.  */
1933
1934 gfc_symbol *
1935 gfc_use_derived (gfc_symbol *sym)
1936 {
1937   gfc_symbol *s;
1938   gfc_typespec *t;
1939   gfc_symtree *st;
1940   int i;
1941
1942   if (!sym)
1943     return NULL;
1944
1945   if (sym->attr.unlimited_polymorphic)
1946     return sym;
1947
1948   if (sym->attr.generic)
1949     sym = gfc_find_dt_in_generic (sym);
1950
1951   if (sym->components != NULL || sym->attr.zero_comp)
1952     return sym;               /* Already defined.  */
1953
1954   if (sym->ns->parent == NULL)
1955     goto bad;
1956
1957   if (gfc_find_symbol (sym->name, sym->ns->parent, 1, &s))
1958     {
1959       gfc_error ("Symbol '%s' at %C is ambiguous", sym->name);
1960       return NULL;
1961     }
1962
1963   if (s == NULL || s->attr.flavor != FL_DERIVED)
1964     goto bad;
1965
1966   /* Get rid of symbol sym, translating all references to s.  */
1967   for (i = 0; i < GFC_LETTERS; i++)
1968     {
1969       t = &sym->ns->default_type[i];
1970       if (t->u.derived == sym)
1971         t->u.derived = s;
1972     }
1973
1974   st = gfc_find_symtree (sym->ns->sym_root, sym->name);
1975   st->n.sym = s;
1976
1977   s->refs++;
1978
1979   /* Unlink from list of modified symbols.  */
1980   gfc_commit_symbol (sym);
1981
1982   switch_types (sym->ns->sym_root, sym, s);
1983
1984   /* TODO: Also have to replace sym -> s in other lists like
1985      namelists, common lists and interface lists.  */
1986   gfc_free_symbol (sym);
1987
1988   return s;
1989
1990 bad:
1991   gfc_error ("Derived type '%s' at %C is being used before it is defined",
1992              sym->name);
1993   return NULL;
1994 }
1995
1996
1997 /* Given a derived type node and a component name, try to locate the
1998    component structure.  Returns the NULL pointer if the component is
1999    not found or the components are private.  If noaccess is set, no access
2000    checks are done.  */
2001
2002 gfc_component *
2003 gfc_find_component (gfc_symbol *sym, const char *name,
2004                     bool noaccess, bool silent)
2005 {
2006   gfc_component *p;
2007
2008   if (name == NULL || sym == NULL)
2009     return NULL;
2010
2011   sym = gfc_use_derived (sym);
2012
2013   if (sym == NULL)
2014     return NULL;
2015
2016   for (p = sym->components; p; p = p->next)
2017     if (strcmp (p->name, name) == 0)
2018       break;
2019
2020   if (p && sym->attr.use_assoc && !noaccess)
2021     {
2022       bool is_parent_comp = sym->attr.extension && (p == sym->components);
2023       if (p->attr.access == ACCESS_PRIVATE ||
2024           (p->attr.access != ACCESS_PUBLIC
2025            && sym->component_access == ACCESS_PRIVATE
2026            && !is_parent_comp))
2027         {
2028           if (!silent)
2029             gfc_error ("Component '%s' at %C is a PRIVATE component of '%s'",
2030                        name, sym->name);
2031           return NULL;
2032         }
2033     }
2034
2035   if (p == NULL
2036         && sym->attr.extension
2037         && sym->components->ts.type == BT_DERIVED)
2038     {
2039       p = gfc_find_component (sym->components->ts.u.derived, name,
2040                               noaccess, silent);
2041       /* Do not overwrite the error.  */
2042       if (p == NULL)
2043         return p;
2044     }
2045
2046   if (p == NULL && !silent)
2047     gfc_error ("'%s' at %C is not a member of the '%s' structure",
2048                name, sym->name);
2049
2050   return p;
2051 }
2052
2053
2054 /* Given a symbol, free all of the component structures and everything
2055    they point to.  */
2056
2057 static void
2058 free_components (gfc_component *p)
2059 {
2060   gfc_component *q;
2061
2062   for (; p; p = q)
2063     {
2064       q = p->next;
2065
2066       gfc_free_array_spec (p->as);
2067       gfc_free_expr (p->initializer);
2068       free (p->tb);
2069
2070       free (p);
2071     }
2072 }
2073
2074
2075 /******************** Statement label management ********************/
2076
2077 /* Comparison function for statement labels, used for managing the
2078    binary tree.  */
2079
2080 static int
2081 compare_st_labels (void *a1, void *b1)
2082 {
2083   int a = ((gfc_st_label *) a1)->value;
2084   int b = ((gfc_st_label *) b1)->value;
2085
2086   return (b - a);
2087 }
2088
2089
2090 /* Free a single gfc_st_label structure, making sure the tree is not
2091    messed up.  This function is called only when some parse error
2092    occurs.  */
2093
2094 void
2095 gfc_free_st_label (gfc_st_label *label)
2096 {
2097
2098   if (label == NULL)
2099     return;
2100
2101   gfc_delete_bbt (&gfc_current_ns->st_labels, label, compare_st_labels);
2102
2103   if (label->format != NULL)
2104     gfc_free_expr (label->format);
2105
2106   free (label);
2107 }
2108
2109
2110 /* Free a whole tree of gfc_st_label structures.  */
2111
2112 static void
2113 free_st_labels (gfc_st_label *label)
2114 {
2115
2116   if (label == NULL)
2117     return;
2118
2119   free_st_labels (label->left);
2120   free_st_labels (label->right);
2121
2122   if (label->format != NULL)
2123     gfc_free_expr (label->format);
2124   free (label);
2125 }
2126
2127
2128 /* Given a label number, search for and return a pointer to the label
2129    structure, creating it if it does not exist.  */
2130
2131 gfc_st_label *
2132 gfc_get_st_label (int labelno)
2133 {
2134   gfc_st_label *lp;
2135   gfc_namespace *ns;
2136
2137   if (gfc_current_state () == COMP_DERIVED)
2138     ns = gfc_current_block ()->f2k_derived;
2139   else
2140     {
2141       /* Find the namespace of the scoping unit:
2142          If we're in a BLOCK construct, jump to the parent namespace.  */
2143       ns = gfc_current_ns;
2144       while (ns->proc_name && ns->proc_name->attr.flavor == FL_LABEL)
2145         ns = ns->parent;
2146     }
2147
2148   /* First see if the label is already in this namespace.  */
2149   lp = ns->st_labels;
2150   while (lp)
2151     {
2152       if (lp->value == labelno)
2153         return lp;
2154
2155       if (lp->value < labelno)
2156         lp = lp->left;
2157       else
2158         lp = lp->right;
2159     }
2160
2161   lp = XCNEW (gfc_st_label);
2162
2163   lp->value = labelno;
2164   lp->defined = ST_LABEL_UNKNOWN;
2165   lp->referenced = ST_LABEL_UNKNOWN;
2166
2167   gfc_insert_bbt (&ns->st_labels, lp, compare_st_labels);
2168
2169   return lp;
2170 }
2171
2172
2173 /* Called when a statement with a statement label is about to be
2174    accepted.  We add the label to the list of the current namespace,
2175    making sure it hasn't been defined previously and referenced
2176    correctly.  */
2177
2178 void
2179 gfc_define_st_label (gfc_st_label *lp, gfc_sl_type type, locus *label_locus)
2180 {
2181   int labelno;
2182
2183   labelno = lp->value;
2184
2185   if (lp->defined != ST_LABEL_UNKNOWN)
2186     gfc_error ("Duplicate statement label %d at %L and %L", labelno,
2187                &lp->where, label_locus);
2188   else
2189     {
2190       lp->where = *label_locus;
2191
2192       switch (type)
2193         {
2194         case ST_LABEL_FORMAT:
2195           if (lp->referenced == ST_LABEL_TARGET
2196               || lp->referenced == ST_LABEL_DO_TARGET)
2197             gfc_error ("Label %d at %C already referenced as branch target",
2198                        labelno);
2199           else
2200             lp->defined = ST_LABEL_FORMAT;
2201
2202           break;
2203
2204         case ST_LABEL_TARGET:
2205         case ST_LABEL_DO_TARGET:
2206           if (lp->referenced == ST_LABEL_FORMAT)
2207             gfc_error ("Label %d at %C already referenced as a format label",
2208                        labelno);
2209           else
2210             lp->defined = type;
2211
2212           if (lp->referenced == ST_LABEL_DO_TARGET && type != ST_LABEL_DO_TARGET
2213               && gfc_notify_std (GFC_STD_F95_OBS, "DO termination statement "
2214                                  "which is not END DO or CONTINUE with label "
2215                                  "%d at %C", labelno) == FAILURE)
2216             return;
2217           break;
2218
2219         default:
2220           lp->defined = ST_LABEL_BAD_TARGET;
2221           lp->referenced = ST_LABEL_BAD_TARGET;
2222         }
2223     }
2224 }
2225
2226
2227 /* Reference a label.  Given a label and its type, see if that
2228    reference is consistent with what is known about that label,
2229    updating the unknown state.  Returns FAILURE if something goes
2230    wrong.  */
2231
2232 gfc_try
2233 gfc_reference_st_label (gfc_st_label *lp, gfc_sl_type type)
2234 {
2235   gfc_sl_type label_type;
2236   int labelno;
2237   gfc_try rc;
2238
2239   if (lp == NULL)
2240     return SUCCESS;
2241
2242   labelno = lp->value;
2243
2244   if (lp->defined != ST_LABEL_UNKNOWN)
2245     label_type = lp->defined;
2246   else
2247     {
2248       label_type = lp->referenced;
2249       lp->where = gfc_current_locus;
2250     }
2251
2252   if (label_type == ST_LABEL_FORMAT
2253       && (type == ST_LABEL_TARGET || type == ST_LABEL_DO_TARGET))
2254     {
2255       gfc_error ("Label %d at %C previously used as a FORMAT label", labelno);
2256       rc = FAILURE;
2257       goto done;
2258     }
2259
2260   if ((label_type == ST_LABEL_TARGET || label_type == ST_LABEL_DO_TARGET
2261        || label_type == ST_LABEL_BAD_TARGET)
2262       && type == ST_LABEL_FORMAT)
2263     {
2264       gfc_error ("Label %d at %C previously used as branch target", labelno);
2265       rc = FAILURE;
2266       goto done;
2267     }
2268
2269   if (lp->referenced == ST_LABEL_DO_TARGET && type == ST_LABEL_DO_TARGET
2270       && gfc_notify_std (GFC_STD_F95_OBS, "Shared DO termination label %d "
2271                          "at %C", labelno) == FAILURE)
2272     return FAILURE;
2273
2274   if (lp->referenced != ST_LABEL_DO_TARGET)
2275     lp->referenced = type;
2276   rc = SUCCESS;
2277
2278 done:
2279   return rc;
2280 }
2281
2282
2283 /************** Symbol table management subroutines ****************/
2284
2285 /* Basic details: Fortran 95 requires a potentially unlimited number
2286    of distinct namespaces when compiling a program unit.  This case
2287    occurs during a compilation of internal subprograms because all of
2288    the internal subprograms must be read before we can start
2289    generating code for the host.
2290
2291    Given the tricky nature of the Fortran grammar, we must be able to
2292    undo changes made to a symbol table if the current interpretation
2293    of a statement is found to be incorrect.  Whenever a symbol is
2294    looked up, we make a copy of it and link to it.  All of these
2295    symbols are kept in a vector so that we can commit or
2296    undo the changes at a later time.
2297
2298    A symtree may point to a symbol node outside of its namespace.  In
2299    this case, that symbol has been used as a host associated variable
2300    at some previous time.  */
2301
2302 /* Allocate a new namespace structure.  Copies the implicit types from
2303    PARENT if PARENT_TYPES is set.  */
2304
2305 gfc_namespace *
2306 gfc_get_namespace (gfc_namespace *parent, int parent_types)
2307 {
2308   gfc_namespace *ns;
2309   gfc_typespec *ts;
2310   int in;
2311   int i;
2312
2313   ns = XCNEW (gfc_namespace);
2314   ns->sym_root = NULL;
2315   ns->uop_root = NULL;
2316   ns->tb_sym_root = NULL;
2317   ns->finalizers = NULL;
2318   ns->default_access = ACCESS_UNKNOWN;
2319   ns->parent = parent;
2320
2321   for (in = GFC_INTRINSIC_BEGIN; in != GFC_INTRINSIC_END; in++)
2322     {
2323       ns->operator_access[in] = ACCESS_UNKNOWN;
2324       ns->tb_op[in] = NULL;
2325     }
2326
2327   /* Initialize default implicit types.  */
2328   for (i = 'a'; i <= 'z'; i++)
2329     {
2330       ns->set_flag[i - 'a'] = 0;
2331       ts = &ns->default_type[i - 'a'];
2332
2333       if (parent_types && ns->parent != NULL)
2334         {
2335           /* Copy parent settings.  */
2336           *ts = ns->parent->default_type[i - 'a'];
2337           continue;
2338         }
2339
2340       if (gfc_option.flag_implicit_none != 0)
2341         {
2342           gfc_clear_ts (ts);
2343           continue;
2344         }
2345
2346       if ('i' <= i && i <= 'n')
2347         {
2348           ts->type = BT_INTEGER;
2349           ts->kind = gfc_default_integer_kind;
2350         }
2351       else
2352         {
2353           ts->type = BT_REAL;
2354           ts->kind = gfc_default_real_kind;
2355         }
2356     }
2357
2358   ns->refs = 1;
2359
2360   return ns;
2361 }
2362
2363
2364 /* Comparison function for symtree nodes.  */
2365
2366 static int
2367 compare_symtree (void *_st1, void *_st2)
2368 {
2369   gfc_symtree *st1, *st2;
2370
2371   st1 = (gfc_symtree *) _st1;
2372   st2 = (gfc_symtree *) _st2;
2373
2374   return strcmp (st1->name, st2->name);
2375 }
2376
2377
2378 /* Allocate a new symtree node and associate it with the new symbol.  */
2379
2380 gfc_symtree *
2381 gfc_new_symtree (gfc_symtree **root, const char *name)
2382 {
2383   gfc_symtree *st;
2384
2385   st = XCNEW (gfc_symtree);
2386   st->name = gfc_get_string (name);
2387
2388   gfc_insert_bbt (root, st, compare_symtree);
2389   return st;
2390 }
2391
2392
2393 /* Delete a symbol from the tree.  Does not free the symbol itself!  */
2394
2395 void
2396 gfc_delete_symtree (gfc_symtree **root, const char *name)
2397 {
2398   gfc_symtree st, *st0;
2399
2400   st0 = gfc_find_symtree (*root, name);
2401
2402   st.name = gfc_get_string (name);
2403   gfc_delete_bbt (root, &st, compare_symtree);
2404
2405   free (st0);
2406 }
2407
2408
2409 /* Given a root symtree node and a name, try to find the symbol within
2410    the namespace.  Returns NULL if the symbol is not found.  */
2411
2412 gfc_symtree *
2413 gfc_find_symtree (gfc_symtree *st, const char *name)
2414 {
2415   int c;
2416
2417   while (st != NULL)
2418     {
2419       c = strcmp (name, st->name);
2420       if (c == 0)
2421         return st;
2422
2423       st = (c < 0) ? st->left : st->right;
2424     }
2425
2426   return NULL;
2427 }
2428
2429
2430 /* Return a symtree node with a name that is guaranteed to be unique
2431    within the namespace and corresponds to an illegal fortran name.  */
2432
2433 gfc_symtree *
2434 gfc_get_unique_symtree (gfc_namespace *ns)
2435 {
2436   char name[GFC_MAX_SYMBOL_LEN + 1];
2437   static int serial = 0;
2438
2439   sprintf (name, "@%d", serial++);
2440   return gfc_new_symtree (&ns->sym_root, name);
2441 }
2442
2443
2444 /* Given a name find a user operator node, creating it if it doesn't
2445    exist.  These are much simpler than symbols because they can't be
2446    ambiguous with one another.  */
2447
2448 gfc_user_op *
2449 gfc_get_uop (const char *name)
2450 {
2451   gfc_user_op *uop;
2452   gfc_symtree *st;
2453
2454   st = gfc_find_symtree (gfc_current_ns->uop_root, name);
2455   if (st != NULL)
2456     return st->n.uop;
2457
2458   st = gfc_new_symtree (&gfc_current_ns->uop_root, name);
2459
2460   uop = st->n.uop = XCNEW (gfc_user_op);
2461   uop->name = gfc_get_string (name);
2462   uop->access = ACCESS_UNKNOWN;
2463   uop->ns = gfc_current_ns;
2464
2465   return uop;
2466 }
2467
2468
2469 /* Given a name find the user operator node.  Returns NULL if it does
2470    not exist.  */
2471
2472 gfc_user_op *
2473 gfc_find_uop (const char *name, gfc_namespace *ns)
2474 {
2475   gfc_symtree *st;
2476
2477   if (ns == NULL)
2478     ns = gfc_current_ns;
2479
2480   st = gfc_find_symtree (ns->uop_root, name);
2481   return (st == NULL) ? NULL : st->n.uop;
2482 }
2483
2484
2485 /* Remove a gfc_symbol structure and everything it points to.  */
2486
2487 void
2488 gfc_free_symbol (gfc_symbol *sym)
2489 {
2490
2491   if (sym == NULL)
2492     return;
2493
2494   gfc_free_array_spec (sym->as);
2495
2496   free_components (sym->components);
2497
2498   gfc_free_expr (sym->value);
2499
2500   gfc_free_namelist (sym->namelist);
2501
2502   if (sym->ns != sym->formal_ns)
2503     gfc_free_namespace (sym->formal_ns);
2504
2505   if (!sym->attr.generic_copy)
2506     gfc_free_interface (sym->generic);
2507
2508   gfc_free_formal_arglist (sym->formal);
2509
2510   gfc_free_namespace (sym->f2k_derived);
2511
2512   if (sym->common_block && sym->common_block->name[0] != '\0')
2513     {
2514       sym->common_block->refs--;
2515       if (sym->common_block->refs == 0)
2516         free (sym->common_block);
2517     }
2518
2519   free (sym);
2520 }
2521
2522
2523 /* Decrease the reference counter and free memory when we reach zero.  */
2524
2525 void
2526 gfc_release_symbol (gfc_symbol *sym)
2527 {
2528   if (sym == NULL)
2529     return;
2530
2531   if (sym->formal_ns != NULL && sym->refs == 2 && sym->formal_ns != sym->ns
2532       && (!sym->attr.entry || !sym->module))
2533     {
2534       /* As formal_ns contains a reference to sym, delete formal_ns just
2535          before the deletion of sym.  */
2536       gfc_namespace *ns = sym->formal_ns;
2537       sym->formal_ns = NULL;
2538       gfc_free_namespace (ns);
2539     }
2540
2541   sym->refs--;
2542   if (sym->refs > 0)
2543     return;
2544
2545   gcc_assert (sym->refs == 0);
2546   gfc_free_symbol (sym);
2547 }
2548
2549
2550 /* Allocate and initialize a new symbol node.  */
2551
2552 gfc_symbol *
2553 gfc_new_symbol (const char *name, gfc_namespace *ns)
2554 {
2555   gfc_symbol *p;
2556
2557   p = XCNEW (gfc_symbol);
2558
2559   gfc_clear_ts (&p->ts);
2560   gfc_clear_attr (&p->attr);
2561   p->ns = ns;
2562
2563   p->declared_at = gfc_current_locus;
2564
2565   if (strlen (name) > GFC_MAX_SYMBOL_LEN)
2566     gfc_internal_error ("new_symbol(): Symbol name too long");
2567
2568   p->name = gfc_get_string (name);
2569
2570   /* Make sure flags for symbol being C bound are clear initially.  */
2571   p->attr.is_bind_c = 0;
2572   p->attr.is_iso_c = 0;
2573
2574   /* Clear the ptrs we may need.  */
2575   p->common_block = NULL;
2576   p->f2k_derived = NULL;
2577   p->assoc = NULL;
2578
2579   return p;
2580 }
2581
2582
2583 /* Generate an error if a symbol is ambiguous.  */
2584
2585 static void
2586 ambiguous_symbol (const char *name, gfc_symtree *st)
2587 {
2588
2589   if (st->n.sym->module)
2590     gfc_error ("Name '%s' at %C is an ambiguous reference to '%s' "
2591                "from module '%s'", name, st->n.sym->name, st->n.sym->module);
2592   else
2593     gfc_error ("Name '%s' at %C is an ambiguous reference to '%s' "
2594                "from current program unit", name, st->n.sym->name);
2595 }
2596
2597
2598 /* If we're in a SELECT TYPE block, check if the variable 'st' matches any
2599    selector on the stack. If yes, replace it by the corresponding temporary.  */
2600
2601 static void
2602 select_type_insert_tmp (gfc_symtree **st)
2603 {
2604   gfc_select_type_stack *stack = select_type_stack;
2605   for (; stack; stack = stack->prev)
2606     if ((*st)->n.sym == stack->selector && stack->tmp)
2607       *st = stack->tmp;
2608 }
2609
2610
2611 /* Look for a symtree in the current procedure -- that is, go up to
2612    parent namespaces but only if inside a BLOCK.  Returns NULL if not found.  */
2613
2614 gfc_symtree*
2615 gfc_find_symtree_in_proc (const char* name, gfc_namespace* ns)
2616 {
2617   while (ns)
2618     {
2619       gfc_symtree* st = gfc_find_symtree (ns->sym_root, name);
2620       if (st)
2621         return st;
2622
2623       if (!ns->construct_entities)
2624         break;
2625       ns = ns->parent;
2626     }
2627
2628   return NULL;
2629 }
2630
2631
2632 /* Search for a symtree starting in the current namespace, resorting to
2633    any parent namespaces if requested by a nonzero parent_flag.
2634    Returns nonzero if the name is ambiguous.  */
2635
2636 int
2637 gfc_find_sym_tree (const char *name, gfc_namespace *ns, int parent_flag,
2638                    gfc_symtree **result)
2639 {
2640   gfc_symtree *st;
2641
2642   if (ns == NULL)
2643     ns = gfc_current_ns;
2644
2645   do
2646     {
2647       st = gfc_find_symtree (ns->sym_root, name);
2648       if (st != NULL)
2649         {
2650           select_type_insert_tmp (&st);
2651
2652           *result = st;
2653           /* Ambiguous generic interfaces are permitted, as long
2654              as the specific interfaces are different.  */
2655           if (st->ambiguous && !st->n.sym->attr.generic)
2656             {
2657               ambiguous_symbol (name, st);
2658               return 1;
2659             }
2660
2661           return 0;
2662         }
2663
2664       if (!parent_flag)
2665         break;
2666
2667       /* Don't escape an interface block.  */
2668       if (ns && !ns->has_import_set
2669           && ns->proc_name && ns->proc_name->attr.if_source == IFSRC_IFBODY)
2670         break;
2671
2672       ns = ns->parent;
2673     }
2674   while (ns != NULL);
2675
2676   *result = NULL;
2677   return 0;
2678 }
2679
2680
2681 /* Same, but returns the symbol instead.  */
2682
2683 int
2684 gfc_find_symbol (const char *name, gfc_namespace *ns, int parent_flag,
2685                  gfc_symbol **result)
2686 {
2687   gfc_symtree *st;
2688   int i;
2689
2690   i = gfc_find_sym_tree (name, ns, parent_flag, &st);
2691
2692   if (st == NULL)
2693     *result = NULL;
2694   else
2695     *result = st->n.sym;
2696
2697   return i;
2698 }
2699
2700
2701 /* Save symbol with the information necessary to back it out.  */
2702
2703 static void
2704 save_symbol_data (gfc_symbol *sym)
2705 {
2706
2707   if (sym->gfc_new || sym->old_symbol != NULL)
2708     return;
2709
2710   sym->old_symbol = XCNEW (gfc_symbol);
2711   *(sym->old_symbol) = *sym;
2712
2713   latest_undo_chgset->syms.safe_push (sym);
2714 }
2715
2716
2717 /* Given a name, find a symbol, or create it if it does not exist yet
2718    in the current namespace.  If the symbol is found we make sure that
2719    it's OK.
2720
2721    The integer return code indicates
2722      0   All OK
2723      1   The symbol name was ambiguous
2724      2   The name meant to be established was already host associated.
2725
2726    So if the return value is nonzero, then an error was issued.  */
2727
2728 int
2729 gfc_get_sym_tree (const char *name, gfc_namespace *ns, gfc_symtree **result,
2730                   bool allow_subroutine)
2731 {
2732   gfc_symtree *st;
2733   gfc_symbol *p;
2734
2735   /* This doesn't usually happen during resolution.  */
2736   if (ns == NULL)
2737     ns = gfc_current_ns;
2738
2739   /* Try to find the symbol in ns.  */
2740   st = gfc_find_symtree (ns->sym_root, name);
2741
2742   if (st == NULL)
2743     {
2744       /* If not there, create a new symbol.  */
2745       p = gfc_new_symbol (name, ns);
2746
2747       /* Add to the list of tentative symbols.  */
2748       p->old_symbol = NULL;
2749       p->mark = 1;
2750       p->gfc_new = 1;
2751       latest_undo_chgset->syms.safe_push (p);
2752
2753       st = gfc_new_symtree (&ns->sym_root, name);
2754       st->n.sym = p;
2755       p->refs++;
2756
2757     }
2758   else
2759     {
2760       /* Make sure the existing symbol is OK.  Ambiguous
2761          generic interfaces are permitted, as long as the
2762          specific interfaces are different.  */
2763       if (st->ambiguous && !st->n.sym->attr.generic)
2764         {
2765           ambiguous_symbol (name, st);
2766           return 1;
2767         }
2768
2769       p = st->n.sym;
2770       if (p->ns != ns && (!p->attr.function || ns->proc_name != p)
2771           && !(allow_subroutine && p->attr.subroutine)
2772           && !(ns->proc_name && ns->proc_name->attr.if_source == IFSRC_IFBODY
2773           && (ns->has_import_set || p->attr.imported)))
2774         {
2775           /* Symbol is from another namespace.  */
2776           gfc_error ("Symbol '%s' at %C has already been host associated",
2777                      name);
2778           return 2;
2779         }
2780
2781       p->mark = 1;
2782
2783       /* Copy in case this symbol is changed.  */
2784       save_symbol_data (p);
2785     }
2786
2787   *result = st;
2788   return 0;
2789 }
2790
2791
2792 int
2793 gfc_get_symbol (const char *name, gfc_namespace *ns, gfc_symbol **result)
2794 {
2795   gfc_symtree *st;
2796   int i;
2797
2798   i = gfc_get_sym_tree (name, ns, &st, false);
2799   if (i != 0)
2800     return i;
2801
2802   if (st)
2803     *result = st->n.sym;
2804   else
2805     *result = NULL;
2806   return i;
2807 }
2808
2809
2810 /* Subroutine that searches for a symbol, creating it if it doesn't
2811    exist, but tries to host-associate the symbol if possible.  */
2812
2813 int
2814 gfc_get_ha_sym_tree (const char *name, gfc_symtree **result)
2815 {
2816   gfc_symtree *st;
2817   int i;
2818
2819   i = gfc_find_sym_tree (name, gfc_current_ns, 0, &st);
2820
2821   if (st != NULL)
2822     {
2823       save_symbol_data (st->n.sym);
2824       *result = st;
2825       return i;
2826     }
2827
2828   i = gfc_find_sym_tree (name, gfc_current_ns, 1, &st);
2829   if (i)
2830     return i;
2831
2832   if (st != NULL)
2833     {
2834       *result = st;
2835       return 0;
2836     }
2837
2838   return gfc_get_sym_tree (name, gfc_current_ns, result, false);
2839 }
2840
2841
2842 int
2843 gfc_get_ha_symbol (const char *name, gfc_symbol **result)
2844 {
2845   int i;
2846   gfc_symtree *st;
2847
2848   i = gfc_get_ha_sym_tree (name, &st);
2849
2850   if (st)
2851     *result = st->n.sym;
2852   else
2853     *result = NULL;
2854
2855   return i;
2856 }
2857
2858
2859 /* Search for the symtree belonging to a gfc_common_head; we cannot use
2860    head->name as the common_root symtree's name might be mangled.  */
2861
2862 static gfc_symtree *
2863 find_common_symtree (gfc_symtree *st, gfc_common_head *head)
2864 {
2865
2866   gfc_symtree *result;
2867
2868   if (st == NULL)
2869     return NULL;
2870
2871   if (st->n.common == head)
2872     return st;
2873
2874   result = find_common_symtree (st->left, head);
2875   if (!result)
2876     result = find_common_symtree (st->right, head);
2877
2878   return result;
2879 }
2880
2881
2882 /* Restore previous state of symbol.  Just copy simple stuff.  */
2883
2884 static void
2885 restore_old_symbol (gfc_symbol *p)
2886 {
2887   gfc_symbol *old;
2888
2889   p->mark = 0;
2890   old = p->old_symbol;
2891
2892   p->ts.type = old->ts.type;
2893   p->ts.kind = old->ts.kind;
2894
2895   p->attr = old->attr;
2896
2897   if (p->value != old->value)
2898     {
2899       gfc_free_expr (old->value);
2900       p->value = NULL;
2901     }
2902
2903   if (p->as != old->as)
2904     {
2905       if (p->as)
2906         gfc_free_array_spec (p->as);
2907       p->as = old->as;
2908     }
2909
2910   p->generic = old->generic;
2911   p->component_access = old->component_access;
2912
2913   if (p->namelist != NULL && old->namelist == NULL)
2914     {
2915       gfc_free_namelist (p->namelist);
2916       p->namelist = NULL;
2917     }
2918   else
2919     {
2920       if (p->namelist_tail != old->namelist_tail)
2921         {
2922           gfc_free_namelist (old->namelist_tail->next);
2923           old->namelist_tail->next = NULL;
2924         }
2925     }
2926
2927   p->namelist_tail = old->namelist_tail;
2928
2929   if (p->formal != old->formal)
2930     {
2931       gfc_free_formal_arglist (p->formal);
2932       p->formal = old->formal;
2933     }
2934
2935   free (p->old_symbol);
2936   p->old_symbol = NULL;
2937 }
2938
2939
2940 /* Undoes all the changes made to symbols in the current statement.
2941    This subroutine is made simpler due to the fact that attributes are
2942    never removed once added.  */
2943
2944 void
2945 gfc_undo_symbols (void)
2946 {
2947   gfc_symbol *p;
2948   unsigned i;
2949
2950   FOR_EACH_VEC_ELT (latest_undo_chgset->syms, i, p)
2951     {
2952       if (p->gfc_new)
2953         {
2954           /* Symbol was new.  */
2955           if (p->attr.in_common && p->common_block && p->common_block->head)
2956             {
2957               /* If the symbol was added to any common block, it
2958                  needs to be removed to stop the resolver looking
2959                  for a (possibly) dead symbol.  */
2960
2961               if (p->common_block->head == p && !p->common_next)
2962                 {
2963                   gfc_symtree st, *st0;
2964                   st0 = find_common_symtree (p->ns->common_root,
2965                                              p->common_block);
2966                   if (st0)
2967                     {
2968                       st.name = st0->name;
2969                       gfc_delete_bbt (&p->ns->common_root, &st, compare_symtree);
2970                       free (st0);
2971                     }
2972                 }
2973
2974               if (p->common_block->head == p)
2975                 p->common_block->head = p->common_next;
2976               else
2977                 {
2978                   gfc_symbol *cparent, *csym;
2979
2980                   cparent = p->common_block->head;
2981                   csym = cparent->common_next;
2982
2983                   while (csym != p)
2984                     {
2985                       cparent = csym;
2986                       csym = csym->common_next;
2987                     }
2988
2989                   gcc_assert(cparent->common_next == p);
2990
2991                   cparent->common_next = csym->common_next;
2992                 }
2993             }
2994
2995           /* The derived type is saved in the symtree with the first
2996              letter capitalized; the all lower-case version to the
2997              derived type contains its associated generic function.  */
2998           if (p->attr.flavor == FL_DERIVED)
2999             gfc_delete_symtree (&p->ns->sym_root, gfc_get_string ("%c%s",
3000                         (char) TOUPPER ((unsigned char) p->name[0]),
3001                         &p->name[1]));
3002           else
3003             gfc_delete_symtree (&p->ns->sym_root, p->name);
3004
3005           gfc_release_symbol (p);
3006         }
3007       else
3008         restore_old_symbol (p);
3009     }
3010
3011   latest_undo_chgset->syms.truncate (0);
3012   latest_undo_chgset->tbps.truncate (0);
3013 }
3014
3015
3016 /* Free sym->old_symbol. sym->old_symbol is mostly a shallow copy of sym; the
3017    components of old_symbol that might need deallocation are the "allocatables"
3018    that are restored in gfc_undo_symbols(), with two exceptions: namelist and
3019    namelist_tail.  In case these differ between old_symbol and sym, it's just
3020    because sym->namelist has gotten a few more items.  */
3021
3022 static void
3023 free_old_symbol (gfc_symbol *sym)
3024 {
3025
3026   if (sym->old_symbol == NULL)
3027     return;
3028
3029   if (sym->old_symbol->as != sym->as)
3030     gfc_free_array_spec (sym->old_symbol->as);
3031
3032   if (sym->old_symbol->value != sym->value)
3033     gfc_free_expr (sym->old_symbol->value);
3034
3035   if (sym->old_symbol->formal != sym->formal)
3036     gfc_free_formal_arglist (sym->old_symbol->formal);
3037
3038   free (sym->old_symbol);
3039   sym->old_symbol = NULL;
3040 }
3041
3042
3043 /* Makes the changes made in the current statement permanent-- gets
3044    rid of undo information.  */
3045
3046 void
3047 gfc_commit_symbols (void)
3048 {
3049   gfc_symbol *p;
3050   gfc_typebound_proc *tbp;
3051   unsigned i;
3052
3053   FOR_EACH_VEC_ELT (latest_undo_chgset->syms, i, p)
3054     {
3055       p->mark = 0;
3056       p->gfc_new = 0;
3057       free_old_symbol (p);
3058     }
3059   latest_undo_chgset->syms.truncate (0);
3060
3061   FOR_EACH_VEC_ELT (latest_undo_chgset->tbps, i, tbp)
3062     tbp->error = 0;
3063   latest_undo_chgset->tbps.truncate (0);
3064 }
3065
3066
3067 /* Makes the changes made in one symbol permanent -- gets rid of undo
3068    information.  */
3069
3070 void
3071 gfc_commit_symbol (gfc_symbol *sym)
3072 {
3073   gfc_symbol *p;
3074   unsigned i;
3075
3076   FOR_EACH_VEC_ELT (latest_undo_chgset->syms, i, p)
3077     if (p == sym)
3078       {
3079         latest_undo_chgset->syms.unordered_remove (i);
3080         break;
3081       }
3082
3083   sym->mark = 0;
3084   sym->gfc_new = 0;
3085
3086   free_old_symbol (sym);
3087 }
3088
3089
3090 /* Recursively free trees containing type-bound procedures.  */
3091
3092 static void
3093 free_tb_tree (gfc_symtree *t)
3094 {
3095   if (t == NULL)
3096     return;
3097
3098   free_tb_tree (t->left);
3099   free_tb_tree (t->right);
3100
3101   /* TODO: Free type-bound procedure structs themselves; probably needs some
3102      sort of ref-counting mechanism.  */
3103
3104   free (t);
3105 }
3106
3107
3108 /* Recursive function that deletes an entire tree and all the common
3109    head structures it points to.  */
3110
3111 static void
3112 free_common_tree (gfc_symtree * common_tree)
3113 {
3114   if (common_tree == NULL)
3115     return;
3116
3117   free_common_tree (common_tree->left);
3118   free_common_tree (common_tree->right);
3119
3120   free (common_tree);
3121 }
3122
3123
3124 /* Recursive function that deletes an entire tree and all the user
3125    operator nodes that it contains.  */
3126
3127 static void
3128 free_uop_tree (gfc_symtree *uop_tree)
3129 {
3130   if (uop_tree == NULL)
3131     return;
3132
3133   free_uop_tree (uop_tree->left);
3134   free_uop_tree (uop_tree->right);
3135
3136   gfc_free_interface (uop_tree->n.uop->op);
3137   free (uop_tree->n.uop);
3138   free (uop_tree);
3139 }
3140
3141
3142 /* Recursive function that deletes an entire tree and all the symbols
3143    that it contains.  */
3144
3145 static void
3146 free_sym_tree (gfc_symtree *sym_tree)
3147 {
3148   if (sym_tree == NULL)
3149     return;
3150
3151   free_sym_tree (sym_tree->left);
3152   free_sym_tree (sym_tree->right);
3153
3154   gfc_release_symbol (sym_tree->n.sym);
3155   free (sym_tree);
3156 }
3157
3158
3159 /* Free the derived type list.  */
3160
3161 void
3162 gfc_free_dt_list (void)
3163 {
3164   gfc_dt_list *dt, *n;
3165
3166   for (dt = gfc_derived_types; dt; dt = n)
3167     {
3168       n = dt->next;
3169       free (dt);
3170     }
3171
3172   gfc_derived_types = NULL;
3173 }
3174
3175
3176 /* Free the gfc_equiv_info's.  */
3177
3178 static void
3179 gfc_free_equiv_infos (gfc_equiv_info *s)
3180 {
3181   if (s == NULL)
3182     return;
3183   gfc_free_equiv_infos (s->next);
3184   free (s);
3185 }
3186
3187
3188 /* Free the gfc_equiv_lists.  */
3189
3190 static void
3191 gfc_free_equiv_lists (gfc_equiv_list *l)
3192 {
3193   if (l == NULL)
3194     return;
3195   gfc_free_equiv_lists (l->next);
3196   gfc_free_equiv_infos (l->equiv);
3197   free (l);
3198 }
3199
3200
3201 /* Free a finalizer procedure list.  */
3202
3203 void
3204 gfc_free_finalizer (gfc_finalizer* el)
3205 {
3206   if (el)
3207     {
3208       gfc_release_symbol (el->proc_sym);
3209       free (el);
3210     }
3211 }
3212
3213 static void
3214 gfc_free_finalizer_list (gfc_finalizer* list)
3215 {
3216   while (list)
3217     {
3218       gfc_finalizer* current = list;
3219       list = list->next;
3220       gfc_free_finalizer (current);
3221     }
3222 }
3223
3224
3225 /* Create a new gfc_charlen structure and add it to a namespace.
3226    If 'old_cl' is given, the newly created charlen will be a copy of it.  */
3227
3228 gfc_charlen*
3229 gfc_new_charlen (gfc_namespace *ns, gfc_charlen *old_cl)
3230 {
3231   gfc_charlen *cl;
3232   cl = gfc_get_charlen ();
3233
3234   /* Copy old_cl.  */
3235   if (old_cl)
3236     {
3237       /* Put into namespace, but don't allow reject_statement
3238          to free it if old_cl is given.  */
3239       gfc_charlen **prev = &ns->cl_list;
3240       cl->next = ns->old_cl_list;
3241       while (*prev != ns->old_cl_list)
3242         prev = &(*prev)->next;
3243       *prev = cl;
3244       ns->old_cl_list = cl;
3245       cl->length = gfc_copy_expr (old_cl->length);
3246       cl->length_from_typespec = old_cl->length_from_typespec;
3247       cl->backend_decl = old_cl->backend_decl;
3248       cl->passed_length = old_cl->passed_length;
3249       cl->resolved = old_cl->resolved;
3250     }
3251   else
3252     {
3253       /* Put into namespace.  */
3254       cl->next = ns->cl_list;
3255       ns->cl_list = cl;
3256     }
3257
3258   return cl;
3259 }
3260
3261
3262 /* Free the charlen list from cl to end (end is not freed).
3263    Free the whole list if end is NULL.  */
3264
3265 void
3266 gfc_free_charlen (gfc_charlen *cl, gfc_charlen *end)
3267 {
3268   gfc_charlen *cl2;
3269
3270   for (; cl != end; cl = cl2)
3271     {
3272       gcc_assert (cl);
3273
3274       cl2 = cl->next;
3275       gfc_free_expr (cl->length);
3276       free (cl);
3277     }
3278 }
3279
3280
3281 /* Free entry list structs.  */
3282
3283 static void
3284 free_entry_list (gfc_entry_list *el)
3285 {
3286   gfc_entry_list *next;
3287
3288   if (el == NULL)
3289     return;
3290
3291   next = el->next;
3292   free (el);
3293   free_entry_list (next);
3294 }
3295
3296
3297 /* Free a namespace structure and everything below it.  Interface
3298    lists associated with intrinsic operators are not freed.  These are
3299    taken care of when a specific name is freed.  */
3300
3301 void
3302 gfc_free_namespace (gfc_namespace *ns)
3303 {
3304   gfc_namespace *p, *q;
3305   int i;
3306
3307   if (ns == NULL)
3308     return;
3309
3310   ns->refs--;
3311   if (ns->refs > 0)
3312     return;
3313   gcc_assert (ns->refs == 0);
3314
3315   gfc_free_statements (ns->code);
3316
3317   free_sym_tree (ns->sym_root);
3318   free_uop_tree (ns->uop_root);
3319   free_common_tree (ns->common_root);
3320   free_tb_tree (ns->tb_sym_root);
3321   free_tb_tree (ns->tb_uop_root);
3322   gfc_free_finalizer_list (ns->finalizers);
3323   gfc_free_charlen (ns->cl_list, NULL);
3324   free_st_labels (ns->st_labels);
3325
3326   free_entry_list (ns->entries);
3327   gfc_free_equiv (ns->equiv);
3328   gfc_free_equiv_lists (ns->equiv_lists);
3329   gfc_free_use_stmts (ns->use_stmts);
3330
3331   for (i = GFC_INTRINSIC_BEGIN; i != GFC_INTRINSIC_END; i++)
3332     gfc_free_interface (ns->op[i]);
3333
3334   gfc_free_data (ns->data);
3335   p = ns->contained;
3336   free (ns);
3337
3338   /* Recursively free any contained namespaces.  */
3339   while (p != NULL)
3340     {
3341       q = p;
3342       p = p->sibling;
3343       gfc_free_namespace (q);
3344     }
3345 }
3346
3347
3348 void
3349 gfc_symbol_init_2 (void)
3350 {
3351
3352   gfc_current_ns = gfc_get_namespace (NULL, 0);
3353 }
3354
3355
3356 void
3357 gfc_symbol_done_2 (void)
3358 {
3359
3360   gfc_free_namespace (gfc_current_ns);
3361   gfc_current_ns = NULL;
3362   gfc_free_dt_list ();
3363 }
3364
3365
3366 /* Count how many nodes a symtree has.  */
3367
3368 static unsigned
3369 count_st_nodes (const gfc_symtree *st)
3370 {
3371   unsigned nodes;
3372   if (!st)
3373     return 0;
3374
3375   nodes = count_st_nodes (st->left);
3376   nodes++;
3377   nodes += count_st_nodes (st->right);
3378
3379   return nodes;
3380 }
3381
3382
3383 /* Convert symtree tree into symtree vector.  */
3384
3385 static unsigned
3386 fill_st_vector (gfc_symtree *st, gfc_symtree **st_vec, unsigned node_cntr)
3387 {
3388   if (!st)
3389     return node_cntr;
3390
3391   node_cntr = fill_st_vector (st->left, st_vec, node_cntr);
3392   st_vec[node_cntr++] = st;
3393   node_cntr = fill_st_vector (st->right, st_vec, node_cntr);
3394
3395   return node_cntr;
3396 }
3397
3398
3399 /* Traverse namespace.  As the functions might modify the symtree, we store the
3400    symtree as a vector and operate on this vector.  Note: We assume that
3401    sym_func or st_func never deletes nodes from the symtree - only adding is
3402    allowed. Additionally, newly added nodes are not traversed.  */
3403
3404 static void
3405 do_traverse_symtree (gfc_symtree *st, void (*st_func) (gfc_symtree *),
3406                      void (*sym_func) (gfc_symbol *))
3407 {
3408   gfc_symtree **st_vec;
3409   unsigned nodes, i, node_cntr;
3410
3411   gcc_assert ((st_func && !sym_func) || (!st_func && sym_func));
3412   nodes = count_st_nodes (st);
3413   st_vec = XALLOCAVEC (gfc_symtree *, nodes);
3414   node_cntr = 0;
3415   fill_st_vector (st, st_vec, node_cntr);
3416
3417   if (sym_func)
3418     {
3419       /* Clear marks.  */
3420       for (i = 0; i < nodes; i++)
3421         st_vec[i]->n.sym->mark = 0;
3422       for (i = 0; i < nodes; i++)
3423         if (!st_vec[i]->n.sym->mark)
3424           {
3425             (*sym_func) (st_vec[i]->n.sym);
3426             st_vec[i]->n.sym->mark = 1;
3427           }
3428      }
3429    else
3430       for (i = 0; i < nodes; i++)
3431         (*st_func) (st_vec[i]);
3432 }
3433
3434
3435 /* Recursively traverse the symtree nodes.  */
3436
3437 void
3438 gfc_traverse_symtree (gfc_symtree *st, void (*st_func) (gfc_symtree *))
3439 {
3440   do_traverse_symtree (st, st_func, NULL);
3441 }
3442
3443
3444 /* Call a given function for all symbols in the namespace.  We take
3445    care that each gfc_symbol node is called exactly once.  */
3446
3447 void
3448 gfc_traverse_ns (gfc_namespace *ns, void (*sym_func) (gfc_symbol *))
3449 {
3450   do_traverse_symtree (ns->sym_root, NULL, sym_func);
3451 }
3452
3453
3454 /* Return TRUE when name is the name of an intrinsic type.  */
3455
3456 bool
3457 gfc_is_intrinsic_typename (const char *name)
3458 {
3459   if (strcmp (name, "integer") == 0
3460       || strcmp (name, "real") == 0
3461       || strcmp (name, "character") == 0
3462       || strcmp (name, "logical") == 0
3463       || strcmp (name, "complex") == 0
3464       || strcmp (name, "doubleprecision") == 0
3465       || strcmp (name, "doublecomplex") == 0)
3466     return true;
3467   else
3468     return false;
3469 }
3470
3471
3472 /* Return TRUE if the symbol is an automatic variable.  */
3473
3474 static bool
3475 gfc_is_var_automatic (gfc_symbol *sym)
3476 {
3477   /* Pointer and allocatable variables are never automatic.  */
3478   if (sym->attr.pointer || sym->attr.allocatable)
3479     return false;
3480   /* Check for arrays with non-constant size.  */
3481   if (sym->attr.dimension && sym->as
3482       && !gfc_is_compile_time_shape (sym->as))
3483     return true;
3484   /* Check for non-constant length character variables.  */
3485   if (sym->ts.type == BT_CHARACTER
3486       && sym->ts.u.cl
3487       && !gfc_is_constant_expr (sym->ts.u.cl->length))
3488     return true;
3489   return false;
3490 }
3491
3492 /* Given a symbol, mark it as SAVEd if it is allowed.  */
3493
3494 static void
3495 save_symbol (gfc_symbol *sym)
3496 {
3497
3498   if (sym->attr.use_assoc)
3499     return;
3500
3501   if (sym->attr.in_common
3502       || sym->attr.dummy
3503       || sym->attr.result
3504       || sym->attr.flavor != FL_VARIABLE)
3505     return;
3506   /* Automatic objects are not saved.  */
3507   if (gfc_is_var_automatic (sym))
3508     return;
3509   gfc_add_save (&sym->attr, SAVE_EXPLICIT, sym->name, &sym->declared_at);
3510 }
3511
3512
3513 /* Mark those symbols which can be SAVEd as such.  */
3514
3515 void
3516 gfc_save_all (gfc_namespace *ns)
3517 {
3518   gfc_traverse_ns (ns, save_symbol);
3519 }
3520
3521
3522 /* Make sure that no changes to symbols are pending.  */
3523
3524 void
3525 gfc_enforce_clean_symbol_state(void)
3526 {
3527   gcc_assert (latest_undo_chgset->syms.is_empty ());
3528 }
3529
3530
3531 /************** Global symbol handling ************/
3532
3533
3534 /* Search a tree for the global symbol.  */
3535
3536 gfc_gsymbol *
3537 gfc_find_gsymbol (gfc_gsymbol *symbol, const char *name)
3538 {
3539   int c;
3540
3541   if (symbol == NULL)
3542     return NULL;
3543
3544   while (symbol)
3545     {
3546       c = strcmp (name, symbol->name);
3547       if (!c)
3548         return symbol;
3549
3550       symbol = (c < 0) ? symbol->left : symbol->right;
3551     }
3552
3553   return NULL;
3554 }
3555
3556
3557 /* Compare two global symbols. Used for managing the BB tree.  */
3558
3559 static int
3560 gsym_compare (void *_s1, void *_s2)
3561 {
3562   gfc_gsymbol *s1, *s2;
3563
3564   s1 = (gfc_gsymbol *) _s1;
3565   s2 = (gfc_gsymbol *) _s2;
3566   return strcmp (s1->name, s2->name);
3567 }
3568
3569
3570 /* Get a global symbol, creating it if it doesn't exist.  */
3571
3572 gfc_gsymbol *
3573 gfc_get_gsymbol (const char *name)
3574 {
3575   gfc_gsymbol *s;
3576
3577   s = gfc_find_gsymbol (gfc_gsym_root, name);
3578   if (s != NULL)
3579     return s;
3580
3581   s = XCNEW (gfc_gsymbol);
3582   s->type = GSYM_UNKNOWN;
3583   s->name = gfc_get_string (name);
3584
3585   gfc_insert_bbt (&gfc_gsym_root, s, gsym_compare);
3586
3587   return s;
3588 }
3589
3590
3591 static gfc_symbol *
3592 get_iso_c_binding_dt (int sym_id)
3593 {
3594   gfc_dt_list *dt_list;
3595
3596   dt_list = gfc_derived_types;
3597
3598   /* Loop through the derived types in the name list, searching for
3599      the desired symbol from iso_c_binding.  Search the parent namespaces
3600      if necessary and requested to (parent_flag).  */
3601   while (dt_list != NULL)
3602     {
3603       if (dt_list->derived->from_intmod != INTMOD_NONE
3604           && dt_list->derived->intmod_sym_id == sym_id)
3605         return dt_list->derived;
3606
3607       dt_list = dt_list->next;
3608     }
3609
3610   return NULL;
3611 }
3612
3613
3614 /* Verifies that the given derived type symbol, derived_sym, is interoperable
3615    with C.  This is necessary for any derived type that is BIND(C) and for
3616    derived types that are parameters to functions that are BIND(C).  All
3617    fields of the derived type are required to be interoperable, and are tested
3618    for such.  If an error occurs, the errors are reported here, allowing for
3619    multiple errors to be handled for a single derived type.  */
3620
3621 gfc_try
3622 verify_bind_c_derived_type (gfc_symbol *derived_sym)
3623 {
3624   gfc_component *curr_comp = NULL;
3625   gfc_try is_c_interop = FAILURE;
3626   gfc_try retval = SUCCESS;
3627
3628   if (derived_sym == NULL)
3629     gfc_internal_error ("verify_bind_c_derived_type(): Given symbol is "
3630                         "unexpectedly NULL");
3631
3632   /* If we've already looked at this derived symbol, do not look at it again
3633      so we don't repeat warnings/errors.  */
3634   if (derived_sym->ts.is_c_interop)
3635     return SUCCESS;
3636
3637   /* The derived type must have the BIND attribute to be interoperable
3638      J3/04-007, Section 15.2.3.  */
3639   if (derived_sym->attr.is_bind_c != 1)
3640     {
3641       derived_sym->ts.is_c_interop = 0;
3642       gfc_error_now ("Derived type '%s' declared at %L must have the BIND "
3643                      "attribute to be C interoperable", derived_sym->name,
3644                      &(derived_sym->declared_at));
3645       retval = FAILURE;
3646     }
3647
3648   curr_comp = derived_sym->components;
3649
3650   /* Fortran 2003 allows an empty derived type.  C99 appears to disallow an
3651      empty struct.  Section 15.2 in Fortran 2003 states:  "The following
3652      subclauses define the conditions under which a Fortran entity is
3653      interoperable.  If a Fortran entity is interoperable, an equivalent
3654      entity may be defined by means of C and the Fortran entity is said
3655      to be interoperable with the C entity.  There does not have to be such
3656      an interoperating C entity."
3657   */
3658   if (curr_comp == NULL)
3659     {
3660       gfc_warning ("Derived type '%s' with BIND(C) attribute at %L is empty, "
3661                    "and may be inaccessible by the C companion processor",
3662                    derived_sym->name, &(derived_sym->declared_at));
3663       derived_sym->ts.is_c_interop = 1;
3664       derived_sym->attr.is_bind_c = 1;
3665       return SUCCESS;
3666     }
3667
3668
3669   /* Initialize the derived type as being C interoperable.
3670      If we find an error in the components, this will be set false.  */
3671   derived_sym->ts.is_c_interop = 1;
3672
3673   /* Loop through the list of components to verify that the kind of
3674      each is a C interoperable type.  */
3675   do
3676     {
3677       /* The components cannot be pointers (fortran sense).
3678          J3/04-007, Section 15.2.3, C1505.      */
3679       if (curr_comp->attr.pointer != 0)
3680         {
3681           gfc_error ("Component '%s' at %L cannot have the "
3682                      "POINTER attribute because it is a member "
3683                      "of the BIND(C) derived type '%s' at %L",
3684                      curr_comp->name, &(curr_comp->loc),
3685                      derived_sym->name, &(derived_sym->declared_at));
3686           retval = FAILURE;
3687         }
3688
3689       if (curr_comp->attr.proc_pointer != 0)
3690         {
3691           gfc_error ("Procedure pointer component '%s' at %L cannot be a member"
3692                      " of the BIND(C) derived type '%s' at %L", curr_comp->name,
3693                      &curr_comp->loc, derived_sym->name,
3694                      &derived_sym->declared_at);
3695           retval = FAILURE;
3696         }
3697
3698       /* The components cannot be allocatable.
3699          J3/04-007, Section 15.2.3, C1505.      */
3700       if (curr_comp->attr.allocatable != 0)
3701         {
3702           gfc_error ("Component '%s' at %L cannot have the "
3703                      "ALLOCATABLE attribute because it is a member "
3704                      "of the BIND(C) derived type '%s' at %L",
3705                      curr_comp->name, &(curr_comp->loc),
3706                      derived_sym->name, &(derived_sym->declared_at));
3707           retval = FAILURE;
3708         }
3709
3710       /* BIND(C) derived types must have interoperable components.  */
3711       if (curr_comp->ts.type == BT_DERIVED
3712           && curr_comp->ts.u.derived->ts.is_iso_c != 1
3713           && curr_comp->ts.u.derived != derived_sym)
3714         {
3715           /* This should be allowed; the draft says a derived-type can not
3716              have type parameters if it is has the BIND attribute.  Type
3717              parameters seem to be for making parameterized derived types.
3718              There's no need to verify the type if it is c_ptr/c_funptr.  */
3719           retval = verify_bind_c_derived_type (curr_comp->ts.u.derived);
3720         }
3721       else
3722         {
3723           /* Grab the typespec for the given component and test the kind.  */
3724           is_c_interop = gfc_verify_c_interop (&(curr_comp->ts));
3725
3726           if (is_c_interop != SUCCESS)
3727             {
3728               /* Report warning and continue since not fatal.  The
3729                  draft does specify a constraint that requires all fields
3730                  to interoperate, but if the user says real(4), etc., it
3731                  may interoperate with *something* in C, but the compiler
3732                  most likely won't know exactly what.  Further, it may not
3733                  interoperate with the same data type(s) in C if the user
3734                  recompiles with different flags (e.g., -m32 and -m64 on
3735                  x86_64 and using integer(4) to claim interop with a
3736                  C_LONG).  */
3737               if (derived_sym->attr.is_bind_c == 1
3738                   && gfc_option.warn_c_binding_type)
3739                 /* If the derived type is bind(c), all fields must be
3740                    interop.  */
3741                 gfc_warning ("Component '%s' in derived type '%s' at %L "
3742                              "may not be C interoperable, even though "
3743                              "derived type '%s' is BIND(C)",
3744                              curr_comp->name, derived_sym->name,
3745                              &(curr_comp->loc), derived_sym->name);
3746               else if (gfc_option.warn_c_binding_type)
3747                 /* If derived type is param to bind(c) routine, or to one
3748                    of the iso_c_binding procs, it must be interoperable, so
3749                    all fields must interop too.  */
3750                 gfc_warning ("Component '%s' in derived type '%s' at %L "
3751                              "may not be C interoperable",
3752                              curr_comp->name, derived_sym->name,
3753                              &(curr_comp->loc));
3754             }
3755         }
3756
3757       curr_comp = curr_comp->next;
3758     } while (curr_comp != NULL);
3759
3760
3761   /* Make sure we don't have conflicts with the attributes.  */
3762   if (derived_sym->attr.access == ACCESS_PRIVATE)
3763     {
3764       gfc_error ("Derived type '%s' at %L cannot be declared with both "
3765                  "PRIVATE and BIND(C) attributes", derived_sym->name,
3766                  &(derived_sym->declared_at));
3767       retval = FAILURE;
3768     }
3769
3770   if (derived_sym->attr.sequence != 0)
3771     {
3772       gfc_error ("Derived type '%s' at %L cannot have the SEQUENCE "
3773                  "attribute because it is BIND(C)", derived_sym->name,
3774                  &(derived_sym->declared_at));
3775       retval = FAILURE;
3776     }
3777
3778   /* Mark the derived type as not being C interoperable if we found an
3779      error.  If there were only warnings, proceed with the assumption
3780      it's interoperable.  */
3781   if (retval == FAILURE)
3782     derived_sym->ts.is_c_interop = 0;
3783
3784   return retval;
3785 }
3786
3787
3788 /* Generate symbols for the named constants c_null_ptr and c_null_funptr.  */
3789
3790 static gfc_try
3791 gen_special_c_interop_ptr (int ptr_id, const char *ptr_name,
3792                            const char *module_name)
3793 {
3794   gfc_symtree *tmp_symtree;
3795   gfc_symbol *tmp_sym;
3796   gfc_constructor *c;
3797
3798   tmp_symtree = gfc_find_symtree (gfc_current_ns->sym_root, ptr_name);
3799
3800   if (tmp_symtree != NULL)
3801     tmp_sym = tmp_symtree->n.sym;
3802   else
3803     {
3804       tmp_sym = NULL;
3805       gfc_internal_error ("gen_special_c_interop_ptr(): Unable to "
3806                           "create symbol for %s", ptr_name);
3807     }
3808
3809   tmp_sym->ts.is_c_interop = 1;
3810   tmp_sym->attr.is_c_interop = 1;
3811   tmp_sym->ts.is_iso_c = 1;
3812   tmp_sym->ts.type = BT_DERIVED;
3813   tmp_sym->attr.flavor = FL_PARAMETER;
3814
3815   /* The c_ptr and c_funptr derived types will provide the
3816      definition for c_null_ptr and c_null_funptr, respectively.  */
3817   if (ptr_id == ISOCBINDING_NULL_PTR)
3818     tmp_sym->ts.u.derived = get_iso_c_binding_dt (ISOCBINDING_PTR);
3819   else
3820     tmp_sym->ts.u.derived = get_iso_c_binding_dt (ISOCBINDING_FUNPTR);
3821   if (tmp_sym->ts.u.derived == NULL)
3822     {
3823       /* This can occur if the user forgot to declare c_ptr or
3824          c_funptr and they're trying to use one of the procedures
3825          that has arg(s) of the missing type.  In this case, a
3826          regular version of the thing should have been put in the
3827          current ns.  */
3828
3829       generate_isocbinding_symbol (module_name, ptr_id == ISOCBINDING_NULL_PTR
3830                                    ? ISOCBINDING_PTR : ISOCBINDING_FUNPTR,
3831                                    (const char *) (ptr_id == ISOCBINDING_NULL_PTR
3832                                    ? "c_ptr"
3833                                    : "c_funptr"));
3834       tmp_sym->ts.u.derived =
3835         get_iso_c_binding_dt (ptr_id == ISOCBINDING_NULL_PTR
3836                               ? ISOCBINDING_PTR : ISOCBINDING_FUNPTR);
3837     }
3838
3839   /* Module name is some mangled version of iso_c_binding.  */
3840   tmp_sym->module = gfc_get_string (module_name);
3841
3842   /* Say it's from the iso_c_binding module.  */
3843   tmp_sym->attr.is_iso_c = 1;
3844
3845   tmp_sym->attr.use_assoc = 1;
3846   tmp_sym->attr.is_bind_c = 1;
3847   /* Since we never generate a call to this symbol, don't set the
3848      binding_label.  */
3849
3850   /* Set the c_address field of c_null_ptr and c_null_funptr to
3851      the value of NULL.  */
3852   tmp_sym->value = gfc_get_expr ();
3853   tmp_sym->value->expr_type = EXPR_STRUCTURE;
3854   tmp_sym->value->ts.type = BT_DERIVED;
3855   tmp_sym->value->ts.u.derived = tmp_sym->ts.u.derived;
3856   gfc_constructor_append_expr (&tmp_sym->value->value.constructor, NULL, NULL);
3857   c = gfc_constructor_first (tmp_sym->value->value.constructor);
3858   c->expr = gfc_get_expr ();
3859   c->expr->expr_type = EXPR_NULL;
3860   c->expr->ts.is_iso_c = 1;
3861
3862   return SUCCESS;
3863 }
3864
3865
3866 /* Add a formal argument, gfc_formal_arglist, to the
3867    end of the given list of arguments.  Set the reference to the
3868    provided symbol, param_sym, in the argument.  */
3869
3870 static void
3871 add_formal_arg (gfc_formal_arglist **head,
3872                 gfc_formal_arglist **tail,
3873                 gfc_formal_arglist *formal_arg,
3874                 gfc_symbol *param_sym)
3875 {
3876   /* Put in list, either as first arg or at the tail (curr arg).  */
3877   if (*head == NULL)
3878     *head = *tail = formal_arg;
3879   else
3880     {
3881       (*tail)->next = formal_arg;
3882       (*tail) = formal_arg;
3883     }
3884
3885   (*tail)->sym = param_sym;
3886   (*tail)->next = NULL;
3887
3888   return;
3889 }
3890
3891
3892 /* Generates a symbol representing the CPTR argument to an
3893    iso_c_binding procedure.  Also, create a gfc_formal_arglist for the
3894    CPTR and add it to the provided argument list.  */
3895
3896 static void
3897 gen_cptr_param (gfc_formal_arglist **head,
3898                 gfc_formal_arglist **tail,
3899                 const char *module_name,
3900                 gfc_namespace *ns, const char *c_ptr_name,
3901                 int iso_c_sym_id)
3902 {
3903   gfc_symbol *param_sym = NULL;
3904   gfc_symbol *c_ptr_sym = NULL;
3905   gfc_symtree *param_symtree = NULL;
3906   gfc_formal_arglist *formal_arg = NULL;
3907   const char *c_ptr_in;
3908   const char *c_ptr_type = NULL;
3909
3910   if (iso_c_sym_id == ISOCBINDING_F_PROCPOINTER)
3911     c_ptr_type = "c_funptr";
3912   else
3913     c_ptr_type = "c_ptr";
3914
3915   if(c_ptr_name == NULL)
3916     c_ptr_in = "gfc_cptr__";
3917   else
3918     c_ptr_in = c_ptr_name;
3919   gfc_get_sym_tree (c_ptr_in, ns, &param_symtree, false);
3920   if (param_symtree != NULL)
3921     param_sym = param_symtree->n.sym;
3922   else
3923     gfc_internal_error ("gen_cptr_param(): Unable to "
3924                         "create symbol for %s", c_ptr_in);
3925
3926   /* Set up the appropriate fields for the new c_ptr param sym.  */
3927   param_sym->refs++;
3928   param_sym->attr.flavor = FL_DERIVED;
3929   param_sym->ts.type = BT_DERIVED;
3930   param_sym->attr.intent = INTENT_IN;
3931   param_sym->attr.dummy = 1;
3932
3933   /* This will pass the ptr to the iso_c routines as a (void *).  */
3934   param_sym->attr.value = 1;
3935   param_sym->attr.use_assoc = 1;
3936
3937   /* Get the symbol for c_ptr or c_funptr, no matter what it's name is
3938      (user renamed).  */
3939   if (iso_c_sym_id == ISOCBINDING_F_PROCPOINTER)
3940     c_ptr_sym = get_iso_c_binding_dt (ISOCBINDING_FUNPTR);
3941   else
3942     c_ptr_sym = get_iso_c_binding_dt (ISOCBINDING_PTR);
3943   if (c_ptr_sym == NULL)
3944     {
3945       /* This can happen if the user did not define c_ptr but they are
3946          trying to use one of the iso_c_binding functions that need it.  */
3947       if (iso_c_sym_id == ISOCBINDING_F_PROCPOINTER)
3948         generate_isocbinding_symbol (module_name, ISOCBINDING_FUNPTR,
3949                                      (const char *)c_ptr_type);
3950       else
3951         generate_isocbinding_symbol (module_name, ISOCBINDING_PTR,
3952                                      (const char *)c_ptr_type);
3953
3954       gfc_get_ha_symbol (c_ptr_type, &(c_ptr_sym));
3955     }
3956
3957   param_sym->ts.u.derived = c_ptr_sym;
3958   param_sym->module = gfc_get_string (module_name);
3959
3960   /* Make new formal arg.  */
3961   formal_arg = gfc_get_formal_arglist ();
3962   /* Add arg to list of formal args (the CPTR arg).  */
3963   add_formal_arg (head, tail, formal_arg, param_sym);
3964
3965   /* Validate changes.  */
3966   gfc_commit_symbol (param_sym);
3967 }
3968
3969
3970 /* Generates a symbol representing the FPTR argument to an
3971    iso_c_binding procedure.  Also, create a gfc_formal_arglist for the
3972    FPTR and add it to the provided argument list.  */
3973
3974 static void
3975 gen_fptr_param (gfc_formal_arglist **head,
3976                 gfc_formal_arglist **tail,
3977                 const char *module_name,
3978                 gfc_namespace *ns, const char *f_ptr_name, int proc)
3979 {
3980   gfc_symbol *param_sym = NULL;
3981   gfc_symtree *param_symtree = NULL;
3982   gfc_formal_arglist *formal_arg = NULL;
3983   const char *f_ptr_out = "gfc_fptr__";
3984
3985   if (f_ptr_name != NULL)
3986     f_ptr_out = f_ptr_name;
3987
3988   gfc_get_sym_tree (f_ptr_out, ns, &param_symtree, false);
3989   if (param_symtree != NULL)
3990     param_sym = param_symtree->n.sym;
3991   else
3992     gfc_internal_error ("generateFPtrParam(): Unable to "
3993                         "create symbol for %s", f_ptr_out);
3994
3995   /* Set up the necessary fields for the fptr output param sym.  */
3996   param_sym->refs++;
3997   if (proc)
3998     param_sym->attr.proc_pointer = 1;
3999   else
4000     param_sym->attr.pointer = 1;
4001   param_sym->attr.dummy = 1;
4002   param_sym->attr.use_assoc = 1;
4003
4004   /* ISO C Binding type to allow any pointer type as actual param.  */
4005   param_sym->ts.type = BT_VOID;
4006   param_sym->module = gfc_get_string (module_name);
4007
4008   /* Make the arg.  */
4009   formal_arg = gfc_get_formal_arglist ();
4010   /* Add arg to list of formal args.  */
4011   add_formal_arg (head, tail, formal_arg, param_sym);
4012
4013   /* Validate changes.  */
4014   gfc_commit_symbol (param_sym);
4015 }
4016
4017
4018 /* Generates a symbol representing the optional SHAPE argument for the
4019    iso_c_binding c_f_pointer() procedure.  Also, create a
4020    gfc_formal_arglist for the SHAPE and add it to the provided
4021    argument list.  */
4022
4023 static void
4024 gen_shape_param (gfc_formal_arglist **head,
4025                  gfc_formal_arglist **tail,
4026                  const char *module_name,
4027                  gfc_namespace *ns, const char *shape_param_name)
4028 {
4029   gfc_symbol *param_sym = NULL;
4030   gfc_symtree *param_symtree = NULL;
4031   gfc_formal_arglist *formal_arg = NULL;
4032   const char *shape_param = "gfc_shape_array__";
4033
4034   if (shape_param_name != NULL)
4035     shape_param = shape_param_name;
4036
4037   gfc_get_sym_tree (shape_param, ns, &param_symtree, false);
4038   if (param_symtree != NULL)
4039     param_sym = param_symtree->n.sym;
4040   else
4041     gfc_internal_error ("generateShapeParam(): Unable to "
4042                         "create symbol for %s", shape_param);
4043
4044   /* Set up the necessary fields for the shape input param sym.  */
4045   param_sym->refs++;
4046   param_sym->attr.dummy = 1;
4047   param_sym->attr.use_assoc = 1;
4048
4049   /* Integer array, rank 1, describing the shape of the object.  Make it's
4050      type BT_VOID initially so we can accept any type/kind combination of
4051      integer.  During gfc_iso_c_sub_interface (resolve.c), we'll make it
4052      of BT_INTEGER type.  */
4053   param_sym->ts.type = BT_VOID;
4054
4055   /* Initialize the kind to default integer.  However, it will be overridden
4056      during resolution to match the kind of the SHAPE parameter given as
4057      the actual argument (to allow for any valid integer kind).  */
4058   param_sym->ts.kind = gfc_default_integer_kind;
4059   param_sym->as = gfc_get_array_spec ();
4060
4061   param_sym->as->rank = 1;
4062   param_sym->as->lower[0] = gfc_get_int_expr (gfc_default_integer_kind,
4063                                               NULL, 1);
4064
4065   /* The extent is unknown until we get it.  The length give us
4066      the rank the incoming pointer.  */
4067   param_sym->as->type = AS_ASSUMED_SHAPE;
4068
4069   /* The arg is also optional; it is required iff the second arg
4070      (fptr) is to an array, otherwise, it's ignored.  */
4071   param_sym->attr.optional = 1;
4072   param_sym->attr.intent = INTENT_IN;
4073   param_sym->attr.dimension = 1;
4074   param_sym->module = gfc_get_string (module_name);
4075
4076   /* Make the arg.  */
4077   formal_arg = gfc_get_formal_arglist ();
4078   /* Add arg to list of formal args.  */
4079   add_formal_arg (head, tail, formal_arg, param_sym);
4080
4081   /* Validate changes.  */
4082   gfc_commit_symbol (param_sym);
4083 }
4084
4085
4086 /* Add a procedure interface to the given symbol (i.e., store a
4087    reference to the list of formal arguments).  */
4088
4089 static void
4090 add_proc_interface (gfc_symbol *sym, ifsrc source, gfc_formal_arglist *formal)
4091 {
4092
4093   sym->formal = formal;
4094   sym->attr.if_source = source;
4095 }
4096
4097
4098 /* Copy the formal args from an existing symbol, src, into a new
4099    symbol, dest.  New formal args are created, and the description of
4100    each arg is set according to the existing ones.  This function is
4101    used when creating procedure declaration variables from a procedure
4102    declaration statement (see match_proc_decl()) to create the formal
4103    args based on the args of a given named interface.  */
4104
4105 void
4106 gfc_copy_formal_args_intr (gfc_symbol *dest, gfc_intrinsic_sym *src)
4107 {
4108   gfc_formal_arglist *head = NULL;
4109   gfc_formal_arglist *tail = NULL;
4110   gfc_formal_arglist *formal_arg = NULL;
4111   gfc_intrinsic_arg *curr_arg = NULL;
4112   gfc_formal_arglist *formal_prev = NULL;
4113   /* Save current namespace so we can change it for formal args.  */
4114   gfc_namespace *parent_ns = gfc_current_ns;
4115
4116   /* Create a new namespace, which will be the formal ns (namespace
4117      of the formal args).  */
4118   gfc_current_ns = gfc_get_namespace (parent_ns, 0);
4119   gfc_current_ns->proc_name = dest;
4120
4121   for (curr_arg = src->formal; curr_arg; curr_arg = curr_arg->next)
4122     {
4123       formal_arg = gfc_get_formal_arglist ();
4124       gfc_get_symbol (curr_arg->name, gfc_current_ns, &(formal_arg->sym));
4125
4126       /* May need to copy more info for the symbol.  */
4127       formal_arg->sym->ts = curr_arg->ts;
4128       formal_arg->sym->attr.optional = curr_arg->optional;
4129       formal_arg->sym->attr.value = curr_arg->value;
4130       formal_arg->sym->attr.intent = curr_arg->intent;
4131       formal_arg->sym->attr.flavor = FL_VARIABLE;
4132       formal_arg->sym->attr.dummy = 1;
4133
4134       if (formal_arg->sym->ts.type == BT_CHARACTER)
4135         formal_arg->sym->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
4136
4137       /* If this isn't the first arg, set up the next ptr.  For the
4138         last arg built, the formal_arg->next will never get set to
4139         anything other than NULL.  */
4140       if (formal_prev != NULL)
4141         formal_prev->next = formal_arg;
4142       else
4143         formal_arg->next = NULL;
4144
4145       formal_prev = formal_arg;
4146
4147       /* Add arg to list of formal args.  */
4148       add_formal_arg (&head, &tail, formal_arg, formal_arg->sym);
4149
4150       /* Validate changes.  */
4151       gfc_commit_symbol (formal_arg->sym);
4152     }
4153
4154   /* Add the interface to the symbol.  */
4155   add_proc_interface (dest, IFSRC_DECL, head);
4156
4157   /* Store the formal namespace information.  */
4158   if (dest->formal != NULL)
4159     /* The current ns should be that for the dest proc.  */
4160     dest->formal_ns = gfc_current_ns;
4161   /* Restore the current namespace to what it was on entry.  */
4162   gfc_current_ns = parent_ns;
4163 }
4164
4165
4166 /* Builds the parameter list for the iso_c_binding procedure
4167    c_f_pointer or c_f_procpointer.  The old_sym typically refers to a
4168    generic version of either the c_f_pointer or c_f_procpointer
4169    functions.  The new_proc_sym represents a "resolved" version of the
4170    symbol.  The functions are resolved to match the types of their
4171    parameters; for example, c_f_pointer(cptr, fptr) would resolve to
4172    something similar to c_f_pointer_i4 if the type of data object fptr
4173    pointed to was a default integer.  The actual name of the resolved
4174    procedure symbol is further mangled with the module name, etc., but
4175    the idea holds true.  */
4176
4177 static void
4178 build_formal_args (gfc_symbol *new_proc_sym,
4179                    gfc_symbol *old_sym, int add_optional_arg)
4180 {
4181   gfc_formal_arglist *head = NULL, *tail = NULL;
4182   gfc_namespace *parent_ns = NULL;
4183
4184   parent_ns = gfc_current_ns;
4185   /* Create a new namespace, which will be the formal ns (namespace
4186      of the formal args).  */
4187   gfc_current_ns = gfc_get_namespace(parent_ns, 0);
4188   gfc_current_ns->proc_name = new_proc_sym;
4189
4190   /* Generate the params.  */
4191   if (old_sym->intmod_sym_id == ISOCBINDING_F_PROCPOINTER)
4192     {
4193       gen_cptr_param (&head, &tail, (const char *) new_proc_sym->module,
4194                       gfc_current_ns, "cptr", old_sym->intmod_sym_id);
4195       gen_fptr_param (&head, &tail, (const char *) new_proc_sym->module,
4196                       gfc_current_ns, "fptr", 1);
4197     }
4198   else if (old_sym->intmod_sym_id == ISOCBINDING_F_POINTER)
4199     {
4200       gen_cptr_param (&head, &tail, (const char *) new_proc_sym->module,
4201                       gfc_current_ns, "cptr", old_sym->intmod_sym_id);
4202       gen_fptr_param (&head, &tail, (const char *) new_proc_sym->module,
4203                       gfc_current_ns, "fptr", 0);
4204       /* If we're dealing with c_f_pointer, it has an optional third arg.  */
4205       gen_shape_param (&head, &tail,(const char *) new_proc_sym->module,
4206                        gfc_current_ns, "shape");
4207
4208     }
4209   else if (old_sym->intmod_sym_id == ISOCBINDING_ASSOCIATED)
4210     {
4211       /* c_associated has one required arg and one optional; both
4212          are c_ptrs.  */
4213       gen_cptr_param (&head, &tail, (const char *) new_proc_sym->module,
4214                       gfc_current_ns, "c_ptr_1", ISOCBINDING_ASSOCIATED);
4215       if (add_optional_arg)
4216         {
4217           gen_cptr_param (&head, &tail, (const char *) new_proc_sym->module,
4218                           gfc_current_ns, "c_ptr_2", ISOCBINDING_ASSOCIATED);
4219           /* The last param is optional so mark it as such.  */
4220           tail->sym->attr.optional = 1;
4221         }
4222     }
4223
4224   /* Add the interface (store formal args to new_proc_sym).  */
4225   add_proc_interface (new_proc_sym, IFSRC_DECL, head);
4226
4227   /* Set up the formal_ns pointer to the one created for the
4228      new procedure so it'll get cleaned up during gfc_free_symbol().  */
4229   new_proc_sym->formal_ns = gfc_current_ns;
4230
4231   gfc_current_ns = parent_ns;
4232 }
4233
4234 static int
4235 std_for_isocbinding_symbol (int id)
4236 {
4237   switch (id)
4238     {
4239 #define NAMED_INTCST(a,b,c,d) \
4240       case a:\
4241         return d;
4242 #include "iso-c-binding.def"
4243 #undef NAMED_INTCST
4244
4245 #define NAMED_FUNCTION(a,b,c,d) \
4246       case a:\
4247         return d;
4248 #include "iso-c-binding.def"
4249 #undef NAMED_FUNCTION
4250
4251        default:
4252          return GFC_STD_F2003;
4253     }
4254 }
4255
4256 /* Generate the given set of C interoperable kind objects, or all
4257    interoperable kinds.  This function will only be given kind objects
4258    for valid iso_c_binding defined types because this is verified when
4259    the 'use' statement is parsed.  If the user gives an 'only' clause,
4260    the specific kinds are looked up; if they don't exist, an error is
4261    reported.  If the user does not give an 'only' clause, all
4262    iso_c_binding symbols are generated.  If a list of specific kinds
4263    is given, it must have a NULL in the first empty spot to mark the
4264    end of the list.  */
4265
4266
4267 void
4268 generate_isocbinding_symbol (const char *mod_name, iso_c_binding_symbol s,
4269                              const char *local_name)
4270 {
4271   const char *const name = (local_name && local_name[0]) ? local_name
4272                                              : c_interop_kinds_table[s].name;
4273   gfc_symtree *tmp_symtree = NULL;
4274   gfc_symbol *tmp_sym = NULL;
4275   int index;
4276
4277   if (gfc_notification_std (std_for_isocbinding_symbol (s)) == ERROR)
4278     return;
4279
4280   tmp_symtree = gfc_find_symtree (gfc_current_ns->sym_root, name);
4281
4282   /* Already exists in this scope so don't re-add it. */
4283   if (tmp_symtree != NULL && (tmp_sym = tmp_symtree->n.sym) != NULL
4284       && (!tmp_sym->attr.generic
4285           || (tmp_sym = gfc_find_dt_in_generic (tmp_sym)) != NULL)
4286       && tmp_sym->from_intmod == INTMOD_ISO_C_BINDING)
4287     {
4288       if (tmp_sym->attr.flavor == FL_DERIVED
4289           && !get_iso_c_binding_dt (tmp_sym->intmod_sym_id))
4290         {
4291           gfc_dt_list *dt_list;
4292           dt_list = gfc_get_dt_list ();
4293           dt_list->derived = tmp_sym;
4294           dt_list->next = gfc_derived_types;
4295           gfc_derived_types = dt_list;
4296         }
4297
4298       return;
4299     }
4300
4301   /* Create the sym tree in the current ns.  */
4302   gfc_get_sym_tree (name, gfc_current_ns, &tmp_symtree, false);
4303   if (tmp_symtree)
4304     tmp_sym = tmp_symtree->n.sym;
4305   else
4306     gfc_internal_error ("generate_isocbinding_symbol(): Unable to "
4307                         "create symbol");
4308
4309   /* Say what module this symbol belongs to.  */
4310   tmp_sym->module = gfc_get_string (mod_name);
4311   tmp_sym->from_intmod = INTMOD_ISO_C_BINDING;
4312   tmp_sym->intmod_sym_id = s;
4313
4314   switch (s)
4315     {
4316
4317 #define NAMED_INTCST(a,b,c,d) case a :
4318 #define NAMED_REALCST(a,b,c,d) case a :
4319 #define NAMED_CMPXCST(a,b,c,d) case a :
4320 #define NAMED_LOGCST(a,b,c) case a :
4321 #define NAMED_CHARKNDCST(a,b,c) case a :
4322 #include "iso-c-binding.def"
4323
4324         tmp_sym->value = gfc_get_int_expr (gfc_default_integer_kind, NULL,
4325                                            c_interop_kinds_table[s].value);
4326
4327         /* Initialize an integer constant expression node.  */
4328         tmp_sym->attr.flavor = FL_PARAMETER;
4329         tmp_sym->ts.type = BT_INTEGER;
4330         tmp_sym->ts.kind = gfc_default_integer_kind;
4331
4332         /* Mark this type as a C interoperable one.  */
4333         tmp_sym->ts.is_c_interop = 1;
4334         tmp_sym->ts.is_iso_c = 1;
4335         tmp_sym->value->ts.is_c_interop = 1;
4336         tmp_sym->value->ts.is_iso_c = 1;
4337         tmp_sym->attr.is_c_interop = 1;
4338
4339         /* Tell what f90 type this c interop kind is valid.  */
4340         tmp_sym->ts.f90_type = c_interop_kinds_table[s].f90_type;
4341
4342         /* Say it's from the iso_c_binding module.  */
4343         tmp_sym->attr.is_iso_c = 1;
4344
4345         /* Make it use associated.  */
4346         tmp_sym->attr.use_assoc = 1;
4347         break;
4348
4349
4350 #define NAMED_CHARCST(a,b,c) case a :
4351 #include "iso-c-binding.def"
4352
4353         /* Initialize an integer constant expression node for the
4354            length of the character.  */
4355         tmp_sym->value = gfc_get_character_expr (gfc_default_character_kind,
4356                                                  &gfc_current_locus, NULL, 1);
4357         tmp_sym->value->ts.is_c_interop = 1;
4358         tmp_sym->value->ts.is_iso_c = 1;
4359         tmp_sym->value->value.character.length = 1;
4360         tmp_sym->value->value.character.string[0]
4361           = (gfc_char_t) c_interop_kinds_table[s].value;
4362         tmp_sym->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
4363         tmp_sym->ts.u.cl->length = gfc_get_int_expr (gfc_default_integer_kind,
4364                                                      NULL, 1);
4365
4366         /* May not need this in both attr and ts, but do need in
4367            attr for writing module file.  */
4368         tmp_sym->attr.is_c_interop = 1;
4369
4370         tmp_sym->attr.flavor = FL_PARAMETER;
4371         tmp_sym->ts.type = BT_CHARACTER;
4372
4373         /* Need to set it to the C_CHAR kind.  */
4374         tmp_sym->ts.kind = gfc_default_character_kind;
4375
4376         /* Mark this type as a C interoperable one.  */
4377         tmp_sym->ts.is_c_interop = 1;
4378         tmp_sym->ts.is_iso_c = 1;
4379
4380         /* Tell what f90 type this c interop kind is valid.  */
4381         tmp_sym->ts.f90_type = BT_CHARACTER;
4382
4383         /* Say it's from the iso_c_binding module.  */
4384         tmp_sym->attr.is_iso_c = 1;
4385
4386         /* Make it use associated.  */
4387         tmp_sym->attr.use_assoc = 1;
4388         break;
4389
4390       case ISOCBINDING_PTR:
4391       case ISOCBINDING_FUNPTR:
4392         {
4393           gfc_interface *intr, *head;
4394           gfc_symbol *dt_sym;
4395           const char *hidden_name;
4396           gfc_dt_list **dt_list_ptr = NULL;
4397           gfc_component *tmp_comp = NULL;
4398           char comp_name[(GFC_MAX_SYMBOL_LEN * 2) + 1];
4399
4400           hidden_name = gfc_get_string ("%c%s",
4401                             (char) TOUPPER ((unsigned char) tmp_sym->name[0]),
4402                             &tmp_sym->name[1]);
4403
4404           /* Generate real derived type.  */
4405           tmp_symtree = gfc_find_symtree (gfc_current_ns->sym_root,
4406                                           hidden_name);
4407
4408           if (tmp_symtree != NULL)
4409             gcc_unreachable ();
4410           gfc_get_sym_tree (hidden_name, gfc_current_ns, &tmp_symtree, false);
4411           if (tmp_symtree)
4412             dt_sym = tmp_symtree->n.sym;
4413           else
4414             gcc_unreachable ();
4415
4416           /* Generate an artificial generic function.  */
4417           dt_sym->name = gfc_get_string (tmp_sym->name);
4418           head = tmp_sym->generic;
4419           intr = gfc_get_interface ();
4420           intr->sym = dt_sym;
4421           intr->where = gfc_current_locus;
4422           intr->next = head;
4423           tmp_sym->generic = intr;
4424
4425           if (!tmp_sym->attr.generic
4426               && gfc_add_generic (&tmp_sym->attr, tmp_sym->name, NULL)
4427                  == FAILURE)
4428             return;
4429
4430           if (!tmp_sym->attr.function
4431               && gfc_add_function (&tmp_sym->attr, tmp_sym->name, NULL)
4432                  == FAILURE)
4433             return;
4434
4435           /* Say what module this symbol belongs to.  */
4436           dt_sym->module = gfc_get_string (mod_name);
4437           dt_sym->from_intmod = INTMOD_ISO_C_BINDING;
4438           dt_sym->intmod_sym_id = s;
4439
4440           /* Initialize an integer constant expression node.  */
4441           dt_sym->attr.flavor = FL_DERIVED;
4442           dt_sym->ts.is_c_interop = 1;
4443           dt_sym->attr.is_c_interop = 1;
4444           dt_sym->attr.is_iso_c = 1;
4445           dt_sym->ts.is_iso_c = 1;
4446           dt_sym->ts.type = BT_DERIVED;
4447
4448           /* A derived type must have the bind attribute to be
4449              interoperable (J3/04-007, Section 15.2.3), even though
4450              the binding label is not used.  */
4451           dt_sym->attr.is_bind_c = 1;
4452
4453           dt_sym->attr.referenced = 1;
4454           dt_sym->ts.u.derived = dt_sym;
4455
4456           /* Add the symbol created for the derived type to the current ns.  */
4457           dt_list_ptr = &(gfc_derived_types);
4458           while (*dt_list_ptr != NULL && (*dt_list_ptr)->next != NULL)
4459             dt_list_ptr = &((*dt_list_ptr)->next);
4460
4461           /* There is already at least one derived type in the list, so append
4462              the one we're currently building for c_ptr or c_funptr.  */
4463           if (*dt_list_ptr != NULL)
4464             dt_list_ptr = &((*dt_list_ptr)->next);
4465           (*dt_list_ptr) = gfc_get_dt_list ();
4466           (*dt_list_ptr)->derived = dt_sym;
4467           (*dt_list_ptr)->next = NULL;
4468
4469           /* Set up the component of the derived type, which will be
4470              an integer with kind equal to c_ptr_size.  Mangle the name of
4471              the field for the c_address to prevent the curious user from
4472              trying to access it from Fortran.  */
4473           sprintf (comp_name, "__%s_%s", dt_sym->name, "c_address");
4474           gfc_add_component (dt_sym, comp_name, &tmp_comp);
4475           if (tmp_comp == NULL)
4476           gfc_internal_error ("generate_isocbinding_symbol(): Unable to "
4477                               "create component for c_address");
4478
4479           tmp_comp->ts.type = BT_INTEGER;
4480
4481           /* Set this because the module will need to read/write this field.  */
4482           tmp_comp->ts.f90_type = BT_INTEGER;
4483
4484           /* The kinds for c_ptr and c_funptr are the same.  */
4485           index = get_c_kind ("c_ptr", c_interop_kinds_table);
4486           tmp_comp->ts.kind = c_interop_kinds_table[index].value;
4487
4488           tmp_comp->attr.pointer = 0;
4489           tmp_comp->attr.dimension = 0;
4490
4491           /* Mark the component as C interoperable.  */
4492           tmp_comp->ts.is_c_interop = 1;
4493
4494           /* Make it use associated (iso_c_binding module).  */
4495           dt_sym->attr.use_assoc = 1;
4496         }
4497
4498         break;
4499
4500       case ISOCBINDING_NULL_PTR:
4501       case ISOCBINDING_NULL_FUNPTR:
4502         gen_special_c_interop_ptr (s, name, mod_name);
4503         break;
4504
4505       case ISOCBINDING_F_POINTER:
4506       case ISOCBINDING_ASSOCIATED:
4507       case ISOCBINDING_LOC:
4508       case ISOCBINDING_FUNLOC:
4509       case ISOCBINDING_F_PROCPOINTER:
4510
4511         tmp_sym->attr.proc = PROC_MODULE;
4512
4513         /* Use the procedure's name as it is in the iso_c_binding module for
4514            setting the binding label in case the user renamed the symbol.  */
4515         tmp_sym->binding_label =
4516           gfc_get_string ("%s_%s", mod_name,
4517                           c_interop_kinds_table[s].name);
4518         tmp_sym->attr.is_iso_c = 1;
4519         if (s == ISOCBINDING_F_POINTER || s == ISOCBINDING_F_PROCPOINTER)
4520           tmp_sym->attr.subroutine = 1;
4521         else
4522           {
4523             /* TODO!  This needs to be finished more for the expr of the
4524                function or something!
4525                This may not need to be here, because trying to do c_loc
4526                as an external.  */
4527             if (s == ISOCBINDING_ASSOCIATED)
4528               {
4529                 tmp_sym->attr.function = 1;
4530                 tmp_sym->ts.type = BT_LOGICAL;
4531                 tmp_sym->ts.kind = gfc_default_logical_kind;
4532                 tmp_sym->result = tmp_sym;
4533               }
4534             else
4535               {
4536                /* Here, we're taking the simple approach.  We're defining
4537                   c_loc as an external identifier so the compiler will put
4538                   what we expect on the stack for the address we want the
4539                   C address of.  */
4540                 tmp_sym->ts.type = BT_DERIVED;
4541                 if (s == ISOCBINDING_LOC)
4542                   tmp_sym->ts.u.derived =
4543                     get_iso_c_binding_dt (ISOCBINDING_PTR);
4544                 else
4545                   tmp_sym->ts.u.derived =
4546                     get_iso_c_binding_dt (ISOCBINDING_FUNPTR);
4547
4548                 if (tmp_sym->ts.u.derived == NULL)
4549                   {
4550                     /* Create the necessary derived type so we can continue
4551                        processing the file.  */
4552                     generate_isocbinding_symbol
4553                       (mod_name, s == ISOCBINDING_FUNLOC
4554                                 ? ISOCBINDING_FUNPTR : ISOCBINDING_PTR,
4555                       (const char *)(s == ISOCBINDING_FUNLOC
4556                                 ? "c_funptr" : "c_ptr"));
4557                     tmp_sym->ts.u.derived =
4558                     get_iso_c_binding_dt (s == ISOCBINDING_FUNLOC
4559                                             ? ISOCBINDING_FUNPTR
4560                                             : ISOCBINDING_PTR);
4561                   }
4562
4563                 /* The function result is itself (no result clause).  */
4564                 tmp_sym->result = tmp_sym;
4565                 tmp_sym->attr.external = 1;
4566                 tmp_sym->attr.use_assoc = 0;
4567                 tmp_sym->attr.pure = 1;
4568                 tmp_sym->attr.if_source = IFSRC_UNKNOWN;
4569                 tmp_sym->attr.proc = PROC_UNKNOWN;
4570               }
4571           }
4572
4573         tmp_sym->attr.flavor = FL_PROCEDURE;
4574         tmp_sym->attr.contained = 0;
4575
4576        /* Try using this builder routine, with the new and old symbols
4577           both being the generic iso_c proc sym being created.  This
4578           will create the formal args (and the new namespace for them).
4579           Don't build an arg list for c_loc because we're going to treat
4580           c_loc as an external procedure.  */
4581         if (s != ISOCBINDING_LOC && s != ISOCBINDING_FUNLOC)
4582           /* The 1 says to add any optional args, if applicable.  */
4583           build_formal_args (tmp_sym, tmp_sym, 1);
4584
4585         /* Set this after setting up the symbol, to prevent error messages.  */
4586         tmp_sym->attr.use_assoc = 1;
4587
4588         /* This symbol will not be referenced directly.  It will be
4589            resolved to the implementation for the given f90 kind.  */
4590         tmp_sym->attr.referenced = 0;
4591
4592         break;
4593
4594       default:
4595         gcc_unreachable ();
4596     }
4597   gfc_commit_symbol (tmp_sym);
4598 }
4599
4600
4601 /* Creates a new symbol based off of an old iso_c symbol, with a new
4602    binding label.  This function can be used to create a new,
4603    resolved, version of a procedure symbol for c_f_pointer or
4604    c_f_procpointer that is based on the generic symbols.  A new
4605    parameter list is created for the new symbol using
4606    build_formal_args().  The add_optional_flag specifies whether the
4607    to add the optional SHAPE argument.  The new symbol is
4608    returned.  */
4609
4610 gfc_symbol *
4611 get_iso_c_sym (gfc_symbol *old_sym, char *new_name,
4612                const char *new_binding_label, int add_optional_arg)
4613 {
4614   gfc_symtree *new_symtree = NULL;
4615
4616   /* See if we have a symbol by that name already available, looking
4617      through any parent namespaces.  */
4618   gfc_find_sym_tree (new_name, gfc_current_ns, 1, &new_symtree);
4619   if (new_symtree != NULL)
4620     /* Return the existing symbol.  */
4621     return new_symtree->n.sym;
4622
4623   /* Create the symtree/symbol, with attempted host association.  */
4624   gfc_get_ha_sym_tree (new_name, &new_symtree);
4625   if (new_symtree == NULL)
4626     gfc_internal_error ("get_iso_c_sym(): Unable to create "
4627                         "symtree for '%s'", new_name);
4628
4629   /* Now fill in the fields of the resolved symbol with the old sym.  */
4630   new_symtree->n.sym->binding_label = new_binding_label;
4631   new_symtree->n.sym->attr = old_sym->attr;
4632   new_symtree->n.sym->ts = old_sym->ts;
4633   new_symtree->n.sym->module = gfc_get_string (old_sym->module);
4634   new_symtree->n.sym->from_intmod = old_sym->from_intmod;
4635   new_symtree->n.sym->intmod_sym_id = old_sym->intmod_sym_id;
4636   if (old_sym->attr.function)
4637     new_symtree->n.sym->result = new_symtree->n.sym;
4638   /* Build the formal arg list.  */
4639   build_formal_args (new_symtree->n.sym, old_sym, add_optional_arg);
4640
4641   gfc_commit_symbol (new_symtree->n.sym);
4642
4643   return new_symtree->n.sym;
4644 }
4645
4646
4647 /* Check that a symbol is already typed.  If strict is not set, an untyped
4648    symbol is acceptable for non-standard-conforming mode.  */
4649
4650 gfc_try
4651 gfc_check_symbol_typed (gfc_symbol* sym, gfc_namespace* ns,
4652                         bool strict, locus where)
4653 {
4654   gcc_assert (sym);
4655
4656   if (gfc_matching_prefix)
4657     return SUCCESS;
4658
4659   /* Check for the type and try to give it an implicit one.  */
4660   if (sym->ts.type == BT_UNKNOWN
4661       && gfc_set_default_type (sym, 0, ns) == FAILURE)
4662     {
4663       if (strict)
4664         {
4665           gfc_error ("Symbol '%s' is used before it is typed at %L",
4666                      sym->name, &where);
4667           return FAILURE;
4668         }
4669
4670       if (gfc_notify_std (GFC_STD_GNU,
4671                           "Symbol '%s' is used before"
4672                           " it is typed at %L", sym->name, &where) == FAILURE)
4673         return FAILURE;
4674     }
4675
4676   /* Everything is ok.  */
4677   return SUCCESS;
4678 }
4679
4680
4681 /* Construct a typebound-procedure structure.  Those are stored in a tentative
4682    list and marked `error' until symbols are committed.  */
4683
4684 gfc_typebound_proc*
4685 gfc_get_typebound_proc (gfc_typebound_proc *tb0)
4686 {
4687   gfc_typebound_proc *result;
4688
4689   result = XCNEW (gfc_typebound_proc);
4690   if (tb0)
4691     *result = *tb0;
4692   result->error = 1;
4693
4694   latest_undo_chgset->tbps.safe_push (result);
4695
4696   return result;
4697 }
4698
4699
4700 /* Get the super-type of a given derived type.  */
4701
4702 gfc_symbol*
4703 gfc_get_derived_super_type (gfc_symbol* derived)
4704 {
4705   gcc_assert (derived);
4706
4707   if (derived->attr.generic)
4708     derived = gfc_find_dt_in_generic (derived);
4709
4710   if (!derived->attr.extension)
4711     return NULL;
4712
4713   gcc_assert (derived->components);
4714   gcc_assert (derived->components->ts.type == BT_DERIVED);
4715   gcc_assert (derived->components->ts.u.derived);
4716
4717   if (derived->components->ts.u.derived->attr.generic)
4718     return gfc_find_dt_in_generic (derived->components->ts.u.derived);
4719
4720   return derived->components->ts.u.derived;
4721 }
4722
4723
4724 /* Get the ultimate super-type of a given derived type.  */
4725
4726 gfc_symbol*
4727 gfc_get_ultimate_derived_super_type (gfc_symbol* derived)
4728 {
4729   if (!derived->attr.extension)
4730     return NULL;
4731
4732   derived = gfc_get_derived_super_type (derived);
4733
4734   if (derived->attr.extension)
4735     return gfc_get_ultimate_derived_super_type (derived);
4736   else
4737     return derived;
4738 }
4739
4740
4741 /* Check if a derived type t2 is an extension of (or equal to) a type t1.  */
4742
4743 bool
4744 gfc_type_is_extension_of (gfc_symbol *t1, gfc_symbol *t2)
4745 {
4746   while (!gfc_compare_derived_types (t1, t2) && t2->attr.extension)
4747     t2 = gfc_get_derived_super_type (t2);
4748   return gfc_compare_derived_types (t1, t2);
4749 }
4750
4751
4752 /* Check if two typespecs are type compatible (F03:5.1.1.2):
4753    If ts1 is nonpolymorphic, ts2 must be the same type.
4754    If ts1 is polymorphic (CLASS), ts2 must be an extension of ts1.  */
4755
4756 bool
4757 gfc_type_compatible (gfc_typespec *ts1, gfc_typespec *ts2)
4758 {
4759   bool is_class1 = (ts1->type == BT_CLASS);
4760   bool is_class2 = (ts2->type == BT_CLASS);
4761   bool is_derived1 = (ts1->type == BT_DERIVED);
4762   bool is_derived2 = (ts2->type == BT_DERIVED);
4763
4764   if (is_class1
4765       && ts1->u.derived->components
4766       && ts1->u.derived->components->ts.u.derived->attr.unlimited_polymorphic)
4767     return 1;
4768
4769   if (!is_derived1 && !is_derived2 && !is_class1 && !is_class2)
4770     return (ts1->type == ts2->type);
4771
4772   if (is_derived1 && is_derived2)
4773     return gfc_compare_derived_types (ts1->u.derived, ts2->u.derived);
4774
4775   if (is_class1 && is_derived2)
4776     return gfc_type_is_extension_of (ts1->u.derived->components->ts.u.derived,
4777                                      ts2->u.derived);
4778   else if (is_class1 && is_class2)
4779     return gfc_type_is_extension_of (ts1->u.derived->components->ts.u.derived,
4780                                      ts2->u.derived->components->ts.u.derived);
4781   else
4782     return 0;
4783 }
4784
4785
4786 /* Find the parent-namespace of the current function.  If we're inside
4787    BLOCK constructs, it may not be the current one.  */
4788
4789 gfc_namespace*
4790 gfc_find_proc_namespace (gfc_namespace* ns)
4791 {
4792   while (ns->construct_entities)
4793     {
4794       ns = ns->parent;
4795       gcc_assert (ns);
4796     }
4797
4798   return ns;
4799 }
4800
4801
4802 /* Check if an associate-variable should be translated as an `implicit' pointer
4803    internally (if it is associated to a variable and not an array with
4804    descriptor).  */
4805
4806 bool
4807 gfc_is_associate_pointer (gfc_symbol* sym)
4808 {
4809   if (!sym->assoc)
4810     return false;
4811
4812   if (sym->ts.type == BT_CLASS)
4813     return true;
4814
4815   if (!sym->assoc->variable)
4816     return false;
4817
4818   if (sym->attr.dimension && sym->as->type != AS_EXPLICIT)
4819     return false;
4820
4821   return true;
4822 }
4823
4824
4825 gfc_symbol *
4826 gfc_find_dt_in_generic (gfc_symbol *sym)
4827 {
4828   gfc_interface *intr = NULL;
4829
4830   if (!sym || sym->attr.flavor == FL_DERIVED)
4831     return sym;
4832
4833   if (sym->attr.generic)
4834     for (intr = sym->generic; intr; intr = intr->next)
4835       if (intr->sym->attr.flavor == FL_DERIVED)
4836         break;
4837   return intr ? intr->sym : NULL;
4838 }
4839
4840
4841 /* Get the dummy arguments from a procedure symbol. If it has been declared
4842    via a PROCEDURE statement with a named interface, ts.interface will be set
4843    and the arguments need to be taken from there.  */
4844
4845 gfc_formal_arglist *
4846 gfc_sym_get_dummy_args (gfc_symbol *sym)
4847 {
4848   gfc_formal_arglist *dummies;
4849
4850   dummies = sym->formal;
4851   if (dummies == NULL && sym->ts.interface != NULL)
4852     dummies = sym->ts.interface->formal;
4853
4854   return dummies;
4855 }