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