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