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