gcc/fortran/symbol.c

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