gcc/fortran/symbol.c

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