gcc/fortran/symbol.c

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