gcc/fortran/symbol.c

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