gcc/fortran/symbol.c

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