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       /* Don't escape an interface block.  */
2654       if (ns && !ns->has_import_set
2655           && ns->proc_name && ns->proc_name->attr.if_source == IFSRC_IFBODY)
2656         break;
2657
2658       ns = ns->parent;
2659     }
2660   while (ns != NULL);
2661
2662   *result = NULL;
2663   return 0;
2664 }
2665
2666
2667 /* Same, but returns the symbol instead.  */
2668
2669 int
2670 gfc_find_symbol (const char *name, gfc_namespace *ns, int parent_flag,
2671                  gfc_symbol **result)
2672 {
2673   gfc_symtree *st;
2674   int i;
2675
2676   i = gfc_find_sym_tree (name, ns, parent_flag, &st);
2677
2678   if (st == NULL)
2679     *result = NULL;
2680   else
2681     *result = st->n.sym;
2682
2683   return i;
2684 }
2685
2686
2687 /* Save symbol with the information necessary to back it out.  */
2688
2689 static void
2690 save_symbol_data (gfc_symbol *sym)
2691 {
2692
2693   if (sym->gfc_new || sym->old_symbol != NULL)
2694     return;
2695
2696   sym->old_symbol = XCNEW (gfc_symbol);
2697   *(sym->old_symbol) = *sym;
2698
2699   sym->tlink = changed_syms;
2700   changed_syms = sym;
2701 }
2702
2703
2704 /* Given a name, find a symbol, or create it if it does not exist yet
2705    in the current namespace.  If the symbol is found we make sure that
2706    it's OK.
2707
2708    The integer return code indicates
2709      0   All OK
2710      1   The symbol name was ambiguous
2711      2   The name meant to be established was already host associated.
2712
2713    So if the return value is nonzero, then an error was issued.  */
2714
2715 int
2716 gfc_get_sym_tree (const char *name, gfc_namespace *ns, gfc_symtree **result,
2717                   bool allow_subroutine)
2718 {
2719   gfc_symtree *st;
2720   gfc_symbol *p;
2721
2722   /* This doesn't usually happen during resolution.  */
2723   if (ns == NULL)
2724     ns = gfc_current_ns;
2725
2726   /* Try to find the symbol in ns.  */
2727   st = gfc_find_symtree (ns->sym_root, name);
2728
2729   if (st == NULL)
2730     {
2731       /* If not there, create a new symbol.  */
2732       p = gfc_new_symbol (name, ns);
2733
2734       /* Add to the list of tentative symbols.  */
2735       p->old_symbol = NULL;
2736       p->tlink = changed_syms;
2737       p->mark = 1;
2738       p->gfc_new = 1;
2739       changed_syms = p;
2740
2741       st = gfc_new_symtree (&ns->sym_root, name);
2742       st->n.sym = p;
2743       p->refs++;
2744
2745     }
2746   else
2747     {
2748       /* Make sure the existing symbol is OK.  Ambiguous
2749          generic interfaces are permitted, as long as the
2750          specific interfaces are different.  */
2751       if (st->ambiguous && !st->n.sym->attr.generic)
2752         {
2753           ambiguous_symbol (name, st);
2754           return 1;
2755         }
2756
2757       p = st->n.sym;
2758       if (p->ns != ns && (!p->attr.function || ns->proc_name != p)
2759           && !(allow_subroutine && p->attr.subroutine)
2760           && !(ns->proc_name && ns->proc_name->attr.if_source == IFSRC_IFBODY
2761           && (ns->has_import_set || p->attr.imported)))
2762         {
2763           /* Symbol is from another namespace.  */
2764           gfc_error ("Symbol '%s' at %C has already been host associated",
2765                      name);
2766           return 2;
2767         }
2768
2769       p->mark = 1;
2770
2771       /* Copy in case this symbol is changed.  */
2772       save_symbol_data (p);
2773     }
2774
2775   *result = st;
2776   return 0;
2777 }
2778
2779
2780 int
2781 gfc_get_symbol (const char *name, gfc_namespace *ns, gfc_symbol **result)
2782 {
2783   gfc_symtree *st;
2784   int i;
2785
2786   i = gfc_get_sym_tree (name, ns, &st, false);
2787   if (i != 0)
2788     return i;
2789
2790   if (st)
2791     *result = st->n.sym;
2792   else
2793     *result = NULL;
2794   return i;
2795 }
2796
2797
2798 /* Subroutine that searches for a symbol, creating it if it doesn't
2799    exist, but tries to host-associate the symbol if possible.  */
2800
2801 int
2802 gfc_get_ha_sym_tree (const char *name, gfc_symtree **result)
2803 {
2804   gfc_symtree *st;
2805   int i;
2806
2807   i = gfc_find_sym_tree (name, gfc_current_ns, 0, &st);
2808
2809   if (st != NULL)
2810     {
2811       save_symbol_data (st->n.sym);
2812       *result = st;
2813       return i;
2814     }
2815
2816   i = gfc_find_sym_tree (name, gfc_current_ns, 1, &st);
2817   if (i)
2818     return i;
2819
2820   if (st != NULL)
2821     {
2822       *result = st;
2823       return 0;
2824     }
2825
2826   return gfc_get_sym_tree (name, gfc_current_ns, result, false);
2827 }
2828
2829
2830 int
2831 gfc_get_ha_symbol (const char *name, gfc_symbol **result)
2832 {
2833   int i;
2834   gfc_symtree *st;
2835
2836   i = gfc_get_ha_sym_tree (name, &st);
2837
2838   if (st)
2839     *result = st->n.sym;
2840   else
2841     *result = NULL;
2842
2843   return i;
2844 }
2845
2846 /* Undoes all the changes made to symbols in the current statement.
2847    This subroutine is made simpler due to the fact that attributes are
2848    never removed once added.  */
2849
2850 void
2851 gfc_undo_symbols (void)
2852 {
2853   gfc_symbol *p, *q, *old;
2854   tentative_tbp *tbp, *tbq;
2855
2856   for (p = changed_syms; p; p = q)
2857     {
2858       q = p->tlink;
2859
2860       if (p->gfc_new)
2861         {
2862           /* Symbol was new.  */
2863           if (p->attr.in_common && p->common_block && p->common_block->head)
2864             {
2865               /* If the symbol was added to any common block, it
2866                  needs to be removed to stop the resolver looking
2867                  for a (possibly) dead symbol.  */
2868
2869               if (p->common_block->head == p)
2870                 p->common_block->head = p->common_next;
2871               else
2872                 {
2873                   gfc_symbol *cparent, *csym;
2874
2875                   cparent = p->common_block->head;
2876                   csym = cparent->common_next;
2877
2878                   while (csym != p)
2879                     {
2880                       cparent = csym;
2881                       csym = csym->common_next;
2882                     }
2883
2884                   gcc_assert(cparent->common_next == p);
2885
2886                   cparent->common_next = csym->common_next;
2887                 }
2888             }
2889
2890           /* The derived type is saved in the symtree with the first
2891              letter capitalized; the all lower-case version to the
2892              derived type contains its associated generic function.  */
2893           if (p->attr.flavor == FL_DERIVED)
2894             gfc_delete_symtree (&p->ns->sym_root, gfc_get_string ("%c%s",
2895                         (char) TOUPPER ((unsigned char) p->name[0]),
2896                         &p->name[1]));
2897           else
2898             gfc_delete_symtree (&p->ns->sym_root, p->name);
2899
2900           gfc_release_symbol (p);
2901           continue;
2902         }
2903
2904       /* Restore previous state of symbol.  Just copy simple stuff.  */
2905       p->mark = 0;
2906       old = p->old_symbol;
2907
2908       p->ts.type = old->ts.type;
2909       p->ts.kind = old->ts.kind;
2910
2911       p->attr = old->attr;
2912
2913       if (p->value != old->value)
2914         {
2915           gfc_free_expr (old->value);
2916           p->value = NULL;
2917         }
2918
2919       if (p->as != old->as)
2920         {
2921           if (p->as)
2922             gfc_free_array_spec (p->as);
2923           p->as = old->as;
2924         }
2925
2926       p->generic = old->generic;
2927       p->component_access = old->component_access;
2928
2929       if (p->namelist != NULL && old->namelist == NULL)
2930         {
2931           gfc_free_namelist (p->namelist);
2932           p->namelist = NULL;
2933         }
2934       else
2935         {
2936           if (p->namelist_tail != old->namelist_tail)
2937             {
2938               gfc_free_namelist (old->namelist_tail);
2939               old->namelist_tail->next = NULL;
2940             }
2941         }
2942
2943       p->namelist_tail = old->namelist_tail;
2944
2945       if (p->formal != old->formal)
2946         {
2947           gfc_free_formal_arglist (p->formal);
2948           p->formal = old->formal;
2949         }
2950
2951       free (p->old_symbol);
2952       p->old_symbol = NULL;
2953       p->tlink = NULL;
2954     }
2955
2956   changed_syms = NULL;
2957
2958   for (tbp = tentative_tbp_list; tbp; tbp = tbq)
2959     {
2960       tbq = tbp->next;
2961       /* Procedure is already marked `error' by default.  */
2962       free (tbp);
2963     }
2964   tentative_tbp_list = NULL;
2965 }
2966
2967
2968 /* Free sym->old_symbol. sym->old_symbol is mostly a shallow copy of sym; the
2969    components of old_symbol that might need deallocation are the "allocatables"
2970    that are restored in gfc_undo_symbols(), with two exceptions: namelist and
2971    namelist_tail.  In case these differ between old_symbol and sym, it's just
2972    because sym->namelist has gotten a few more items.  */
2973
2974 static void
2975 free_old_symbol (gfc_symbol *sym)
2976 {
2977
2978   if (sym->old_symbol == NULL)
2979     return;
2980
2981   if (sym->old_symbol->as != sym->as)
2982     gfc_free_array_spec (sym->old_symbol->as);
2983
2984   if (sym->old_symbol->value != sym->value)
2985     gfc_free_expr (sym->old_symbol->value);
2986
2987   if (sym->old_symbol->formal != sym->formal)
2988     gfc_free_formal_arglist (sym->old_symbol->formal);
2989
2990   free (sym->old_symbol);
2991   sym->old_symbol = NULL;
2992 }
2993
2994
2995 /* Makes the changes made in the current statement permanent-- gets
2996    rid of undo information.  */
2997
2998 void
2999 gfc_commit_symbols (void)
3000 {
3001   gfc_symbol *p, *q;
3002   tentative_tbp *tbp, *tbq;
3003
3004   for (p = changed_syms; p; p = q)
3005     {
3006       q = p->tlink;
3007       p->tlink = NULL;
3008       p->mark = 0;
3009       p->gfc_new = 0;
3010       free_old_symbol (p);
3011     }
3012   changed_syms = NULL;
3013
3014   for (tbp = tentative_tbp_list; tbp; tbp = tbq)
3015     {
3016       tbq = tbp->next;
3017       tbp->proc->error = 0;
3018       free (tbp);
3019     }
3020   tentative_tbp_list = NULL;
3021 }
3022
3023
3024 /* Makes the changes made in one symbol permanent -- gets rid of undo
3025    information.  */
3026
3027 void
3028 gfc_commit_symbol (gfc_symbol *sym)
3029 {
3030   gfc_symbol *p;
3031
3032   if (changed_syms == sym)
3033     changed_syms = sym->tlink;
3034   else
3035     {
3036       for (p = changed_syms; p; p = p->tlink)
3037         if (p->tlink == sym)
3038           {
3039             p->tlink = sym->tlink;
3040             break;
3041           }
3042     }
3043
3044   sym->tlink = NULL;
3045   sym->mark = 0;
3046   sym->gfc_new = 0;
3047
3048   free_old_symbol (sym);
3049 }
3050
3051
3052 /* Recursively free trees containing type-bound procedures.  */
3053
3054 static void
3055 free_tb_tree (gfc_symtree *t)
3056 {
3057   if (t == NULL)
3058     return;
3059
3060   free_tb_tree (t->left);
3061   free_tb_tree (t->right);
3062
3063   /* TODO: Free type-bound procedure structs themselves; probably needs some
3064      sort of ref-counting mechanism.  */
3065
3066   free (t);
3067 }
3068
3069
3070 /* Recursive function that deletes an entire tree and all the common
3071    head structures it points to.  */
3072
3073 static void
3074 free_common_tree (gfc_symtree * common_tree)
3075 {
3076   if (common_tree == NULL)
3077     return;
3078
3079   free_common_tree (common_tree->left);
3080   free_common_tree (common_tree->right);
3081
3082   free (common_tree);
3083 }
3084
3085
3086 /* Recursive function that deletes an entire tree and all the user
3087    operator nodes that it contains.  */
3088
3089 static void
3090 free_uop_tree (gfc_symtree *uop_tree)
3091 {
3092   if (uop_tree == NULL)
3093     return;
3094
3095   free_uop_tree (uop_tree->left);
3096   free_uop_tree (uop_tree->right);
3097
3098   gfc_free_interface (uop_tree->n.uop->op);
3099   free (uop_tree->n.uop);
3100   free (uop_tree);
3101 }
3102
3103
3104 /* Recursive function that deletes an entire tree and all the symbols
3105    that it contains.  */
3106
3107 static void
3108 free_sym_tree (gfc_symtree *sym_tree)
3109 {
3110   if (sym_tree == NULL)
3111     return;
3112
3113   free_sym_tree (sym_tree->left);
3114   free_sym_tree (sym_tree->right);
3115
3116   gfc_release_symbol (sym_tree->n.sym);
3117   free (sym_tree);
3118 }
3119
3120
3121 /* Free the derived type list.  */
3122
3123 void
3124 gfc_free_dt_list (void)
3125 {
3126   gfc_dt_list *dt, *n;
3127
3128   for (dt = gfc_derived_types; dt; dt = n)
3129     {
3130       n = dt->next;
3131       free (dt);
3132     }
3133
3134   gfc_derived_types = NULL;
3135 }
3136
3137
3138 /* Free the gfc_equiv_info's.  */
3139
3140 static void
3141 gfc_free_equiv_infos (gfc_equiv_info *s)
3142 {
3143   if (s == NULL)
3144     return;
3145   gfc_free_equiv_infos (s->next);
3146   free (s);
3147 }
3148
3149
3150 /* Free the gfc_equiv_lists.  */
3151
3152 static void
3153 gfc_free_equiv_lists (gfc_equiv_list *l)
3154 {
3155   if (l == NULL)
3156     return;
3157   gfc_free_equiv_lists (l->next);
3158   gfc_free_equiv_infos (l->equiv);
3159   free (l);
3160 }
3161
3162
3163 /* Free a finalizer procedure list.  */
3164
3165 void
3166 gfc_free_finalizer (gfc_finalizer* el)
3167 {
3168   if (el)
3169     {
3170       gfc_release_symbol (el->proc_sym);
3171       free (el);
3172     }
3173 }
3174
3175 static void
3176 gfc_free_finalizer_list (gfc_finalizer* list)
3177 {
3178   while (list)
3179     {
3180       gfc_finalizer* current = list;
3181       list = list->next;
3182       gfc_free_finalizer (current);
3183     }
3184 }
3185
3186
3187 /* Create a new gfc_charlen structure and add it to a namespace.
3188    If 'old_cl' is given, the newly created charlen will be a copy of it.  */
3189
3190 gfc_charlen*
3191 gfc_new_charlen (gfc_namespace *ns, gfc_charlen *old_cl)
3192 {
3193   gfc_charlen *cl;
3194   cl = gfc_get_charlen ();
3195
3196   /* Copy old_cl.  */
3197   if (old_cl)
3198     {
3199       /* Put into namespace, but don't allow reject_statement
3200          to free it if old_cl is given.  */
3201       gfc_charlen **prev = &ns->cl_list;
3202       cl->next = ns->old_cl_list;
3203       while (*prev != ns->old_cl_list)
3204         prev = &(*prev)->next;
3205       *prev = cl;
3206       ns->old_cl_list = cl;
3207       cl->length = gfc_copy_expr (old_cl->length);
3208       cl->length_from_typespec = old_cl->length_from_typespec;
3209       cl->backend_decl = old_cl->backend_decl;
3210       cl->passed_length = old_cl->passed_length;
3211       cl->resolved = old_cl->resolved;
3212     }
3213   else
3214     {
3215       /* Put into namespace.  */
3216       cl->next = ns->cl_list;
3217       ns->cl_list = cl;
3218     }
3219
3220   return cl;
3221 }
3222
3223
3224 /* Free the charlen list from cl to end (end is not freed).
3225    Free the whole list if end is NULL.  */
3226
3227 void
3228 gfc_free_charlen (gfc_charlen *cl, gfc_charlen *end)
3229 {
3230   gfc_charlen *cl2;
3231
3232   for (; cl != end; cl = cl2)
3233     {
3234       gcc_assert (cl);
3235
3236       cl2 = cl->next;
3237       gfc_free_expr (cl->length);
3238       free (cl);
3239     }
3240 }
3241
3242
3243 /* Free entry list structs.  */
3244
3245 static void
3246 free_entry_list (gfc_entry_list *el)
3247 {
3248   gfc_entry_list *next;
3249
3250   if (el == NULL)
3251     return;
3252
3253   next = el->next;
3254   free (el);
3255   free_entry_list (next);
3256 }
3257
3258
3259 /* Free a namespace structure and everything below it.  Interface
3260    lists associated with intrinsic operators are not freed.  These are
3261    taken care of when a specific name is freed.  */
3262
3263 void
3264 gfc_free_namespace (gfc_namespace *ns)
3265 {
3266   gfc_namespace *p, *q;
3267   int i;
3268
3269   if (ns == NULL)
3270     return;
3271
3272   ns->refs--;
3273   if (ns->refs > 0)
3274     return;
3275   gcc_assert (ns->refs == 0);
3276
3277   gfc_free_statements (ns->code);
3278
3279   free_sym_tree (ns->sym_root);
3280   free_uop_tree (ns->uop_root);
3281   free_common_tree (ns->common_root);
3282   free_tb_tree (ns->tb_sym_root);
3283   free_tb_tree (ns->tb_uop_root);
3284   gfc_free_finalizer_list (ns->finalizers);
3285   gfc_free_charlen (ns->cl_list, NULL);
3286   free_st_labels (ns->st_labels);
3287
3288   free_entry_list (ns->entries);
3289   gfc_free_equiv (ns->equiv);
3290   gfc_free_equiv_lists (ns->equiv_lists);
3291   gfc_free_use_stmts (ns->use_stmts);
3292
3293   for (i = GFC_INTRINSIC_BEGIN; i != GFC_INTRINSIC_END; i++)
3294     gfc_free_interface (ns->op[i]);
3295
3296   gfc_free_data (ns->data);
3297   p = ns->contained;
3298   free (ns);
3299
3300   /* Recursively free any contained namespaces.  */
3301   while (p != NULL)
3302     {
3303       q = p;
3304       p = p->sibling;
3305       gfc_free_namespace (q);
3306     }
3307 }
3308
3309
3310 void
3311 gfc_symbol_init_2 (void)
3312 {
3313
3314   gfc_current_ns = gfc_get_namespace (NULL, 0);
3315 }
3316
3317
3318 void
3319 gfc_symbol_done_2 (void)
3320 {
3321
3322   gfc_free_namespace (gfc_current_ns);
3323   gfc_current_ns = NULL;
3324   gfc_free_dt_list ();
3325 }
3326
3327
3328 /* Count how many nodes a symtree has.  */
3329
3330 static unsigned
3331 count_st_nodes (const gfc_symtree *st)
3332 {
3333   unsigned nodes;
3334   if (!st)
3335     return 0;
3336
3337   nodes = count_st_nodes (st->left);
3338   nodes++;
3339   nodes += count_st_nodes (st->right);
3340
3341   return nodes;
3342 }
3343
3344
3345 /* Convert symtree tree into symtree vector.  */
3346
3347 static unsigned
3348 fill_st_vector (gfc_symtree *st, gfc_symtree **st_vec, unsigned node_cntr)
3349 {
3350   if (!st)
3351     return node_cntr;
3352
3353   node_cntr = fill_st_vector (st->left, st_vec, node_cntr);
3354   st_vec[node_cntr++] = st;
3355   node_cntr = fill_st_vector (st->right, st_vec, node_cntr);
3356
3357   return node_cntr;
3358 }
3359
3360
3361 /* Traverse namespace.  As the functions might modify the symtree, we store the
3362    symtree as a vector and operate on this vector.  Note: We assume that
3363    sym_func or st_func never deletes nodes from the symtree - only adding is
3364    allowed. Additionally, newly added nodes are not traversed.  */
3365
3366 static void
3367 do_traverse_symtree (gfc_symtree *st, void (*st_func) (gfc_symtree *),
3368                      void (*sym_func) (gfc_symbol *))
3369 {
3370   gfc_symtree **st_vec;
3371   unsigned nodes, i, node_cntr;
3372
3373   gcc_assert ((st_func && !sym_func) || (!st_func && sym_func));
3374   nodes = count_st_nodes (st);
3375   st_vec = XALLOCAVEC (gfc_symtree *, nodes);
3376   node_cntr = 0;
3377   fill_st_vector (st, st_vec, node_cntr);
3378
3379   if (sym_func)
3380     {
3381       /* Clear marks.  */
3382       for (i = 0; i < nodes; i++)
3383         st_vec[i]->n.sym->mark = 0;
3384       for (i = 0; i < nodes; i++)
3385         if (!st_vec[i]->n.sym->mark)
3386           {
3387             (*sym_func) (st_vec[i]->n.sym);
3388             st_vec[i]->n.sym->mark = 1;
3389           }
3390      }
3391    else
3392       for (i = 0; i < nodes; i++)
3393         (*st_func) (st_vec[i]);
3394 }
3395
3396
3397 /* Recursively traverse the symtree nodes.  */
3398
3399 void
3400 gfc_traverse_symtree (gfc_symtree *st, void (*st_func) (gfc_symtree *))
3401 {
3402   do_traverse_symtree (st, st_func, NULL);
3403 }
3404
3405
3406 /* Call a given function for all symbols in the namespace.  We take
3407    care that each gfc_symbol node is called exactly once.  */
3408
3409 void
3410 gfc_traverse_ns (gfc_namespace *ns, void (*sym_func) (gfc_symbol *))
3411 {
3412   do_traverse_symtree (ns->sym_root, NULL, sym_func);
3413 }
3414
3415
3416 /* Return TRUE when name is the name of an intrinsic type.  */
3417
3418 bool
3419 gfc_is_intrinsic_typename (const char *name)
3420 {
3421   if (strcmp (name, "integer") == 0
3422       || strcmp (name, "real") == 0
3423       || strcmp (name, "character") == 0
3424       || strcmp (name, "logical") == 0
3425       || strcmp (name, "complex") == 0
3426       || strcmp (name, "doubleprecision") == 0
3427       || strcmp (name, "doublecomplex") == 0)
3428     return true;
3429   else
3430     return false;
3431 }
3432
3433
3434 /* Return TRUE if the symbol is an automatic variable.  */
3435
3436 static bool
3437 gfc_is_var_automatic (gfc_symbol *sym)
3438 {
3439   /* Pointer and allocatable variables are never automatic.  */
3440   if (sym->attr.pointer || sym->attr.allocatable)
3441     return false;
3442   /* Check for arrays with non-constant size.  */
3443   if (sym->attr.dimension && sym->as
3444       && !gfc_is_compile_time_shape (sym->as))
3445     return true;
3446   /* Check for non-constant length character variables.  */
3447   if (sym->ts.type == BT_CHARACTER
3448       && sym->ts.u.cl
3449       && !gfc_is_constant_expr (sym->ts.u.cl->length))
3450     return true;
3451   return false;
3452 }
3453
3454 /* Given a symbol, mark it as SAVEd if it is allowed.  */
3455
3456 static void
3457 save_symbol (gfc_symbol *sym)
3458 {
3459
3460   if (sym->attr.use_assoc)
3461     return;
3462
3463   if (sym->attr.in_common
3464       || sym->attr.dummy
3465       || sym->attr.result
3466       || sym->attr.flavor != FL_VARIABLE)
3467     return;
3468   /* Automatic objects are not saved.  */
3469   if (gfc_is_var_automatic (sym))
3470     return;
3471   gfc_add_save (&sym->attr, SAVE_EXPLICIT, sym->name, &sym->declared_at);
3472 }
3473
3474
3475 /* Mark those symbols which can be SAVEd as such.  */
3476
3477 void
3478 gfc_save_all (gfc_namespace *ns)
3479 {
3480   gfc_traverse_ns (ns, save_symbol);
3481 }
3482
3483
3484 /* Make sure that no changes to symbols are pending.  */
3485
3486 void
3487 gfc_enforce_clean_symbol_state(void)
3488 {
3489   gcc_assert (changed_syms == NULL);
3490 }
3491
3492
3493 /************** Global symbol handling ************/
3494
3495
3496 /* Search a tree for the global symbol.  */
3497
3498 gfc_gsymbol *
3499 gfc_find_gsymbol (gfc_gsymbol *symbol, const char *name)
3500 {
3501   int c;
3502
3503   if (symbol == NULL)
3504     return NULL;
3505
3506   while (symbol)
3507     {
3508       c = strcmp (name, symbol->name);
3509       if (!c)
3510         return symbol;
3511
3512       symbol = (c < 0) ? symbol->left : symbol->right;
3513     }
3514
3515   return NULL;
3516 }
3517
3518
3519 /* Compare two global symbols. Used for managing the BB tree.  */
3520
3521 static int
3522 gsym_compare (void *_s1, void *_s2)
3523 {
3524   gfc_gsymbol *s1, *s2;
3525
3526   s1 = (gfc_gsymbol *) _s1;
3527   s2 = (gfc_gsymbol *) _s2;
3528   return strcmp (s1->name, s2->name);
3529 }
3530
3531
3532 /* Get a global symbol, creating it if it doesn't exist.  */
3533
3534 gfc_gsymbol *
3535 gfc_get_gsymbol (const char *name)
3536 {
3537   gfc_gsymbol *s;
3538
3539   s = gfc_find_gsymbol (gfc_gsym_root, name);
3540   if (s != NULL)
3541     return s;
3542
3543   s = XCNEW (gfc_gsymbol);
3544   s->type = GSYM_UNKNOWN;
3545   s->name = gfc_get_string (name);
3546
3547   gfc_insert_bbt (&gfc_gsym_root, s, gsym_compare);
3548
3549   return s;
3550 }
3551
3552
3553 static gfc_symbol *
3554 get_iso_c_binding_dt (int sym_id)
3555 {
3556   gfc_dt_list *dt_list;
3557
3558   dt_list = gfc_derived_types;
3559
3560   /* Loop through the derived types in the name list, searching for
3561      the desired symbol from iso_c_binding.  Search the parent namespaces
3562      if necessary and requested to (parent_flag).  */
3563   while (dt_list != NULL)
3564     {
3565       if (dt_list->derived->from_intmod != INTMOD_NONE
3566           && dt_list->derived->intmod_sym_id == sym_id)
3567         return dt_list->derived;
3568
3569       dt_list = dt_list->next;
3570     }
3571
3572   return NULL;
3573 }
3574
3575
3576 /* Verifies that the given derived type symbol, derived_sym, is interoperable
3577    with C.  This is necessary for any derived type that is BIND(C) and for
3578    derived types that are parameters to functions that are BIND(C).  All
3579    fields of the derived type are required to be interoperable, and are tested
3580    for such.  If an error occurs, the errors are reported here, allowing for
3581    multiple errors to be handled for a single derived type.  */
3582
3583 gfc_try
3584 verify_bind_c_derived_type (gfc_symbol *derived_sym)
3585 {
3586   gfc_component *curr_comp = NULL;
3587   gfc_try is_c_interop = FAILURE;
3588   gfc_try retval = SUCCESS;
3589
3590   if (derived_sym == NULL)
3591     gfc_internal_error ("verify_bind_c_derived_type(): Given symbol is "
3592                         "unexpectedly NULL");
3593
3594   /* If we've already looked at this derived symbol, do not look at it again
3595      so we don't repeat warnings/errors.  */
3596   if (derived_sym->ts.is_c_interop)
3597     return SUCCESS;
3598
3599   /* The derived type must have the BIND attribute to be interoperable
3600      J3/04-007, Section 15.2.3.  */
3601   if (derived_sym->attr.is_bind_c != 1)
3602     {
3603       derived_sym->ts.is_c_interop = 0;
3604       gfc_error_now ("Derived type '%s' declared at %L must have the BIND "
3605                      "attribute to be C interoperable", derived_sym->name,
3606                      &(derived_sym->declared_at));
3607       retval = FAILURE;
3608     }
3609
3610   curr_comp = derived_sym->components;
3611
3612   /* Fortran 2003 allows an empty derived type.  C99 appears to disallow an
3613      empty struct.  Section 15.2 in Fortran 2003 states:  "The following
3614      subclauses define the conditions under which a Fortran entity is
3615      interoperable.  If a Fortran entity is interoperable, an equivalent
3616      entity may be defined by means of C and the Fortran entity is said
3617      to be interoperable with the C entity.  There does not have to be such
3618      an interoperating C entity."
3619   */
3620   if (curr_comp == NULL)
3621     {
3622       gfc_warning ("Derived type '%s' with BIND(C) attribute at %L is empty, "
3623                    "and may be inaccessible by the C companion processor",
3624                    derived_sym->name, &(derived_sym->declared_at));
3625       derived_sym->ts.is_c_interop = 1;
3626       derived_sym->attr.is_bind_c = 1;
3627       return SUCCESS;
3628     }
3629
3630
3631   /* Initialize the derived type as being C interoperable.
3632      If we find an error in the components, this will be set false.  */
3633   derived_sym->ts.is_c_interop = 1;
3634
3635   /* Loop through the list of components to verify that the kind of
3636      each is a C interoperable type.  */
3637   do
3638     {
3639       /* The components cannot be pointers (fortran sense).
3640          J3/04-007, Section 15.2.3, C1505.      */
3641       if (curr_comp->attr.pointer != 0)
3642         {
3643           gfc_error ("Component '%s' at %L cannot have the "
3644                      "POINTER attribute because it is a member "
3645                      "of the BIND(C) derived type '%s' at %L",
3646                      curr_comp->name, &(curr_comp->loc),
3647                      derived_sym->name, &(derived_sym->declared_at));
3648           retval = FAILURE;
3649         }
3650
3651       if (curr_comp->attr.proc_pointer != 0)
3652         {
3653           gfc_error ("Procedure pointer component '%s' at %L cannot be a member"
3654                      " of the BIND(C) derived type '%s' at %L", curr_comp->name,
3655                      &curr_comp->loc, derived_sym->name,
3656                      &derived_sym->declared_at);
3657           retval = FAILURE;
3658         }
3659
3660       /* The components cannot be allocatable.
3661          J3/04-007, Section 15.2.3, C1505.      */
3662       if (curr_comp->attr.allocatable != 0)
3663         {
3664           gfc_error ("Component '%s' at %L cannot have the "
3665                      "ALLOCATABLE attribute because it is a member "
3666                      "of the BIND(C) derived type '%s' at %L",
3667                      curr_comp->name, &(curr_comp->loc),
3668                      derived_sym->name, &(derived_sym->declared_at));
3669           retval = FAILURE;
3670         }
3671
3672       /* BIND(C) derived types must have interoperable components.  */
3673       if (curr_comp->ts.type == BT_DERIVED
3674           && curr_comp->ts.u.derived->ts.is_iso_c != 1
3675           && curr_comp->ts.u.derived != derived_sym)
3676         {
3677           /* This should be allowed; the draft says a derived-type can not
3678              have type parameters if it is has the BIND attribute.  Type
3679              parameters seem to be for making parameterized derived types.
3680              There's no need to verify the type if it is c_ptr/c_funptr.  */
3681           retval = verify_bind_c_derived_type (curr_comp->ts.u.derived);
3682         }
3683       else
3684         {
3685           /* Grab the typespec for the given component and test the kind.  */
3686           is_c_interop = gfc_verify_c_interop (&(curr_comp->ts));
3687
3688           if (is_c_interop != SUCCESS)
3689             {
3690               /* Report warning and continue since not fatal.  The
3691                  draft does specify a constraint that requires all fields
3692                  to interoperate, but if the user says real(4), etc., it
3693                  may interoperate with *something* in C, but the compiler
3694                  most likely won't know exactly what.  Further, it may not
3695                  interoperate with the same data type(s) in C if the user
3696                  recompiles with different flags (e.g., -m32 and -m64 on
3697                  x86_64 and using integer(4) to claim interop with a
3698                  C_LONG).  */
3699               if (derived_sym->attr.is_bind_c == 1)
3700                 /* If the derived type is bind(c), all fields must be
3701                    interop.  */
3702                 gfc_warning ("Component '%s' in derived type '%s' at %L "
3703                              "may not be C interoperable, even though "
3704                              "derived type '%s' is BIND(C)",
3705                              curr_comp->name, derived_sym->name,
3706                              &(curr_comp->loc), derived_sym->name);
3707               else
3708                 /* If derived type is param to bind(c) routine, or to one
3709                    of the iso_c_binding procs, it must be interoperable, so
3710                    all fields must interop too.  */
3711                 gfc_warning ("Component '%s' in derived type '%s' at %L "
3712                              "may not be C interoperable",
3713                              curr_comp->name, derived_sym->name,
3714                              &(curr_comp->loc));
3715             }
3716         }
3717
3718       curr_comp = curr_comp->next;
3719     } while (curr_comp != NULL);
3720
3721
3722   /* Make sure we don't have conflicts with the attributes.  */
3723   if (derived_sym->attr.access == ACCESS_PRIVATE)
3724     {
3725       gfc_error ("Derived type '%s' at %L cannot be declared with both "
3726                  "PRIVATE and BIND(C) attributes", derived_sym->name,
3727                  &(derived_sym->declared_at));
3728       retval = FAILURE;
3729     }
3730
3731   if (derived_sym->attr.sequence != 0)
3732     {
3733       gfc_error ("Derived type '%s' at %L cannot have the SEQUENCE "
3734                  "attribute because it is BIND(C)", derived_sym->name,
3735                  &(derived_sym->declared_at));
3736       retval = FAILURE;
3737     }
3738
3739   /* Mark the derived type as not being C interoperable if we found an
3740      error.  If there were only warnings, proceed with the assumption
3741      it's interoperable.  */
3742   if (retval == FAILURE)
3743     derived_sym->ts.is_c_interop = 0;
3744
3745   return retval;
3746 }
3747
3748
3749 /* Generate symbols for the named constants c_null_ptr and c_null_funptr.  */
3750
3751 static gfc_try
3752 gen_special_c_interop_ptr (int ptr_id, const char *ptr_name,
3753                            const char *module_name)
3754 {
3755   gfc_symtree *tmp_symtree;
3756   gfc_symbol *tmp_sym;
3757   gfc_constructor *c;
3758
3759   tmp_symtree = gfc_find_symtree (gfc_current_ns->sym_root, ptr_name);
3760
3761   if (tmp_symtree != NULL)
3762     tmp_sym = tmp_symtree->n.sym;
3763   else
3764     {
3765       tmp_sym = NULL;
3766       gfc_internal_error ("gen_special_c_interop_ptr(): Unable to "
3767                           "create symbol for %s", ptr_name);
3768     }
3769
3770   tmp_sym->ts.is_c_interop = 1;
3771   tmp_sym->attr.is_c_interop = 1;
3772   tmp_sym->ts.is_iso_c = 1;
3773   tmp_sym->ts.type = BT_DERIVED;
3774   tmp_sym->attr.flavor = FL_PARAMETER;
3775
3776   /* The c_ptr and c_funptr derived types will provide the
3777      definition for c_null_ptr and c_null_funptr, respectively.  */
3778   if (ptr_id == ISOCBINDING_NULL_PTR)
3779     tmp_sym->ts.u.derived = get_iso_c_binding_dt (ISOCBINDING_PTR);
3780   else
3781     tmp_sym->ts.u.derived = get_iso_c_binding_dt (ISOCBINDING_FUNPTR);
3782   if (tmp_sym->ts.u.derived == NULL)
3783     {
3784       /* This can occur if the user forgot to declare c_ptr or
3785          c_funptr and they're trying to use one of the procedures
3786          that has arg(s) of the missing type.  In this case, a
3787          regular version of the thing should have been put in the
3788          current ns.  */
3789
3790       generate_isocbinding_symbol (module_name, ptr_id == ISOCBINDING_NULL_PTR
3791                                    ? ISOCBINDING_PTR : ISOCBINDING_FUNPTR,
3792                                    (const char *) (ptr_id == ISOCBINDING_NULL_PTR
3793                                    ? "c_ptr"
3794                                    : "c_funptr"));
3795       tmp_sym->ts.u.derived =
3796         get_iso_c_binding_dt (ptr_id == ISOCBINDING_NULL_PTR
3797                               ? ISOCBINDING_PTR : ISOCBINDING_FUNPTR);
3798     }
3799
3800   /* Module name is some mangled version of iso_c_binding.  */
3801   tmp_sym->module = gfc_get_string (module_name);
3802
3803   /* Say it's from the iso_c_binding module.  */
3804   tmp_sym->attr.is_iso_c = 1;
3805
3806   tmp_sym->attr.use_assoc = 1;
3807   tmp_sym->attr.is_bind_c = 1;
3808   /* Since we never generate a call to this symbol, don't set the
3809      binding_label.  */
3810
3811   /* Set the c_address field of c_null_ptr and c_null_funptr to
3812      the value of NULL.  */
3813   tmp_sym->value = gfc_get_expr ();
3814   tmp_sym->value->expr_type = EXPR_STRUCTURE;
3815   tmp_sym->value->ts.type = BT_DERIVED;
3816   tmp_sym->value->ts.u.derived = tmp_sym->ts.u.derived;
3817   gfc_constructor_append_expr (&tmp_sym->value->value.constructor, NULL, NULL);
3818   c = gfc_constructor_first (tmp_sym->value->value.constructor);
3819   c->expr = gfc_get_expr ();
3820   c->expr->expr_type = EXPR_NULL;
3821   c->expr->ts.is_iso_c = 1;
3822
3823   return SUCCESS;
3824 }
3825
3826
3827 /* Add a formal argument, gfc_formal_arglist, to the
3828    end of the given list of arguments.  Set the reference to the
3829    provided symbol, param_sym, in the argument.  */
3830
3831 static void
3832 add_formal_arg (gfc_formal_arglist **head,
3833                 gfc_formal_arglist **tail,
3834                 gfc_formal_arglist *formal_arg,
3835                 gfc_symbol *param_sym)
3836 {
3837   /* Put in list, either as first arg or at the tail (curr arg).  */
3838   if (*head == NULL)
3839     *head = *tail = formal_arg;
3840   else
3841     {
3842       (*tail)->next = formal_arg;
3843       (*tail) = formal_arg;
3844     }
3845
3846   (*tail)->sym = param_sym;
3847   (*tail)->next = NULL;
3848
3849   return;
3850 }
3851
3852
3853 /* Generates a symbol representing the CPTR argument to an
3854    iso_c_binding procedure.  Also, create a gfc_formal_arglist for the
3855    CPTR and add it to the provided argument list.  */
3856
3857 static void
3858 gen_cptr_param (gfc_formal_arglist **head,
3859                 gfc_formal_arglist **tail,
3860                 const char *module_name,
3861                 gfc_namespace *ns, const char *c_ptr_name,
3862                 int iso_c_sym_id)
3863 {
3864   gfc_symbol *param_sym = NULL;
3865   gfc_symbol *c_ptr_sym = NULL;
3866   gfc_symtree *param_symtree = NULL;
3867   gfc_formal_arglist *formal_arg = NULL;
3868   const char *c_ptr_in;
3869   const char *c_ptr_type = NULL;
3870
3871   if (iso_c_sym_id == ISOCBINDING_F_PROCPOINTER)
3872     c_ptr_type = "c_funptr";
3873   else
3874     c_ptr_type = "c_ptr";
3875
3876   if(c_ptr_name == NULL)
3877     c_ptr_in = "gfc_cptr__";
3878   else
3879     c_ptr_in = c_ptr_name;
3880   gfc_get_sym_tree (c_ptr_in, ns, &param_symtree, false);
3881   if (param_symtree != NULL)
3882     param_sym = param_symtree->n.sym;
3883   else
3884     gfc_internal_error ("gen_cptr_param(): Unable to "
3885                         "create symbol for %s", c_ptr_in);
3886
3887   /* Set up the appropriate fields for the new c_ptr param sym.  */
3888   param_sym->refs++;
3889   param_sym->attr.flavor = FL_DERIVED;
3890   param_sym->ts.type = BT_DERIVED;
3891   param_sym->attr.intent = INTENT_IN;
3892   param_sym->attr.dummy = 1;
3893
3894   /* This will pass the ptr to the iso_c routines as a (void *).  */
3895   param_sym->attr.value = 1;
3896   param_sym->attr.use_assoc = 1;
3897
3898   /* Get the symbol for c_ptr or c_funptr, no matter what it's name is
3899      (user renamed).  */
3900   if (iso_c_sym_id == ISOCBINDING_F_PROCPOINTER)
3901     c_ptr_sym = get_iso_c_binding_dt (ISOCBINDING_FUNPTR);
3902   else
3903     c_ptr_sym = get_iso_c_binding_dt (ISOCBINDING_PTR);
3904   if (c_ptr_sym == NULL)
3905     {
3906       /* This can happen if the user did not define c_ptr but they are
3907          trying to use one of the iso_c_binding functions that need it.  */
3908       if (iso_c_sym_id == ISOCBINDING_F_PROCPOINTER)
3909         generate_isocbinding_symbol (module_name, ISOCBINDING_FUNPTR,
3910                                      (const char *)c_ptr_type);
3911       else
3912         generate_isocbinding_symbol (module_name, ISOCBINDING_PTR,
3913                                      (const char *)c_ptr_type);
3914
3915       gfc_get_ha_symbol (c_ptr_type, &(c_ptr_sym));
3916     }
3917
3918   param_sym->ts.u.derived = c_ptr_sym;
3919   param_sym->module = gfc_get_string (module_name);
3920
3921   /* Make new formal arg.  */
3922   formal_arg = gfc_get_formal_arglist ();
3923   /* Add arg to list of formal args (the CPTR arg).  */
3924   add_formal_arg (head, tail, formal_arg, param_sym);
3925
3926   /* Validate changes.  */
3927   gfc_commit_symbol (param_sym);
3928 }
3929
3930
3931 /* Generates a symbol representing the FPTR argument to an
3932    iso_c_binding procedure.  Also, create a gfc_formal_arglist for the
3933    FPTR and add it to the provided argument list.  */
3934
3935 static void
3936 gen_fptr_param (gfc_formal_arglist **head,
3937                 gfc_formal_arglist **tail,
3938                 const char *module_name,
3939                 gfc_namespace *ns, const char *f_ptr_name, int proc)
3940 {
3941   gfc_symbol *param_sym = NULL;
3942   gfc_symtree *param_symtree = NULL;
3943   gfc_formal_arglist *formal_arg = NULL;
3944   const char *f_ptr_out = "gfc_fptr__";
3945
3946   if (f_ptr_name != NULL)
3947     f_ptr_out = f_ptr_name;
3948
3949   gfc_get_sym_tree (f_ptr_out, ns, &param_symtree, false);
3950   if (param_symtree != NULL)
3951     param_sym = param_symtree->n.sym;
3952   else
3953     gfc_internal_error ("generateFPtrParam(): Unable to "
3954                         "create symbol for %s", f_ptr_out);
3955
3956   /* Set up the necessary fields for the fptr output param sym.  */
3957   param_sym->refs++;
3958   if (proc)
3959     param_sym->attr.proc_pointer = 1;
3960   else
3961     param_sym->attr.pointer = 1;
3962   param_sym->attr.dummy = 1;
3963   param_sym->attr.use_assoc = 1;
3964
3965   /* ISO C Binding type to allow any pointer type as actual param.  */
3966   param_sym->ts.type = BT_VOID;
3967   param_sym->module = gfc_get_string (module_name);
3968
3969   /* Make the arg.  */
3970   formal_arg = gfc_get_formal_arglist ();
3971   /* Add arg to list of formal args.  */
3972   add_formal_arg (head, tail, formal_arg, param_sym);
3973
3974   /* Validate changes.  */
3975   gfc_commit_symbol (param_sym);
3976 }
3977
3978
3979 /* Generates a symbol representing the optional SHAPE argument for the
3980    iso_c_binding c_f_pointer() procedure.  Also, create a
3981    gfc_formal_arglist for the SHAPE and add it to the provided
3982    argument list.  */
3983
3984 static void
3985 gen_shape_param (gfc_formal_arglist **head,
3986                  gfc_formal_arglist **tail,
3987                  const char *module_name,
3988                  gfc_namespace *ns, const char *shape_param_name)
3989 {
3990   gfc_symbol *param_sym = NULL;
3991   gfc_symtree *param_symtree = NULL;
3992   gfc_formal_arglist *formal_arg = NULL;
3993   const char *shape_param = "gfc_shape_array__";
3994
3995   if (shape_param_name != NULL)
3996     shape_param = shape_param_name;
3997
3998   gfc_get_sym_tree (shape_param, ns, &param_symtree, false);
3999   if (param_symtree != NULL)
4000     param_sym = param_symtree->n.sym;
4001   else
4002     gfc_internal_error ("generateShapeParam(): Unable to "
4003                         "create symbol for %s", shape_param);
4004
4005   /* Set up the necessary fields for the shape input param sym.  */
4006   param_sym->refs++;
4007   param_sym->attr.dummy = 1;
4008   param_sym->attr.use_assoc = 1;
4009
4010   /* Integer array, rank 1, describing the shape of the object.  Make it's
4011      type BT_VOID initially so we can accept any type/kind combination of
4012      integer.  During gfc_iso_c_sub_interface (resolve.c), we'll make it
4013      of BT_INTEGER type.  */
4014   param_sym->ts.type = BT_VOID;
4015
4016   /* Initialize the kind to default integer.  However, it will be overridden
4017      during resolution to match the kind of the SHAPE parameter given as
4018      the actual argument (to allow for any valid integer kind).  */
4019   param_sym->ts.kind = gfc_default_integer_kind;
4020   param_sym->as = gfc_get_array_spec ();
4021
4022   param_sym->as->rank = 1;
4023   param_sym->as->lower[0] = gfc_get_int_expr (gfc_default_integer_kind,
4024                                               NULL, 1);
4025
4026   /* The extent is unknown until we get it.  The length give us
4027      the rank the incoming pointer.  */
4028   param_sym->as->type = AS_ASSUMED_SHAPE;
4029
4030   /* The arg is also optional; it is required iff the second arg
4031      (fptr) is to an array, otherwise, it's ignored.  */
4032   param_sym->attr.optional = 1;
4033   param_sym->attr.intent = INTENT_IN;
4034   param_sym->attr.dimension = 1;
4035   param_sym->module = gfc_get_string (module_name);
4036
4037   /* Make the arg.  */
4038   formal_arg = gfc_get_formal_arglist ();
4039   /* Add arg to list of formal args.  */
4040   add_formal_arg (head, tail, formal_arg, param_sym);
4041
4042   /* Validate changes.  */
4043   gfc_commit_symbol (param_sym);
4044 }
4045
4046
4047 /* Add a procedure interface to the given symbol (i.e., store a
4048    reference to the list of formal arguments).  */
4049
4050 static void
4051 add_proc_interface (gfc_symbol *sym, ifsrc source,
4052                     gfc_formal_arglist *formal)
4053 {
4054
4055   sym->formal = formal;
4056   sym->attr.if_source = source;
4057 }
4058
4059
4060 /* Copy the formal args from an existing symbol, src, into a new
4061    symbol, dest.  New formal args are created, and the description of
4062    each arg is set according to the existing ones.  This function is
4063    used when creating procedure declaration variables from a procedure
4064    declaration statement (see match_proc_decl()) to create the formal
4065    args based on the args of a given named interface.  */
4066
4067 void
4068 gfc_copy_formal_args (gfc_symbol *dest, gfc_symbol *src)
4069 {
4070   gfc_formal_arglist *head = NULL;
4071   gfc_formal_arglist *tail = NULL;
4072   gfc_formal_arglist *formal_arg = NULL;
4073   gfc_formal_arglist *curr_arg = NULL;
4074   gfc_formal_arglist *formal_prev = NULL;
4075   /* Save current namespace so we can change it for formal args.  */
4076   gfc_namespace *parent_ns = gfc_current_ns;
4077
4078   /* Create a new namespace, which will be the formal ns (namespace
4079      of the formal args).  */
4080   gfc_current_ns = gfc_get_namespace (parent_ns, 0);
4081   gfc_current_ns->proc_name = dest;
4082
4083   for (curr_arg = src->formal; curr_arg; curr_arg = curr_arg->next)
4084     {
4085       formal_arg = gfc_get_formal_arglist ();
4086       gfc_get_symbol (curr_arg->sym->name, gfc_current_ns, &(formal_arg->sym));
4087
4088       /* May need to copy more info for the symbol.  */
4089       formal_arg->sym->attr = curr_arg->sym->attr;
4090       formal_arg->sym->ts = curr_arg->sym->ts;
4091       formal_arg->sym->as = gfc_copy_array_spec (curr_arg->sym->as);
4092       gfc_copy_formal_args (formal_arg->sym, curr_arg->sym);
4093
4094       /* If this isn't the first arg, set up the next ptr.  For the
4095         last arg built, the formal_arg->next will never get set to
4096         anything other than NULL.  */
4097       if (formal_prev != NULL)
4098         formal_prev->next = formal_arg;
4099       else
4100         formal_arg->next = NULL;
4101
4102       formal_prev = formal_arg;
4103
4104       /* Add arg to list of formal args.  */
4105       add_formal_arg (&head, &tail, formal_arg, formal_arg->sym);
4106
4107       /* Validate changes.  */
4108       gfc_commit_symbol (formal_arg->sym);
4109     }
4110
4111   /* Add the interface to the symbol.  */
4112   add_proc_interface (dest, IFSRC_DECL, head);
4113
4114   /* Store the formal namespace information.  */
4115   if (dest->formal != NULL)
4116     /* The current ns should be that for the dest proc.  */
4117     dest->formal_ns = gfc_current_ns;
4118   /* Restore the current namespace to what it was on entry.  */
4119   gfc_current_ns = parent_ns;
4120 }
4121
4122
4123 void
4124 gfc_copy_formal_args_intr (gfc_symbol *dest, gfc_intrinsic_sym *src)
4125 {
4126   gfc_formal_arglist *head = NULL;
4127   gfc_formal_arglist *tail = NULL;
4128   gfc_formal_arglist *formal_arg = NULL;
4129   gfc_intrinsic_arg *curr_arg = NULL;
4130   gfc_formal_arglist *formal_prev = NULL;
4131   /* Save current namespace so we can change it for formal args.  */
4132   gfc_namespace *parent_ns = gfc_current_ns;
4133
4134   /* Create a new namespace, which will be the formal ns (namespace
4135      of the formal args).  */
4136   gfc_current_ns = gfc_get_namespace (parent_ns, 0);
4137   gfc_current_ns->proc_name = dest;
4138
4139   for (curr_arg = src->formal; curr_arg; curr_arg = curr_arg->next)
4140     {
4141       formal_arg = gfc_get_formal_arglist ();
4142       gfc_get_symbol (curr_arg->name, gfc_current_ns, &(formal_arg->sym));
4143
4144       /* May need to copy more info for the symbol.  */
4145       formal_arg->sym->ts = curr_arg->ts;
4146       formal_arg->sym->attr.optional = curr_arg->optional;
4147       formal_arg->sym->attr.value = curr_arg->value;
4148       formal_arg->sym->attr.intent = curr_arg->intent;
4149       formal_arg->sym->attr.flavor = FL_VARIABLE;
4150       formal_arg->sym->attr.dummy = 1;
4151
4152       if (formal_arg->sym->ts.type == BT_CHARACTER)
4153         formal_arg->sym->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
4154
4155       /* If this isn't the first arg, set up the next ptr.  For the
4156         last arg built, the formal_arg->next will never get set to
4157         anything other than NULL.  */
4158       if (formal_prev != NULL)
4159         formal_prev->next = formal_arg;
4160       else
4161         formal_arg->next = NULL;
4162
4163       formal_prev = formal_arg;
4164
4165       /* Add arg to list of formal args.  */
4166       add_formal_arg (&head, &tail, formal_arg, formal_arg->sym);
4167
4168       /* Validate changes.  */
4169       gfc_commit_symbol (formal_arg->sym);
4170     }
4171
4172   /* Add the interface to the symbol.  */
4173   add_proc_interface (dest, IFSRC_DECL, head);
4174
4175   /* Store the formal namespace information.  */
4176   if (dest->formal != NULL)
4177     /* The current ns should be that for the dest proc.  */
4178     dest->formal_ns = gfc_current_ns;
4179   /* Restore the current namespace to what it was on entry.  */
4180   gfc_current_ns = parent_ns;
4181 }
4182
4183
4184 void
4185 gfc_copy_formal_args_ppc (gfc_component *dest, gfc_symbol *src)
4186 {
4187   gfc_formal_arglist *head = NULL;
4188   gfc_formal_arglist *tail = NULL;
4189   gfc_formal_arglist *formal_arg = NULL;
4190   gfc_formal_arglist *curr_arg = NULL;
4191   gfc_formal_arglist *formal_prev = NULL;
4192   /* Save current namespace so we can change it for formal args.  */
4193   gfc_namespace *parent_ns = gfc_current_ns;
4194
4195   /* Create a new namespace, which will be the formal ns (namespace
4196      of the formal args).  */
4197   gfc_current_ns = gfc_get_namespace (parent_ns, 0);
4198   /* TODO: gfc_current_ns->proc_name = dest;*/
4199
4200   for (curr_arg = src->formal; curr_arg; curr_arg = curr_arg->next)
4201     {
4202       formal_arg = gfc_get_formal_arglist ();
4203       gfc_get_symbol (curr_arg->sym->name, gfc_current_ns, &(formal_arg->sym));
4204
4205       /* May need to copy more info for the symbol.  */
4206       formal_arg->sym->attr = curr_arg->sym->attr;
4207       formal_arg->sym->ts = curr_arg->sym->ts;
4208       formal_arg->sym->as = gfc_copy_array_spec (curr_arg->sym->as);
4209       gfc_copy_formal_args (formal_arg->sym, curr_arg->sym);
4210
4211       /* If this isn't the first arg, set up the next ptr.  For the
4212         last arg built, the formal_arg->next will never get set to
4213         anything other than NULL.  */
4214       if (formal_prev != NULL)
4215         formal_prev->next = formal_arg;
4216       else
4217         formal_arg->next = NULL;
4218
4219       formal_prev = formal_arg;
4220
4221       /* Add arg to list of formal args.  */
4222       add_formal_arg (&head, &tail, formal_arg, formal_arg->sym);
4223
4224       /* Validate changes.  */
4225       gfc_commit_symbol (formal_arg->sym);
4226     }
4227
4228   /* Add the interface to the symbol.  */
4229   gfc_free_formal_arglist (dest->formal);
4230   dest->formal = head;
4231   dest->attr.if_source = IFSRC_DECL;
4232
4233   /* Store the formal namespace information.  */
4234   if (dest->formal != NULL)
4235     /* The current ns should be that for the dest proc.  */
4236     dest->formal_ns = gfc_current_ns;
4237   /* Restore the current namespace to what it was on entry.  */
4238   gfc_current_ns = parent_ns;
4239 }
4240
4241
4242 /* Builds the parameter list for the iso_c_binding procedure
4243    c_f_pointer or c_f_procpointer.  The old_sym typically refers to a
4244    generic version of either the c_f_pointer or c_f_procpointer
4245    functions.  The new_proc_sym represents a "resolved" version of the
4246    symbol.  The functions are resolved to match the types of their
4247    parameters; for example, c_f_pointer(cptr, fptr) would resolve to
4248    something similar to c_f_pointer_i4 if the type of data object fptr
4249    pointed to was a default integer.  The actual name of the resolved
4250    procedure symbol is further mangled with the module name, etc., but
4251    the idea holds true.  */
4252
4253 static void
4254 build_formal_args (gfc_symbol *new_proc_sym,
4255                    gfc_symbol *old_sym, int add_optional_arg)
4256 {
4257   gfc_formal_arglist *head = NULL, *tail = NULL;
4258   gfc_namespace *parent_ns = NULL;
4259
4260   parent_ns = gfc_current_ns;
4261   /* Create a new namespace, which will be the formal ns (namespace
4262      of the formal args).  */
4263   gfc_current_ns = gfc_get_namespace(parent_ns, 0);
4264   gfc_current_ns->proc_name = new_proc_sym;
4265
4266   /* Generate the params.  */
4267   if (old_sym->intmod_sym_id == ISOCBINDING_F_PROCPOINTER)
4268     {
4269       gen_cptr_param (&head, &tail, (const char *) new_proc_sym->module,
4270                       gfc_current_ns, "cptr", old_sym->intmod_sym_id);
4271       gen_fptr_param (&head, &tail, (const char *) new_proc_sym->module,
4272                       gfc_current_ns, "fptr", 1);
4273     }
4274   else if (old_sym->intmod_sym_id == ISOCBINDING_F_POINTER)
4275     {
4276       gen_cptr_param (&head, &tail, (const char *) new_proc_sym->module,
4277                       gfc_current_ns, "cptr", old_sym->intmod_sym_id);
4278       gen_fptr_param (&head, &tail, (const char *) new_proc_sym->module,
4279                       gfc_current_ns, "fptr", 0);
4280       /* If we're dealing with c_f_pointer, it has an optional third arg.  */
4281       gen_shape_param (&head, &tail,(const char *) new_proc_sym->module,
4282                        gfc_current_ns, "shape");
4283
4284     }
4285   else if (old_sym->intmod_sym_id == ISOCBINDING_ASSOCIATED)
4286     {
4287       /* c_associated has one required arg and one optional; both
4288          are c_ptrs.  */
4289       gen_cptr_param (&head, &tail, (const char *) new_proc_sym->module,
4290                       gfc_current_ns, "c_ptr_1", ISOCBINDING_ASSOCIATED);
4291       if (add_optional_arg)
4292         {
4293           gen_cptr_param (&head, &tail, (const char *) new_proc_sym->module,
4294                           gfc_current_ns, "c_ptr_2", ISOCBINDING_ASSOCIATED);
4295           /* The last param is optional so mark it as such.  */
4296           tail->sym->attr.optional = 1;
4297         }
4298     }
4299
4300   /* Add the interface (store formal args to new_proc_sym).  */
4301   add_proc_interface (new_proc_sym, IFSRC_DECL, head);
4302
4303   /* Set up the formal_ns pointer to the one created for the
4304      new procedure so it'll get cleaned up during gfc_free_symbol().  */
4305   new_proc_sym->formal_ns = gfc_current_ns;
4306
4307   gfc_current_ns = parent_ns;
4308 }
4309
4310 static int
4311 std_for_isocbinding_symbol (int id)
4312 {
4313   switch (id)
4314     {
4315 #define NAMED_INTCST(a,b,c,d) \
4316       case a:\
4317         return d;
4318 #include "iso-c-binding.def"
4319 #undef NAMED_INTCST
4320
4321 #define NAMED_FUNCTION(a,b,c,d) \
4322       case a:\
4323         return d;
4324 #include "iso-c-binding.def"
4325 #undef NAMED_FUNCTION
4326
4327        default:
4328          return GFC_STD_F2003;
4329     }
4330 }
4331
4332 /* Generate the given set of C interoperable kind objects, or all
4333    interoperable kinds.  This function will only be given kind objects
4334    for valid iso_c_binding defined types because this is verified when
4335    the 'use' statement is parsed.  If the user gives an 'only' clause,
4336    the specific kinds are looked up; if they don't exist, an error is
4337    reported.  If the user does not give an 'only' clause, all
4338    iso_c_binding symbols are generated.  If a list of specific kinds
4339    is given, it must have a NULL in the first empty spot to mark the
4340    end of the list.  */
4341
4342
4343 void
4344 generate_isocbinding_symbol (const char *mod_name, iso_c_binding_symbol s,
4345                              const char *local_name)
4346 {
4347   const char *const name = (local_name && local_name[0]) ? local_name
4348                                              : c_interop_kinds_table[s].name;
4349   gfc_symtree *tmp_symtree = NULL;
4350   gfc_symbol *tmp_sym = NULL;
4351   int index;
4352
4353   if (gfc_notification_std (std_for_isocbinding_symbol (s)) == ERROR)
4354     return;
4355
4356   tmp_symtree = gfc_find_symtree (gfc_current_ns->sym_root, name);
4357
4358   /* Already exists in this scope so don't re-add it. */
4359   if (tmp_symtree != NULL && (tmp_sym = tmp_symtree->n.sym) != NULL
4360       && (!tmp_sym->attr.generic
4361           || (tmp_sym = gfc_find_dt_in_generic (tmp_sym)) != NULL)
4362       && tmp_sym->from_intmod == INTMOD_ISO_C_BINDING)
4363     {
4364       if (tmp_sym->attr.flavor == FL_DERIVED
4365           && !get_iso_c_binding_dt (tmp_sym->intmod_sym_id))
4366         {
4367           gfc_dt_list *dt_list;
4368           dt_list = gfc_get_dt_list ();
4369           dt_list->derived = tmp_sym;
4370           dt_list->next = gfc_derived_types;
4371           gfc_derived_types = dt_list;
4372         }
4373
4374       return;
4375     }
4376
4377   /* Create the sym tree in the current ns.  */
4378   gfc_get_sym_tree (name, gfc_current_ns, &tmp_symtree, false);
4379   if (tmp_symtree)
4380     tmp_sym = tmp_symtree->n.sym;
4381   else
4382     gfc_internal_error ("generate_isocbinding_symbol(): Unable to "
4383                         "create symbol");
4384
4385   /* Say what module this symbol belongs to.  */
4386   tmp_sym->module = gfc_get_string (mod_name);
4387   tmp_sym->from_intmod = INTMOD_ISO_C_BINDING;
4388   tmp_sym->intmod_sym_id = s;
4389
4390   switch (s)
4391     {
4392
4393 #define NAMED_INTCST(a,b,c,d) case a :
4394 #define NAMED_REALCST(a,b,c,d) case a :
4395 #define NAMED_CMPXCST(a,b,c,d) case a :
4396 #define NAMED_LOGCST(a,b,c) case a :
4397 #define NAMED_CHARKNDCST(a,b,c) case a :
4398 #include "iso-c-binding.def"
4399
4400         tmp_sym->value = gfc_get_int_expr (gfc_default_integer_kind, NULL,
4401                                            c_interop_kinds_table[s].value);
4402
4403         /* Initialize an integer constant expression node.  */
4404         tmp_sym->attr.flavor = FL_PARAMETER;
4405         tmp_sym->ts.type = BT_INTEGER;
4406         tmp_sym->ts.kind = gfc_default_integer_kind;
4407
4408         /* Mark this type as a C interoperable one.  */
4409         tmp_sym->ts.is_c_interop = 1;
4410         tmp_sym->ts.is_iso_c = 1;
4411         tmp_sym->value->ts.is_c_interop = 1;
4412         tmp_sym->value->ts.is_iso_c = 1;
4413         tmp_sym->attr.is_c_interop = 1;
4414
4415         /* Tell what f90 type this c interop kind is valid.  */
4416         tmp_sym->ts.f90_type = c_interop_kinds_table[s].f90_type;
4417
4418         /* Say it's from the iso_c_binding module.  */
4419         tmp_sym->attr.is_iso_c = 1;
4420
4421         /* Make it use associated.  */
4422         tmp_sym->attr.use_assoc = 1;
4423         break;
4424
4425
4426 #define NAMED_CHARCST(a,b,c) case a :
4427 #include "iso-c-binding.def"
4428
4429         /* Initialize an integer constant expression node for the
4430            length of the character.  */
4431         tmp_sym->value = gfc_get_character_expr (gfc_default_character_kind,
4432                                                  &gfc_current_locus, NULL, 1);
4433         tmp_sym->value->ts.is_c_interop = 1;
4434         tmp_sym->value->ts.is_iso_c = 1;
4435         tmp_sym->value->value.character.length = 1;
4436         tmp_sym->value->value.character.string[0]
4437           = (gfc_char_t) c_interop_kinds_table[s].value;
4438         tmp_sym->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
4439         tmp_sym->ts.u.cl->length = gfc_get_int_expr (gfc_default_integer_kind,
4440                                                      NULL, 1);
4441
4442         /* May not need this in both attr and ts, but do need in
4443            attr for writing module file.  */
4444         tmp_sym->attr.is_c_interop = 1;
4445
4446         tmp_sym->attr.flavor = FL_PARAMETER;
4447         tmp_sym->ts.type = BT_CHARACTER;
4448
4449         /* Need to set it to the C_CHAR kind.  */
4450         tmp_sym->ts.kind = gfc_default_character_kind;
4451
4452         /* Mark this type as a C interoperable one.  */
4453         tmp_sym->ts.is_c_interop = 1;
4454         tmp_sym->ts.is_iso_c = 1;
4455
4456         /* Tell what f90 type this c interop kind is valid.  */
4457         tmp_sym->ts.f90_type = BT_CHARACTER;
4458
4459         /* Say it's from the iso_c_binding module.  */
4460         tmp_sym->attr.is_iso_c = 1;
4461
4462         /* Make it use associated.  */
4463         tmp_sym->attr.use_assoc = 1;
4464         break;
4465
4466       case ISOCBINDING_PTR:
4467       case ISOCBINDING_FUNPTR:
4468         {
4469           gfc_interface *intr, *head;
4470           gfc_symbol *dt_sym;
4471           const char *hidden_name;
4472           gfc_dt_list **dt_list_ptr = NULL;
4473           gfc_component *tmp_comp = NULL;
4474           char comp_name[(GFC_MAX_SYMBOL_LEN * 2) + 1];
4475
4476           hidden_name = gfc_get_string ("%c%s",
4477                             (char) TOUPPER ((unsigned char) tmp_sym->name[0]),
4478                             &tmp_sym->name[1]);
4479
4480           /* Generate real derived type.  */
4481           tmp_symtree = gfc_find_symtree (gfc_current_ns->sym_root,
4482                                           hidden_name);
4483
4484           if (tmp_symtree != NULL)
4485             gcc_unreachable ();
4486           gfc_get_sym_tree (hidden_name, gfc_current_ns, &tmp_symtree, false);
4487           if (tmp_symtree)
4488             dt_sym = tmp_symtree->n.sym;
4489           else
4490             gcc_unreachable ();
4491
4492           /* Generate an artificial generic function.  */
4493           dt_sym->name = gfc_get_string (tmp_sym->name);
4494           head = tmp_sym->generic;
4495           intr = gfc_get_interface ();
4496           intr->sym = dt_sym;
4497           intr->where = gfc_current_locus;
4498           intr->next = head;
4499           tmp_sym->generic = intr;
4500
4501           if (!tmp_sym->attr.generic
4502               && gfc_add_generic (&tmp_sym->attr, tmp_sym->name, NULL)
4503                  == FAILURE)
4504             return;
4505
4506           if (!tmp_sym->attr.function
4507               && gfc_add_function (&tmp_sym->attr, tmp_sym->name, NULL)
4508                  == FAILURE)
4509             return;
4510
4511           /* Say what module this symbol belongs to.  */
4512           dt_sym->module = gfc_get_string (mod_name);
4513           dt_sym->from_intmod = INTMOD_ISO_C_BINDING;
4514           dt_sym->intmod_sym_id = s;
4515
4516           /* Initialize an integer constant expression node.  */
4517           dt_sym->attr.flavor = FL_DERIVED;
4518           dt_sym->ts.is_c_interop = 1;
4519           dt_sym->attr.is_c_interop = 1;
4520           dt_sym->attr.is_iso_c = 1;
4521           dt_sym->ts.is_iso_c = 1;
4522           dt_sym->ts.type = BT_DERIVED;
4523
4524           /* A derived type must have the bind attribute to be
4525              interoperable (J3/04-007, Section 15.2.3), even though
4526              the binding label is not used.  */
4527           dt_sym->attr.is_bind_c = 1;
4528
4529           dt_sym->attr.referenced = 1;
4530           dt_sym->ts.u.derived = dt_sym;
4531
4532           /* Add the symbol created for the derived type to the current ns.  */
4533           dt_list_ptr = &(gfc_derived_types);
4534           while (*dt_list_ptr != NULL && (*dt_list_ptr)->next != NULL)
4535             dt_list_ptr = &((*dt_list_ptr)->next);
4536
4537           /* There is already at least one derived type in the list, so append
4538              the one we're currently building for c_ptr or c_funptr.  */
4539           if (*dt_list_ptr != NULL)
4540             dt_list_ptr = &((*dt_list_ptr)->next);
4541           (*dt_list_ptr) = gfc_get_dt_list ();
4542           (*dt_list_ptr)->derived = dt_sym;
4543           (*dt_list_ptr)->next = NULL;
4544
4545           /* Set up the component of the derived type, which will be
4546              an integer with kind equal to c_ptr_size.  Mangle the name of
4547              the field for the c_address to prevent the curious user from
4548              trying to access it from Fortran.  */
4549           sprintf (comp_name, "__%s_%s", dt_sym->name, "c_address");
4550           gfc_add_component (dt_sym, comp_name, &tmp_comp);
4551           if (tmp_comp == NULL)
4552           gfc_internal_error ("generate_isocbinding_symbol(): Unable to "
4553                               "create component for c_address");
4554
4555           tmp_comp->ts.type = BT_INTEGER;
4556
4557           /* Set this because the module will need to read/write this field.  */
4558           tmp_comp->ts.f90_type = BT_INTEGER;
4559
4560           /* The kinds for c_ptr and c_funptr are the same.  */
4561           index = get_c_kind ("c_ptr", c_interop_kinds_table);
4562           tmp_comp->ts.kind = c_interop_kinds_table[index].value;
4563
4564           tmp_comp->attr.pointer = 0;
4565           tmp_comp->attr.dimension = 0;
4566
4567           /* Mark the component as C interoperable.  */
4568           tmp_comp->ts.is_c_interop = 1;
4569
4570           /* Make it use associated (iso_c_binding module).  */
4571           dt_sym->attr.use_assoc = 1;
4572         }
4573
4574         break;
4575
4576       case ISOCBINDING_NULL_PTR:
4577       case ISOCBINDING_NULL_FUNPTR:
4578         gen_special_c_interop_ptr (s, name, mod_name);
4579         break;
4580
4581       case ISOCBINDING_F_POINTER:
4582       case ISOCBINDING_ASSOCIATED:
4583       case ISOCBINDING_LOC:
4584       case ISOCBINDING_FUNLOC:
4585       case ISOCBINDING_F_PROCPOINTER:
4586
4587         tmp_sym->attr.proc = PROC_MODULE;
4588
4589         /* Use the procedure's name as it is in the iso_c_binding module for
4590            setting the binding label in case the user renamed the symbol.  */
4591         tmp_sym->binding_label =
4592           gfc_get_string ("%s_%s", mod_name,
4593                           c_interop_kinds_table[s].name);
4594         tmp_sym->attr.is_iso_c = 1;
4595         if (s == ISOCBINDING_F_POINTER || s == ISOCBINDING_F_PROCPOINTER)
4596           tmp_sym->attr.subroutine = 1;
4597         else
4598           {
4599             /* TODO!  This needs to be finished more for the expr of the
4600                function or something!
4601                This may not need to be here, because trying to do c_loc
4602                as an external.  */
4603             if (s == ISOCBINDING_ASSOCIATED)
4604               {
4605                 tmp_sym->attr.function = 1;
4606                 tmp_sym->ts.type = BT_LOGICAL;
4607                 tmp_sym->ts.kind = gfc_default_logical_kind;
4608                 tmp_sym->result = tmp_sym;
4609               }
4610             else
4611               {
4612                /* Here, we're taking the simple approach.  We're defining
4613                   c_loc as an external identifier so the compiler will put
4614                   what we expect on the stack for the address we want the
4615                   C address of.  */
4616                 tmp_sym->ts.type = BT_DERIVED;
4617                 if (s == ISOCBINDING_LOC)
4618                   tmp_sym->ts.u.derived =
4619                     get_iso_c_binding_dt (ISOCBINDING_PTR);
4620                 else
4621                   tmp_sym->ts.u.derived =
4622                     get_iso_c_binding_dt (ISOCBINDING_FUNPTR);
4623
4624                 if (tmp_sym->ts.u.derived == NULL)
4625                   {
4626                     /* Create the necessary derived type so we can continue
4627                        processing the file.  */
4628                     generate_isocbinding_symbol
4629                       (mod_name, s == ISOCBINDING_FUNLOC
4630                                 ? ISOCBINDING_FUNPTR : ISOCBINDING_PTR,
4631                       (const char *)(s == ISOCBINDING_FUNLOC
4632                                 ? "c_funptr" : "c_ptr"));
4633                     tmp_sym->ts.u.derived =
4634                     get_iso_c_binding_dt (s == ISOCBINDING_FUNLOC
4635                                             ? ISOCBINDING_FUNPTR
4636                                             : ISOCBINDING_PTR);
4637                   }
4638
4639                 /* The function result is itself (no result clause).  */
4640                 tmp_sym->result = tmp_sym;
4641                 tmp_sym->attr.external = 1;
4642                 tmp_sym->attr.use_assoc = 0;
4643                 tmp_sym->attr.pure = 1;
4644                 tmp_sym->attr.if_source = IFSRC_UNKNOWN;
4645                 tmp_sym->attr.proc = PROC_UNKNOWN;
4646               }
4647           }
4648
4649         tmp_sym->attr.flavor = FL_PROCEDURE;
4650         tmp_sym->attr.contained = 0;
4651
4652        /* Try using this builder routine, with the new and old symbols
4653           both being the generic iso_c proc sym being created.  This
4654           will create the formal args (and the new namespace for them).
4655           Don't build an arg list for c_loc because we're going to treat
4656           c_loc as an external procedure.  */
4657         if (s != ISOCBINDING_LOC && s != ISOCBINDING_FUNLOC)
4658           /* The 1 says to add any optional args, if applicable.  */
4659           build_formal_args (tmp_sym, tmp_sym, 1);
4660
4661         /* Set this after setting up the symbol, to prevent error messages.  */
4662         tmp_sym->attr.use_assoc = 1;
4663
4664         /* This symbol will not be referenced directly.  It will be
4665            resolved to the implementation for the given f90 kind.  */
4666         tmp_sym->attr.referenced = 0;
4667
4668         break;
4669
4670       default:
4671         gcc_unreachable ();
4672     }
4673   gfc_commit_symbol (tmp_sym);
4674 }
4675
4676
4677 /* Creates a new symbol based off of an old iso_c symbol, with a new
4678    binding label.  This function can be used to create a new,
4679    resolved, version of a procedure symbol for c_f_pointer or
4680    c_f_procpointer that is based on the generic symbols.  A new
4681    parameter list is created for the new symbol using
4682    build_formal_args().  The add_optional_flag specifies whether the
4683    to add the optional SHAPE argument.  The new symbol is
4684    returned.  */
4685
4686 gfc_symbol *
4687 get_iso_c_sym (gfc_symbol *old_sym, char *new_name,
4688                const char *new_binding_label, int add_optional_arg)
4689 {
4690   gfc_symtree *new_symtree = NULL;
4691
4692   /* See if we have a symbol by that name already available, looking
4693      through any parent namespaces.  */
4694   gfc_find_sym_tree (new_name, gfc_current_ns, 1, &new_symtree);
4695   if (new_symtree != NULL)
4696     /* Return the existing symbol.  */
4697     return new_symtree->n.sym;
4698
4699   /* Create the symtree/symbol, with attempted host association.  */
4700   gfc_get_ha_sym_tree (new_name, &new_symtree);
4701   if (new_symtree == NULL)
4702     gfc_internal_error ("get_iso_c_sym(): Unable to create "
4703                         "symtree for '%s'", new_name);
4704
4705   /* Now fill in the fields of the resolved symbol with the old sym.  */
4706   new_symtree->n.sym->binding_label = new_binding_label;
4707   new_symtree->n.sym->attr = old_sym->attr;
4708   new_symtree->n.sym->ts = old_sym->ts;
4709   new_symtree->n.sym->module = gfc_get_string (old_sym->module);
4710   new_symtree->n.sym->from_intmod = old_sym->from_intmod;
4711   new_symtree->n.sym->intmod_sym_id = old_sym->intmod_sym_id;
4712   if (old_sym->attr.function)
4713     new_symtree->n.sym->result = new_symtree->n.sym;
4714   /* Build the formal arg list.  */
4715   build_formal_args (new_symtree->n.sym, old_sym, add_optional_arg);
4716
4717   gfc_commit_symbol (new_symtree->n.sym);
4718
4719   return new_symtree->n.sym;
4720 }
4721
4722
4723 /* Check that a symbol is already typed.  If strict is not set, an untyped
4724    symbol is acceptable for non-standard-conforming mode.  */
4725
4726 gfc_try
4727 gfc_check_symbol_typed (gfc_symbol* sym, gfc_namespace* ns,
4728                         bool strict, locus where)
4729 {
4730   gcc_assert (sym);
4731
4732   if (gfc_matching_prefix)
4733     return SUCCESS;
4734
4735   /* Check for the type and try to give it an implicit one.  */
4736   if (sym->ts.type == BT_UNKNOWN
4737       && gfc_set_default_type (sym, 0, ns) == FAILURE)
4738     {
4739       if (strict)
4740         {
4741           gfc_error ("Symbol '%s' is used before it is typed at %L",
4742                      sym->name, &where);
4743           return FAILURE;
4744         }
4745
4746       if (gfc_notify_std (GFC_STD_GNU,
4747                           "Extension: Symbol '%s' is used before"
4748                           " it is typed at %L", sym->name, &where) == FAILURE)
4749         return FAILURE;
4750     }
4751
4752   /* Everything is ok.  */
4753   return SUCCESS;
4754 }
4755
4756
4757 /* Construct a typebound-procedure structure.  Those are stored in a tentative
4758    list and marked `error' until symbols are committed.  */
4759
4760 gfc_typebound_proc*
4761 gfc_get_typebound_proc (gfc_typebound_proc *tb0)
4762 {
4763   gfc_typebound_proc *result;
4764   tentative_tbp *list_node;
4765
4766   result = XCNEW (gfc_typebound_proc);
4767   if (tb0)
4768     *result = *tb0;
4769   result->error = 1;
4770
4771   list_node = XCNEW (tentative_tbp);
4772   list_node->next = tentative_tbp_list;
4773   list_node->proc = result;
4774   tentative_tbp_list = list_node;
4775
4776   return result;
4777 }
4778
4779
4780 /* Get the super-type of a given derived type.  */
4781
4782 gfc_symbol*
4783 gfc_get_derived_super_type (gfc_symbol* derived)
4784 {
4785   if (derived && derived->attr.generic)
4786     derived = gfc_find_dt_in_generic (derived);
4787
4788   if (!derived->attr.extension)
4789     return NULL;
4790
4791   gcc_assert (derived->components);
4792   gcc_assert (derived->components->ts.type == BT_DERIVED);
4793   gcc_assert (derived->components->ts.u.derived);
4794
4795   if (derived->components->ts.u.derived->attr.generic)
4796     return gfc_find_dt_in_generic (derived->components->ts.u.derived);
4797
4798   return derived->components->ts.u.derived;
4799 }
4800
4801
4802 /* Get the ultimate super-type of a given derived type.  */
4803
4804 gfc_symbol*
4805 gfc_get_ultimate_derived_super_type (gfc_symbol* derived)
4806 {
4807   if (!derived->attr.extension)
4808     return NULL;
4809
4810   derived = gfc_get_derived_super_type (derived);
4811
4812   if (derived->attr.extension)
4813     return gfc_get_ultimate_derived_super_type (derived);
4814   else
4815     return derived;
4816 }
4817
4818
4819 /* Check if a derived type t2 is an extension of (or equal to) a type t1.  */
4820
4821 bool
4822 gfc_type_is_extension_of (gfc_symbol *t1, gfc_symbol *t2)
4823 {
4824   while (!gfc_compare_derived_types (t1, t2) && t2->attr.extension)
4825     t2 = gfc_get_derived_super_type (t2);
4826   return gfc_compare_derived_types (t1, t2);
4827 }
4828
4829
4830 /* Check if two typespecs are type compatible (F03:5.1.1.2):
4831    If ts1 is nonpolymorphic, ts2 must be the same type.
4832    If ts1 is polymorphic (CLASS), ts2 must be an extension of ts1.  */
4833
4834 bool
4835 gfc_type_compatible (gfc_typespec *ts1, gfc_typespec *ts2)
4836 {
4837   bool is_class1 = (ts1->type == BT_CLASS);
4838   bool is_class2 = (ts2->type == BT_CLASS);
4839   bool is_derived1 = (ts1->type == BT_DERIVED);
4840   bool is_derived2 = (ts2->type == BT_DERIVED);
4841
4842   if (!is_derived1 && !is_derived2 && !is_class1 && !is_class2)
4843     return (ts1->type == ts2->type);
4844
4845   if (is_derived1 && is_derived2)
4846     return gfc_compare_derived_types (ts1->u.derived, ts2->u.derived);
4847
4848   if (is_class1 && is_derived2)
4849     return gfc_type_is_extension_of (ts1->u.derived->components->ts.u.derived,
4850                                      ts2->u.derived);
4851   else if (is_class1 && is_class2)
4852     return gfc_type_is_extension_of (ts1->u.derived->components->ts.u.derived,
4853                                      ts2->u.derived->components->ts.u.derived);
4854   else
4855     return 0;
4856 }
4857
4858
4859 /* Find the parent-namespace of the current function.  If we're inside
4860    BLOCK constructs, it may not be the current one.  */
4861
4862 gfc_namespace*
4863 gfc_find_proc_namespace (gfc_namespace* ns)
4864 {
4865   while (ns->construct_entities)
4866     {
4867       ns = ns->parent;
4868       gcc_assert (ns);
4869     }
4870
4871   return ns;
4872 }
4873
4874
4875 /* Check if an associate-variable should be translated as an `implicit' pointer
4876    internally (if it is associated to a variable and not an array with
4877    descriptor).  */
4878
4879 bool
4880 gfc_is_associate_pointer (gfc_symbol* sym)
4881 {
4882   if (!sym->assoc)
4883     return false;
4884
4885   if (!sym->assoc->variable)
4886     return false;
4887
4888   if (sym->attr.dimension && sym->as->type != AS_EXPLICIT)
4889     return false;
4890
4891   return true;
4892 }
4893
4894
4895 gfc_symbol *
4896 gfc_find_dt_in_generic (gfc_symbol *sym)
4897 {
4898   gfc_interface *intr = NULL;
4899
4900   if (!sym || sym->attr.flavor == FL_DERIVED)
4901     return sym;
4902
4903   if (sym->attr.generic)
4904     for (intr = (sym ? sym->generic : NULL); intr; intr = intr->next)
4905       if (intr->sym->attr.flavor == FL_DERIVED)
4906         break;
4907   return intr ? intr->sym : NULL;
4908 }