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