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.unlimited_polymorphic)
1959     return sym;
1960
1961   if (sym->attr.generic)
1962     sym = gfc_find_dt_in_generic (sym);
1963
1964   if (sym->components != NULL || sym->attr.zero_comp)
1965     return sym;               /* Already defined.  */
1966
1967   if (sym->ns->parent == NULL)
1968     goto bad;
1969
1970   if (gfc_find_symbol (sym->name, sym->ns->parent, 1, &s))
1971     {
1972       gfc_error ("Symbol '%s' at %C is ambiguous", sym->name);
1973       return NULL;
1974     }
1975
1976   if (s == NULL || s->attr.flavor != FL_DERIVED)
1977     goto bad;
1978
1979   /* Get rid of symbol sym, translating all references to s.  */
1980   for (i = 0; i < GFC_LETTERS; i++)
1981     {
1982       t = &sym->ns->default_type[i];
1983       if (t->u.derived == sym)
1984         t->u.derived = s;
1985     }
1986
1987   st = gfc_find_symtree (sym->ns->sym_root, sym->name);
1988   st->n.sym = s;
1989
1990   s->refs++;
1991
1992   /* Unlink from list of modified symbols.  */
1993   gfc_commit_symbol (sym);
1994
1995   switch_types (sym->ns->sym_root, sym, s);
1996
1997   /* TODO: Also have to replace sym -> s in other lists like
1998      namelists, common lists and interface lists.  */
1999   gfc_free_symbol (sym);
2000
2001   return s;
2002
2003 bad:
2004   gfc_error ("Derived type '%s' at %C is being used before it is defined",
2005              sym->name);
2006   return NULL;
2007 }
2008
2009
2010 /* Given a derived type node and a component name, try to locate the
2011    component structure.  Returns the NULL pointer if the component is
2012    not found or the components are private.  If noaccess is set, no access
2013    checks are done.  */
2014
2015 gfc_component *
2016 gfc_find_component (gfc_symbol *sym, const char *name,
2017                     bool noaccess, bool silent)
2018 {
2019   gfc_component *p;
2020
2021   if (name == NULL || sym == NULL)
2022     return NULL;
2023
2024   sym = gfc_use_derived (sym);
2025
2026   if (sym == NULL)
2027     return NULL;
2028
2029   for (p = sym->components; p; p = p->next)
2030     if (strcmp (p->name, name) == 0)
2031       break;
2032
2033   if (p && sym->attr.use_assoc && !noaccess)
2034     {
2035       bool is_parent_comp = sym->attr.extension && (p == sym->components);
2036       if (p->attr.access == ACCESS_PRIVATE ||
2037           (p->attr.access != ACCESS_PUBLIC
2038            && sym->component_access == ACCESS_PRIVATE
2039            && !is_parent_comp))
2040         {
2041           if (!silent)
2042             gfc_error ("Component '%s' at %C is a PRIVATE component of '%s'",
2043                        name, sym->name);
2044           return NULL;
2045         }
2046     }
2047
2048   if (p == NULL
2049         && sym->attr.extension
2050         && sym->components->ts.type == BT_DERIVED)
2051     {
2052       p = gfc_find_component (sym->components->ts.u.derived, name,
2053                               noaccess, silent);
2054       /* Do not overwrite the error.  */
2055       if (p == NULL)
2056         return p;
2057     }
2058
2059   if (p == NULL && !silent)
2060     gfc_error ("'%s' at %C is not a member of the '%s' structure",
2061                name, sym->name);
2062
2063   return p;
2064 }
2065
2066
2067 /* Given a symbol, free all of the component structures and everything
2068    they point to.  */
2069
2070 static void
2071 free_components (gfc_component *p)
2072 {
2073   gfc_component *q;
2074
2075   for (; p; p = q)
2076     {
2077       q = p->next;
2078
2079       gfc_free_array_spec (p->as);
2080       gfc_free_expr (p->initializer);
2081
2082       gfc_free_formal_arglist (p->formal);
2083       gfc_free_namespace (p->formal_ns);
2084
2085       free (p);
2086     }
2087 }
2088
2089
2090 /******************** Statement label management ********************/
2091
2092 /* Comparison function for statement labels, used for managing the
2093    binary tree.  */
2094
2095 static int
2096 compare_st_labels (void *a1, void *b1)
2097 {
2098   int a = ((gfc_st_label *) a1)->value;
2099   int b = ((gfc_st_label *) b1)->value;
2100
2101   return (b - a);
2102 }
2103
2104
2105 /* Free a single gfc_st_label structure, making sure the tree is not
2106    messed up.  This function is called only when some parse error
2107    occurs.  */
2108
2109 void
2110 gfc_free_st_label (gfc_st_label *label)
2111 {
2112
2113   if (label == NULL)
2114     return;
2115
2116   gfc_delete_bbt (&gfc_current_ns->st_labels, label, compare_st_labels);
2117
2118   if (label->format != NULL)
2119     gfc_free_expr (label->format);
2120
2121   free (label);
2122 }
2123
2124
2125 /* Free a whole tree of gfc_st_label structures.  */
2126
2127 static void
2128 free_st_labels (gfc_st_label *label)
2129 {
2130
2131   if (label == NULL)
2132     return;
2133
2134   free_st_labels (label->left);
2135   free_st_labels (label->right);
2136
2137   if (label->format != NULL)
2138     gfc_free_expr (label->format);
2139   free (label);
2140 }
2141
2142
2143 /* Given a label number, search for and return a pointer to the label
2144    structure, creating it if it does not exist.  */
2145
2146 gfc_st_label *
2147 gfc_get_st_label (int labelno)
2148 {
2149   gfc_st_label *lp;
2150   gfc_namespace *ns;
2151
2152   if (gfc_current_state () == COMP_DERIVED)
2153     ns = gfc_current_block ()->f2k_derived;
2154   else
2155     {
2156       /* Find the namespace of the scoping unit:
2157          If we're in a BLOCK construct, jump to the parent namespace.  */
2158       ns = gfc_current_ns;
2159       while (ns->proc_name && ns->proc_name->attr.flavor == FL_LABEL)
2160         ns = ns->parent;
2161     }
2162
2163   /* First see if the label is already in this namespace.  */
2164   lp = ns->st_labels;
2165   while (lp)
2166     {
2167       if (lp->value == labelno)
2168         return lp;
2169
2170       if (lp->value < labelno)
2171         lp = lp->left;
2172       else
2173         lp = lp->right;
2174     }
2175
2176   lp = XCNEW (gfc_st_label);
2177
2178   lp->value = labelno;
2179   lp->defined = ST_LABEL_UNKNOWN;
2180   lp->referenced = ST_LABEL_UNKNOWN;
2181
2182   gfc_insert_bbt (&ns->st_labels, lp, compare_st_labels);
2183
2184   return lp;
2185 }
2186
2187
2188 /* Called when a statement with a statement label is about to be
2189    accepted.  We add the label to the list of the current namespace,
2190    making sure it hasn't been defined previously and referenced
2191    correctly.  */
2192
2193 void
2194 gfc_define_st_label (gfc_st_label *lp, gfc_sl_type type, locus *label_locus)
2195 {
2196   int labelno;
2197
2198   labelno = lp->value;
2199
2200   if (lp->defined != ST_LABEL_UNKNOWN)
2201     gfc_error ("Duplicate statement label %d at %L and %L", labelno,
2202                &lp->where, label_locus);
2203   else
2204     {
2205       lp->where = *label_locus;
2206
2207       switch (type)
2208         {
2209         case ST_LABEL_FORMAT:
2210           if (lp->referenced == ST_LABEL_TARGET
2211               || lp->referenced == ST_LABEL_DO_TARGET)
2212             gfc_error ("Label %d at %C already referenced as branch target",
2213                        labelno);
2214           else
2215             lp->defined = ST_LABEL_FORMAT;
2216
2217           break;
2218
2219         case ST_LABEL_TARGET:
2220         case ST_LABEL_DO_TARGET:
2221           if (lp->referenced == ST_LABEL_FORMAT)
2222             gfc_error ("Label %d at %C already referenced as a format label",
2223                        labelno);
2224           else
2225             lp->defined = type;
2226
2227           if (lp->referenced == ST_LABEL_DO_TARGET && type != ST_LABEL_DO_TARGET
2228               && gfc_notify_std (GFC_STD_F95_OBS, "DO termination statement "
2229                                  "which is not END DO or CONTINUE with label "
2230                                  "%d at %C", labelno) == FAILURE)
2231             return;
2232           break;
2233
2234         default:
2235           lp->defined = ST_LABEL_BAD_TARGET;
2236           lp->referenced = ST_LABEL_BAD_TARGET;
2237         }
2238     }
2239 }
2240
2241
2242 /* Reference a label.  Given a label and its type, see if that
2243    reference is consistent with what is known about that label,
2244    updating the unknown state.  Returns FAILURE if something goes
2245    wrong.  */
2246
2247 gfc_try
2248 gfc_reference_st_label (gfc_st_label *lp, gfc_sl_type type)
2249 {
2250   gfc_sl_type label_type;
2251   int labelno;
2252   gfc_try rc;
2253
2254   if (lp == NULL)
2255     return SUCCESS;
2256
2257   labelno = lp->value;
2258
2259   if (lp->defined != ST_LABEL_UNKNOWN)
2260     label_type = lp->defined;
2261   else
2262     {
2263       label_type = lp->referenced;
2264       lp->where = gfc_current_locus;
2265     }
2266
2267   if (label_type == ST_LABEL_FORMAT
2268       && (type == ST_LABEL_TARGET || type == ST_LABEL_DO_TARGET))
2269     {
2270       gfc_error ("Label %d at %C previously used as a FORMAT label", labelno);
2271       rc = FAILURE;
2272       goto done;
2273     }
2274
2275   if ((label_type == ST_LABEL_TARGET || label_type == ST_LABEL_DO_TARGET
2276        || label_type == ST_LABEL_BAD_TARGET)
2277       && type == ST_LABEL_FORMAT)
2278     {
2279       gfc_error ("Label %d at %C previously used as branch target", labelno);
2280       rc = FAILURE;
2281       goto done;
2282     }
2283
2284   if (lp->referenced == ST_LABEL_DO_TARGET && type == ST_LABEL_DO_TARGET
2285       && gfc_notify_std (GFC_STD_F95_OBS, "Shared DO termination label %d "
2286                          "at %C", labelno) == FAILURE)
2287     return FAILURE;
2288
2289   if (lp->referenced != ST_LABEL_DO_TARGET)
2290     lp->referenced = type;
2291   rc = SUCCESS;
2292
2293 done:
2294   return rc;
2295 }
2296
2297
2298 /************** Symbol table management subroutines ****************/
2299
2300 /* Basic details: Fortran 95 requires a potentially unlimited number
2301    of distinct namespaces when compiling a program unit.  This case
2302    occurs during a compilation of internal subprograms because all of
2303    the internal subprograms must be read before we can start
2304    generating code for the host.
2305
2306    Given the tricky nature of the Fortran grammar, we must be able to
2307    undo changes made to a symbol table if the current interpretation
2308    of a statement is found to be incorrect.  Whenever a symbol is
2309    looked up, we make a copy of it and link to it.  All of these
2310    symbols are kept in a singly linked list so that we can commit or
2311    undo the changes at a later time.
2312
2313    A symtree may point to a symbol node outside of its namespace.  In
2314    this case, that symbol has been used as a host associated variable
2315    at some previous time.  */
2316
2317 /* Allocate a new namespace structure.  Copies the implicit types from
2318    PARENT if PARENT_TYPES is set.  */
2319
2320 gfc_namespace *
2321 gfc_get_namespace (gfc_namespace *parent, int parent_types)
2322 {
2323   gfc_namespace *ns;
2324   gfc_typespec *ts;
2325   int in;
2326   int i;
2327
2328   ns = XCNEW (gfc_namespace);
2329   ns->sym_root = NULL;
2330   ns->uop_root = NULL;
2331   ns->tb_sym_root = NULL;
2332   ns->finalizers = NULL;
2333   ns->default_access = ACCESS_UNKNOWN;
2334   ns->parent = parent;
2335
2336   for (in = GFC_INTRINSIC_BEGIN; in != GFC_INTRINSIC_END; in++)
2337     {
2338       ns->operator_access[in] = ACCESS_UNKNOWN;
2339       ns->tb_op[in] = NULL;
2340     }
2341
2342   /* Initialize default implicit types.  */
2343   for (i = 'a'; i <= 'z'; i++)
2344     {
2345       ns->set_flag[i - 'a'] = 0;
2346       ts = &ns->default_type[i - 'a'];
2347
2348       if (parent_types && ns->parent != NULL)
2349         {
2350           /* Copy parent settings.  */
2351           *ts = ns->parent->default_type[i - 'a'];
2352           continue;
2353         }
2354
2355       if (gfc_option.flag_implicit_none != 0)
2356         {
2357           gfc_clear_ts (ts);
2358           continue;
2359         }
2360
2361       if ('i' <= i && i <= 'n')
2362         {
2363           ts->type = BT_INTEGER;
2364           ts->kind = gfc_default_integer_kind;
2365         }
2366       else
2367         {
2368           ts->type = BT_REAL;
2369           ts->kind = gfc_default_real_kind;
2370         }
2371     }
2372
2373   ns->refs = 1;
2374
2375   return ns;
2376 }
2377
2378
2379 /* Comparison function for symtree nodes.  */
2380
2381 static int
2382 compare_symtree (void *_st1, void *_st2)
2383 {
2384   gfc_symtree *st1, *st2;
2385
2386   st1 = (gfc_symtree *) _st1;
2387   st2 = (gfc_symtree *) _st2;
2388
2389   return strcmp (st1->name, st2->name);
2390 }
2391
2392
2393 /* Allocate a new symtree node and associate it with the new symbol.  */
2394
2395 gfc_symtree *
2396 gfc_new_symtree (gfc_symtree **root, const char *name)
2397 {
2398   gfc_symtree *st;
2399
2400   st = XCNEW (gfc_symtree);
2401   st->name = gfc_get_string (name);
2402
2403   gfc_insert_bbt (root, st, compare_symtree);
2404   return st;
2405 }
2406
2407
2408 /* Delete a symbol from the tree.  Does not free the symbol itself!  */
2409
2410 void
2411 gfc_delete_symtree (gfc_symtree **root, const char *name)
2412 {
2413   gfc_symtree st, *st0;
2414
2415   st0 = gfc_find_symtree (*root, name);
2416
2417   st.name = gfc_get_string (name);
2418   gfc_delete_bbt (root, &st, compare_symtree);
2419
2420   free (st0);
2421 }
2422
2423
2424 /* Given a root symtree node and a name, try to find the symbol within
2425    the namespace.  Returns NULL if the symbol is not found.  */
2426
2427 gfc_symtree *
2428 gfc_find_symtree (gfc_symtree *st, const char *name)
2429 {
2430   int c;
2431
2432   while (st != NULL)
2433     {
2434       c = strcmp (name, st->name);
2435       if (c == 0)
2436         return st;
2437
2438       st = (c < 0) ? st->left : st->right;
2439     }
2440
2441   return NULL;
2442 }
2443
2444
2445 /* Return a symtree node with a name that is guaranteed to be unique
2446    within the namespace and corresponds to an illegal fortran name.  */
2447
2448 gfc_symtree *
2449 gfc_get_unique_symtree (gfc_namespace *ns)
2450 {
2451   char name[GFC_MAX_SYMBOL_LEN + 1];
2452   static int serial = 0;
2453
2454   sprintf (name, "@%d", serial++);
2455   return gfc_new_symtree (&ns->sym_root, name);
2456 }
2457
2458
2459 /* Given a name find a user operator node, creating it if it doesn't
2460    exist.  These are much simpler than symbols because they can't be
2461    ambiguous with one another.  */
2462
2463 gfc_user_op *
2464 gfc_get_uop (const char *name)
2465 {
2466   gfc_user_op *uop;
2467   gfc_symtree *st;
2468
2469   st = gfc_find_symtree (gfc_current_ns->uop_root, name);
2470   if (st != NULL)
2471     return st->n.uop;
2472
2473   st = gfc_new_symtree (&gfc_current_ns->uop_root, name);
2474
2475   uop = st->n.uop = XCNEW (gfc_user_op);
2476   uop->name = gfc_get_string (name);
2477   uop->access = ACCESS_UNKNOWN;
2478   uop->ns = gfc_current_ns;
2479
2480   return uop;
2481 }
2482
2483
2484 /* Given a name find the user operator node.  Returns NULL if it does
2485    not exist.  */
2486
2487 gfc_user_op *
2488 gfc_find_uop (const char *name, gfc_namespace *ns)
2489 {
2490   gfc_symtree *st;
2491
2492   if (ns == NULL)
2493     ns = gfc_current_ns;
2494
2495   st = gfc_find_symtree (ns->uop_root, name);
2496   return (st == NULL) ? NULL : st->n.uop;
2497 }
2498
2499
2500 /* Remove a gfc_symbol structure and everything it points to.  */
2501
2502 void
2503 gfc_free_symbol (gfc_symbol *sym)
2504 {
2505
2506   if (sym == NULL)
2507     return;
2508
2509   gfc_free_array_spec (sym->as);
2510
2511   free_components (sym->components);
2512
2513   gfc_free_expr (sym->value);
2514
2515   gfc_free_namelist (sym->namelist);
2516
2517   if (sym->ns != sym->formal_ns)
2518     gfc_free_namespace (sym->formal_ns);
2519
2520   if (!sym->attr.generic_copy)
2521     gfc_free_interface (sym->generic);
2522
2523   gfc_free_formal_arglist (sym->formal);
2524
2525   gfc_free_namespace (sym->f2k_derived);
2526
2527   if (sym->common_block && sym->common_block->name[0] != '\0')
2528     {
2529       sym->common_block->refs--;
2530       if (sym->common_block->refs == 0)
2531         free (sym->common_block);
2532     }
2533
2534   free (sym);
2535 }
2536
2537
2538 /* Decrease the reference counter and free memory when we reach zero.  */
2539
2540 void
2541 gfc_release_symbol (gfc_symbol *sym)
2542 {
2543   if (sym == NULL)
2544     return;
2545
2546   if (sym->formal_ns != NULL && sym->refs == 2 && sym->formal_ns != sym->ns
2547       && (!sym->attr.entry || !sym->module))
2548     {
2549       /* As formal_ns contains a reference to sym, delete formal_ns just
2550          before the deletion of sym.  */
2551       gfc_namespace *ns = sym->formal_ns;
2552       sym->formal_ns = NULL;
2553       gfc_free_namespace (ns);
2554     }
2555
2556   sym->refs--;
2557   if (sym->refs > 0)
2558     return;
2559
2560   gcc_assert (sym->refs == 0);
2561   gfc_free_symbol (sym);
2562 }
2563
2564
2565 /* Allocate and initialize a new symbol node.  */
2566
2567 gfc_symbol *
2568 gfc_new_symbol (const char *name, gfc_namespace *ns)
2569 {
2570   gfc_symbol *p;
2571
2572   p = XCNEW (gfc_symbol);
2573
2574   gfc_clear_ts (&p->ts);
2575   gfc_clear_attr (&p->attr);
2576   p->ns = ns;
2577
2578   p->declared_at = gfc_current_locus;
2579
2580   if (strlen (name) > GFC_MAX_SYMBOL_LEN)
2581     gfc_internal_error ("new_symbol(): Symbol name too long");
2582
2583   p->name = gfc_get_string (name);
2584
2585   /* Make sure flags for symbol being C bound are clear initially.  */
2586   p->attr.is_bind_c = 0;
2587   p->attr.is_iso_c = 0;
2588
2589   /* Clear the ptrs we may need.  */
2590   p->common_block = NULL;
2591   p->f2k_derived = NULL;
2592   p->assoc = NULL;
2593
2594   return p;
2595 }
2596
2597
2598 /* Generate an error if a symbol is ambiguous.  */
2599
2600 static void
2601 ambiguous_symbol (const char *name, gfc_symtree *st)
2602 {
2603
2604   if (st->n.sym->module)
2605     gfc_error ("Name '%s' at %C is an ambiguous reference to '%s' "
2606                "from module '%s'", name, st->n.sym->name, st->n.sym->module);
2607   else
2608     gfc_error ("Name '%s' at %C is an ambiguous reference to '%s' "
2609                "from current program unit", name, st->n.sym->name);
2610 }
2611
2612
2613 /* If we're in a SELECT TYPE block, check if the variable 'st' matches any
2614    selector on the stack. If yes, replace it by the corresponding temporary.  */
2615
2616 static void
2617 select_type_insert_tmp (gfc_symtree **st)
2618 {
2619   gfc_select_type_stack *stack = select_type_stack;
2620   for (; stack; stack = stack->prev)
2621     if ((*st)->n.sym == stack->selector && stack->tmp)
2622       *st = stack->tmp;
2623 }
2624
2625
2626 /* Look for a symtree in the current procedure -- that is, go up to
2627    parent namespaces but only if inside a BLOCK.  Returns NULL if not found.  */
2628
2629 gfc_symtree*
2630 gfc_find_symtree_in_proc (const char* name, gfc_namespace* ns)
2631 {
2632   while (ns)
2633     {
2634       gfc_symtree* st = gfc_find_symtree (ns->sym_root, name);
2635       if (st)
2636         return st;
2637
2638       if (!ns->construct_entities)
2639         break;
2640       ns = ns->parent;
2641     }
2642
2643   return NULL;
2644 }
2645
2646
2647 /* Search for a symtree starting in the current namespace, resorting to
2648    any parent namespaces if requested by a nonzero parent_flag.
2649    Returns nonzero if the name is ambiguous.  */
2650
2651 int
2652 gfc_find_sym_tree (const char *name, gfc_namespace *ns, int parent_flag,
2653                    gfc_symtree **result)
2654 {
2655   gfc_symtree *st;
2656
2657   if (ns == NULL)
2658     ns = gfc_current_ns;
2659
2660   do
2661     {
2662       st = gfc_find_symtree (ns->sym_root, name);
2663       if (st != NULL)
2664         {
2665           select_type_insert_tmp (&st);
2666
2667           *result = st;
2668           /* Ambiguous generic interfaces are permitted, as long
2669              as the specific interfaces are different.  */
2670           if (st->ambiguous && !st->n.sym->attr.generic)
2671             {
2672               ambiguous_symbol (name, st);
2673               return 1;
2674             }
2675
2676           return 0;
2677         }
2678
2679       if (!parent_flag)
2680         break;
2681
2682       ns = ns->parent;
2683     }
2684   while (ns != NULL);
2685
2686   *result = NULL;
2687   return 0;
2688 }
2689
2690
2691 /* Same, but returns the symbol instead.  */
2692
2693 int
2694 gfc_find_symbol (const char *name, gfc_namespace *ns, int parent_flag,
2695                  gfc_symbol **result)
2696 {
2697   gfc_symtree *st;
2698   int i;
2699
2700   i = gfc_find_sym_tree (name, ns, parent_flag, &st);
2701
2702   if (st == NULL)
2703     *result = NULL;
2704   else
2705     *result = st->n.sym;
2706
2707   return i;
2708 }
2709
2710
2711 /* Save symbol with the information necessary to back it out.  */
2712
2713 static void
2714 save_symbol_data (gfc_symbol *sym)
2715 {
2716
2717   if (sym->gfc_new || sym->old_symbol != NULL)
2718     return;
2719
2720   sym->old_symbol = XCNEW (gfc_symbol);
2721   *(sym->old_symbol) = *sym;
2722
2723   sym->tlink = changed_syms;
2724   changed_syms = sym;
2725 }
2726
2727
2728 /* Given a name, find a symbol, or create it if it does not exist yet
2729    in the current namespace.  If the symbol is found we make sure that
2730    it's OK.
2731
2732    The integer return code indicates
2733      0   All OK
2734      1   The symbol name was ambiguous
2735      2   The name meant to be established was already host associated.
2736
2737    So if the return value is nonzero, then an error was issued.  */
2738
2739 int
2740 gfc_get_sym_tree (const char *name, gfc_namespace *ns, gfc_symtree **result,
2741                   bool allow_subroutine)
2742 {
2743   gfc_symtree *st;
2744   gfc_symbol *p;
2745
2746   /* This doesn't usually happen during resolution.  */
2747   if (ns == NULL)
2748     ns = gfc_current_ns;
2749
2750   /* Try to find the symbol in ns.  */
2751   st = gfc_find_symtree (ns->sym_root, name);
2752
2753   if (st == NULL)
2754     {
2755       /* If not there, create a new symbol.  */
2756       p = gfc_new_symbol (name, ns);
2757
2758       /* Add to the list of tentative symbols.  */
2759       p->old_symbol = NULL;
2760       p->tlink = changed_syms;
2761       p->mark = 1;
2762       p->gfc_new = 1;
2763       changed_syms = p;
2764
2765       st = gfc_new_symtree (&ns->sym_root, name);
2766       st->n.sym = p;
2767       p->refs++;
2768
2769     }
2770   else
2771     {
2772       /* Make sure the existing symbol is OK.  Ambiguous
2773          generic interfaces are permitted, as long as the
2774          specific interfaces are different.  */
2775       if (st->ambiguous && !st->n.sym->attr.generic)
2776         {
2777           ambiguous_symbol (name, st);
2778           return 1;
2779         }
2780
2781       p = st->n.sym;
2782       if (p->ns != ns && (!p->attr.function || ns->proc_name != p)
2783           && !(allow_subroutine && p->attr.subroutine)
2784           && !(ns->proc_name && ns->proc_name->attr.if_source == IFSRC_IFBODY
2785           && (ns->has_import_set || p->attr.imported)))
2786         {
2787           /* Symbol is from another namespace.  */
2788           gfc_error ("Symbol '%s' at %C has already been host associated",
2789                      name);
2790           return 2;
2791         }
2792
2793       p->mark = 1;
2794
2795       /* Copy in case this symbol is changed.  */
2796       save_symbol_data (p);
2797     }
2798
2799   *result = st;
2800   return 0;
2801 }
2802
2803
2804 int
2805 gfc_get_symbol (const char *name, gfc_namespace *ns, gfc_symbol **result)
2806 {
2807   gfc_symtree *st;
2808   int i;
2809
2810   i = gfc_get_sym_tree (name, ns, &st, false);
2811   if (i != 0)
2812     return i;
2813
2814   if (st)
2815     *result = st->n.sym;
2816   else
2817     *result = NULL;
2818   return i;
2819 }
2820
2821
2822 /* Subroutine that searches for a symbol, creating it if it doesn't
2823    exist, but tries to host-associate the symbol if possible.  */
2824
2825 int
2826 gfc_get_ha_sym_tree (const char *name, gfc_symtree **result)
2827 {
2828   gfc_symtree *st;
2829   int i;
2830
2831   i = gfc_find_sym_tree (name, gfc_current_ns, 0, &st);
2832
2833   if (st != NULL)
2834     {
2835       save_symbol_data (st->n.sym);
2836       *result = st;
2837       return i;
2838     }
2839
2840   if (gfc_current_ns->parent != NULL)
2841     {
2842       i = gfc_find_sym_tree (name, gfc_current_ns->parent, 1, &st);
2843       if (i)
2844         return i;
2845
2846       if (st != NULL)
2847         {
2848           *result = st;
2849           return 0;
2850         }
2851     }
2852
2853   return gfc_get_sym_tree (name, gfc_current_ns, result, false);
2854 }
2855
2856
2857 int
2858 gfc_get_ha_symbol (const char *name, gfc_symbol **result)
2859 {
2860   int i;
2861   gfc_symtree *st;
2862
2863   i = gfc_get_ha_sym_tree (name, &st);
2864
2865   if (st)
2866     *result = st->n.sym;
2867   else
2868     *result = NULL;
2869
2870   return i;
2871 }
2872
2873
2874 /* Search for the symtree belonging to a gfc_common_head; we cannot use
2875    head->name as the common_root symtree's name might be mangled.  */
2876
2877 static gfc_symtree *
2878 find_common_symtree (gfc_symtree *st, gfc_common_head *head)
2879 {
2880
2881   gfc_symtree *result;
2882
2883   if (st == NULL)
2884     return NULL;
2885
2886   if (st->n.common == head)
2887     return st;
2888
2889   result = find_common_symtree (st->left, head);
2890   if (!result)
2891     result = find_common_symtree (st->right, head);
2892
2893   return result;
2894 }
2895
2896
2897 /* Undoes all the changes made to symbols in the current statement.
2898    This subroutine is made simpler due to the fact that attributes are
2899    never removed once added.  */
2900
2901 void
2902 gfc_undo_symbols (void)
2903 {
2904   gfc_symbol *p, *q, *old;
2905   tentative_tbp *tbp, *tbq;
2906
2907   for (p = changed_syms; p; p = q)
2908     {
2909       q = p->tlink;
2910
2911       if (p->gfc_new)
2912         {
2913           /* Symbol was new.  */
2914           if (p->attr.in_common && p->common_block && p->common_block->head)
2915             {
2916               /* If the symbol was added to any common block, it
2917                  needs to be removed to stop the resolver looking
2918                  for a (possibly) dead symbol.  */
2919
2920               if (p->common_block->head == p && !p->common_next)
2921                 {
2922                   gfc_symtree st, *st0;
2923                   st0 = find_common_symtree (p->ns->common_root,
2924                                              p->common_block);
2925                   if (st0)
2926                     {
2927                       st.name = st0->name;
2928                       gfc_delete_bbt (&p->ns->common_root, &st, compare_symtree);
2929                       free (st0);
2930                     }
2931                 }
2932
2933               if (p->common_block->head == p)
2934                 p->common_block->head = p->common_next;
2935               else
2936                 {
2937                   gfc_symbol *cparent, *csym;
2938
2939                   cparent = p->common_block->head;
2940                   csym = cparent->common_next;
2941
2942                   while (csym != p)
2943                     {
2944                       cparent = csym;
2945                       csym = csym->common_next;
2946                     }
2947
2948                   gcc_assert(cparent->common_next == p);
2949
2950                   cparent->common_next = csym->common_next;
2951                 }
2952             }
2953
2954           /* The derived type is saved in the symtree with the first
2955              letter capitalized; the all lower-case version to the
2956              derived type contains its associated generic function.  */
2957           if (p->attr.flavor == FL_DERIVED)
2958             gfc_delete_symtree (&p->ns->sym_root, gfc_get_string ("%c%s",
2959                         (char) TOUPPER ((unsigned char) p->name[0]),
2960                         &p->name[1]));
2961           else
2962             gfc_delete_symtree (&p->ns->sym_root, p->name);
2963
2964           gfc_release_symbol (p);
2965           continue;
2966         }
2967
2968       /* Restore previous state of symbol.  Just copy simple stuff.  */
2969       p->mark = 0;
2970       old = p->old_symbol;
2971
2972       p->ts.type = old->ts.type;
2973       p->ts.kind = old->ts.kind;
2974
2975       p->attr = old->attr;
2976
2977       if (p->value != old->value)
2978         {
2979           gfc_free_expr (old->value);
2980           p->value = NULL;
2981         }
2982
2983       if (p->as != old->as)
2984         {
2985           if (p->as)
2986             gfc_free_array_spec (p->as);
2987           p->as = old->as;
2988         }
2989
2990       p->generic = old->generic;
2991       p->component_access = old->component_access;
2992
2993       if (p->namelist != NULL && old->namelist == NULL)
2994         {
2995           gfc_free_namelist (p->namelist);
2996           p->namelist = NULL;
2997         }
2998       else
2999         {
3000           if (p->namelist_tail != old->namelist_tail)
3001             {
3002               gfc_free_namelist (old->namelist_tail->next);
3003               old->namelist_tail->next = NULL;
3004             }
3005         }
3006
3007       p->namelist_tail = old->namelist_tail;
3008
3009       if (p->formal != old->formal)
3010         {
3011           gfc_free_formal_arglist (p->formal);
3012           p->formal = old->formal;
3013         }
3014
3015       free (p->old_symbol);
3016       p->old_symbol = NULL;
3017       p->tlink = NULL;
3018     }
3019
3020   changed_syms = NULL;
3021
3022   for (tbp = tentative_tbp_list; tbp; tbp = tbq)
3023     {
3024       tbq = tbp->next;
3025       /* Procedure is already marked `error' by default.  */
3026       free (tbp);
3027     }
3028   tentative_tbp_list = NULL;
3029 }
3030
3031
3032 /* Free sym->old_symbol. sym->old_symbol is mostly a shallow copy of sym; the
3033    components of old_symbol that might need deallocation are the "allocatables"
3034    that are restored in gfc_undo_symbols(), with two exceptions: namelist and
3035    namelist_tail.  In case these differ between old_symbol and sym, it's just
3036    because sym->namelist has gotten a few more items.  */
3037
3038 static void
3039 free_old_symbol (gfc_symbol *sym)
3040 {
3041
3042   if (sym->old_symbol == NULL)
3043     return;
3044
3045   if (sym->old_symbol->as != sym->as)
3046     gfc_free_array_spec (sym->old_symbol->as);
3047
3048   if (sym->old_symbol->value != sym->value)
3049     gfc_free_expr (sym->old_symbol->value);
3050
3051   if (sym->old_symbol->formal != sym->formal)
3052     gfc_free_formal_arglist (sym->old_symbol->formal);
3053
3054   free (sym->old_symbol);
3055   sym->old_symbol = NULL;
3056 }
3057
3058
3059 /* Makes the changes made in the current statement permanent-- gets
3060    rid of undo information.  */
3061
3062 void
3063 gfc_commit_symbols (void)
3064 {
3065   gfc_symbol *p, *q;
3066   tentative_tbp *tbp, *tbq;
3067
3068   for (p = changed_syms; p; p = q)
3069     {
3070       q = p->tlink;
3071       p->tlink = NULL;
3072       p->mark = 0;
3073       p->gfc_new = 0;
3074       free_old_symbol (p);
3075     }
3076   changed_syms = NULL;
3077
3078   for (tbp = tentative_tbp_list; tbp; tbp = tbq)
3079     {
3080       tbq = tbp->next;
3081       tbp->proc->error = 0;
3082       free (tbp);
3083     }
3084   tentative_tbp_list = NULL;
3085 }
3086
3087
3088 /* Makes the changes made in one symbol permanent -- gets rid of undo
3089    information.  */
3090
3091 void
3092 gfc_commit_symbol (gfc_symbol *sym)
3093 {
3094   gfc_symbol *p;
3095
3096   if (changed_syms == sym)
3097     changed_syms = sym->tlink;
3098   else
3099     {
3100       for (p = changed_syms; p; p = p->tlink)
3101         if (p->tlink == sym)
3102           {
3103             p->tlink = sym->tlink;
3104             break;
3105           }
3106     }
3107
3108   sym->tlink = NULL;
3109   sym->mark = 0;
3110   sym->gfc_new = 0;
3111
3112   free_old_symbol (sym);
3113 }
3114
3115
3116 /* Recursively free trees containing type-bound procedures.  */
3117
3118 static void
3119 free_tb_tree (gfc_symtree *t)
3120 {
3121   if (t == NULL)
3122     return;
3123
3124   free_tb_tree (t->left);
3125   free_tb_tree (t->right);
3126
3127   /* TODO: Free type-bound procedure structs themselves; probably needs some
3128      sort of ref-counting mechanism.  */
3129
3130   free (t);
3131 }
3132
3133
3134 /* Recursive function that deletes an entire tree and all the common
3135    head structures it points to.  */
3136
3137 static void
3138 free_common_tree (gfc_symtree * common_tree)
3139 {
3140   if (common_tree == NULL)
3141     return;
3142
3143   free_common_tree (common_tree->left);
3144   free_common_tree (common_tree->right);
3145
3146   free (common_tree);
3147 }
3148
3149
3150 /* Recursive function that deletes an entire tree and all the user
3151    operator nodes that it contains.  */
3152
3153 static void
3154 free_uop_tree (gfc_symtree *uop_tree)
3155 {
3156   if (uop_tree == NULL)
3157     return;
3158
3159   free_uop_tree (uop_tree->left);
3160   free_uop_tree (uop_tree->right);
3161
3162   gfc_free_interface (uop_tree->n.uop->op);
3163   free (uop_tree->n.uop);
3164   free (uop_tree);
3165 }
3166
3167
3168 /* Recursive function that deletes an entire tree and all the symbols
3169    that it contains.  */
3170
3171 static void
3172 free_sym_tree (gfc_symtree *sym_tree)
3173 {
3174   if (sym_tree == NULL)
3175     return;
3176
3177   free_sym_tree (sym_tree->left);
3178   free_sym_tree (sym_tree->right);
3179
3180   gfc_release_symbol (sym_tree->n.sym);
3181   free (sym_tree);
3182 }
3183
3184
3185 /* Free the derived type list.  */
3186
3187 void
3188 gfc_free_dt_list (void)
3189 {
3190   gfc_dt_list *dt, *n;
3191
3192   for (dt = gfc_derived_types; dt; dt = n)
3193     {
3194       n = dt->next;
3195       free (dt);
3196     }
3197
3198   gfc_derived_types = NULL;
3199 }
3200
3201
3202 /* Free the gfc_equiv_info's.  */
3203
3204 static void
3205 gfc_free_equiv_infos (gfc_equiv_info *s)
3206 {
3207   if (s == NULL)
3208     return;
3209   gfc_free_equiv_infos (s->next);
3210   free (s);
3211 }
3212
3213
3214 /* Free the gfc_equiv_lists.  */
3215
3216 static void
3217 gfc_free_equiv_lists (gfc_equiv_list *l)
3218 {
3219   if (l == NULL)
3220     return;
3221   gfc_free_equiv_lists (l->next);
3222   gfc_free_equiv_infos (l->equiv);
3223   free (l);
3224 }
3225
3226
3227 /* Free a finalizer procedure list.  */
3228
3229 void
3230 gfc_free_finalizer (gfc_finalizer* el)
3231 {
3232   if (el)
3233     {
3234       gfc_release_symbol (el->proc_sym);
3235       free (el);
3236     }
3237 }
3238
3239 static void
3240 gfc_free_finalizer_list (gfc_finalizer* list)
3241 {
3242   while (list)
3243     {
3244       gfc_finalizer* current = list;
3245       list = list->next;
3246       gfc_free_finalizer (current);
3247     }
3248 }
3249
3250
3251 /* Create a new gfc_charlen structure and add it to a namespace.
3252    If 'old_cl' is given, the newly created charlen will be a copy of it.  */
3253
3254 gfc_charlen*
3255 gfc_new_charlen (gfc_namespace *ns, gfc_charlen *old_cl)
3256 {
3257   gfc_charlen *cl;
3258   cl = gfc_get_charlen ();
3259
3260   /* Copy old_cl.  */
3261   if (old_cl)
3262     {
3263       /* Put into namespace, but don't allow reject_statement
3264          to free it if old_cl is given.  */
3265       gfc_charlen **prev = &ns->cl_list;
3266       cl->next = ns->old_cl_list;
3267       while (*prev != ns->old_cl_list)
3268         prev = &(*prev)->next;
3269       *prev = cl;
3270       ns->old_cl_list = cl;
3271       cl->length = gfc_copy_expr (old_cl->length);
3272       cl->length_from_typespec = old_cl->length_from_typespec;
3273       cl->backend_decl = old_cl->backend_decl;
3274       cl->passed_length = old_cl->passed_length;
3275       cl->resolved = old_cl->resolved;
3276     }
3277   else
3278     {
3279       /* Put into namespace.  */
3280       cl->next = ns->cl_list;
3281       ns->cl_list = cl;
3282     }
3283
3284   return cl;
3285 }
3286
3287
3288 /* Free the charlen list from cl to end (end is not freed).
3289    Free the whole list if end is NULL.  */
3290
3291 void
3292 gfc_free_charlen (gfc_charlen *cl, gfc_charlen *end)
3293 {
3294   gfc_charlen *cl2;
3295
3296   for (; cl != end; cl = cl2)
3297     {
3298       gcc_assert (cl);
3299
3300       cl2 = cl->next;
3301       gfc_free_expr (cl->length);
3302       free (cl);
3303     }
3304 }
3305
3306
3307 /* Free entry list structs.  */
3308
3309 static void
3310 free_entry_list (gfc_entry_list *el)
3311 {
3312   gfc_entry_list *next;
3313
3314   if (el == NULL)
3315     return;
3316
3317   next = el->next;
3318   free (el);
3319   free_entry_list (next);
3320 }
3321
3322
3323 /* Free a namespace structure and everything below it.  Interface
3324    lists associated with intrinsic operators are not freed.  These are
3325    taken care of when a specific name is freed.  */
3326
3327 void
3328 gfc_free_namespace (gfc_namespace *ns)
3329 {
3330   gfc_namespace *p, *q;
3331   int i;
3332
3333   if (ns == NULL)
3334     return;
3335
3336   ns->refs--;
3337   if (ns->refs > 0)
3338     return;
3339   gcc_assert (ns->refs == 0);
3340
3341   gfc_free_statements (ns->code);
3342
3343   free_sym_tree (ns->sym_root);
3344   free_uop_tree (ns->uop_root);
3345   free_common_tree (ns->common_root);
3346   free_tb_tree (ns->tb_sym_root);
3347   free_tb_tree (ns->tb_uop_root);
3348   gfc_free_finalizer_list (ns->finalizers);
3349   gfc_free_charlen (ns->cl_list, NULL);
3350   free_st_labels (ns->st_labels);
3351
3352   free_entry_list (ns->entries);
3353   gfc_free_equiv (ns->equiv);
3354   gfc_free_equiv_lists (ns->equiv_lists);
3355   gfc_free_use_stmts (ns->use_stmts);
3356
3357   for (i = GFC_INTRINSIC_BEGIN; i != GFC_INTRINSIC_END; i++)
3358     gfc_free_interface (ns->op[i]);
3359
3360   gfc_free_data (ns->data);
3361   p = ns->contained;
3362   free (ns);
3363
3364   /* Recursively free any contained namespaces.  */
3365   while (p != NULL)
3366     {
3367       q = p;
3368       p = p->sibling;
3369       gfc_free_namespace (q);
3370     }
3371 }
3372
3373
3374 void
3375 gfc_symbol_init_2 (void)
3376 {
3377
3378   gfc_current_ns = gfc_get_namespace (NULL, 0);
3379 }
3380
3381
3382 void
3383 gfc_symbol_done_2 (void)
3384 {
3385
3386   gfc_free_namespace (gfc_current_ns);
3387   gfc_current_ns = NULL;
3388   gfc_free_dt_list ();
3389 }
3390
3391
3392 /* Count how many nodes a symtree has.  */
3393
3394 static unsigned
3395 count_st_nodes (const gfc_symtree *st)
3396 {
3397   unsigned nodes;
3398   if (!st)
3399     return 0;
3400
3401   nodes = count_st_nodes (st->left);
3402   nodes++;
3403   nodes += count_st_nodes (st->right);
3404
3405   return nodes;
3406 }
3407
3408
3409 /* Convert symtree tree into symtree vector.  */
3410
3411 static unsigned
3412 fill_st_vector (gfc_symtree *st, gfc_symtree **st_vec, unsigned node_cntr)
3413 {
3414   if (!st)
3415     return node_cntr;
3416
3417   node_cntr = fill_st_vector (st->left, st_vec, node_cntr);
3418   st_vec[node_cntr++] = st;
3419   node_cntr = fill_st_vector (st->right, st_vec, node_cntr);
3420
3421   return node_cntr;
3422 }
3423
3424
3425 /* Traverse namespace.  As the functions might modify the symtree, we store the
3426    symtree as a vector and operate on this vector.  Note: We assume that
3427    sym_func or st_func never deletes nodes from the symtree - only adding is
3428    allowed. Additionally, newly added nodes are not traversed.  */
3429
3430 static void
3431 do_traverse_symtree (gfc_symtree *st, void (*st_func) (gfc_symtree *),
3432                      void (*sym_func) (gfc_symbol *))
3433 {
3434   gfc_symtree **st_vec;
3435   unsigned nodes, i, node_cntr;
3436
3437   gcc_assert ((st_func && !sym_func) || (!st_func && sym_func));
3438   nodes = count_st_nodes (st);
3439   st_vec = XALLOCAVEC (gfc_symtree *, nodes);
3440   node_cntr = 0;
3441   fill_st_vector (st, st_vec, node_cntr);
3442
3443   if (sym_func)
3444     {
3445       /* Clear marks.  */
3446       for (i = 0; i < nodes; i++)
3447         st_vec[i]->n.sym->mark = 0;
3448       for (i = 0; i < nodes; i++)
3449         if (!st_vec[i]->n.sym->mark)
3450           {
3451             (*sym_func) (st_vec[i]->n.sym);
3452             st_vec[i]->n.sym->mark = 1;
3453           }
3454      }
3455    else
3456       for (i = 0; i < nodes; i++)
3457         (*st_func) (st_vec[i]);
3458 }
3459
3460
3461 /* Recursively traverse the symtree nodes.  */
3462
3463 void
3464 gfc_traverse_symtree (gfc_symtree *st, void (*st_func) (gfc_symtree *))
3465 {
3466   do_traverse_symtree (st, st_func, NULL);
3467 }
3468
3469
3470 /* Call a given function for all symbols in the namespace.  We take
3471    care that each gfc_symbol node is called exactly once.  */
3472
3473 void
3474 gfc_traverse_ns (gfc_namespace *ns, void (*sym_func) (gfc_symbol *))
3475 {
3476   do_traverse_symtree (ns->sym_root, NULL, sym_func);
3477 }
3478
3479
3480 /* Return TRUE when name is the name of an intrinsic type.  */
3481
3482 bool
3483 gfc_is_intrinsic_typename (const char *name)
3484 {
3485   if (strcmp (name, "integer") == 0
3486       || strcmp (name, "real") == 0
3487       || strcmp (name, "character") == 0
3488       || strcmp (name, "logical") == 0
3489       || strcmp (name, "complex") == 0
3490       || strcmp (name, "doubleprecision") == 0
3491       || strcmp (name, "doublecomplex") == 0)
3492     return true;
3493   else
3494     return false;
3495 }
3496
3497
3498 /* Return TRUE if the symbol is an automatic variable.  */
3499
3500 static bool
3501 gfc_is_var_automatic (gfc_symbol *sym)
3502 {
3503   /* Pointer and allocatable variables are never automatic.  */
3504   if (sym->attr.pointer || sym->attr.allocatable)
3505     return false;
3506   /* Check for arrays with non-constant size.  */
3507   if (sym->attr.dimension && sym->as
3508       && !gfc_is_compile_time_shape (sym->as))
3509     return true;
3510   /* Check for non-constant length character variables.  */
3511   if (sym->ts.type == BT_CHARACTER
3512       && sym->ts.u.cl
3513       && !gfc_is_constant_expr (sym->ts.u.cl->length))
3514     return true;
3515   return false;
3516 }
3517
3518 /* Given a symbol, mark it as SAVEd if it is allowed.  */
3519
3520 static void
3521 save_symbol (gfc_symbol *sym)
3522 {
3523
3524   if (sym->attr.use_assoc)
3525     return;
3526
3527   if (sym->attr.in_common
3528       || sym->attr.dummy
3529       || sym->attr.result
3530       || sym->attr.flavor != FL_VARIABLE)
3531     return;
3532   /* Automatic objects are not saved.  */
3533   if (gfc_is_var_automatic (sym))
3534     return;
3535   gfc_add_save (&sym->attr, SAVE_EXPLICIT, sym->name, &sym->declared_at);
3536 }
3537
3538
3539 /* Mark those symbols which can be SAVEd as such.  */
3540
3541 void
3542 gfc_save_all (gfc_namespace *ns)
3543 {
3544   gfc_traverse_ns (ns, save_symbol);
3545 }
3546
3547
3548 /* Make sure that no changes to symbols are pending.  */
3549
3550 void
3551 gfc_enforce_clean_symbol_state(void)
3552 {
3553   gcc_assert (changed_syms == NULL);
3554 }
3555
3556
3557 /************** Global symbol handling ************/
3558
3559
3560 /* Search a tree for the global symbol.  */
3561
3562 gfc_gsymbol *
3563 gfc_find_gsymbol (gfc_gsymbol *symbol, const char *name)
3564 {
3565   int c;
3566
3567   if (symbol == NULL)
3568     return NULL;
3569
3570   while (symbol)
3571     {
3572       c = strcmp (name, symbol->name);
3573       if (!c)
3574         return symbol;
3575
3576       symbol = (c < 0) ? symbol->left : symbol->right;
3577     }
3578
3579   return NULL;
3580 }
3581
3582
3583 /* Compare two global symbols. Used for managing the BB tree.  */
3584
3585 static int
3586 gsym_compare (void *_s1, void *_s2)
3587 {
3588   gfc_gsymbol *s1, *s2;
3589
3590   s1 = (gfc_gsymbol *) _s1;
3591   s2 = (gfc_gsymbol *) _s2;
3592   return strcmp (s1->name, s2->name);
3593 }
3594
3595
3596 /* Get a global symbol, creating it if it doesn't exist.  */
3597
3598 gfc_gsymbol *
3599 gfc_get_gsymbol (const char *name)
3600 {
3601   gfc_gsymbol *s;
3602
3603   s = gfc_find_gsymbol (gfc_gsym_root, name);
3604   if (s != NULL)
3605     return s;
3606
3607   s = XCNEW (gfc_gsymbol);
3608   s->type = GSYM_UNKNOWN;
3609   s->name = gfc_get_string (name);
3610
3611   gfc_insert_bbt (&gfc_gsym_root, s, gsym_compare);
3612
3613   return s;
3614 }
3615
3616
3617 static gfc_symbol *
3618 get_iso_c_binding_dt (int sym_id)
3619 {
3620   gfc_dt_list *dt_list;
3621
3622   dt_list = gfc_derived_types;
3623
3624   /* Loop through the derived types in the name list, searching for
3625      the desired symbol from iso_c_binding.  Search the parent namespaces
3626      if necessary and requested to (parent_flag).  */
3627   while (dt_list != NULL)
3628     {
3629       if (dt_list->derived->from_intmod != INTMOD_NONE
3630           && dt_list->derived->intmod_sym_id == sym_id)
3631         return dt_list->derived;
3632
3633       dt_list = dt_list->next;
3634     }
3635
3636   return NULL;
3637 }
3638
3639
3640 /* Verifies that the given derived type symbol, derived_sym, is interoperable
3641    with C.  This is necessary for any derived type that is BIND(C) and for
3642    derived types that are parameters to functions that are BIND(C).  All
3643    fields of the derived type are required to be interoperable, and are tested
3644    for such.  If an error occurs, the errors are reported here, allowing for
3645    multiple errors to be handled for a single derived type.  */
3646
3647 gfc_try
3648 verify_bind_c_derived_type (gfc_symbol *derived_sym)
3649 {
3650   gfc_component *curr_comp = NULL;
3651   gfc_try is_c_interop = FAILURE;
3652   gfc_try retval = SUCCESS;
3653
3654   if (derived_sym == NULL)
3655     gfc_internal_error ("verify_bind_c_derived_type(): Given symbol is "
3656                         "unexpectedly NULL");
3657
3658   /* If we've already looked at this derived symbol, do not look at it again
3659      so we don't repeat warnings/errors.  */
3660   if (derived_sym->ts.is_c_interop)
3661     return SUCCESS;
3662
3663   /* The derived type must have the BIND attribute to be interoperable
3664      J3/04-007, Section 15.2.3.  */
3665   if (derived_sym->attr.is_bind_c != 1)
3666     {
3667       derived_sym->ts.is_c_interop = 0;
3668       gfc_error_now ("Derived type '%s' declared at %L must have the BIND "
3669                      "attribute to be C interoperable", derived_sym->name,
3670                      &(derived_sym->declared_at));
3671       retval = FAILURE;
3672     }
3673
3674   curr_comp = derived_sym->components;
3675
3676   /* Fortran 2003 allows an empty derived type.  C99 appears to disallow an
3677      empty struct.  Section 15.2 in Fortran 2003 states:  "The following
3678      subclauses define the conditions under which a Fortran entity is
3679      interoperable.  If a Fortran entity is interoperable, an equivalent
3680      entity may be defined by means of C and the Fortran entity is said
3681      to be interoperable with the C entity.  There does not have to be such
3682      an interoperating C entity."
3683   */
3684   if (curr_comp == NULL)
3685     {
3686       gfc_warning ("Derived type '%s' with BIND(C) attribute at %L is empty, "
3687                    "and may be inaccessible by the C companion processor",
3688                    derived_sym->name, &(derived_sym->declared_at));
3689       derived_sym->ts.is_c_interop = 1;
3690       derived_sym->attr.is_bind_c = 1;
3691       return SUCCESS;
3692     }
3693
3694
3695   /* Initialize the derived type as being C interoperable.
3696      If we find an error in the components, this will be set false.  */
3697   derived_sym->ts.is_c_interop = 1;
3698
3699   /* Loop through the list of components to verify that the kind of
3700      each is a C interoperable type.  */
3701   do
3702     {
3703       /* The components cannot be pointers (fortran sense).
3704          J3/04-007, Section 15.2.3, C1505.      */
3705       if (curr_comp->attr.pointer != 0)
3706         {
3707           gfc_error ("Component '%s' at %L cannot have the "
3708                      "POINTER attribute because it is a member "
3709                      "of the BIND(C) derived type '%s' at %L",
3710                      curr_comp->name, &(curr_comp->loc),
3711                      derived_sym->name, &(derived_sym->declared_at));
3712           retval = FAILURE;
3713         }
3714
3715       if (curr_comp->attr.proc_pointer != 0)
3716         {
3717           gfc_error ("Procedure pointer component '%s' at %L cannot be a member"
3718                      " of the BIND(C) derived type '%s' at %L", curr_comp->name,
3719                      &curr_comp->loc, derived_sym->name,
3720                      &derived_sym->declared_at);
3721           retval = FAILURE;
3722         }
3723
3724       /* The components cannot be allocatable.
3725          J3/04-007, Section 15.2.3, C1505.      */
3726       if (curr_comp->attr.allocatable != 0)
3727         {
3728           gfc_error ("Component '%s' at %L cannot have the "
3729                      "ALLOCATABLE attribute because it is a member "
3730                      "of the BIND(C) derived type '%s' at %L",
3731                      curr_comp->name, &(curr_comp->loc),
3732                      derived_sym->name, &(derived_sym->declared_at));
3733           retval = FAILURE;
3734         }
3735
3736       /* BIND(C) derived types must have interoperable components.  */
3737       if (curr_comp->ts.type == BT_DERIVED
3738           && curr_comp->ts.u.derived->ts.is_iso_c != 1
3739           && curr_comp->ts.u.derived != derived_sym)
3740         {
3741           /* This should be allowed; the draft says a derived-type can not
3742              have type parameters if it is has the BIND attribute.  Type
3743              parameters seem to be for making parameterized derived types.
3744              There's no need to verify the type if it is c_ptr/c_funptr.  */
3745           retval = verify_bind_c_derived_type (curr_comp->ts.u.derived);
3746         }
3747       else
3748         {
3749           /* Grab the typespec for the given component and test the kind.  */
3750           is_c_interop = gfc_verify_c_interop (&(curr_comp->ts));
3751
3752           if (is_c_interop != SUCCESS)
3753             {
3754               /* Report warning and continue since not fatal.  The
3755                  draft does specify a constraint that requires all fields
3756                  to interoperate, but if the user says real(4), etc., it
3757                  may interoperate with *something* in C, but the compiler
3758                  most likely won't know exactly what.  Further, it may not
3759                  interoperate with the same data type(s) in C if the user
3760                  recompiles with different flags (e.g., -m32 and -m64 on
3761                  x86_64 and using integer(4) to claim interop with a
3762                  C_LONG).  */
3763               if (derived_sym->attr.is_bind_c == 1
3764                   && gfc_option.warn_c_binding_type)
3765                 /* If the derived type is bind(c), all fields must be
3766                    interop.  */
3767                 gfc_warning ("Component '%s' in derived type '%s' at %L "
3768                              "may not be C interoperable, even though "
3769                              "derived type '%s' is BIND(C)",
3770                              curr_comp->name, derived_sym->name,
3771                              &(curr_comp->loc), derived_sym->name);
3772               else if (gfc_option.warn_c_binding_type)
3773                 /* If derived type is param to bind(c) routine, or to one
3774                    of the iso_c_binding procs, it must be interoperable, so
3775                    all fields must interop too.  */
3776                 gfc_warning ("Component '%s' in derived type '%s' at %L "
3777                              "may not be C interoperable",
3778                              curr_comp->name, derived_sym->name,
3779                              &(curr_comp->loc));
3780             }
3781         }
3782
3783       curr_comp = curr_comp->next;
3784     } while (curr_comp != NULL);
3785
3786
3787   /* Make sure we don't have conflicts with the attributes.  */
3788   if (derived_sym->attr.access == ACCESS_PRIVATE)
3789     {
3790       gfc_error ("Derived type '%s' at %L cannot be declared with both "
3791                  "PRIVATE and BIND(C) attributes", derived_sym->name,
3792                  &(derived_sym->declared_at));
3793       retval = FAILURE;
3794     }
3795
3796   if (derived_sym->attr.sequence != 0)
3797     {
3798       gfc_error ("Derived type '%s' at %L cannot have the SEQUENCE "
3799                  "attribute because it is BIND(C)", derived_sym->name,
3800                  &(derived_sym->declared_at));
3801       retval = FAILURE;
3802     }
3803
3804   /* Mark the derived type as not being C interoperable if we found an
3805      error.  If there were only warnings, proceed with the assumption
3806      it's interoperable.  */
3807   if (retval == FAILURE)
3808     derived_sym->ts.is_c_interop = 0;
3809
3810   return retval;
3811 }
3812
3813
3814 /* Generate symbols for the named constants c_null_ptr and c_null_funptr.  */
3815
3816 static gfc_try
3817 gen_special_c_interop_ptr (int ptr_id, const char *ptr_name,
3818                            const char *module_name)
3819 {
3820   gfc_symtree *tmp_symtree;
3821   gfc_symbol *tmp_sym;
3822   gfc_constructor *c;
3823
3824   tmp_symtree = gfc_find_symtree (gfc_current_ns->sym_root, ptr_name);
3825
3826   if (tmp_symtree != NULL)
3827     tmp_sym = tmp_symtree->n.sym;
3828   else
3829     {
3830       tmp_sym = NULL;
3831       gfc_internal_error ("gen_special_c_interop_ptr(): Unable to "
3832                           "create symbol for %s", ptr_name);
3833     }
3834
3835   tmp_sym->ts.is_c_interop = 1;
3836   tmp_sym->attr.is_c_interop = 1;
3837   tmp_sym->ts.is_iso_c = 1;
3838   tmp_sym->ts.type = BT_DERIVED;
3839   tmp_sym->attr.flavor = FL_PARAMETER;
3840
3841   /* The c_ptr and c_funptr derived types will provide the
3842      definition for c_null_ptr and c_null_funptr, respectively.  */
3843   if (ptr_id == ISOCBINDING_NULL_PTR)
3844     tmp_sym->ts.u.derived = get_iso_c_binding_dt (ISOCBINDING_PTR);
3845   else
3846     tmp_sym->ts.u.derived = get_iso_c_binding_dt (ISOCBINDING_FUNPTR);
3847   if (tmp_sym->ts.u.derived == NULL)
3848     {
3849       /* This can occur if the user forgot to declare c_ptr or
3850          c_funptr and they're trying to use one of the procedures
3851          that has arg(s) of the missing type.  In this case, a
3852          regular version of the thing should have been put in the
3853          current ns.  */
3854
3855       generate_isocbinding_symbol (module_name, ptr_id == ISOCBINDING_NULL_PTR
3856                                    ? ISOCBINDING_PTR : ISOCBINDING_FUNPTR,
3857                                    (const char *) (ptr_id == ISOCBINDING_NULL_PTR
3858                                    ? "c_ptr"
3859                                    : "c_funptr"));
3860       tmp_sym->ts.u.derived =
3861         get_iso_c_binding_dt (ptr_id == ISOCBINDING_NULL_PTR
3862                               ? ISOCBINDING_PTR : ISOCBINDING_FUNPTR);
3863     }
3864
3865   /* Module name is some mangled version of iso_c_binding.  */
3866   tmp_sym->module = gfc_get_string (module_name);
3867
3868   /* Say it's from the iso_c_binding module.  */
3869   tmp_sym->attr.is_iso_c = 1;
3870
3871   tmp_sym->attr.use_assoc = 1;
3872   tmp_sym->attr.is_bind_c = 1;
3873   /* Since we never generate a call to this symbol, don't set the
3874      binding_label.  */
3875
3876   /* Set the c_address field of c_null_ptr and c_null_funptr to
3877      the value of NULL.  */
3878   tmp_sym->value = gfc_get_expr ();
3879   tmp_sym->value->expr_type = EXPR_STRUCTURE;
3880   tmp_sym->value->ts.type = BT_DERIVED;
3881   tmp_sym->value->ts.u.derived = tmp_sym->ts.u.derived;
3882   gfc_constructor_append_expr (&tmp_sym->value->value.constructor, NULL, NULL);
3883   c = gfc_constructor_first (tmp_sym->value->value.constructor);
3884   c->expr = gfc_get_expr ();
3885   c->expr->expr_type = EXPR_NULL;
3886   c->expr->ts.is_iso_c = 1;
3887
3888   return SUCCESS;
3889 }
3890
3891
3892 /* Add a formal argument, gfc_formal_arglist, to the
3893    end of the given list of arguments.  Set the reference to the
3894    provided symbol, param_sym, in the argument.  */
3895
3896 static void
3897 add_formal_arg (gfc_formal_arglist **head,
3898                 gfc_formal_arglist **tail,
3899                 gfc_formal_arglist *formal_arg,
3900                 gfc_symbol *param_sym)
3901 {
3902   /* Put in list, either as first arg or at the tail (curr arg).  */
3903   if (*head == NULL)
3904     *head = *tail = formal_arg;
3905   else
3906     {
3907       (*tail)->next = formal_arg;
3908       (*tail) = formal_arg;
3909     }
3910
3911   (*tail)->sym = param_sym;
3912   (*tail)->next = NULL;
3913
3914   return;
3915 }
3916
3917
3918 /* Generates a symbol representing the CPTR argument to an
3919    iso_c_binding procedure.  Also, create a gfc_formal_arglist for the
3920    CPTR and add it to the provided argument list.  */
3921
3922 static void
3923 gen_cptr_param (gfc_formal_arglist **head,
3924                 gfc_formal_arglist **tail,
3925                 const char *module_name,
3926                 gfc_namespace *ns, const char *c_ptr_name,
3927                 int iso_c_sym_id)
3928 {
3929   gfc_symbol *param_sym = NULL;
3930   gfc_symbol *c_ptr_sym = NULL;
3931   gfc_symtree *param_symtree = NULL;
3932   gfc_formal_arglist *formal_arg = NULL;
3933   const char *c_ptr_in;
3934   const char *c_ptr_type = NULL;
3935
3936   if (iso_c_sym_id == ISOCBINDING_F_PROCPOINTER)
3937     c_ptr_type = "c_funptr";
3938   else
3939     c_ptr_type = "c_ptr";
3940
3941   if(c_ptr_name == NULL)
3942     c_ptr_in = "gfc_cptr__";
3943   else
3944     c_ptr_in = c_ptr_name;
3945   gfc_get_sym_tree (c_ptr_in, ns, &param_symtree, false);
3946   if (param_symtree != NULL)
3947     param_sym = param_symtree->n.sym;
3948   else
3949     gfc_internal_error ("gen_cptr_param(): Unable to "
3950                         "create symbol for %s", c_ptr_in);
3951
3952   /* Set up the appropriate fields for the new c_ptr param sym.  */
3953   param_sym->refs++;
3954   param_sym->attr.flavor = FL_DERIVED;
3955   param_sym->ts.type = BT_DERIVED;
3956   param_sym->attr.intent = INTENT_IN;
3957   param_sym->attr.dummy = 1;
3958
3959   /* This will pass the ptr to the iso_c routines as a (void *).  */
3960   param_sym->attr.value = 1;
3961   param_sym->attr.use_assoc = 1;
3962
3963   /* Get the symbol for c_ptr or c_funptr, no matter what it's name is
3964      (user renamed).  */
3965   if (iso_c_sym_id == ISOCBINDING_F_PROCPOINTER)
3966     c_ptr_sym = get_iso_c_binding_dt (ISOCBINDING_FUNPTR);
3967   else
3968     c_ptr_sym = get_iso_c_binding_dt (ISOCBINDING_PTR);
3969   if (c_ptr_sym == NULL)
3970     {
3971       /* This can happen if the user did not define c_ptr but they are
3972          trying to use one of the iso_c_binding functions that need it.  */
3973       if (iso_c_sym_id == ISOCBINDING_F_PROCPOINTER)
3974         generate_isocbinding_symbol (module_name, ISOCBINDING_FUNPTR,
3975                                      (const char *)c_ptr_type);
3976       else
3977         generate_isocbinding_symbol (module_name, ISOCBINDING_PTR,
3978                                      (const char *)c_ptr_type);
3979
3980       gfc_get_ha_symbol (c_ptr_type, &(c_ptr_sym));
3981     }
3982
3983   param_sym->ts.u.derived = c_ptr_sym;
3984   param_sym->module = gfc_get_string (module_name);
3985
3986   /* Make new formal arg.  */
3987   formal_arg = gfc_get_formal_arglist ();
3988   /* Add arg to list of formal args (the CPTR arg).  */
3989   add_formal_arg (head, tail, formal_arg, param_sym);
3990
3991   /* Validate changes.  */
3992   gfc_commit_symbol (param_sym);
3993 }
3994
3995
3996 /* Generates a symbol representing the FPTR argument to an
3997    iso_c_binding procedure.  Also, create a gfc_formal_arglist for the
3998    FPTR and add it to the provided argument list.  */
3999
4000 static void
4001 gen_fptr_param (gfc_formal_arglist **head,
4002                 gfc_formal_arglist **tail,
4003                 const char *module_name,
4004                 gfc_namespace *ns, const char *f_ptr_name, int proc)
4005 {
4006   gfc_symbol *param_sym = NULL;
4007   gfc_symtree *param_symtree = NULL;
4008   gfc_formal_arglist *formal_arg = NULL;
4009   const char *f_ptr_out = "gfc_fptr__";
4010
4011   if (f_ptr_name != NULL)
4012     f_ptr_out = f_ptr_name;
4013
4014   gfc_get_sym_tree (f_ptr_out, ns, &param_symtree, false);
4015   if (param_symtree != NULL)
4016     param_sym = param_symtree->n.sym;
4017   else
4018     gfc_internal_error ("generateFPtrParam(): Unable to "
4019                         "create symbol for %s", f_ptr_out);
4020
4021   /* Set up the necessary fields for the fptr output param sym.  */
4022   param_sym->refs++;
4023   if (proc)
4024     param_sym->attr.proc_pointer = 1;
4025   else
4026     param_sym->attr.pointer = 1;
4027   param_sym->attr.dummy = 1;
4028   param_sym->attr.use_assoc = 1;
4029
4030   /* ISO C Binding type to allow any pointer type as actual param.  */
4031   param_sym->ts.type = BT_VOID;
4032   param_sym->module = gfc_get_string (module_name);
4033
4034   /* Make the arg.  */
4035   formal_arg = gfc_get_formal_arglist ();
4036   /* Add arg to list of formal args.  */
4037   add_formal_arg (head, tail, formal_arg, param_sym);
4038
4039   /* Validate changes.  */
4040   gfc_commit_symbol (param_sym);
4041 }
4042
4043
4044 /* Generates a symbol representing the optional SHAPE argument for the
4045    iso_c_binding c_f_pointer() procedure.  Also, create a
4046    gfc_formal_arglist for the SHAPE and add it to the provided
4047    argument list.  */
4048
4049 static void
4050 gen_shape_param (gfc_formal_arglist **head,
4051                  gfc_formal_arglist **tail,
4052                  const char *module_name,
4053                  gfc_namespace *ns, const char *shape_param_name)
4054 {
4055   gfc_symbol *param_sym = NULL;
4056   gfc_symtree *param_symtree = NULL;
4057   gfc_formal_arglist *formal_arg = NULL;
4058   const char *shape_param = "gfc_shape_array__";
4059
4060   if (shape_param_name != NULL)
4061     shape_param = shape_param_name;
4062
4063   gfc_get_sym_tree (shape_param, ns, &param_symtree, false);
4064   if (param_symtree != NULL)
4065     param_sym = param_symtree->n.sym;
4066   else
4067     gfc_internal_error ("generateShapeParam(): Unable to "
4068                         "create symbol for %s", shape_param);
4069
4070   /* Set up the necessary fields for the shape input param sym.  */
4071   param_sym->refs++;
4072   param_sym->attr.dummy = 1;
4073   param_sym->attr.use_assoc = 1;
4074
4075   /* Integer array, rank 1, describing the shape of the object.  Make it's
4076      type BT_VOID initially so we can accept any type/kind combination of
4077      integer.  During gfc_iso_c_sub_interface (resolve.c), we'll make it
4078      of BT_INTEGER type.  */
4079   param_sym->ts.type = BT_VOID;
4080
4081   /* Initialize the kind to default integer.  However, it will be overridden
4082      during resolution to match the kind of the SHAPE parameter given as
4083      the actual argument (to allow for any valid integer kind).  */
4084   param_sym->ts.kind = gfc_default_integer_kind;
4085   param_sym->as = gfc_get_array_spec ();
4086
4087   param_sym->as->rank = 1;
4088   param_sym->as->lower[0] = gfc_get_int_expr (gfc_default_integer_kind,
4089                                               NULL, 1);
4090
4091   /* The extent is unknown until we get it.  The length give us
4092      the rank the incoming pointer.  */
4093   param_sym->as->type = AS_ASSUMED_SHAPE;
4094
4095   /* The arg is also optional; it is required iff the second arg
4096      (fptr) is to an array, otherwise, it's ignored.  */
4097   param_sym->attr.optional = 1;
4098   param_sym->attr.intent = INTENT_IN;
4099   param_sym->attr.dimension = 1;
4100   param_sym->module = gfc_get_string (module_name);
4101
4102   /* Make the arg.  */
4103   formal_arg = gfc_get_formal_arglist ();
4104   /* Add arg to list of formal args.  */
4105   add_formal_arg (head, tail, formal_arg, param_sym);
4106
4107   /* Validate changes.  */
4108   gfc_commit_symbol (param_sym);
4109 }
4110
4111
4112 /* Add a procedure interface to the given symbol (i.e., store a
4113    reference to the list of formal arguments).  */
4114
4115 static void
4116 add_proc_interface (gfc_symbol *sym, ifsrc source, gfc_formal_arglist *formal)
4117 {
4118
4119   sym->formal = formal;
4120   sym->attr.if_source = source;
4121 }
4122
4123
4124 /* Copy the formal args from an existing symbol, src, into a new
4125    symbol, dest.  New formal args are created, and the description of
4126    each arg is set according to the existing ones.  This function is
4127    used when creating procedure declaration variables from a procedure
4128    declaration statement (see match_proc_decl()) to create the formal
4129    args based on the args of a given named interface.  */
4130
4131 void
4132 gfc_copy_formal_args (gfc_symbol *dest, gfc_symbol *src, ifsrc if_src)
4133 {
4134   gfc_formal_arglist *head = NULL;
4135   gfc_formal_arglist *tail = NULL;
4136   gfc_formal_arglist *formal_arg = NULL;
4137   gfc_formal_arglist *curr_arg = NULL;
4138   gfc_formal_arglist *formal_prev = NULL;
4139   /* Save current namespace so we can change it for formal args.  */
4140   gfc_namespace *parent_ns = gfc_current_ns;
4141
4142   /* Create a new namespace, which will be the formal ns (namespace
4143      of the formal args).  */
4144   gfc_current_ns = gfc_get_namespace (parent_ns, 0);
4145   gfc_current_ns->proc_name = dest;
4146   dest->formal_ns = gfc_current_ns;
4147
4148   for (curr_arg = src->formal; curr_arg; curr_arg = curr_arg->next)
4149     {
4150       formal_arg = gfc_get_formal_arglist ();
4151       gfc_get_symbol (curr_arg->sym->name, gfc_current_ns, &(formal_arg->sym));
4152
4153       /* May need to copy more info for the symbol.  */
4154       formal_arg->sym->attr = curr_arg->sym->attr;
4155       formal_arg->sym->ts = curr_arg->sym->ts;
4156       formal_arg->sym->as = gfc_copy_array_spec (curr_arg->sym->as);
4157       gfc_copy_formal_args (formal_arg->sym, curr_arg->sym,
4158                             curr_arg->sym->attr.if_source);
4159
4160       /* If this isn't the first arg, set up the next ptr.  For the
4161         last arg built, the formal_arg->next will never get set to
4162         anything other than NULL.  */
4163       if (formal_prev != NULL)
4164         formal_prev->next = formal_arg;
4165       else
4166         formal_arg->next = NULL;
4167
4168       formal_prev = formal_arg;
4169
4170       /* Add arg to list of formal args.  */
4171       add_formal_arg (&head, &tail, formal_arg, formal_arg->sym);
4172
4173       /* Validate changes.  */
4174       gfc_commit_symbol (formal_arg->sym);
4175     }
4176
4177   /* Add the interface to the symbol.  */
4178   add_proc_interface (dest, if_src, head);
4179
4180   /* Store the formal namespace information.  */
4181   if (dest->formal != NULL)
4182     /* The current ns should be that for the dest proc.  */
4183     dest->formal_ns = gfc_current_ns;
4184   /* Restore the current namespace to what it was on entry.  */
4185   gfc_current_ns = parent_ns;
4186 }
4187
4188
4189 void
4190 gfc_copy_formal_args_intr (gfc_symbol *dest, gfc_intrinsic_sym *src)
4191 {
4192   gfc_formal_arglist *head = NULL;
4193   gfc_formal_arglist *tail = NULL;
4194   gfc_formal_arglist *formal_arg = NULL;
4195   gfc_intrinsic_arg *curr_arg = NULL;
4196   gfc_formal_arglist *formal_prev = NULL;
4197   /* Save current namespace so we can change it for formal args.  */
4198   gfc_namespace *parent_ns = gfc_current_ns;
4199
4200   /* Create a new namespace, which will be the formal ns (namespace
4201      of the formal args).  */
4202   gfc_current_ns = gfc_get_namespace (parent_ns, 0);
4203   gfc_current_ns->proc_name = dest;
4204
4205   for (curr_arg = src->formal; curr_arg; curr_arg = curr_arg->next)
4206     {
4207       formal_arg = gfc_get_formal_arglist ();
4208       gfc_get_symbol (curr_arg->name, gfc_current_ns, &(formal_arg->sym));
4209
4210       /* May need to copy more info for the symbol.  */
4211       formal_arg->sym->ts = curr_arg->ts;
4212       formal_arg->sym->attr.optional = curr_arg->optional;
4213       formal_arg->sym->attr.value = curr_arg->value;
4214       formal_arg->sym->attr.intent = curr_arg->intent;
4215       formal_arg->sym->attr.flavor = FL_VARIABLE;
4216       formal_arg->sym->attr.dummy = 1;
4217
4218       if (formal_arg->sym->ts.type == BT_CHARACTER)
4219         formal_arg->sym->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
4220
4221       /* If this isn't the first arg, set up the next ptr.  For the
4222         last arg built, the formal_arg->next will never get set to
4223         anything other than NULL.  */
4224       if (formal_prev != NULL)
4225         formal_prev->next = formal_arg;
4226       else
4227         formal_arg->next = NULL;
4228
4229       formal_prev = formal_arg;
4230
4231       /* Add arg to list of formal args.  */
4232       add_formal_arg (&head, &tail, formal_arg, formal_arg->sym);
4233
4234       /* Validate changes.  */
4235       gfc_commit_symbol (formal_arg->sym);
4236     }
4237
4238   /* Add the interface to the symbol.  */
4239   add_proc_interface (dest, IFSRC_DECL, head);
4240
4241   /* Store the formal namespace information.  */
4242   if (dest->formal != NULL)
4243     /* The current ns should be that for the dest proc.  */
4244     dest->formal_ns = gfc_current_ns;
4245   /* Restore the current namespace to what it was on entry.  */
4246   gfc_current_ns = parent_ns;
4247 }
4248
4249
4250 void
4251 gfc_copy_formal_args_ppc (gfc_component *dest, gfc_symbol *src, ifsrc if_src)
4252 {
4253   gfc_formal_arglist *head = NULL;
4254   gfc_formal_arglist *tail = NULL;
4255   gfc_formal_arglist *formal_arg = NULL;
4256   gfc_formal_arglist *curr_arg = NULL;
4257   gfc_formal_arglist *formal_prev = NULL;
4258   /* Save current namespace so we can change it for formal args.  */
4259   gfc_namespace *parent_ns = gfc_current_ns;
4260
4261   /* Create a new namespace, which will be the formal ns (namespace
4262      of the formal args).  */
4263   gfc_current_ns = gfc_get_namespace (parent_ns, 0);
4264   /* TODO: gfc_current_ns->proc_name = dest;*/
4265
4266   for (curr_arg = src->formal; curr_arg; curr_arg = curr_arg->next)
4267     {
4268       formal_arg = gfc_get_formal_arglist ();
4269       gfc_get_symbol (curr_arg->sym->name, gfc_current_ns, &(formal_arg->sym));
4270
4271       /* May need to copy more info for the symbol.  */
4272       formal_arg->sym->attr = curr_arg->sym->attr;
4273       formal_arg->sym->ts = curr_arg->sym->ts;
4274       formal_arg->sym->as = gfc_copy_array_spec (curr_arg->sym->as);
4275       gfc_copy_formal_args (formal_arg->sym, curr_arg->sym,
4276                             curr_arg->sym->attr.if_source);
4277
4278       /* If this isn't the first arg, set up the next ptr.  For the
4279         last arg built, the formal_arg->next will never get set to
4280         anything other than NULL.  */
4281       if (formal_prev != NULL)
4282         formal_prev->next = formal_arg;
4283       else
4284         formal_arg->next = NULL;
4285
4286       formal_prev = formal_arg;
4287
4288       /* Add arg to list of formal args.  */
4289       add_formal_arg (&head, &tail, formal_arg, formal_arg->sym);
4290
4291       /* Validate changes.  */
4292       gfc_commit_symbol (formal_arg->sym);
4293     }
4294
4295   /* Add the interface to the symbol.  */
4296   gfc_free_formal_arglist (dest->formal);
4297   dest->formal = head;
4298   dest->attr.if_source = if_src;
4299
4300   /* Store the formal namespace information.  */
4301   if (dest->formal != NULL)
4302     /* The current ns should be that for the dest proc.  */
4303     dest->formal_ns = gfc_current_ns;
4304   /* Restore the current namespace to what it was on entry.  */
4305   gfc_current_ns = parent_ns;
4306 }
4307
4308
4309 /* Builds the parameter list for the iso_c_binding procedure
4310    c_f_pointer or c_f_procpointer.  The old_sym typically refers to a
4311    generic version of either the c_f_pointer or c_f_procpointer
4312    functions.  The new_proc_sym represents a "resolved" version of the
4313    symbol.  The functions are resolved to match the types of their
4314    parameters; for example, c_f_pointer(cptr, fptr) would resolve to
4315    something similar to c_f_pointer_i4 if the type of data object fptr
4316    pointed to was a default integer.  The actual name of the resolved
4317    procedure symbol is further mangled with the module name, etc., but
4318    the idea holds true.  */
4319
4320 static void
4321 build_formal_args (gfc_symbol *new_proc_sym,
4322                    gfc_symbol *old_sym, int add_optional_arg)
4323 {
4324   gfc_formal_arglist *head = NULL, *tail = NULL;
4325   gfc_namespace *parent_ns = NULL;
4326
4327   parent_ns = gfc_current_ns;
4328   /* Create a new namespace, which will be the formal ns (namespace
4329      of the formal args).  */
4330   gfc_current_ns = gfc_get_namespace(parent_ns, 0);
4331   gfc_current_ns->proc_name = new_proc_sym;
4332
4333   /* Generate the params.  */
4334   if (old_sym->intmod_sym_id == ISOCBINDING_F_PROCPOINTER)
4335     {
4336       gen_cptr_param (&head, &tail, (const char *) new_proc_sym->module,
4337                       gfc_current_ns, "cptr", old_sym->intmod_sym_id);
4338       gen_fptr_param (&head, &tail, (const char *) new_proc_sym->module,
4339                       gfc_current_ns, "fptr", 1);
4340     }
4341   else if (old_sym->intmod_sym_id == ISOCBINDING_F_POINTER)
4342     {
4343       gen_cptr_param (&head, &tail, (const char *) new_proc_sym->module,
4344                       gfc_current_ns, "cptr", old_sym->intmod_sym_id);
4345       gen_fptr_param (&head, &tail, (const char *) new_proc_sym->module,
4346                       gfc_current_ns, "fptr", 0);
4347       /* If we're dealing with c_f_pointer, it has an optional third arg.  */
4348       gen_shape_param (&head, &tail,(const char *) new_proc_sym->module,
4349                        gfc_current_ns, "shape");
4350
4351     }
4352   else if (old_sym->intmod_sym_id == ISOCBINDING_ASSOCIATED)
4353     {
4354       /* c_associated has one required arg and one optional; both
4355          are c_ptrs.  */
4356       gen_cptr_param (&head, &tail, (const char *) new_proc_sym->module,
4357                       gfc_current_ns, "c_ptr_1", ISOCBINDING_ASSOCIATED);
4358       if (add_optional_arg)
4359         {
4360           gen_cptr_param (&head, &tail, (const char *) new_proc_sym->module,
4361                           gfc_current_ns, "c_ptr_2", ISOCBINDING_ASSOCIATED);
4362           /* The last param is optional so mark it as such.  */
4363           tail->sym->attr.optional = 1;
4364         }
4365     }
4366
4367   /* Add the interface (store formal args to new_proc_sym).  */
4368   add_proc_interface (new_proc_sym, IFSRC_DECL, head);
4369
4370   /* Set up the formal_ns pointer to the one created for the
4371      new procedure so it'll get cleaned up during gfc_free_symbol().  */
4372   new_proc_sym->formal_ns = gfc_current_ns;
4373
4374   gfc_current_ns = parent_ns;
4375 }
4376
4377 static int
4378 std_for_isocbinding_symbol (int id)
4379 {
4380   switch (id)
4381     {
4382 #define NAMED_INTCST(a,b,c,d) \
4383       case a:\
4384         return d;
4385 #include "iso-c-binding.def"
4386 #undef NAMED_INTCST
4387
4388 #define NAMED_FUNCTION(a,b,c,d) \
4389       case a:\
4390         return d;
4391 #include "iso-c-binding.def"
4392 #undef NAMED_FUNCTION
4393
4394        default:
4395          return GFC_STD_F2003;
4396     }
4397 }
4398
4399 /* Generate the given set of C interoperable kind objects, or all
4400    interoperable kinds.  This function will only be given kind objects
4401    for valid iso_c_binding defined types because this is verified when
4402    the 'use' statement is parsed.  If the user gives an 'only' clause,
4403    the specific kinds are looked up; if they don't exist, an error is
4404    reported.  If the user does not give an 'only' clause, all
4405    iso_c_binding symbols are generated.  If a list of specific kinds
4406    is given, it must have a NULL in the first empty spot to mark the
4407    end of the list.  */
4408
4409
4410 void
4411 generate_isocbinding_symbol (const char *mod_name, iso_c_binding_symbol s,
4412                              const char *local_name)
4413 {
4414   const char *const name = (local_name && local_name[0]) ? local_name
4415                                              : c_interop_kinds_table[s].name;
4416   gfc_symtree *tmp_symtree = NULL;
4417   gfc_symbol *tmp_sym = NULL;
4418   int index;
4419
4420   if (gfc_notification_std (std_for_isocbinding_symbol (s)) == ERROR)
4421     return;
4422
4423   tmp_symtree = gfc_find_symtree (gfc_current_ns->sym_root, name);
4424
4425   /* Already exists in this scope so don't re-add it. */
4426   if (tmp_symtree != NULL && (tmp_sym = tmp_symtree->n.sym) != NULL
4427       && (!tmp_sym->attr.generic
4428           || (tmp_sym = gfc_find_dt_in_generic (tmp_sym)) != NULL)
4429       && tmp_sym->from_intmod == INTMOD_ISO_C_BINDING)
4430     {
4431       if (tmp_sym->attr.flavor == FL_DERIVED
4432           && !get_iso_c_binding_dt (tmp_sym->intmod_sym_id))
4433         {
4434           gfc_dt_list *dt_list;
4435           dt_list = gfc_get_dt_list ();
4436           dt_list->derived = tmp_sym;
4437           dt_list->next = gfc_derived_types;
4438           gfc_derived_types = dt_list;
4439         }
4440
4441       return;
4442     }
4443
4444   /* Create the sym tree in the current ns.  */
4445   gfc_get_sym_tree (name, gfc_current_ns, &tmp_symtree, false);
4446   if (tmp_symtree)
4447     tmp_sym = tmp_symtree->n.sym;
4448   else
4449     gfc_internal_error ("generate_isocbinding_symbol(): Unable to "
4450                         "create symbol");
4451
4452   /* Say what module this symbol belongs to.  */
4453   tmp_sym->module = gfc_get_string (mod_name);
4454   tmp_sym->from_intmod = INTMOD_ISO_C_BINDING;
4455   tmp_sym->intmod_sym_id = s;
4456
4457   switch (s)
4458     {
4459
4460 #define NAMED_INTCST(a,b,c,d) case a :
4461 #define NAMED_REALCST(a,b,c,d) case a :
4462 #define NAMED_CMPXCST(a,b,c,d) case a :
4463 #define NAMED_LOGCST(a,b,c) case a :
4464 #define NAMED_CHARKNDCST(a,b,c) case a :
4465 #include "iso-c-binding.def"
4466
4467         tmp_sym->value = gfc_get_int_expr (gfc_default_integer_kind, NULL,
4468                                            c_interop_kinds_table[s].value);
4469
4470         /* Initialize an integer constant expression node.  */
4471         tmp_sym->attr.flavor = FL_PARAMETER;
4472         tmp_sym->ts.type = BT_INTEGER;
4473         tmp_sym->ts.kind = gfc_default_integer_kind;
4474
4475         /* Mark this type as a C interoperable one.  */
4476         tmp_sym->ts.is_c_interop = 1;
4477         tmp_sym->ts.is_iso_c = 1;
4478         tmp_sym->value->ts.is_c_interop = 1;
4479         tmp_sym->value->ts.is_iso_c = 1;
4480         tmp_sym->attr.is_c_interop = 1;
4481
4482         /* Tell what f90 type this c interop kind is valid.  */
4483         tmp_sym->ts.f90_type = c_interop_kinds_table[s].f90_type;
4484
4485         /* Say it's from the iso_c_binding module.  */
4486         tmp_sym->attr.is_iso_c = 1;
4487
4488         /* Make it use associated.  */
4489         tmp_sym->attr.use_assoc = 1;
4490         break;
4491
4492
4493 #define NAMED_CHARCST(a,b,c) case a :
4494 #include "iso-c-binding.def"
4495
4496         /* Initialize an integer constant expression node for the
4497            length of the character.  */
4498         tmp_sym->value = gfc_get_character_expr (gfc_default_character_kind,
4499                                                  &gfc_current_locus, NULL, 1);
4500         tmp_sym->value->ts.is_c_interop = 1;
4501         tmp_sym->value->ts.is_iso_c = 1;
4502         tmp_sym->value->value.character.length = 1;
4503         tmp_sym->value->value.character.string[0]
4504           = (gfc_char_t) c_interop_kinds_table[s].value;
4505         tmp_sym->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
4506         tmp_sym->ts.u.cl->length = gfc_get_int_expr (gfc_default_integer_kind,
4507                                                      NULL, 1);
4508
4509         /* May not need this in both attr and ts, but do need in
4510            attr for writing module file.  */
4511         tmp_sym->attr.is_c_interop = 1;
4512
4513         tmp_sym->attr.flavor = FL_PARAMETER;
4514         tmp_sym->ts.type = BT_CHARACTER;
4515
4516         /* Need to set it to the C_CHAR kind.  */
4517         tmp_sym->ts.kind = gfc_default_character_kind;
4518
4519         /* Mark this type as a C interoperable one.  */
4520         tmp_sym->ts.is_c_interop = 1;
4521         tmp_sym->ts.is_iso_c = 1;
4522
4523         /* Tell what f90 type this c interop kind is valid.  */
4524         tmp_sym->ts.f90_type = BT_CHARACTER;
4525
4526         /* Say it's from the iso_c_binding module.  */
4527         tmp_sym->attr.is_iso_c = 1;
4528
4529         /* Make it use associated.  */
4530         tmp_sym->attr.use_assoc = 1;
4531         break;
4532
4533       case ISOCBINDING_PTR:
4534       case ISOCBINDING_FUNPTR:
4535         {
4536           gfc_interface *intr, *head;
4537           gfc_symbol *dt_sym;
4538           const char *hidden_name;
4539           gfc_dt_list **dt_list_ptr = NULL;
4540           gfc_component *tmp_comp = NULL;
4541           char comp_name[(GFC_MAX_SYMBOL_LEN * 2) + 1];
4542
4543           hidden_name = gfc_get_string ("%c%s",
4544                             (char) TOUPPER ((unsigned char) tmp_sym->name[0]),
4545                             &tmp_sym->name[1]);
4546
4547           /* Generate real derived type.  */
4548           tmp_symtree = gfc_find_symtree (gfc_current_ns->sym_root,
4549                                           hidden_name);
4550
4551           if (tmp_symtree != NULL)
4552             gcc_unreachable ();
4553           gfc_get_sym_tree (hidden_name, gfc_current_ns, &tmp_symtree, false);
4554           if (tmp_symtree)
4555             dt_sym = tmp_symtree->n.sym;
4556           else
4557             gcc_unreachable ();
4558
4559           /* Generate an artificial generic function.  */
4560           dt_sym->name = gfc_get_string (tmp_sym->name);
4561           head = tmp_sym->generic;
4562           intr = gfc_get_interface ();
4563           intr->sym = dt_sym;
4564           intr->where = gfc_current_locus;
4565           intr->next = head;
4566           tmp_sym->generic = intr;
4567
4568           if (!tmp_sym->attr.generic
4569               && gfc_add_generic (&tmp_sym->attr, tmp_sym->name, NULL)
4570                  == FAILURE)
4571             return;
4572
4573           if (!tmp_sym->attr.function
4574               && gfc_add_function (&tmp_sym->attr, tmp_sym->name, NULL)
4575                  == FAILURE)
4576             return;
4577
4578           /* Say what module this symbol belongs to.  */
4579           dt_sym->module = gfc_get_string (mod_name);
4580           dt_sym->from_intmod = INTMOD_ISO_C_BINDING;
4581           dt_sym->intmod_sym_id = s;
4582
4583           /* Initialize an integer constant expression node.  */
4584           dt_sym->attr.flavor = FL_DERIVED;
4585           dt_sym->ts.is_c_interop = 1;
4586           dt_sym->attr.is_c_interop = 1;
4587           dt_sym->attr.is_iso_c = 1;
4588           dt_sym->ts.is_iso_c = 1;
4589           dt_sym->ts.type = BT_DERIVED;
4590
4591           /* A derived type must have the bind attribute to be
4592              interoperable (J3/04-007, Section 15.2.3), even though
4593              the binding label is not used.  */
4594           dt_sym->attr.is_bind_c = 1;
4595
4596           dt_sym->attr.referenced = 1;
4597           dt_sym->ts.u.derived = dt_sym;
4598
4599           /* Add the symbol created for the derived type to the current ns.  */
4600           dt_list_ptr = &(gfc_derived_types);
4601           while (*dt_list_ptr != NULL && (*dt_list_ptr)->next != NULL)
4602             dt_list_ptr = &((*dt_list_ptr)->next);
4603
4604           /* There is already at least one derived type in the list, so append
4605              the one we're currently building for c_ptr or c_funptr.  */
4606           if (*dt_list_ptr != NULL)
4607             dt_list_ptr = &((*dt_list_ptr)->next);
4608           (*dt_list_ptr) = gfc_get_dt_list ();
4609           (*dt_list_ptr)->derived = dt_sym;
4610           (*dt_list_ptr)->next = NULL;
4611
4612           /* Set up the component of the derived type, which will be
4613              an integer with kind equal to c_ptr_size.  Mangle the name of
4614              the field for the c_address to prevent the curious user from
4615              trying to access it from Fortran.  */
4616           sprintf (comp_name, "__%s_%s", dt_sym->name, "c_address");
4617           gfc_add_component (dt_sym, comp_name, &tmp_comp);
4618           if (tmp_comp == NULL)
4619           gfc_internal_error ("generate_isocbinding_symbol(): Unable to "
4620                               "create component for c_address");
4621
4622           tmp_comp->ts.type = BT_INTEGER;
4623
4624           /* Set this because the module will need to read/write this field.  */
4625           tmp_comp->ts.f90_type = BT_INTEGER;
4626
4627           /* The kinds for c_ptr and c_funptr are the same.  */
4628           index = get_c_kind ("c_ptr", c_interop_kinds_table);
4629           tmp_comp->ts.kind = c_interop_kinds_table[index].value;
4630
4631           tmp_comp->attr.pointer = 0;
4632           tmp_comp->attr.dimension = 0;
4633
4634           /* Mark the component as C interoperable.  */
4635           tmp_comp->ts.is_c_interop = 1;
4636
4637           /* Make it use associated (iso_c_binding module).  */
4638           dt_sym->attr.use_assoc = 1;
4639         }
4640
4641         break;
4642
4643       case ISOCBINDING_NULL_PTR:
4644       case ISOCBINDING_NULL_FUNPTR:
4645         gen_special_c_interop_ptr (s, name, mod_name);
4646         break;
4647
4648       case ISOCBINDING_F_POINTER:
4649       case ISOCBINDING_ASSOCIATED:
4650       case ISOCBINDING_LOC:
4651       case ISOCBINDING_FUNLOC:
4652       case ISOCBINDING_F_PROCPOINTER:
4653
4654         tmp_sym->attr.proc = PROC_MODULE;
4655
4656         /* Use the procedure's name as it is in the iso_c_binding module for
4657            setting the binding label in case the user renamed the symbol.  */
4658         tmp_sym->binding_label =
4659           gfc_get_string ("%s_%s", mod_name,
4660                           c_interop_kinds_table[s].name);
4661         tmp_sym->attr.is_iso_c = 1;
4662         if (s == ISOCBINDING_F_POINTER || s == ISOCBINDING_F_PROCPOINTER)
4663           tmp_sym->attr.subroutine = 1;
4664         else
4665           {
4666             /* TODO!  This needs to be finished more for the expr of the
4667                function or something!
4668                This may not need to be here, because trying to do c_loc
4669                as an external.  */
4670             if (s == ISOCBINDING_ASSOCIATED)
4671               {
4672                 tmp_sym->attr.function = 1;
4673                 tmp_sym->ts.type = BT_LOGICAL;
4674                 tmp_sym->ts.kind = gfc_default_logical_kind;
4675                 tmp_sym->result = tmp_sym;
4676               }
4677             else
4678               {
4679                /* Here, we're taking the simple approach.  We're defining
4680                   c_loc as an external identifier so the compiler will put
4681                   what we expect on the stack for the address we want the
4682                   C address of.  */
4683                 tmp_sym->ts.type = BT_DERIVED;
4684                 if (s == ISOCBINDING_LOC)
4685                   tmp_sym->ts.u.derived =
4686                     get_iso_c_binding_dt (ISOCBINDING_PTR);
4687                 else
4688                   tmp_sym->ts.u.derived =
4689                     get_iso_c_binding_dt (ISOCBINDING_FUNPTR);
4690
4691                 if (tmp_sym->ts.u.derived == NULL)
4692                   {
4693                     /* Create the necessary derived type so we can continue
4694                        processing the file.  */
4695                     generate_isocbinding_symbol
4696                       (mod_name, s == ISOCBINDING_FUNLOC
4697                                 ? ISOCBINDING_FUNPTR : ISOCBINDING_PTR,
4698                       (const char *)(s == ISOCBINDING_FUNLOC
4699                                 ? "c_funptr" : "c_ptr"));
4700                     tmp_sym->ts.u.derived =
4701                     get_iso_c_binding_dt (s == ISOCBINDING_FUNLOC
4702                                             ? ISOCBINDING_FUNPTR
4703                                             : ISOCBINDING_PTR);
4704                   }
4705
4706                 /* The function result is itself (no result clause).  */
4707                 tmp_sym->result = tmp_sym;
4708                 tmp_sym->attr.external = 1;
4709                 tmp_sym->attr.use_assoc = 0;
4710                 tmp_sym->attr.pure = 1;
4711                 tmp_sym->attr.if_source = IFSRC_UNKNOWN;
4712                 tmp_sym->attr.proc = PROC_UNKNOWN;
4713               }
4714           }
4715
4716         tmp_sym->attr.flavor = FL_PROCEDURE;
4717         tmp_sym->attr.contained = 0;
4718
4719        /* Try using this builder routine, with the new and old symbols
4720           both being the generic iso_c proc sym being created.  This
4721           will create the formal args (and the new namespace for them).
4722           Don't build an arg list for c_loc because we're going to treat
4723           c_loc as an external procedure.  */
4724         if (s != ISOCBINDING_LOC && s != ISOCBINDING_FUNLOC)
4725           /* The 1 says to add any optional args, if applicable.  */
4726           build_formal_args (tmp_sym, tmp_sym, 1);
4727
4728         /* Set this after setting up the symbol, to prevent error messages.  */
4729         tmp_sym->attr.use_assoc = 1;
4730
4731         /* This symbol will not be referenced directly.  It will be
4732            resolved to the implementation for the given f90 kind.  */
4733         tmp_sym->attr.referenced = 0;
4734
4735         break;
4736
4737       default:
4738         gcc_unreachable ();
4739     }
4740   gfc_commit_symbol (tmp_sym);
4741 }
4742
4743
4744 /* Creates a new symbol based off of an old iso_c symbol, with a new
4745    binding label.  This function can be used to create a new,
4746    resolved, version of a procedure symbol for c_f_pointer or
4747    c_f_procpointer that is based on the generic symbols.  A new
4748    parameter list is created for the new symbol using
4749    build_formal_args().  The add_optional_flag specifies whether the
4750    to add the optional SHAPE argument.  The new symbol is
4751    returned.  */
4752
4753 gfc_symbol *
4754 get_iso_c_sym (gfc_symbol *old_sym, char *new_name,
4755                const char *new_binding_label, int add_optional_arg)
4756 {
4757   gfc_symtree *new_symtree = NULL;
4758
4759   /* See if we have a symbol by that name already available, looking
4760      through any parent namespaces.  */
4761   gfc_find_sym_tree (new_name, gfc_current_ns, 1, &new_symtree);
4762   if (new_symtree != NULL)
4763     /* Return the existing symbol.  */
4764     return new_symtree->n.sym;
4765
4766   /* Create the symtree/symbol, with attempted host association.  */
4767   gfc_get_ha_sym_tree (new_name, &new_symtree);
4768   if (new_symtree == NULL)
4769     gfc_internal_error ("get_iso_c_sym(): Unable to create "
4770                         "symtree for '%s'", new_name);
4771
4772   /* Now fill in the fields of the resolved symbol with the old sym.  */
4773   new_symtree->n.sym->binding_label = new_binding_label;
4774   new_symtree->n.sym->attr = old_sym->attr;
4775   new_symtree->n.sym->ts = old_sym->ts;
4776   new_symtree->n.sym->module = gfc_get_string (old_sym->module);
4777   new_symtree->n.sym->from_intmod = old_sym->from_intmod;
4778   new_symtree->n.sym->intmod_sym_id = old_sym->intmod_sym_id;
4779   if (old_sym->attr.function)
4780     new_symtree->n.sym->result = new_symtree->n.sym;
4781   /* Build the formal arg list.  */
4782   build_formal_args (new_symtree->n.sym, old_sym, add_optional_arg);
4783
4784   gfc_commit_symbol (new_symtree->n.sym);
4785
4786   return new_symtree->n.sym;
4787 }
4788
4789
4790 /* Check that a symbol is already typed.  If strict is not set, an untyped
4791    symbol is acceptable for non-standard-conforming mode.  */
4792
4793 gfc_try
4794 gfc_check_symbol_typed (gfc_symbol* sym, gfc_namespace* ns,
4795                         bool strict, locus where)
4796 {
4797   gcc_assert (sym);
4798
4799   if (gfc_matching_prefix)
4800     return SUCCESS;
4801
4802   /* Check for the type and try to give it an implicit one.  */
4803   if (sym->ts.type == BT_UNKNOWN
4804       && gfc_set_default_type (sym, 0, ns) == FAILURE)
4805     {
4806       if (strict)
4807         {
4808           gfc_error ("Symbol '%s' is used before it is typed at %L",
4809                      sym->name, &where);
4810           return FAILURE;
4811         }
4812
4813       if (gfc_notify_std (GFC_STD_GNU,
4814                           "Symbol '%s' is used before"
4815                           " it is typed at %L", sym->name, &where) == FAILURE)
4816         return FAILURE;
4817     }
4818
4819   /* Everything is ok.  */
4820   return SUCCESS;
4821 }
4822
4823
4824 /* Construct a typebound-procedure structure.  Those are stored in a tentative
4825    list and marked `error' until symbols are committed.  */
4826
4827 gfc_typebound_proc*
4828 gfc_get_typebound_proc (gfc_typebound_proc *tb0)
4829 {
4830   gfc_typebound_proc *result;
4831   tentative_tbp *list_node;
4832
4833   result = XCNEW (gfc_typebound_proc);
4834   if (tb0)
4835     *result = *tb0;
4836   result->error = 1;
4837
4838   list_node = XCNEW (tentative_tbp);
4839   list_node->next = tentative_tbp_list;
4840   list_node->proc = result;
4841   tentative_tbp_list = list_node;
4842
4843   return result;
4844 }
4845
4846
4847 /* Get the super-type of a given derived type.  */
4848
4849 gfc_symbol*
4850 gfc_get_derived_super_type (gfc_symbol* derived)
4851 {
4852   gcc_assert (derived);
4853
4854   if (derived->attr.generic)
4855     derived = gfc_find_dt_in_generic (derived);
4856
4857   if (!derived->attr.extension)
4858     return NULL;
4859
4860   gcc_assert (derived->components);
4861   gcc_assert (derived->components->ts.type == BT_DERIVED);
4862   gcc_assert (derived->components->ts.u.derived);
4863
4864   if (derived->components->ts.u.derived->attr.generic)
4865     return gfc_find_dt_in_generic (derived->components->ts.u.derived);
4866
4867   return derived->components->ts.u.derived;
4868 }
4869
4870
4871 /* Get the ultimate super-type of a given derived type.  */
4872
4873 gfc_symbol*
4874 gfc_get_ultimate_derived_super_type (gfc_symbol* derived)
4875 {
4876   if (!derived->attr.extension)
4877     return NULL;
4878
4879   derived = gfc_get_derived_super_type (derived);
4880
4881   if (derived->attr.extension)
4882     return gfc_get_ultimate_derived_super_type (derived);
4883   else
4884     return derived;
4885 }
4886
4887
4888 /* Check if a derived type t2 is an extension of (or equal to) a type t1.  */
4889
4890 bool
4891 gfc_type_is_extension_of (gfc_symbol *t1, gfc_symbol *t2)
4892 {
4893   while (!gfc_compare_derived_types (t1, t2) && t2->attr.extension)
4894     t2 = gfc_get_derived_super_type (t2);
4895   return gfc_compare_derived_types (t1, t2);
4896 }
4897
4898
4899 /* Check if two typespecs are type compatible (F03:5.1.1.2):
4900    If ts1 is nonpolymorphic, ts2 must be the same type.
4901    If ts1 is polymorphic (CLASS), ts2 must be an extension of ts1.  */
4902
4903 bool
4904 gfc_type_compatible (gfc_typespec *ts1, gfc_typespec *ts2)
4905 {
4906   bool is_class1 = (ts1->type == BT_CLASS);
4907   bool is_class2 = (ts2->type == BT_CLASS);
4908   bool is_derived1 = (ts1->type == BT_DERIVED);
4909   bool is_derived2 = (ts2->type == BT_DERIVED);
4910
4911   if (is_class1
4912       && ts1->u.derived->components
4913       && ts1->u.derived->components->ts.u.derived->attr.unlimited_polymorphic)
4914     return 1;
4915
4916   if (!is_derived1 && !is_derived2 && !is_class1 && !is_class2)
4917     return (ts1->type == ts2->type);
4918
4919   if (is_derived1 && is_derived2)
4920     return gfc_compare_derived_types (ts1->u.derived, ts2->u.derived);
4921
4922   if (is_class1 && is_derived2)
4923     return gfc_type_is_extension_of (ts1->u.derived->components->ts.u.derived,
4924                                      ts2->u.derived);
4925   else if (is_class1 && is_class2)
4926     return gfc_type_is_extension_of (ts1->u.derived->components->ts.u.derived,
4927                                      ts2->u.derived->components->ts.u.derived);
4928   else
4929     return 0;
4930 }
4931
4932
4933 /* Find the parent-namespace of the current function.  If we're inside
4934    BLOCK constructs, it may not be the current one.  */
4935
4936 gfc_namespace*
4937 gfc_find_proc_namespace (gfc_namespace* ns)
4938 {
4939   while (ns->construct_entities)
4940     {
4941       ns = ns->parent;
4942       gcc_assert (ns);
4943     }
4944
4945   return ns;
4946 }
4947
4948
4949 /* Check if an associate-variable should be translated as an `implicit' pointer
4950    internally (if it is associated to a variable and not an array with
4951    descriptor).  */
4952
4953 bool
4954 gfc_is_associate_pointer (gfc_symbol* sym)
4955 {
4956   if (!sym->assoc)
4957     return false;
4958
4959   if (sym->ts.type == BT_CLASS)
4960     return true;
4961
4962   if (!sym->assoc->variable)
4963     return false;
4964
4965   if (sym->attr.dimension && sym->as->type != AS_EXPLICIT)
4966     return false;
4967
4968   return true;
4969 }
4970
4971
4972 gfc_symbol *
4973 gfc_find_dt_in_generic (gfc_symbol *sym)
4974 {
4975   gfc_interface *intr = NULL;
4976
4977   if (!sym || sym->attr.flavor == FL_DERIVED)
4978     return sym;
4979
4980   if (sym->attr.generic)
4981     for (intr = sym->generic; intr; intr = intr->next)
4982       if (intr->sym->attr.flavor == FL_DERIVED)
4983         break;
4984   return intr ? intr->sym : NULL;
4985 }