gcc/fortran/symbol.c

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