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, NULL };
 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 /* Tells whether there is only one set of changes in the stack.  */
2702
2703 static bool
2704 single_undo_checkpoint_p (void)
2705 {
2706   if (latest_undo_chgset == &default_undo_chgset_var)
2707     {
2708       gcc_assert (latest_undo_chgset->previous == NULL);
2709       return true;
2710     }
2711   else
2712     {
2713       gcc_assert (latest_undo_chgset->previous != NULL);
2714       return false;
2715     }
2716 }
2717
2718 /* Save symbol with the information necessary to back it out.  */
2719
2720 static void
2721 save_symbol_data (gfc_symbol *sym)
2722 {
2723   gfc_symbol *s;
2724   unsigned i;
2725
2726   if (!single_undo_checkpoint_p ())
2727     {
2728       /* If there is more than one change set, look for the symbol in the
2729          current one.  If it is found there, we can reuse it.  */
2730       FOR_EACH_VEC_ELT (latest_undo_chgset->syms, i, s)
2731         if (s == sym)
2732           {
2733             gcc_assert (sym->gfc_new || sym->old_symbol != NULL);
2734             return;
2735           }
2736     }
2737   else if (sym->gfc_new || sym->old_symbol != NULL)
2738     return;
2739
2740   s = XCNEW (gfc_symbol);
2741   *s = *sym;
2742   sym->old_symbol = s;
2743   sym->gfc_new = 0;
2744
2745   latest_undo_chgset->syms.safe_push (sym);
2746 }
2747
2748
2749 /* Given a name, find a symbol, or create it if it does not exist yet
2750    in the current namespace.  If the symbol is found we make sure that
2751    it's OK.
2752
2753    The integer return code indicates
2754      0   All OK
2755      1   The symbol name was ambiguous
2756      2   The name meant to be established was already host associated.
2757
2758    So if the return value is nonzero, then an error was issued.  */
2759
2760 int
2761 gfc_get_sym_tree (const char *name, gfc_namespace *ns, gfc_symtree **result,
2762                   bool allow_subroutine)
2763 {
2764   gfc_symtree *st;
2765   gfc_symbol *p;
2766
2767   /* This doesn't usually happen during resolution.  */
2768   if (ns == NULL)
2769     ns = gfc_current_ns;
2770
2771   /* Try to find the symbol in ns.  */
2772   st = gfc_find_symtree (ns->sym_root, name);
2773
2774   if (st == NULL)
2775     {
2776       /* If not there, create a new symbol.  */
2777       p = gfc_new_symbol (name, ns);
2778
2779       /* Add to the list of tentative symbols.  */
2780       p->old_symbol = NULL;
2781       p->mark = 1;
2782       p->gfc_new = 1;
2783       latest_undo_chgset->syms.safe_push (p);
2784
2785       st = gfc_new_symtree (&ns->sym_root, name);
2786       st->n.sym = p;
2787       p->refs++;
2788
2789     }
2790   else
2791     {
2792       /* Make sure the existing symbol is OK.  Ambiguous
2793          generic interfaces are permitted, as long as the
2794          specific interfaces are different.  */
2795       if (st->ambiguous && !st->n.sym->attr.generic)
2796         {
2797           ambiguous_symbol (name, st);
2798           return 1;
2799         }
2800
2801       p = st->n.sym;
2802       if (p->ns != ns && (!p->attr.function || ns->proc_name != p)
2803           && !(allow_subroutine && p->attr.subroutine)
2804           && !(ns->proc_name && ns->proc_name->attr.if_source == IFSRC_IFBODY
2805           && (ns->has_import_set || p->attr.imported)))
2806         {
2807           /* Symbol is from another namespace.  */
2808           gfc_error ("Symbol '%s' at %C has already been host associated",
2809                      name);
2810           return 2;
2811         }
2812
2813       p->mark = 1;
2814
2815       /* Copy in case this symbol is changed.  */
2816       save_symbol_data (p);
2817     }
2818
2819   *result = st;
2820   return 0;
2821 }
2822
2823
2824 int
2825 gfc_get_symbol (const char *name, gfc_namespace *ns, gfc_symbol **result)
2826 {
2827   gfc_symtree *st;
2828   int i;
2829
2830   i = gfc_get_sym_tree (name, ns, &st, false);
2831   if (i != 0)
2832     return i;
2833
2834   if (st)
2835     *result = st->n.sym;
2836   else
2837     *result = NULL;
2838   return i;
2839 }
2840
2841
2842 /* Subroutine that searches for a symbol, creating it if it doesn't
2843    exist, but tries to host-associate the symbol if possible.  */
2844
2845 int
2846 gfc_get_ha_sym_tree (const char *name, gfc_symtree **result)
2847 {
2848   gfc_symtree *st;
2849   int i;
2850
2851   i = gfc_find_sym_tree (name, gfc_current_ns, 0, &st);
2852
2853   if (st != NULL)
2854     {
2855       save_symbol_data (st->n.sym);
2856       *result = st;
2857       return i;
2858     }
2859
2860   i = gfc_find_sym_tree (name, gfc_current_ns, 1, &st);
2861   if (i)
2862     return i;
2863
2864   if (st != NULL)
2865     {
2866       *result = st;
2867       return 0;
2868     }
2869
2870   return gfc_get_sym_tree (name, gfc_current_ns, result, false);
2871 }
2872
2873
2874 int
2875 gfc_get_ha_symbol (const char *name, gfc_symbol **result)
2876 {
2877   int i;
2878   gfc_symtree *st;
2879
2880   i = gfc_get_ha_sym_tree (name, &st);
2881
2882   if (st)
2883     *result = st->n.sym;
2884   else
2885     *result = NULL;
2886
2887   return i;
2888 }
2889
2890
2891 /* Search for the symtree belonging to a gfc_common_head; we cannot use
2892    head->name as the common_root symtree's name might be mangled.  */
2893
2894 static gfc_symtree *
2895 find_common_symtree (gfc_symtree *st, gfc_common_head *head)
2896 {
2897
2898   gfc_symtree *result;
2899
2900   if (st == NULL)
2901     return NULL;
2902
2903   if (st->n.common == head)
2904     return st;
2905
2906   result = find_common_symtree (st->left, head);
2907   if (!result)
2908     result = find_common_symtree (st->right, head);
2909
2910   return result;
2911 }
2912
2913
2914 /* Clear the given storage, and make it the current change set for registering
2915    changed symbols.  Its contents are freed after a call to
2916    gfc_restore_last_undo_checkpoint or gfc_drop_last_undo_checkpoint, but
2917    it is up to the caller to free the storage itself.  It is usually a local
2918    variable, so there is nothing to do anyway.  */
2919
2920 void
2921 gfc_new_undo_checkpoint (gfc_undo_change_set &chg_syms)
2922 {
2923   chg_syms.syms = vNULL;
2924   chg_syms.tbps = vNULL;
2925   chg_syms.previous = latest_undo_chgset;
2926   latest_undo_chgset = &chg_syms;
2927 }
2928
2929
2930 /* Restore previous state of symbol.  Just copy simple stuff.  */
2931
2932 static void
2933 restore_old_symbol (gfc_symbol *p)
2934 {
2935   gfc_symbol *old;
2936
2937   p->mark = 0;
2938   old = p->old_symbol;
2939
2940   p->ts.type = old->ts.type;
2941   p->ts.kind = old->ts.kind;
2942
2943   p->attr = old->attr;
2944
2945   if (p->value != old->value)
2946     {
2947       gcc_checking_assert (old->value == NULL);
2948       gfc_free_expr (p->value);
2949       p->value = NULL;
2950     }
2951
2952   if (p->as != old->as)
2953     {
2954       if (p->as)
2955         gfc_free_array_spec (p->as);
2956       p->as = old->as;
2957     }
2958
2959   p->generic = old->generic;
2960   p->component_access = old->component_access;
2961
2962   if (p->namelist != NULL && old->namelist == NULL)
2963     {
2964       gfc_free_namelist (p->namelist);
2965       p->namelist = NULL;
2966     }
2967   else
2968     {
2969       if (p->namelist_tail != old->namelist_tail)
2970         {
2971           gfc_free_namelist (old->namelist_tail->next);
2972           old->namelist_tail->next = NULL;
2973         }
2974     }
2975
2976   p->namelist_tail = old->namelist_tail;
2977
2978   if (p->formal != old->formal)
2979     {
2980       gfc_free_formal_arglist (p->formal);
2981       p->formal = old->formal;
2982     }
2983
2984   p->old_symbol = old->old_symbol;
2985   free (old);
2986 }
2987
2988
2989 /* Frees the internal data of a gfc_undo_change_set structure.  Doesn't free
2990    the structure itself.  */
2991
2992 static void
2993 free_undo_change_set_data (gfc_undo_change_set &cs)
2994 {
2995   cs.syms.release ();
2996   cs.tbps.release ();
2997 }
2998
2999
3000 /* Given a change set pointer, free its target's contents and update it with
3001    the address of the previous change set.  Note that only the contents are
3002    freed, not the target itself (the contents' container).  It is not a problem
3003    as the latter will be a local variable usually.  */
3004
3005 static void
3006 pop_undo_change_set (gfc_undo_change_set *&cs)
3007 {
3008   free_undo_change_set_data (*cs);
3009   cs = cs->previous;
3010 }
3011
3012
3013 static void free_old_symbol (gfc_symbol *sym);
3014
3015
3016 /* Merges the current change set into the previous one.  The changes themselves
3017    are left untouched; only one checkpoint is forgotten.  */
3018
3019 void
3020 gfc_drop_last_undo_checkpoint (void)
3021 {
3022   gfc_symbol *s, *t;
3023   unsigned i, j;
3024
3025   FOR_EACH_VEC_ELT (latest_undo_chgset->syms, i, s)
3026     {
3027       /* No need to loop in this case.  */
3028       if (s->old_symbol == NULL)
3029         continue;
3030
3031       /* Remove the duplicate symbols.  */
3032       FOR_EACH_VEC_ELT (latest_undo_chgset->previous->syms, j, t)
3033         if (t == s)
3034           {
3035             latest_undo_chgset->previous->syms.unordered_remove (j);
3036
3037             /* S->OLD_SYMBOL is the backup symbol for S as it was at the
3038                last checkpoint.  We drop that checkpoint, so S->OLD_SYMBOL
3039                shall contain from now on the backup symbol for S as it was
3040                at the checkpoint before.  */
3041             if (s->old_symbol->gfc_new)
3042               {
3043                 gcc_assert (s->old_symbol->old_symbol == NULL);
3044                 s->gfc_new = s->old_symbol->gfc_new;
3045                 free_old_symbol (s);
3046               }
3047             else
3048               restore_old_symbol (s->old_symbol);
3049             break;
3050           }
3051     }
3052
3053   latest_undo_chgset->previous->syms.safe_splice (latest_undo_chgset->syms);
3054   latest_undo_chgset->previous->tbps.safe_splice (latest_undo_chgset->tbps);
3055
3056   pop_undo_change_set (latest_undo_chgset);
3057 }
3058
3059
3060 /* Undoes all the changes made to symbols since the previous checkpoint.
3061    This subroutine is made simpler due to the fact that attributes are
3062    never removed once added.  */
3063
3064 void
3065 gfc_restore_last_undo_checkpoint (void)
3066 {
3067   gfc_symbol *p;
3068   unsigned i;
3069
3070   FOR_EACH_VEC_ELT (latest_undo_chgset->syms, i, p)
3071     {
3072       if (p->gfc_new)
3073         {
3074           /* Symbol was new.  */
3075           if (p->attr.in_common && p->common_block && p->common_block->head)
3076             {
3077               /* If the symbol was added to any common block, it
3078                  needs to be removed to stop the resolver looking
3079                  for a (possibly) dead symbol.  */
3080
3081               if (p->common_block->head == p && !p->common_next)
3082                 {
3083                   gfc_symtree st, *st0;
3084                   st0 = find_common_symtree (p->ns->common_root,
3085                                              p->common_block);
3086                   if (st0)
3087                     {
3088                       st.name = st0->name;
3089                       gfc_delete_bbt (&p->ns->common_root, &st, compare_symtree);
3090                       free (st0);
3091                     }
3092                 }
3093
3094               if (p->common_block->head == p)
3095                 p->common_block->head = p->common_next;
3096               else
3097                 {
3098                   gfc_symbol *cparent, *csym;
3099
3100                   cparent = p->common_block->head;
3101                   csym = cparent->common_next;
3102
3103                   while (csym != p)
3104                     {
3105                       cparent = csym;
3106                       csym = csym->common_next;
3107                     }
3108
3109                   gcc_assert(cparent->common_next == p);
3110
3111                   cparent->common_next = csym->common_next;
3112                 }
3113             }
3114
3115           /* The derived type is saved in the symtree with the first
3116              letter capitalized; the all lower-case version to the
3117              derived type contains its associated generic function.  */
3118           if (p->attr.flavor == FL_DERIVED)
3119             gfc_delete_symtree (&p->ns->sym_root, gfc_get_string ("%c%s",
3120                         (char) TOUPPER ((unsigned char) p->name[0]),
3121                         &p->name[1]));
3122           else
3123             gfc_delete_symtree (&p->ns->sym_root, p->name);
3124
3125           gfc_release_symbol (p);
3126         }
3127       else
3128         restore_old_symbol (p);
3129     }
3130
3131   latest_undo_chgset->syms.truncate (0);
3132   latest_undo_chgset->tbps.truncate (0);
3133
3134   if (!single_undo_checkpoint_p ())
3135     pop_undo_change_set (latest_undo_chgset);
3136 }
3137
3138
3139 /* Makes sure that there is only one set of changes; in other words we haven't
3140    forgotten to pair a call to gfc_new_checkpoint with a call to either
3141    gfc_drop_last_undo_checkpoint or gfc_restore_last_undo_checkpoint.  */
3142
3143 static void
3144 enforce_single_undo_checkpoint (void)
3145 {
3146   gcc_checking_assert (single_undo_checkpoint_p ());
3147 }
3148
3149
3150 /* Undoes all the changes made to symbols in the current statement.  */
3151
3152 void
3153 gfc_undo_symbols (void)
3154 {
3155   enforce_single_undo_checkpoint ();
3156   gfc_restore_last_undo_checkpoint ();
3157 }
3158
3159
3160 /* Free sym->old_symbol. sym->old_symbol is mostly a shallow copy of sym; the
3161    components of old_symbol that might need deallocation are the "allocatables"
3162    that are restored in gfc_undo_symbols(), with two exceptions: namelist and
3163    namelist_tail.  In case these differ between old_symbol and sym, it's just
3164    because sym->namelist has gotten a few more items.  */
3165
3166 static void
3167 free_old_symbol (gfc_symbol *sym)
3168 {
3169
3170   if (sym->old_symbol == NULL)
3171     return;
3172
3173   if (sym->old_symbol->as != sym->as)
3174     gfc_free_array_spec (sym->old_symbol->as);
3175
3176   if (sym->old_symbol->value != sym->value)
3177     gfc_free_expr (sym->old_symbol->value);
3178
3179   if (sym->old_symbol->formal != sym->formal)
3180     gfc_free_formal_arglist (sym->old_symbol->formal);
3181
3182   free (sym->old_symbol);
3183   sym->old_symbol = NULL;
3184 }
3185
3186
3187 /* Makes the changes made in the current statement permanent-- gets
3188    rid of undo information.  */
3189
3190 void
3191 gfc_commit_symbols (void)
3192 {
3193   gfc_symbol *p;
3194   gfc_typebound_proc *tbp;
3195   unsigned i;
3196
3197   enforce_single_undo_checkpoint ();
3198
3199   FOR_EACH_VEC_ELT (latest_undo_chgset->syms, i, p)
3200     {
3201       p->mark = 0;
3202       p->gfc_new = 0;
3203       free_old_symbol (p);
3204     }
3205   latest_undo_chgset->syms.truncate (0);
3206
3207   FOR_EACH_VEC_ELT (latest_undo_chgset->tbps, i, tbp)
3208     tbp->error = 0;
3209   latest_undo_chgset->tbps.truncate (0);
3210 }
3211
3212
3213 /* Makes the changes made in one symbol permanent -- gets rid of undo
3214    information.  */
3215
3216 void
3217 gfc_commit_symbol (gfc_symbol *sym)
3218 {
3219   gfc_symbol *p;
3220   unsigned i;
3221
3222   enforce_single_undo_checkpoint ();
3223
3224   FOR_EACH_VEC_ELT (latest_undo_chgset->syms, i, p)
3225     if (p == sym)
3226       {
3227         latest_undo_chgset->syms.unordered_remove (i);
3228         break;
3229       }
3230
3231   sym->mark = 0;
3232   sym->gfc_new = 0;
3233
3234   free_old_symbol (sym);
3235 }
3236
3237
3238 /* Recursively free trees containing type-bound procedures.  */
3239
3240 static void
3241 free_tb_tree (gfc_symtree *t)
3242 {
3243   if (t == NULL)
3244     return;
3245
3246   free_tb_tree (t->left);
3247   free_tb_tree (t->right);
3248
3249   /* TODO: Free type-bound procedure structs themselves; probably needs some
3250      sort of ref-counting mechanism.  */
3251
3252   free (t);
3253 }
3254
3255
3256 /* Recursive function that deletes an entire tree and all the common
3257    head structures it points to.  */
3258
3259 static void
3260 free_common_tree (gfc_symtree * common_tree)
3261 {
3262   if (common_tree == NULL)
3263     return;
3264
3265   free_common_tree (common_tree->left);
3266   free_common_tree (common_tree->right);
3267
3268   free (common_tree);
3269 }
3270
3271
3272 /* Recursive function that deletes an entire tree and all the user
3273    operator nodes that it contains.  */
3274
3275 static void
3276 free_uop_tree (gfc_symtree *uop_tree)
3277 {
3278   if (uop_tree == NULL)
3279     return;
3280
3281   free_uop_tree (uop_tree->left);
3282   free_uop_tree (uop_tree->right);
3283
3284   gfc_free_interface (uop_tree->n.uop->op);
3285   free (uop_tree->n.uop);
3286   free (uop_tree);
3287 }
3288
3289
3290 /* Recursive function that deletes an entire tree and all the symbols
3291    that it contains.  */
3292
3293 static void
3294 free_sym_tree (gfc_symtree *sym_tree)
3295 {
3296   if (sym_tree == NULL)
3297     return;
3298
3299   free_sym_tree (sym_tree->left);
3300   free_sym_tree (sym_tree->right);
3301
3302   gfc_release_symbol (sym_tree->n.sym);
3303   free (sym_tree);
3304 }
3305
3306
3307 /* Free the derived type list.  */
3308
3309 void
3310 gfc_free_dt_list (void)
3311 {
3312   gfc_dt_list *dt, *n;
3313
3314   for (dt = gfc_derived_types; dt; dt = n)
3315     {
3316       n = dt->next;
3317       free (dt);
3318     }
3319
3320   gfc_derived_types = NULL;
3321 }
3322
3323
3324 /* Free the gfc_equiv_info's.  */
3325
3326 static void
3327 gfc_free_equiv_infos (gfc_equiv_info *s)
3328 {
3329   if (s == NULL)
3330     return;
3331   gfc_free_equiv_infos (s->next);
3332   free (s);
3333 }
3334
3335
3336 /* Free the gfc_equiv_lists.  */
3337
3338 static void
3339 gfc_free_equiv_lists (gfc_equiv_list *l)
3340 {
3341   if (l == NULL)
3342     return;
3343   gfc_free_equiv_lists (l->next);
3344   gfc_free_equiv_infos (l->equiv);
3345   free (l);
3346 }
3347
3348
3349 /* Free a finalizer procedure list.  */
3350
3351 void
3352 gfc_free_finalizer (gfc_finalizer* el)
3353 {
3354   if (el)
3355     {
3356       gfc_release_symbol (el->proc_sym);
3357       free (el);
3358     }
3359 }
3360
3361 static void
3362 gfc_free_finalizer_list (gfc_finalizer* list)
3363 {
3364   while (list)
3365     {
3366       gfc_finalizer* current = list;
3367       list = list->next;
3368       gfc_free_finalizer (current);
3369     }
3370 }
3371
3372
3373 /* Create a new gfc_charlen structure and add it to a namespace.
3374    If 'old_cl' is given, the newly created charlen will be a copy of it.  */
3375
3376 gfc_charlen*
3377 gfc_new_charlen (gfc_namespace *ns, gfc_charlen *old_cl)
3378 {
3379   gfc_charlen *cl;
3380   cl = gfc_get_charlen ();
3381
3382   /* Copy old_cl.  */
3383   if (old_cl)
3384     {
3385       /* Put into namespace, but don't allow reject_statement
3386          to free it if old_cl is given.  */
3387       gfc_charlen **prev = &ns->cl_list;
3388       cl->next = ns->old_cl_list;
3389       while (*prev != ns->old_cl_list)
3390         prev = &(*prev)->next;
3391       *prev = cl;
3392       ns->old_cl_list = cl;
3393       cl->length = gfc_copy_expr (old_cl->length);
3394       cl->length_from_typespec = old_cl->length_from_typespec;
3395       cl->backend_decl = old_cl->backend_decl;
3396       cl->passed_length = old_cl->passed_length;
3397       cl->resolved = old_cl->resolved;
3398     }
3399   else
3400     {
3401       /* Put into namespace.  */
3402       cl->next = ns->cl_list;
3403       ns->cl_list = cl;
3404     }
3405
3406   return cl;
3407 }
3408
3409
3410 /* Free the charlen list from cl to end (end is not freed).
3411    Free the whole list if end is NULL.  */
3412
3413 void
3414 gfc_free_charlen (gfc_charlen *cl, gfc_charlen *end)
3415 {
3416   gfc_charlen *cl2;
3417
3418   for (; cl != end; cl = cl2)
3419     {
3420       gcc_assert (cl);
3421
3422       cl2 = cl->next;
3423       gfc_free_expr (cl->length);
3424       free (cl);
3425     }
3426 }
3427
3428
3429 /* Free entry list structs.  */
3430
3431 static void
3432 free_entry_list (gfc_entry_list *el)
3433 {
3434   gfc_entry_list *next;
3435
3436   if (el == NULL)
3437     return;
3438
3439   next = el->next;
3440   free (el);
3441   free_entry_list (next);
3442 }
3443
3444
3445 /* Free a namespace structure and everything below it.  Interface
3446    lists associated with intrinsic operators are not freed.  These are
3447    taken care of when a specific name is freed.  */
3448
3449 void
3450 gfc_free_namespace (gfc_namespace *ns)
3451 {
3452   gfc_namespace *p, *q;
3453   int i;
3454
3455   if (ns == NULL)
3456     return;
3457
3458   ns->refs--;
3459   if (ns->refs > 0)
3460     return;
3461   gcc_assert (ns->refs == 0);
3462
3463   gfc_free_statements (ns->code);
3464
3465   free_sym_tree (ns->sym_root);
3466   free_uop_tree (ns->uop_root);
3467   free_common_tree (ns->common_root);
3468   free_tb_tree (ns->tb_sym_root);
3469   free_tb_tree (ns->tb_uop_root);
3470   gfc_free_finalizer_list (ns->finalizers);
3471   gfc_free_charlen (ns->cl_list, NULL);
3472   free_st_labels (ns->st_labels);
3473
3474   free_entry_list (ns->entries);
3475   gfc_free_equiv (ns->equiv);
3476   gfc_free_equiv_lists (ns->equiv_lists);
3477   gfc_free_use_stmts (ns->use_stmts);
3478
3479   for (i = GFC_INTRINSIC_BEGIN; i != GFC_INTRINSIC_END; i++)
3480     gfc_free_interface (ns->op[i]);
3481
3482   gfc_free_data (ns->data);
3483   p = ns->contained;
3484   free (ns);
3485
3486   /* Recursively free any contained namespaces.  */
3487   while (p != NULL)
3488     {
3489       q = p;
3490       p = p->sibling;
3491       gfc_free_namespace (q);
3492     }
3493 }
3494
3495
3496 void
3497 gfc_symbol_init_2 (void)
3498 {
3499
3500   gfc_current_ns = gfc_get_namespace (NULL, 0);
3501 }
3502
3503
3504 void
3505 gfc_symbol_done_2 (void)
3506 {
3507   gfc_free_namespace (gfc_current_ns);
3508   gfc_current_ns = NULL;
3509   gfc_free_dt_list ();
3510
3511   enforce_single_undo_checkpoint ();
3512   free_undo_change_set_data (*latest_undo_chgset);
3513 }
3514
3515
3516 /* Count how many nodes a symtree has.  */
3517
3518 static unsigned
3519 count_st_nodes (const gfc_symtree *st)
3520 {
3521   unsigned nodes;
3522   if (!st)
3523     return 0;
3524
3525   nodes = count_st_nodes (st->left);
3526   nodes++;
3527   nodes += count_st_nodes (st->right);
3528
3529   return nodes;
3530 }
3531
3532
3533 /* Convert symtree tree into symtree vector.  */
3534
3535 static unsigned
3536 fill_st_vector (gfc_symtree *st, gfc_symtree **st_vec, unsigned node_cntr)
3537 {
3538   if (!st)
3539     return node_cntr;
3540
3541   node_cntr = fill_st_vector (st->left, st_vec, node_cntr);
3542   st_vec[node_cntr++] = st;
3543   node_cntr = fill_st_vector (st->right, st_vec, node_cntr);
3544
3545   return node_cntr;
3546 }
3547
3548
3549 /* Traverse namespace.  As the functions might modify the symtree, we store the
3550    symtree as a vector and operate on this vector.  Note: We assume that
3551    sym_func or st_func never deletes nodes from the symtree - only adding is
3552    allowed. Additionally, newly added nodes are not traversed.  */
3553
3554 static void
3555 do_traverse_symtree (gfc_symtree *st, void (*st_func) (gfc_symtree *),
3556                      void (*sym_func) (gfc_symbol *))
3557 {
3558   gfc_symtree **st_vec;
3559   unsigned nodes, i, node_cntr;
3560
3561   gcc_assert ((st_func && !sym_func) || (!st_func && sym_func));
3562   nodes = count_st_nodes (st);
3563   st_vec = XALLOCAVEC (gfc_symtree *, nodes);
3564   node_cntr = 0;
3565   fill_st_vector (st, st_vec, node_cntr);
3566
3567   if (sym_func)
3568     {
3569       /* Clear marks.  */
3570       for (i = 0; i < nodes; i++)
3571         st_vec[i]->n.sym->mark = 0;
3572       for (i = 0; i < nodes; i++)
3573         if (!st_vec[i]->n.sym->mark)
3574           {
3575             (*sym_func) (st_vec[i]->n.sym);
3576             st_vec[i]->n.sym->mark = 1;
3577           }
3578      }
3579    else
3580       for (i = 0; i < nodes; i++)
3581         (*st_func) (st_vec[i]);
3582 }
3583
3584
3585 /* Recursively traverse the symtree nodes.  */
3586
3587 void
3588 gfc_traverse_symtree (gfc_symtree *st, void (*st_func) (gfc_symtree *))
3589 {
3590   do_traverse_symtree (st, st_func, NULL);
3591 }
3592
3593
3594 /* Call a given function for all symbols in the namespace.  We take
3595    care that each gfc_symbol node is called exactly once.  */
3596
3597 void
3598 gfc_traverse_ns (gfc_namespace *ns, void (*sym_func) (gfc_symbol *))
3599 {
3600   do_traverse_symtree (ns->sym_root, NULL, sym_func);
3601 }
3602
3603
3604 /* Return TRUE when name is the name of an intrinsic type.  */
3605
3606 bool
3607 gfc_is_intrinsic_typename (const char *name)
3608 {
3609   if (strcmp (name, "integer") == 0
3610       || strcmp (name, "real") == 0
3611       || strcmp (name, "character") == 0
3612       || strcmp (name, "logical") == 0
3613       || strcmp (name, "complex") == 0
3614       || strcmp (name, "doubleprecision") == 0
3615       || strcmp (name, "doublecomplex") == 0)
3616     return true;
3617   else
3618     return false;
3619 }
3620
3621
3622 /* Return TRUE if the symbol is an automatic variable.  */
3623
3624 static bool
3625 gfc_is_var_automatic (gfc_symbol *sym)
3626 {
3627   /* Pointer and allocatable variables are never automatic.  */
3628   if (sym->attr.pointer || sym->attr.allocatable)
3629     return false;
3630   /* Check for arrays with non-constant size.  */
3631   if (sym->attr.dimension && sym->as
3632       && !gfc_is_compile_time_shape (sym->as))
3633     return true;
3634   /* Check for non-constant length character variables.  */
3635   if (sym->ts.type == BT_CHARACTER
3636       && sym->ts.u.cl
3637       && !gfc_is_constant_expr (sym->ts.u.cl->length))
3638     return true;
3639   return false;
3640 }
3641
3642 /* Given a symbol, mark it as SAVEd if it is allowed.  */
3643
3644 static void
3645 save_symbol (gfc_symbol *sym)
3646 {
3647
3648   if (sym->attr.use_assoc)
3649     return;
3650
3651   if (sym->attr.in_common
3652       || sym->attr.dummy
3653       || sym->attr.result
3654       || sym->attr.flavor != FL_VARIABLE)
3655     return;
3656   /* Automatic objects are not saved.  */
3657   if (gfc_is_var_automatic (sym))
3658     return;
3659   gfc_add_save (&sym->attr, SAVE_EXPLICIT, sym->name, &sym->declared_at);
3660 }
3661
3662
3663 /* Mark those symbols which can be SAVEd as such.  */
3664
3665 void
3666 gfc_save_all (gfc_namespace *ns)
3667 {
3668   gfc_traverse_ns (ns, save_symbol);
3669 }
3670
3671
3672 /* Make sure that no changes to symbols are pending.  */
3673
3674 void
3675 gfc_enforce_clean_symbol_state(void)
3676 {
3677   enforce_single_undo_checkpoint ();
3678   gcc_assert (latest_undo_chgset->syms.is_empty ());
3679 }
3680
3681
3682 /************** Global symbol handling ************/
3683
3684
3685 /* Search a tree for the global symbol.  */
3686
3687 gfc_gsymbol *
3688 gfc_find_gsymbol (gfc_gsymbol *symbol, const char *name)
3689 {
3690   int c;
3691
3692   if (symbol == NULL)
3693     return NULL;
3694
3695   while (symbol)
3696     {
3697       c = strcmp (name, symbol->name);
3698       if (!c)
3699         return symbol;
3700
3701       symbol = (c < 0) ? symbol->left : symbol->right;
3702     }
3703
3704   return NULL;
3705 }
3706
3707
3708 /* Compare two global symbols. Used for managing the BB tree.  */
3709
3710 static int
3711 gsym_compare (void *_s1, void *_s2)
3712 {
3713   gfc_gsymbol *s1, *s2;
3714
3715   s1 = (gfc_gsymbol *) _s1;
3716   s2 = (gfc_gsymbol *) _s2;
3717   return strcmp (s1->name, s2->name);
3718 }
3719
3720
3721 /* Get a global symbol, creating it if it doesn't exist.  */
3722
3723 gfc_gsymbol *
3724 gfc_get_gsymbol (const char *name)
3725 {
3726   gfc_gsymbol *s;
3727
3728   s = gfc_find_gsymbol (gfc_gsym_root, name);
3729   if (s != NULL)
3730     return s;
3731
3732   s = XCNEW (gfc_gsymbol);
3733   s->type = GSYM_UNKNOWN;
3734   s->name = gfc_get_string (name);
3735
3736   gfc_insert_bbt (&gfc_gsym_root, s, gsym_compare);
3737
3738   return s;
3739 }
3740
3741
3742 static gfc_symbol *
3743 get_iso_c_binding_dt (int sym_id)
3744 {
3745   gfc_dt_list *dt_list;
3746
3747   dt_list = gfc_derived_types;
3748
3749   /* Loop through the derived types in the name list, searching for
3750      the desired symbol from iso_c_binding.  Search the parent namespaces
3751      if necessary and requested to (parent_flag).  */
3752   while (dt_list != NULL)
3753     {
3754       if (dt_list->derived->from_intmod != INTMOD_NONE
3755           && dt_list->derived->intmod_sym_id == sym_id)
3756         return dt_list->derived;
3757
3758       dt_list = dt_list->next;
3759     }
3760
3761   return NULL;
3762 }
3763
3764
3765 /* Verifies that the given derived type symbol, derived_sym, is interoperable
3766    with C.  This is necessary for any derived type that is BIND(C) and for
3767    derived types that are parameters to functions that are BIND(C).  All
3768    fields of the derived type are required to be interoperable, and are tested
3769    for such.  If an error occurs, the errors are reported here, allowing for
3770    multiple errors to be handled for a single derived type.  */
3771
3772 gfc_try
3773 verify_bind_c_derived_type (gfc_symbol *derived_sym)
3774 {
3775   gfc_component *curr_comp = NULL;
3776   gfc_try is_c_interop = FAILURE;
3777   gfc_try retval = SUCCESS;
3778
3779   if (derived_sym == NULL)
3780     gfc_internal_error ("verify_bind_c_derived_type(): Given symbol is "
3781                         "unexpectedly NULL");
3782
3783   /* If we've already looked at this derived symbol, do not look at it again
3784      so we don't repeat warnings/errors.  */
3785   if (derived_sym->ts.is_c_interop)
3786     return SUCCESS;
3787
3788   /* The derived type must have the BIND attribute to be interoperable
3789      J3/04-007, Section 15.2.3.  */
3790   if (derived_sym->attr.is_bind_c != 1)
3791     {
3792       derived_sym->ts.is_c_interop = 0;
3793       gfc_error_now ("Derived type '%s' declared at %L must have the BIND "
3794                      "attribute to be C interoperable", derived_sym->name,
3795                      &(derived_sym->declared_at));
3796       retval = FAILURE;
3797     }
3798
3799   curr_comp = derived_sym->components;
3800
3801   /* Fortran 2003 allows an empty derived type.  C99 appears to disallow an
3802      empty struct.  Section 15.2 in Fortran 2003 states:  "The following
3803      subclauses define the conditions under which a Fortran entity is
3804      interoperable.  If a Fortran entity is interoperable, an equivalent
3805      entity may be defined by means of C and the Fortran entity is said
3806      to be interoperable with the C entity.  There does not have to be such
3807      an interoperating C entity."
3808   */
3809   if (curr_comp == NULL)
3810     {
3811       gfc_warning ("Derived type '%s' with BIND(C) attribute at %L is empty, "
3812                    "and may be inaccessible by the C companion processor",
3813                    derived_sym->name, &(derived_sym->declared_at));
3814       derived_sym->ts.is_c_interop = 1;
3815       derived_sym->attr.is_bind_c = 1;
3816       return SUCCESS;
3817     }
3818
3819
3820   /* Initialize the derived type as being C interoperable.
3821      If we find an error in the components, this will be set false.  */
3822   derived_sym->ts.is_c_interop = 1;
3823
3824   /* Loop through the list of components to verify that the kind of
3825      each is a C interoperable type.  */
3826   do
3827     {
3828       /* The components cannot be pointers (fortran sense).
3829          J3/04-007, Section 15.2.3, C1505.      */
3830       if (curr_comp->attr.pointer != 0)
3831         {
3832           gfc_error ("Component '%s' at %L cannot have the "
3833                      "POINTER attribute because it is a member "
3834                      "of the BIND(C) derived type '%s' at %L",
3835                      curr_comp->name, &(curr_comp->loc),
3836                      derived_sym->name, &(derived_sym->declared_at));
3837           retval = FAILURE;
3838         }
3839
3840       if (curr_comp->attr.proc_pointer != 0)
3841         {
3842           gfc_error ("Procedure pointer component '%s' at %L cannot be a member"
3843                      " of the BIND(C) derived type '%s' at %L", curr_comp->name,
3844                      &curr_comp->loc, derived_sym->name,
3845                      &derived_sym->declared_at);
3846           retval = FAILURE;
3847         }
3848
3849       /* The components cannot be allocatable.
3850          J3/04-007, Section 15.2.3, C1505.      */
3851       if (curr_comp->attr.allocatable != 0)
3852         {
3853           gfc_error ("Component '%s' at %L cannot have the "
3854                      "ALLOCATABLE attribute because it is a member "
3855                      "of the BIND(C) derived type '%s' at %L",
3856                      curr_comp->name, &(curr_comp->loc),
3857                      derived_sym->name, &(derived_sym->declared_at));
3858           retval = FAILURE;
3859         }
3860
3861       /* BIND(C) derived types must have interoperable components.  */
3862       if (curr_comp->ts.type == BT_DERIVED
3863           && curr_comp->ts.u.derived->ts.is_iso_c != 1
3864           && curr_comp->ts.u.derived != derived_sym)
3865         {
3866           /* This should be allowed; the draft says a derived-type can not
3867              have type parameters if it is has the BIND attribute.  Type
3868              parameters seem to be for making parameterized derived types.
3869              There's no need to verify the type if it is c_ptr/c_funptr.  */
3870           retval = verify_bind_c_derived_type (curr_comp->ts.u.derived);
3871         }
3872       else
3873         {
3874           /* Grab the typespec for the given component and test the kind.  */
3875           is_c_interop = gfc_verify_c_interop (&(curr_comp->ts));
3876
3877           if (is_c_interop != SUCCESS)
3878             {
3879               /* Report warning and continue since not fatal.  The
3880                  draft does specify a constraint that requires all fields
3881                  to interoperate, but if the user says real(4), etc., it
3882                  may interoperate with *something* in C, but the compiler
3883                  most likely won't know exactly what.  Further, it may not
3884                  interoperate with the same data type(s) in C if the user
3885                  recompiles with different flags (e.g., -m32 and -m64 on
3886                  x86_64 and using integer(4) to claim interop with a
3887                  C_LONG).  */
3888               if (derived_sym->attr.is_bind_c == 1
3889                   && gfc_option.warn_c_binding_type)
3890                 /* If the derived type is bind(c), all fields must be
3891                    interop.  */
3892                 gfc_warning ("Component '%s' in derived type '%s' at %L "
3893                              "may not be C interoperable, even though "
3894                              "derived type '%s' is BIND(C)",
3895                              curr_comp->name, derived_sym->name,
3896                              &(curr_comp->loc), derived_sym->name);
3897               else if (gfc_option.warn_c_binding_type)
3898                 /* If derived type is param to bind(c) routine, or to one
3899                    of the iso_c_binding procs, it must be interoperable, so
3900                    all fields must interop too.  */
3901                 gfc_warning ("Component '%s' in derived type '%s' at %L "
3902                              "may not be C interoperable",
3903                              curr_comp->name, derived_sym->name,
3904                              &(curr_comp->loc));
3905             }
3906         }
3907
3908       curr_comp = curr_comp->next;
3909     } while (curr_comp != NULL);
3910
3911
3912   /* Make sure we don't have conflicts with the attributes.  */
3913   if (derived_sym->attr.access == ACCESS_PRIVATE)
3914     {
3915       gfc_error ("Derived type '%s' at %L cannot be declared with both "
3916                  "PRIVATE and BIND(C) attributes", derived_sym->name,
3917                  &(derived_sym->declared_at));
3918       retval = FAILURE;
3919     }
3920
3921   if (derived_sym->attr.sequence != 0)
3922     {
3923       gfc_error ("Derived type '%s' at %L cannot have the SEQUENCE "
3924                  "attribute because it is BIND(C)", derived_sym->name,
3925                  &(derived_sym->declared_at));
3926       retval = FAILURE;
3927     }
3928
3929   /* Mark the derived type as not being C interoperable if we found an
3930      error.  If there were only warnings, proceed with the assumption
3931      it's interoperable.  */
3932   if (retval == FAILURE)
3933     derived_sym->ts.is_c_interop = 0;
3934
3935   return retval;
3936 }
3937
3938
3939 /* Generate symbols for the named constants c_null_ptr and c_null_funptr.  */
3940
3941 static gfc_try
3942 gen_special_c_interop_ptr (int ptr_id, const char *ptr_name,
3943                            const char *module_name)
3944 {
3945   gfc_symtree *tmp_symtree;
3946   gfc_symbol *tmp_sym;
3947   gfc_constructor *c;
3948
3949   tmp_symtree = gfc_find_symtree (gfc_current_ns->sym_root, ptr_name);
3950
3951   if (tmp_symtree != NULL)
3952     tmp_sym = tmp_symtree->n.sym;
3953   else
3954     {
3955       tmp_sym = NULL;
3956       gfc_internal_error ("gen_special_c_interop_ptr(): Unable to "
3957                           "create symbol for %s", ptr_name);
3958     }
3959
3960   tmp_sym->ts.is_c_interop = 1;
3961   tmp_sym->attr.is_c_interop = 1;
3962   tmp_sym->ts.is_iso_c = 1;
3963   tmp_sym->ts.type = BT_DERIVED;
3964   tmp_sym->attr.flavor = FL_PARAMETER;
3965
3966   /* The c_ptr and c_funptr derived types will provide the
3967      definition for c_null_ptr and c_null_funptr, respectively.  */
3968   if (ptr_id == ISOCBINDING_NULL_PTR)
3969     tmp_sym->ts.u.derived = get_iso_c_binding_dt (ISOCBINDING_PTR);
3970   else
3971     tmp_sym->ts.u.derived = get_iso_c_binding_dt (ISOCBINDING_FUNPTR);
3972   if (tmp_sym->ts.u.derived == NULL)
3973     {
3974       /* This can occur if the user forgot to declare c_ptr or
3975          c_funptr and they're trying to use one of the procedures
3976          that has arg(s) of the missing type.  In this case, a
3977          regular version of the thing should have been put in the
3978          current ns.  */
3979
3980       generate_isocbinding_symbol (module_name, ptr_id == ISOCBINDING_NULL_PTR
3981                                    ? ISOCBINDING_PTR : ISOCBINDING_FUNPTR,
3982                                    (const char *) (ptr_id == ISOCBINDING_NULL_PTR
3983                                    ? "c_ptr"
3984                                    : "c_funptr"));
3985       tmp_sym->ts.u.derived =
3986         get_iso_c_binding_dt (ptr_id == ISOCBINDING_NULL_PTR
3987                               ? ISOCBINDING_PTR : ISOCBINDING_FUNPTR);
3988     }
3989
3990   /* Module name is some mangled version of iso_c_binding.  */
3991   tmp_sym->module = gfc_get_string (module_name);
3992
3993   /* Say it's from the iso_c_binding module.  */
3994   tmp_sym->attr.is_iso_c = 1;
3995
3996   tmp_sym->attr.use_assoc = 1;
3997   tmp_sym->attr.is_bind_c = 1;
3998   /* Since we never generate a call to this symbol, don't set the
3999      binding_label.  */
4000
4001   /* Set the c_address field of c_null_ptr and c_null_funptr to
4002      the value of NULL.  */
4003   tmp_sym->value = gfc_get_expr ();
4004   tmp_sym->value->expr_type = EXPR_STRUCTURE;
4005   tmp_sym->value->ts.type = BT_DERIVED;
4006   tmp_sym->value->ts.u.derived = tmp_sym->ts.u.derived;
4007   gfc_constructor_append_expr (&tmp_sym->value->value.constructor, NULL, NULL);
4008   c = gfc_constructor_first (tmp_sym->value->value.constructor);
4009   c->expr = gfc_get_expr ();
4010   c->expr->expr_type = EXPR_NULL;
4011   c->expr->ts.is_iso_c = 1;
4012
4013   return SUCCESS;
4014 }
4015
4016
4017 /* Add a formal argument, gfc_formal_arglist, to the
4018    end of the given list of arguments.  Set the reference to the
4019    provided symbol, param_sym, in the argument.  */
4020
4021 static void
4022 add_formal_arg (gfc_formal_arglist **head,
4023                 gfc_formal_arglist **tail,
4024                 gfc_formal_arglist *formal_arg,
4025                 gfc_symbol *param_sym)
4026 {
4027   /* Put in list, either as first arg or at the tail (curr arg).  */
4028   if (*head == NULL)
4029     *head = *tail = formal_arg;
4030   else
4031     {
4032       (*tail)->next = formal_arg;
4033       (*tail) = formal_arg;
4034     }
4035
4036   (*tail)->sym = param_sym;
4037   (*tail)->next = NULL;
4038
4039   return;
4040 }
4041
4042
4043 /* Generates a symbol representing the CPTR argument to an
4044    iso_c_binding procedure.  Also, create a gfc_formal_arglist for the
4045    CPTR and add it to the provided argument list.  */
4046
4047 static void
4048 gen_cptr_param (gfc_formal_arglist **head,
4049                 gfc_formal_arglist **tail,
4050                 const char *module_name,
4051                 gfc_namespace *ns, const char *c_ptr_name,
4052                 int iso_c_sym_id)
4053 {
4054   gfc_symbol *param_sym = NULL;
4055   gfc_symbol *c_ptr_sym = NULL;
4056   gfc_symtree *param_symtree = NULL;
4057   gfc_formal_arglist *formal_arg = NULL;
4058   const char *c_ptr_in;
4059   const char *c_ptr_type = NULL;
4060
4061   if (iso_c_sym_id == ISOCBINDING_F_PROCPOINTER)
4062     c_ptr_type = "c_funptr";
4063   else
4064     c_ptr_type = "c_ptr";
4065
4066   if(c_ptr_name == NULL)
4067     c_ptr_in = "gfc_cptr__";
4068   else
4069     c_ptr_in = c_ptr_name;
4070   gfc_get_sym_tree (c_ptr_in, ns, &param_symtree, false);
4071   if (param_symtree != NULL)
4072     param_sym = param_symtree->n.sym;
4073   else
4074     gfc_internal_error ("gen_cptr_param(): Unable to "
4075                         "create symbol for %s", c_ptr_in);
4076
4077   /* Set up the appropriate fields for the new c_ptr param sym.  */
4078   param_sym->refs++;
4079   param_sym->attr.flavor = FL_DERIVED;
4080   param_sym->ts.type = BT_DERIVED;
4081   param_sym->attr.intent = INTENT_IN;
4082   param_sym->attr.dummy = 1;
4083
4084   /* This will pass the ptr to the iso_c routines as a (void *).  */
4085   param_sym->attr.value = 1;
4086   param_sym->attr.use_assoc = 1;
4087
4088   /* Get the symbol for c_ptr or c_funptr, no matter what it's name is
4089      (user renamed).  */
4090   if (iso_c_sym_id == ISOCBINDING_F_PROCPOINTER)
4091     c_ptr_sym = get_iso_c_binding_dt (ISOCBINDING_FUNPTR);
4092   else
4093     c_ptr_sym = get_iso_c_binding_dt (ISOCBINDING_PTR);
4094   if (c_ptr_sym == NULL)
4095     {
4096       /* This can happen if the user did not define c_ptr but they are
4097          trying to use one of the iso_c_binding functions that need it.  */
4098       if (iso_c_sym_id == ISOCBINDING_F_PROCPOINTER)
4099         generate_isocbinding_symbol (module_name, ISOCBINDING_FUNPTR,
4100                                      (const char *)c_ptr_type);
4101       else
4102         generate_isocbinding_symbol (module_name, ISOCBINDING_PTR,
4103                                      (const char *)c_ptr_type);
4104
4105       gfc_get_ha_symbol (c_ptr_type, &(c_ptr_sym));
4106     }
4107
4108   param_sym->ts.u.derived = c_ptr_sym;
4109   param_sym->module = gfc_get_string (module_name);
4110
4111   /* Make new formal arg.  */
4112   formal_arg = gfc_get_formal_arglist ();
4113   /* Add arg to list of formal args (the CPTR arg).  */
4114   add_formal_arg (head, tail, formal_arg, param_sym);
4115
4116   /* Validate changes.  */
4117   gfc_commit_symbol (param_sym);
4118 }
4119
4120
4121 /* Generates a symbol representing the FPTR argument to an
4122    iso_c_binding procedure.  Also, create a gfc_formal_arglist for the
4123    FPTR and add it to the provided argument list.  */
4124
4125 static void
4126 gen_fptr_param (gfc_formal_arglist **head,
4127                 gfc_formal_arglist **tail,
4128                 const char *module_name,
4129                 gfc_namespace *ns, const char *f_ptr_name, int proc)
4130 {
4131   gfc_symbol *param_sym = NULL;
4132   gfc_symtree *param_symtree = NULL;
4133   gfc_formal_arglist *formal_arg = NULL;
4134   const char *f_ptr_out = "gfc_fptr__";
4135
4136   if (f_ptr_name != NULL)
4137     f_ptr_out = f_ptr_name;
4138
4139   gfc_get_sym_tree (f_ptr_out, ns, &param_symtree, false);
4140   if (param_symtree != NULL)
4141     param_sym = param_symtree->n.sym;
4142   else
4143     gfc_internal_error ("generateFPtrParam(): Unable to "
4144                         "create symbol for %s", f_ptr_out);
4145
4146   /* Set up the necessary fields for the fptr output param sym.  */
4147   param_sym->refs++;
4148   if (proc)
4149     param_sym->attr.proc_pointer = 1;
4150   else
4151     param_sym->attr.pointer = 1;
4152   param_sym->attr.dummy = 1;
4153   param_sym->attr.use_assoc = 1;
4154
4155   /* ISO C Binding type to allow any pointer type as actual param.  */
4156   param_sym->ts.type = BT_VOID;
4157   param_sym->module = gfc_get_string (module_name);
4158
4159   /* Make the arg.  */
4160   formal_arg = gfc_get_formal_arglist ();
4161   /* Add arg to list of formal args.  */
4162   add_formal_arg (head, tail, formal_arg, param_sym);
4163
4164   /* Validate changes.  */
4165   gfc_commit_symbol (param_sym);
4166 }
4167
4168
4169 /* Generates a symbol representing the optional SHAPE argument for the
4170    iso_c_binding c_f_pointer() procedure.  Also, create a
4171    gfc_formal_arglist for the SHAPE and add it to the provided
4172    argument list.  */
4173
4174 static void
4175 gen_shape_param (gfc_formal_arglist **head,
4176                  gfc_formal_arglist **tail,
4177                  const char *module_name,
4178                  gfc_namespace *ns, const char *shape_param_name)
4179 {
4180   gfc_symbol *param_sym = NULL;
4181   gfc_symtree *param_symtree = NULL;
4182   gfc_formal_arglist *formal_arg = NULL;
4183   const char *shape_param = "gfc_shape_array__";
4184
4185   if (shape_param_name != NULL)
4186     shape_param = shape_param_name;
4187
4188   gfc_get_sym_tree (shape_param, ns, &param_symtree, false);
4189   if (param_symtree != NULL)
4190     param_sym = param_symtree->n.sym;
4191   else
4192     gfc_internal_error ("generateShapeParam(): Unable to "
4193                         "create symbol for %s", shape_param);
4194
4195   /* Set up the necessary fields for the shape input param sym.  */
4196   param_sym->refs++;
4197   param_sym->attr.dummy = 1;
4198   param_sym->attr.use_assoc = 1;
4199
4200   /* Integer array, rank 1, describing the shape of the object.  Make it's
4201      type BT_VOID initially so we can accept any type/kind combination of
4202      integer.  During gfc_iso_c_sub_interface (resolve.c), we'll make it
4203      of BT_INTEGER type.  */
4204   param_sym->ts.type = BT_VOID;
4205
4206   /* Initialize the kind to default integer.  However, it will be overridden
4207      during resolution to match the kind of the SHAPE parameter given as
4208      the actual argument (to allow for any valid integer kind).  */
4209   param_sym->ts.kind = gfc_default_integer_kind;
4210   param_sym->as = gfc_get_array_spec ();
4211
4212   param_sym->as->rank = 1;
4213   param_sym->as->lower[0] = gfc_get_int_expr (gfc_default_integer_kind,
4214                                               NULL, 1);
4215
4216   /* The extent is unknown until we get it.  The length give us
4217      the rank the incoming pointer.  */
4218   param_sym->as->type = AS_ASSUMED_SHAPE;
4219
4220   /* The arg is also optional; it is required iff the second arg
4221      (fptr) is to an array, otherwise, it's ignored.  */
4222   param_sym->attr.optional = 1;
4223   param_sym->attr.intent = INTENT_IN;
4224   param_sym->attr.dimension = 1;
4225   param_sym->module = gfc_get_string (module_name);
4226
4227   /* Make the arg.  */
4228   formal_arg = gfc_get_formal_arglist ();
4229   /* Add arg to list of formal args.  */
4230   add_formal_arg (head, tail, formal_arg, param_sym);
4231
4232   /* Validate changes.  */
4233   gfc_commit_symbol (param_sym);
4234 }
4235
4236
4237 /* Add a procedure interface to the given symbol (i.e., store a
4238    reference to the list of formal arguments).  */
4239
4240 static void
4241 add_proc_interface (gfc_symbol *sym, ifsrc source, gfc_formal_arglist *formal)
4242 {
4243
4244   sym->formal = formal;
4245   sym->attr.if_source = source;
4246 }
4247
4248
4249 /* Copy the formal args from an existing symbol, src, into a new
4250    symbol, dest.  New formal args are created, and the description of
4251    each arg is set according to the existing ones.  This function is
4252    used when creating procedure declaration variables from a procedure
4253    declaration statement (see match_proc_decl()) to create the formal
4254    args based on the args of a given named interface.  */
4255
4256 void
4257 gfc_copy_formal_args_intr (gfc_symbol *dest, gfc_intrinsic_sym *src)
4258 {
4259   gfc_formal_arglist *head = NULL;
4260   gfc_formal_arglist *tail = NULL;
4261   gfc_formal_arglist *formal_arg = NULL;
4262   gfc_intrinsic_arg *curr_arg = NULL;
4263   gfc_formal_arglist *formal_prev = NULL;
4264   /* Save current namespace so we can change it for formal args.  */
4265   gfc_namespace *parent_ns = gfc_current_ns;
4266
4267   /* Create a new namespace, which will be the formal ns (namespace
4268      of the formal args).  */
4269   gfc_current_ns = gfc_get_namespace (parent_ns, 0);
4270   gfc_current_ns->proc_name = dest;
4271
4272   for (curr_arg = src->formal; curr_arg; curr_arg = curr_arg->next)
4273     {
4274       formal_arg = gfc_get_formal_arglist ();
4275       gfc_get_symbol (curr_arg->name, gfc_current_ns, &(formal_arg->sym));
4276
4277       /* May need to copy more info for the symbol.  */
4278       formal_arg->sym->ts = curr_arg->ts;
4279       formal_arg->sym->attr.optional = curr_arg->optional;
4280       formal_arg->sym->attr.value = curr_arg->value;
4281       formal_arg->sym->attr.intent = curr_arg->intent;
4282       formal_arg->sym->attr.flavor = FL_VARIABLE;
4283       formal_arg->sym->attr.dummy = 1;
4284
4285       if (formal_arg->sym->ts.type == BT_CHARACTER)
4286         formal_arg->sym->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
4287
4288       /* If this isn't the first arg, set up the next ptr.  For the
4289         last arg built, the formal_arg->next will never get set to
4290         anything other than NULL.  */
4291       if (formal_prev != NULL)
4292         formal_prev->next = formal_arg;
4293       else
4294         formal_arg->next = NULL;
4295
4296       formal_prev = formal_arg;
4297
4298       /* Add arg to list of formal args.  */
4299       add_formal_arg (&head, &tail, formal_arg, formal_arg->sym);
4300
4301       /* Validate changes.  */
4302       gfc_commit_symbol (formal_arg->sym);
4303     }
4304
4305   /* Add the interface to the symbol.  */
4306   add_proc_interface (dest, IFSRC_DECL, head);
4307
4308   /* Store the formal namespace information.  */
4309   if (dest->formal != NULL)
4310     /* The current ns should be that for the dest proc.  */
4311     dest->formal_ns = gfc_current_ns;
4312   /* Restore the current namespace to what it was on entry.  */
4313   gfc_current_ns = parent_ns;
4314 }
4315
4316
4317 /* Builds the parameter list for the iso_c_binding procedure
4318    c_f_pointer or c_f_procpointer.  The old_sym typically refers to a
4319    generic version of either the c_f_pointer or c_f_procpointer
4320    functions.  The new_proc_sym represents a "resolved" version of the
4321    symbol.  The functions are resolved to match the types of their
4322    parameters; for example, c_f_pointer(cptr, fptr) would resolve to
4323    something similar to c_f_pointer_i4 if the type of data object fptr
4324    pointed to was a default integer.  The actual name of the resolved
4325    procedure symbol is further mangled with the module name, etc., but
4326    the idea holds true.  */
4327
4328 static void
4329 build_formal_args (gfc_symbol *new_proc_sym,
4330                    gfc_symbol *old_sym, int add_optional_arg)
4331 {
4332   gfc_formal_arglist *head = NULL, *tail = NULL;
4333   gfc_namespace *parent_ns = NULL;
4334
4335   parent_ns = gfc_current_ns;
4336   /* Create a new namespace, which will be the formal ns (namespace
4337      of the formal args).  */
4338   gfc_current_ns = gfc_get_namespace(parent_ns, 0);
4339   gfc_current_ns->proc_name = new_proc_sym;
4340
4341   /* Generate the params.  */
4342   if (old_sym->intmod_sym_id == ISOCBINDING_F_PROCPOINTER)
4343     {
4344       gen_cptr_param (&head, &tail, (const char *) new_proc_sym->module,
4345                       gfc_current_ns, "cptr", old_sym->intmod_sym_id);
4346       gen_fptr_param (&head, &tail, (const char *) new_proc_sym->module,
4347                       gfc_current_ns, "fptr", 1);
4348     }
4349   else if (old_sym->intmod_sym_id == ISOCBINDING_F_POINTER)
4350     {
4351       gen_cptr_param (&head, &tail, (const char *) new_proc_sym->module,
4352                       gfc_current_ns, "cptr", old_sym->intmod_sym_id);
4353       gen_fptr_param (&head, &tail, (const char *) new_proc_sym->module,
4354                       gfc_current_ns, "fptr", 0);
4355       /* If we're dealing with c_f_pointer, it has an optional third arg.  */
4356       gen_shape_param (&head, &tail,(const char *) new_proc_sym->module,
4357                        gfc_current_ns, "shape");
4358
4359     }
4360   else if (old_sym->intmod_sym_id == ISOCBINDING_ASSOCIATED)
4361     {
4362       /* c_associated has one required arg and one optional; both
4363          are c_ptrs.  */
4364       gen_cptr_param (&head, &tail, (const char *) new_proc_sym->module,
4365                       gfc_current_ns, "c_ptr_1", ISOCBINDING_ASSOCIATED);
4366       if (add_optional_arg)
4367         {
4368           gen_cptr_param (&head, &tail, (const char *) new_proc_sym->module,
4369                           gfc_current_ns, "c_ptr_2", ISOCBINDING_ASSOCIATED);
4370           /* The last param is optional so mark it as such.  */
4371           tail->sym->attr.optional = 1;
4372         }
4373     }
4374
4375   /* Add the interface (store formal args to new_proc_sym).  */
4376   add_proc_interface (new_proc_sym, IFSRC_DECL, head);
4377
4378   /* Set up the formal_ns pointer to the one created for the
4379      new procedure so it'll get cleaned up during gfc_free_symbol().  */
4380   new_proc_sym->formal_ns = gfc_current_ns;
4381
4382   gfc_current_ns = parent_ns;
4383 }
4384
4385 static int
4386 std_for_isocbinding_symbol (int id)
4387 {
4388   switch (id)
4389     {
4390 #define NAMED_INTCST(a,b,c,d) \
4391       case a:\
4392         return d;
4393 #include "iso-c-binding.def"
4394 #undef NAMED_INTCST
4395
4396 #define NAMED_FUNCTION(a,b,c,d) \
4397       case a:\
4398         return d;
4399 #include "iso-c-binding.def"
4400 #undef NAMED_FUNCTION
4401
4402        default:
4403          return GFC_STD_F2003;
4404     }
4405 }
4406
4407 /* Generate the given set of C interoperable kind objects, or all
4408    interoperable kinds.  This function will only be given kind objects
4409    for valid iso_c_binding defined types because this is verified when
4410    the 'use' statement is parsed.  If the user gives an 'only' clause,
4411    the specific kinds are looked up; if they don't exist, an error is
4412    reported.  If the user does not give an 'only' clause, all
4413    iso_c_binding symbols are generated.  If a list of specific kinds
4414    is given, it must have a NULL in the first empty spot to mark the
4415    end of the list.  */
4416
4417
4418 void
4419 generate_isocbinding_symbol (const char *mod_name, iso_c_binding_symbol s,
4420                              const char *local_name)
4421 {
4422   const char *const name = (local_name && local_name[0]) ? local_name
4423                                              : c_interop_kinds_table[s].name;
4424   gfc_symtree *tmp_symtree = NULL;
4425   gfc_symbol *tmp_sym = NULL;
4426   int index;
4427
4428   if (gfc_notification_std (std_for_isocbinding_symbol (s)) == ERROR)
4429     return;
4430
4431   tmp_symtree = gfc_find_symtree (gfc_current_ns->sym_root, name);
4432
4433   /* Already exists in this scope so don't re-add it. */
4434   if (tmp_symtree != NULL && (tmp_sym = tmp_symtree->n.sym) != NULL
4435       && (!tmp_sym->attr.generic
4436           || (tmp_sym = gfc_find_dt_in_generic (tmp_sym)) != NULL)
4437       && tmp_sym->from_intmod == INTMOD_ISO_C_BINDING)
4438     {
4439       if (tmp_sym->attr.flavor == FL_DERIVED
4440           && !get_iso_c_binding_dt (tmp_sym->intmod_sym_id))
4441         {
4442           gfc_dt_list *dt_list;
4443           dt_list = gfc_get_dt_list ();
4444           dt_list->derived = tmp_sym;
4445           dt_list->next = gfc_derived_types;
4446           gfc_derived_types = dt_list;
4447         }
4448
4449       return;
4450     }
4451
4452   /* Create the sym tree in the current ns.  */
4453   gfc_get_sym_tree (name, gfc_current_ns, &tmp_symtree, false);
4454   if (tmp_symtree)
4455     tmp_sym = tmp_symtree->n.sym;
4456   else
4457     gfc_internal_error ("generate_isocbinding_symbol(): Unable to "
4458                         "create symbol");
4459
4460   /* Say what module this symbol belongs to.  */
4461   tmp_sym->module = gfc_get_string (mod_name);
4462   tmp_sym->from_intmod = INTMOD_ISO_C_BINDING;
4463   tmp_sym->intmod_sym_id = s;
4464
4465   switch (s)
4466     {
4467
4468 #define NAMED_INTCST(a,b,c,d) case a :
4469 #define NAMED_REALCST(a,b,c,d) case a :
4470 #define NAMED_CMPXCST(a,b,c,d) case a :
4471 #define NAMED_LOGCST(a,b,c) case a :
4472 #define NAMED_CHARKNDCST(a,b,c) case a :
4473 #include "iso-c-binding.def"
4474
4475         tmp_sym->value = gfc_get_int_expr (gfc_default_integer_kind, NULL,
4476                                            c_interop_kinds_table[s].value);
4477
4478         /* Initialize an integer constant expression node.  */
4479         tmp_sym->attr.flavor = FL_PARAMETER;
4480         tmp_sym->ts.type = BT_INTEGER;
4481         tmp_sym->ts.kind = gfc_default_integer_kind;
4482
4483         /* Mark this type as a C interoperable one.  */
4484         tmp_sym->ts.is_c_interop = 1;
4485         tmp_sym->ts.is_iso_c = 1;
4486         tmp_sym->value->ts.is_c_interop = 1;
4487         tmp_sym->value->ts.is_iso_c = 1;
4488         tmp_sym->attr.is_c_interop = 1;
4489
4490         /* Tell what f90 type this c interop kind is valid.  */
4491         tmp_sym->ts.f90_type = c_interop_kinds_table[s].f90_type;
4492
4493         /* Say it's from the iso_c_binding module.  */
4494         tmp_sym->attr.is_iso_c = 1;
4495
4496         /* Make it use associated.  */
4497         tmp_sym->attr.use_assoc = 1;
4498         break;
4499
4500
4501 #define NAMED_CHARCST(a,b,c) case a :
4502 #include "iso-c-binding.def"
4503
4504         /* Initialize an integer constant expression node for the
4505            length of the character.  */
4506         tmp_sym->value = gfc_get_character_expr (gfc_default_character_kind,
4507                                                  &gfc_current_locus, NULL, 1);
4508         tmp_sym->value->ts.is_c_interop = 1;
4509         tmp_sym->value->ts.is_iso_c = 1;
4510         tmp_sym->value->value.character.length = 1;
4511         tmp_sym->value->value.character.string[0]
4512           = (gfc_char_t) c_interop_kinds_table[s].value;
4513         tmp_sym->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
4514         tmp_sym->ts.u.cl->length = gfc_get_int_expr (gfc_default_integer_kind,
4515                                                      NULL, 1);
4516
4517         /* May not need this in both attr and ts, but do need in
4518            attr for writing module file.  */
4519         tmp_sym->attr.is_c_interop = 1;
4520
4521         tmp_sym->attr.flavor = FL_PARAMETER;
4522         tmp_sym->ts.type = BT_CHARACTER;
4523
4524         /* Need to set it to the C_CHAR kind.  */
4525         tmp_sym->ts.kind = gfc_default_character_kind;
4526
4527         /* Mark this type as a C interoperable one.  */
4528         tmp_sym->ts.is_c_interop = 1;
4529         tmp_sym->ts.is_iso_c = 1;
4530
4531         /* Tell what f90 type this c interop kind is valid.  */
4532         tmp_sym->ts.f90_type = BT_CHARACTER;
4533
4534         /* Say it's from the iso_c_binding module.  */
4535         tmp_sym->attr.is_iso_c = 1;
4536
4537         /* Make it use associated.  */
4538         tmp_sym->attr.use_assoc = 1;
4539         break;
4540
4541       case ISOCBINDING_PTR:
4542       case ISOCBINDING_FUNPTR:
4543         {
4544           gfc_interface *intr, *head;
4545           gfc_symbol *dt_sym;
4546           const char *hidden_name;
4547           gfc_dt_list **dt_list_ptr = NULL;
4548           gfc_component *tmp_comp = NULL;
4549           char comp_name[(GFC_MAX_SYMBOL_LEN * 2) + 1];
4550
4551           hidden_name = gfc_get_string ("%c%s",
4552                             (char) TOUPPER ((unsigned char) tmp_sym->name[0]),
4553                             &tmp_sym->name[1]);
4554
4555           /* Generate real derived type.  */
4556           tmp_symtree = gfc_find_symtree (gfc_current_ns->sym_root,
4557                                           hidden_name);
4558
4559           if (tmp_symtree != NULL)
4560             gcc_unreachable ();
4561           gfc_get_sym_tree (hidden_name, gfc_current_ns, &tmp_symtree, false);
4562           if (tmp_symtree)
4563             dt_sym = tmp_symtree->n.sym;
4564           else
4565             gcc_unreachable ();
4566
4567           /* Generate an artificial generic function.  */
4568           dt_sym->name = gfc_get_string (tmp_sym->name);
4569           head = tmp_sym->generic;
4570           intr = gfc_get_interface ();
4571           intr->sym = dt_sym;
4572           intr->where = gfc_current_locus;
4573           intr->next = head;
4574           tmp_sym->generic = intr;
4575
4576           if (!tmp_sym->attr.generic
4577               && gfc_add_generic (&tmp_sym->attr, tmp_sym->name, NULL)
4578                  == FAILURE)
4579             return;
4580
4581           if (!tmp_sym->attr.function
4582               && gfc_add_function (&tmp_sym->attr, tmp_sym->name, NULL)
4583                  == FAILURE)
4584             return;
4585
4586           /* Say what module this symbol belongs to.  */
4587           dt_sym->module = gfc_get_string (mod_name);
4588           dt_sym->from_intmod = INTMOD_ISO_C_BINDING;
4589           dt_sym->intmod_sym_id = s;
4590
4591           /* Initialize an integer constant expression node.  */
4592           dt_sym->attr.flavor = FL_DERIVED;
4593           dt_sym->ts.is_c_interop = 1;
4594           dt_sym->attr.is_c_interop = 1;
4595           dt_sym->attr.is_iso_c = 1;
4596           dt_sym->ts.is_iso_c = 1;
4597           dt_sym->ts.type = BT_DERIVED;
4598
4599           /* A derived type must have the bind attribute to be
4600              interoperable (J3/04-007, Section 15.2.3), even though
4601              the binding label is not used.  */
4602           dt_sym->attr.is_bind_c = 1;
4603
4604           dt_sym->attr.referenced = 1;
4605           dt_sym->ts.u.derived = dt_sym;
4606
4607           /* Add the symbol created for the derived type to the current ns.  */
4608           dt_list_ptr = &(gfc_derived_types);
4609           while (*dt_list_ptr != NULL && (*dt_list_ptr)->next != NULL)
4610             dt_list_ptr = &((*dt_list_ptr)->next);
4611
4612           /* There is already at least one derived type in the list, so append
4613              the one we're currently building for c_ptr or c_funptr.  */
4614           if (*dt_list_ptr != NULL)
4615             dt_list_ptr = &((*dt_list_ptr)->next);
4616           (*dt_list_ptr) = gfc_get_dt_list ();
4617           (*dt_list_ptr)->derived = dt_sym;
4618           (*dt_list_ptr)->next = NULL;
4619
4620           /* Set up the component of the derived type, which will be
4621              an integer with kind equal to c_ptr_size.  Mangle the name of
4622              the field for the c_address to prevent the curious user from
4623              trying to access it from Fortran.  */
4624           sprintf (comp_name, "__%s_%s", dt_sym->name, "c_address");
4625           gfc_add_component (dt_sym, comp_name, &tmp_comp);
4626           if (tmp_comp == NULL)
4627           gfc_internal_error ("generate_isocbinding_symbol(): Unable to "
4628                               "create component for c_address");
4629
4630           tmp_comp->ts.type = BT_INTEGER;
4631
4632           /* Set this because the module will need to read/write this field.  */
4633           tmp_comp->ts.f90_type = BT_INTEGER;
4634
4635           /* The kinds for c_ptr and c_funptr are the same.  */
4636           index = get_c_kind ("c_ptr", c_interop_kinds_table);
4637           tmp_comp->ts.kind = c_interop_kinds_table[index].value;
4638
4639           tmp_comp->attr.pointer = 0;
4640           tmp_comp->attr.dimension = 0;
4641
4642           /* Mark the component as C interoperable.  */
4643           tmp_comp->ts.is_c_interop = 1;
4644
4645           /* Make it use associated (iso_c_binding module).  */
4646           dt_sym->attr.use_assoc = 1;
4647         }
4648
4649         break;
4650
4651       case ISOCBINDING_NULL_PTR:
4652       case ISOCBINDING_NULL_FUNPTR:
4653         gen_special_c_interop_ptr (s, name, mod_name);
4654         break;
4655
4656       case ISOCBINDING_F_POINTER:
4657       case ISOCBINDING_ASSOCIATED:
4658       case ISOCBINDING_LOC:
4659       case ISOCBINDING_FUNLOC:
4660       case ISOCBINDING_F_PROCPOINTER:
4661
4662         tmp_sym->attr.proc = PROC_MODULE;
4663
4664         /* Use the procedure's name as it is in the iso_c_binding module for
4665            setting the binding label in case the user renamed the symbol.  */
4666         tmp_sym->binding_label =
4667           gfc_get_string ("%s_%s", mod_name,
4668                           c_interop_kinds_table[s].name);
4669         tmp_sym->attr.is_iso_c = 1;
4670         if (s == ISOCBINDING_F_POINTER || s == ISOCBINDING_F_PROCPOINTER)
4671           tmp_sym->attr.subroutine = 1;
4672         else
4673           {
4674             /* TODO!  This needs to be finished more for the expr of the
4675                function or something!
4676                This may not need to be here, because trying to do c_loc
4677                as an external.  */
4678             if (s == ISOCBINDING_ASSOCIATED)
4679               {
4680                 tmp_sym->attr.function = 1;
4681                 tmp_sym->ts.type = BT_LOGICAL;
4682                 tmp_sym->ts.kind = gfc_default_logical_kind;
4683                 tmp_sym->result = tmp_sym;
4684               }
4685             else
4686               {
4687                /* Here, we're taking the simple approach.  We're defining
4688                   c_loc as an external identifier so the compiler will put
4689                   what we expect on the stack for the address we want the
4690                   C address of.  */
4691                 tmp_sym->ts.type = BT_DERIVED;
4692                 if (s == ISOCBINDING_LOC)
4693                   tmp_sym->ts.u.derived =
4694                     get_iso_c_binding_dt (ISOCBINDING_PTR);
4695                 else
4696                   tmp_sym->ts.u.derived =
4697                     get_iso_c_binding_dt (ISOCBINDING_FUNPTR);
4698
4699                 if (tmp_sym->ts.u.derived == NULL)
4700                   {
4701                     /* Create the necessary derived type so we can continue
4702                        processing the file.  */
4703                     generate_isocbinding_symbol
4704                       (mod_name, s == ISOCBINDING_FUNLOC
4705                                 ? ISOCBINDING_FUNPTR : ISOCBINDING_PTR,
4706                       (const char *)(s == ISOCBINDING_FUNLOC
4707                                 ? "c_funptr" : "c_ptr"));
4708                     tmp_sym->ts.u.derived =
4709                     get_iso_c_binding_dt (s == ISOCBINDING_FUNLOC
4710                                             ? ISOCBINDING_FUNPTR
4711                                             : ISOCBINDING_PTR);
4712                   }
4713
4714                 /* The function result is itself (no result clause).  */
4715                 tmp_sym->result = tmp_sym;
4716                 tmp_sym->attr.external = 1;
4717                 tmp_sym->attr.use_assoc = 0;
4718                 tmp_sym->attr.pure = 1;
4719                 tmp_sym->attr.if_source = IFSRC_UNKNOWN;
4720                 tmp_sym->attr.proc = PROC_UNKNOWN;
4721               }
4722           }
4723
4724         tmp_sym->attr.flavor = FL_PROCEDURE;
4725         tmp_sym->attr.contained = 0;
4726
4727        /* Try using this builder routine, with the new and old symbols
4728           both being the generic iso_c proc sym being created.  This
4729           will create the formal args (and the new namespace for them).
4730           Don't build an arg list for c_loc because we're going to treat
4731           c_loc as an external procedure.  */
4732         if (s != ISOCBINDING_LOC && s != ISOCBINDING_FUNLOC)
4733           /* The 1 says to add any optional args, if applicable.  */
4734           build_formal_args (tmp_sym, tmp_sym, 1);
4735
4736         /* Set this after setting up the symbol, to prevent error messages.  */
4737         tmp_sym->attr.use_assoc = 1;
4738
4739         /* This symbol will not be referenced directly.  It will be
4740            resolved to the implementation for the given f90 kind.  */
4741         tmp_sym->attr.referenced = 0;
4742
4743         break;
4744
4745       default:
4746         gcc_unreachable ();
4747     }
4748   gfc_commit_symbol (tmp_sym);
4749 }
4750
4751
4752 /* Creates a new symbol based off of an old iso_c symbol, with a new
4753    binding label.  This function can be used to create a new,
4754    resolved, version of a procedure symbol for c_f_pointer or
4755    c_f_procpointer that is based on the generic symbols.  A new
4756    parameter list is created for the new symbol using
4757    build_formal_args().  The add_optional_flag specifies whether the
4758    to add the optional SHAPE argument.  The new symbol is
4759    returned.  */
4760
4761 gfc_symbol *
4762 get_iso_c_sym (gfc_symbol *old_sym, char *new_name,
4763                const char *new_binding_label, int add_optional_arg)
4764 {
4765   gfc_symtree *new_symtree = NULL;
4766
4767   /* See if we have a symbol by that name already available, looking
4768      through any parent namespaces.  */
4769   gfc_find_sym_tree (new_name, gfc_current_ns, 1, &new_symtree);
4770   if (new_symtree != NULL)
4771     /* Return the existing symbol.  */
4772     return new_symtree->n.sym;
4773
4774   /* Create the symtree/symbol, with attempted host association.  */
4775   gfc_get_ha_sym_tree (new_name, &new_symtree);
4776   if (new_symtree == NULL)
4777     gfc_internal_error ("get_iso_c_sym(): Unable to create "
4778                         "symtree for '%s'", new_name);
4779
4780   /* Now fill in the fields of the resolved symbol with the old sym.  */
4781   new_symtree->n.sym->binding_label = new_binding_label;
4782   new_symtree->n.sym->attr = old_sym->attr;
4783   new_symtree->n.sym->ts = old_sym->ts;
4784   new_symtree->n.sym->module = gfc_get_string (old_sym->module);
4785   new_symtree->n.sym->from_intmod = old_sym->from_intmod;
4786   new_symtree->n.sym->intmod_sym_id = old_sym->intmod_sym_id;
4787   if (old_sym->attr.function)
4788     new_symtree->n.sym->result = new_symtree->n.sym;
4789   /* Build the formal arg list.  */
4790   build_formal_args (new_symtree->n.sym, old_sym, add_optional_arg);
4791
4792   gfc_commit_symbol (new_symtree->n.sym);
4793
4794   return new_symtree->n.sym;
4795 }
4796
4797
4798 /* Check that a symbol is already typed.  If strict is not set, an untyped
4799    symbol is acceptable for non-standard-conforming mode.  */
4800
4801 gfc_try
4802 gfc_check_symbol_typed (gfc_symbol* sym, gfc_namespace* ns,
4803                         bool strict, locus where)
4804 {
4805   gcc_assert (sym);
4806
4807   if (gfc_matching_prefix)
4808     return SUCCESS;
4809
4810   /* Check for the type and try to give it an implicit one.  */
4811   if (sym->ts.type == BT_UNKNOWN
4812       && gfc_set_default_type (sym, 0, ns) == FAILURE)
4813     {
4814       if (strict)
4815         {
4816           gfc_error ("Symbol '%s' is used before it is typed at %L",
4817                      sym->name, &where);
4818           return FAILURE;
4819         }
4820
4821       if (gfc_notify_std (GFC_STD_GNU,
4822                           "Symbol '%s' is used before"
4823                           " it is typed at %L", sym->name, &where) == FAILURE)
4824         return FAILURE;
4825     }
4826
4827   /* Everything is ok.  */
4828   return SUCCESS;
4829 }
4830
4831
4832 /* Construct a typebound-procedure structure.  Those are stored in a tentative
4833    list and marked `error' until symbols are committed.  */
4834
4835 gfc_typebound_proc*
4836 gfc_get_typebound_proc (gfc_typebound_proc *tb0)
4837 {
4838   gfc_typebound_proc *result;
4839
4840   result = XCNEW (gfc_typebound_proc);
4841   if (tb0)
4842     *result = *tb0;
4843   result->error = 1;
4844
4845   latest_undo_chgset->tbps.safe_push (result);
4846
4847   return result;
4848 }
4849
4850
4851 /* Get the super-type of a given derived type.  */
4852
4853 gfc_symbol*
4854 gfc_get_derived_super_type (gfc_symbol* derived)
4855 {
4856   gcc_assert (derived);
4857
4858   if (derived->attr.generic)
4859     derived = gfc_find_dt_in_generic (derived);
4860
4861   if (!derived->attr.extension)
4862     return NULL;
4863
4864   gcc_assert (derived->components);
4865   gcc_assert (derived->components->ts.type == BT_DERIVED);
4866   gcc_assert (derived->components->ts.u.derived);
4867
4868   if (derived->components->ts.u.derived->attr.generic)
4869     return gfc_find_dt_in_generic (derived->components->ts.u.derived);
4870
4871   return derived->components->ts.u.derived;
4872 }
4873
4874
4875 /* Get the ultimate super-type of a given derived type.  */
4876
4877 gfc_symbol*
4878 gfc_get_ultimate_derived_super_type (gfc_symbol* derived)
4879 {
4880   if (!derived->attr.extension)
4881     return NULL;
4882
4883   derived = gfc_get_derived_super_type (derived);
4884
4885   if (derived->attr.extension)
4886     return gfc_get_ultimate_derived_super_type (derived);
4887   else
4888     return derived;
4889 }
4890
4891
4892 /* Check if a derived type t2 is an extension of (or equal to) a type t1.  */
4893
4894 bool
4895 gfc_type_is_extension_of (gfc_symbol *t1, gfc_symbol *t2)
4896 {
4897   while (!gfc_compare_derived_types (t1, t2) && t2->attr.extension)
4898     t2 = gfc_get_derived_super_type (t2);
4899   return gfc_compare_derived_types (t1, t2);
4900 }
4901
4902
4903 /* Check if two typespecs are type compatible (F03:5.1.1.2):
4904    If ts1 is nonpolymorphic, ts2 must be the same type.
4905    If ts1 is polymorphic (CLASS), ts2 must be an extension of ts1.  */
4906
4907 bool
4908 gfc_type_compatible (gfc_typespec *ts1, gfc_typespec *ts2)
4909 {
4910   bool is_class1 = (ts1->type == BT_CLASS);
4911   bool is_class2 = (ts2->type == BT_CLASS);
4912   bool is_derived1 = (ts1->type == BT_DERIVED);
4913   bool is_derived2 = (ts2->type == BT_DERIVED);
4914
4915   if (is_class1
4916       && ts1->u.derived->components
4917       && ts1->u.derived->components->ts.u.derived->attr.unlimited_polymorphic)
4918     return 1;
4919
4920   if (!is_derived1 && !is_derived2 && !is_class1 && !is_class2)
4921     return (ts1->type == ts2->type);
4922
4923   if (is_derived1 && is_derived2)
4924     return gfc_compare_derived_types (ts1->u.derived, ts2->u.derived);
4925
4926   if (is_class1 && is_derived2)
4927     return gfc_type_is_extension_of (ts1->u.derived->components->ts.u.derived,
4928                                      ts2->u.derived);
4929   else if (is_class1 && is_class2)
4930     return gfc_type_is_extension_of (ts1->u.derived->components->ts.u.derived,
4931                                      ts2->u.derived->components->ts.u.derived);
4932   else
4933     return 0;
4934 }
4935
4936
4937 /* Find the parent-namespace of the current function.  If we're inside
4938    BLOCK constructs, it may not be the current one.  */
4939
4940 gfc_namespace*
4941 gfc_find_proc_namespace (gfc_namespace* ns)
4942 {
4943   while (ns->construct_entities)
4944     {
4945       ns = ns->parent;
4946       gcc_assert (ns);
4947     }
4948
4949   return ns;
4950 }
4951
4952
4953 /* Check if an associate-variable should be translated as an `implicit' pointer
4954    internally (if it is associated to a variable and not an array with
4955    descriptor).  */
4956
4957 bool
4958 gfc_is_associate_pointer (gfc_symbol* sym)
4959 {
4960   if (!sym->assoc)
4961     return false;
4962
4963   if (sym->ts.type == BT_CLASS)
4964     return true;
4965
4966   if (!sym->assoc->variable)
4967     return false;
4968
4969   if (sym->attr.dimension && sym->as->type != AS_EXPLICIT)
4970     return false;
4971
4972   return true;
4973 }
4974
4975
4976 gfc_symbol *
4977 gfc_find_dt_in_generic (gfc_symbol *sym)
4978 {
4979   gfc_interface *intr = NULL;
4980
4981   if (!sym || sym->attr.flavor == FL_DERIVED)
4982     return sym;
4983
4984   if (sym->attr.generic)
4985     for (intr = sym->generic; intr; intr = intr->next)
4986       if (intr->sym->attr.flavor == FL_DERIVED)
4987         break;
4988   return intr ? intr->sym : NULL;
4989 }
4990
4991
4992 /* Get the dummy arguments from a procedure symbol. If it has been declared
4993    via a PROCEDURE statement with a named interface, ts.interface will be set
4994    and the arguments need to be taken from there.  */
4995
4996 gfc_formal_arglist *
4997 gfc_sym_get_dummy_args (gfc_symbol *sym)
4998 {
4999   gfc_formal_arglist *dummies;
5000
5001   dummies = sym->formal;
5002   if (dummies == NULL && sym->ts.interface != NULL)
5003     dummies = sym->ts.interface->formal;
5004
5005   return dummies;
5006 }