gcc/fortran/symbol.c

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