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