gcc/fortran/symbol.c

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