gcc/fortran/symbol.c

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