gcc/fortran/resolve.c

   1 /* Perform type resolution on the various structures.
   2    Copyright (C) 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010
   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 #include "config.h"
  23 #include "system.h"
  24 #include "flags.h"
  25 #include "gfortran.h"
  26 #include "obstack.h"
  27 #include "bitmap.h"
  28 #include "arith.h"  /* For gfc_compare_expr().  */
  29 #include "dependency.h"
  30 #include "data.h"
  31 #include "target-memory.h" /* for gfc_simplify_transfer */
  32 #include "constructor.h"
  33
  34 /* Types used in equivalence statements.  */
  35
  36 typedef enum seq_type
  37 {
  38   SEQ_NONDEFAULT, SEQ_NUMERIC, SEQ_CHARACTER, SEQ_MIXED
  39 }
  40 seq_type;
  41
  42 /* Stack to keep track of the nesting of blocks as we move through the
  43    code.  See resolve_branch() and resolve_code().  */
  44
  45 typedef struct code_stack
  46 {
  47   struct gfc_code *head, *current;
  48   struct code_stack *prev;
  49
  50   /* This bitmap keeps track of the targets valid for a branch from
  51      inside this block except for END {IF|SELECT}s of enclosing
  52      blocks.  */
  53   bitmap reachable_labels;
  54 }
  55 code_stack;
  56
  57 static code_stack *cs_base = NULL;
  58
  59
  60 /* Nonzero if we're inside a FORALL block.  */
  61
  62 static int forall_flag;
  63
  64 /* Nonzero if we're inside a OpenMP WORKSHARE or PARALLEL WORKSHARE block.  */
  65
  66 static int omp_workshare_flag;
  67
  68 /* Nonzero if we are processing a formal arglist. The corresponding function
  69    resets the flag each time that it is read.  */
  70 static int formal_arg_flag = 0;
  71
  72 /* True if we are resolving a specification expression.  */
  73 static int specification_expr = 0;
  74
  75 /* The id of the last entry seen.  */
  76 static int current_entry_id;
  77
  78 /* We use bitmaps to determine if a branch target is valid.  */
  79 static bitmap_obstack labels_obstack;
  80
  81 /* True when simplifying a EXPR_VARIABLE argument to an inquiry function.  */
  82 static bool inquiry_argument = false;
  83
  84 int
  85 gfc_is_formal_arg (void)
  86 {
  87   return formal_arg_flag;
  88 }
  89
  90 /* Is the symbol host associated?  */
  91 static bool
  92 is_sym_host_assoc (gfc_symbol *sym, gfc_namespace *ns)
  93 {
  94   for (ns = ns->parent; ns; ns = ns->parent)
  95     {
  96       if (sym->ns == ns)
  97         return true;
  98     }
  99
 100   return false;
 101 }
 102
 103 /* Ensure a typespec used is valid; for instance, TYPE(t) is invalid if t is
 104    an ABSTRACT derived-type.  If where is not NULL, an error message with that
 105    locus is printed, optionally using name.  */
 106
 107 static gfc_try
 108 resolve_typespec_used (gfc_typespec* ts, locus* where, const char* name)
 109 {
 110   if (ts->type == BT_DERIVED && ts->u.derived->attr.abstract)
 111     {
 112       if (where)
 113         {
 114           if (name)
 115             gfc_error ("'%s' at %L is of the ABSTRACT type '%s'",
 116                        name, where, ts->u.derived->name);
 117           else
 118             gfc_error ("ABSTRACT type '%s' used at %L",
 119                        ts->u.derived->name, where);
 120         }
 121
 122       return FAILURE;
 123     }
 124
 125   return SUCCESS;
 126 }
 127
 128
 129 static void resolve_symbol (gfc_symbol *sym);
 130 static gfc_try resolve_intrinsic (gfc_symbol *sym, locus *loc);
 131
 132
 133 /* Resolve the interface for a PROCEDURE declaration or procedure pointer.  */
 134
 135 static gfc_try
 136 resolve_procedure_interface (gfc_symbol *sym)
 137 {
 138   if (sym->ts.interface == sym)
 139     {
 140       gfc_error ("PROCEDURE '%s' at %L may not be used as its own interface",
 141                  sym->name, &sym->declared_at);
 142       return FAILURE;
 143     }
 144   if (sym->ts.interface->attr.procedure)
 145     {
 146       gfc_error ("Interface '%s', used by procedure '%s' at %L, is declared "
 147                  "in a later PROCEDURE statement", sym->ts.interface->name,
 148                  sym->name, &sym->declared_at);
 149       return FAILURE;
 150     }
 151
 152   /* Get the attributes from the interface (now resolved).  */
 153   if (sym->ts.interface->attr.if_source || sym->ts.interface->attr.intrinsic)
 154     {
 155       gfc_symbol *ifc = sym->ts.interface;
 156       resolve_symbol (ifc);
 157
 158       if (ifc->attr.intrinsic)
 159         resolve_intrinsic (ifc, &ifc->declared_at);
 160
 161       if (ifc->result)
 162         sym->ts = ifc->result->ts;
 163       else
 164         sym->ts = ifc->ts;
 165       sym->ts.interface = ifc;
 166       sym->attr.function = ifc->attr.function;
 167       sym->attr.subroutine = ifc->attr.subroutine;
 168       gfc_copy_formal_args (sym, ifc);
 169
 170       sym->attr.allocatable = ifc->attr.allocatable;
 171       sym->attr.pointer = ifc->attr.pointer;
 172       sym->attr.pure = ifc->attr.pure;
 173       sym->attr.elemental = ifc->attr.elemental;
 174       sym->attr.dimension = ifc->attr.dimension;
 175       sym->attr.contiguous = ifc->attr.contiguous;
 176       sym->attr.recursive = ifc->attr.recursive;
 177       sym->attr.always_explicit = ifc->attr.always_explicit;
 178       sym->attr.ext_attr |= ifc->attr.ext_attr;
 179       /* Copy array spec.  */
 180       sym->as = gfc_copy_array_spec (ifc->as);
 181       if (sym->as)
 182         {
 183           int i;
 184           for (i = 0; i < sym->as->rank; i++)
 185             {
 186               gfc_expr_replace_symbols (sym->as->lower[i], sym);
 187               gfc_expr_replace_symbols (sym->as->upper[i], sym);
 188             }
 189         }
 190       /* Copy char length.  */
 191       if (ifc->ts.type == BT_CHARACTER && ifc->ts.u.cl)
 192         {
 193           sym->ts.u.cl = gfc_new_charlen (sym->ns, ifc->ts.u.cl);
 194           gfc_expr_replace_symbols (sym->ts.u.cl->length, sym);
 195           if (sym->ts.u.cl->length && !sym->ts.u.cl->resolved
 196               && gfc_resolve_expr (sym->ts.u.cl->length) == FAILURE)
 197             return FAILURE;
 198         }
 199     }
 200   else if (sym->ts.interface->name[0] != '\0')
 201     {
 202       gfc_error ("Interface '%s' of procedure '%s' at %L must be explicit",
 203                  sym->ts.interface->name, sym->name, &sym->declared_at);
 204       return FAILURE;
 205     }
 206
 207   return SUCCESS;
 208 }
 209
 210
 211 /* Resolve types of formal argument lists.  These have to be done early so that
 212    the formal argument lists of module procedures can be copied to the
 213    containing module before the individual procedures are resolved
 214    individually.  We also resolve argument lists of procedures in interface
 215    blocks because they are self-contained scoping units.
 216
 217    Since a dummy argument cannot be a non-dummy procedure, the only
 218    resort left for untyped names are the IMPLICIT types.  */
 219
 220 static void
 221 resolve_formal_arglist (gfc_symbol *proc)
 222 {
 223   gfc_formal_arglist *f;
 224   gfc_symbol *sym;
 225   int i;
 226
 227   if (proc->result != NULL)
 228     sym = proc->result;
 229   else
 230     sym = proc;
 231
 232   if (gfc_elemental (proc)
 233       || sym->attr.pointer || sym->attr.allocatable
 234       || (sym->as && sym->as->rank > 0))
 235     {
 236       proc->attr.always_explicit = 1;
 237       sym->attr.always_explicit = 1;
 238     }
 239
 240   formal_arg_flag = 1;
 241
 242   for (f = proc->formal; f; f = f->next)
 243     {
 244       sym = f->sym;
 245
 246       if (sym == NULL)
 247         {
 248           /* Alternate return placeholder.  */
 249           if (gfc_elemental (proc))
 250             gfc_error ("Alternate return specifier in elemental subroutine "
 251                        "'%s' at %L is not allowed", proc->name,
 252                        &proc->declared_at);
 253           if (proc->attr.function)
 254             gfc_error ("Alternate return specifier in function "
 255                        "'%s' at %L is not allowed", proc->name,
 256                        &proc->declared_at);
 257           continue;
 258         }
 259       else if (sym->attr.procedure && sym->ts.interface
 260                && sym->attr.if_source != IFSRC_DECL)
 261         resolve_procedure_interface (sym);
 262
 263       if (sym->attr.if_source != IFSRC_UNKNOWN)
 264         resolve_formal_arglist (sym);
 265
 266       if (sym->attr.subroutine || sym->attr.external || sym->attr.intrinsic)
 267         {
 268           if (gfc_pure (proc) && !gfc_pure (sym))
 269             {
 270               gfc_error ("Dummy procedure '%s' of PURE procedure at %L must "
 271                          "also be PURE", sym->name, &sym->declared_at);
 272               continue;
 273             }
 274
 275           if (gfc_elemental (proc))
 276             {
 277               gfc_error ("Dummy procedure at %L not allowed in ELEMENTAL "
 278                          "procedure", &sym->declared_at);
 279               continue;
 280             }
 281
 282           if (sym->attr.function
 283                 && sym->ts.type == BT_UNKNOWN
 284                 && sym->attr.intrinsic)
 285             {
 286               gfc_intrinsic_sym *isym;
 287               isym = gfc_find_function (sym->name);
 288               if (isym == NULL || !isym->specific)
 289                 {
 290                   gfc_error ("Unable to find a specific INTRINSIC procedure "
 291                              "for the reference '%s' at %L", sym->name,
 292                              &sym->declared_at);
 293                 }
 294               sym->ts = isym->ts;
 295             }
 296
 297           continue;
 298         }
 299
 300       if (sym->ts.type == BT_UNKNOWN && !proc->attr.intrinsic
 301           && (!sym->attr.function || sym->result == sym))
 302         gfc_set_default_type (sym, 1, sym->ns);
 303
 304       gfc_resolve_array_spec (sym->as, 0);
 305
 306       /* We can't tell if an array with dimension (:) is assumed or deferred
 307          shape until we know if it has the pointer or allocatable attributes.
 308       */
 309       if (sym->as && sym->as->rank > 0 && sym->as->type == AS_DEFERRED
 310           && !(sym->attr.pointer || sym->attr.allocatable))
 311         {
 312           sym->as->type = AS_ASSUMED_SHAPE;
 313           for (i = 0; i < sym->as->rank; i++)
 314             sym->as->lower[i] = gfc_get_int_expr (gfc_default_integer_kind,
 315                                                   NULL, 1);
 316         }
 317
 318       if ((sym->as && sym->as->rank > 0 && sym->as->type == AS_ASSUMED_SHAPE)
 319           || sym->attr.pointer || sym->attr.allocatable || sym->attr.target
 320           || sym->attr.optional)
 321         {
 322           proc->attr.always_explicit = 1;
 323           if (proc->result)
 324             proc->result->attr.always_explicit = 1;
 325         }
 326
 327       /* If the flavor is unknown at this point, it has to be a variable.
 328          A procedure specification would have already set the type.  */
 329
 330       if (sym->attr.flavor == FL_UNKNOWN)
 331         gfc_add_flavor (&sym->attr, FL_VARIABLE, sym->name, &sym->declared_at);
 332
 333       if (gfc_pure (proc) && !sym->attr.pointer
 334           && sym->attr.flavor != FL_PROCEDURE)
 335         {
 336           if (proc->attr.function && sym->attr.intent != INTENT_IN)
 337             gfc_error ("Argument '%s' of pure function '%s' at %L must be "
 338                        "INTENT(IN)", sym->name, proc->name,
 339                        &sym->declared_at);
 340
 341           if (proc->attr.subroutine && sym->attr.intent == INTENT_UNKNOWN)
 342             gfc_error ("Argument '%s' of pure subroutine '%s' at %L must "
 343                        "have its INTENT specified", sym->name, proc->name,
 344                        &sym->declared_at);
 345         }
 346
 347       if (gfc_elemental (proc))
 348         {
 349           /* F2008, C1289.  */
 350           if (sym->attr.codimension)
 351             {
 352               gfc_error ("Coarray dummy argument '%s' at %L to elemental "
 353                          "procedure", sym->name, &sym->declared_at);
 354               continue;
 355             }
 356
 357           if (sym->as != NULL)
 358             {
 359               gfc_error ("Argument '%s' of elemental procedure at %L must "
 360                          "be scalar", sym->name, &sym->declared_at);
 361               continue;
 362             }
 363
 364           if (sym->attr.allocatable)
 365             {
 366               gfc_error ("Argument '%s' of elemental procedure at %L cannot "
 367                          "have the ALLOCATABLE attribute", sym->name,
 368                          &sym->declared_at);
 369               continue;
 370             }
 371
 372           if (sym->attr.pointer)
 373             {
 374               gfc_error ("Argument '%s' of elemental procedure at %L cannot "
 375                          "have the POINTER attribute", sym->name,
 376                          &sym->declared_at);
 377               continue;
 378             }
 379
 380           if (sym->attr.flavor == FL_PROCEDURE)
 381             {
 382               gfc_error ("Dummy procedure '%s' not allowed in elemental "
 383                          "procedure '%s' at %L", sym->name, proc->name,
 384                          &sym->declared_at);
 385               continue;
 386             }
 387
 388           if (sym->attr.intent == INTENT_UNKNOWN)
 389             {
 390               gfc_error ("Argument '%s' of elemental procedure '%s' at %L must "
 391                          "have its INTENT specified", sym->name, proc->name,
 392                          &sym->declared_at);
 393               continue;
 394             }
 395         }
 396
 397       /* Each dummy shall be specified to be scalar.  */
 398       if (proc->attr.proc == PROC_ST_FUNCTION)
 399         {
 400           if (sym->as != NULL)
 401             {
 402               gfc_error ("Argument '%s' of statement function at %L must "
 403                          "be scalar", sym->name, &sym->declared_at);
 404               continue;
 405             }
 406
 407           if (sym->ts.type == BT_CHARACTER)
 408             {
 409               gfc_charlen *cl = sym->ts.u.cl;
 410               if (!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT)
 411                 {
 412                   gfc_error ("Character-valued argument '%s' of statement "
 413                              "function at %L must have constant length",
 414                              sym->name, &sym->declared_at);
 415                   continue;
 416                 }
 417             }
 418         }
 419     }
 420   formal_arg_flag = 0;
 421 }
 422
 423
 424 /* Work function called when searching for symbols that have argument lists
 425    associated with them.  */
 426
 427 static void
 428 find_arglists (gfc_symbol *sym)
 429 {
 430   if (sym->attr.if_source == IFSRC_UNKNOWN || sym->ns != gfc_current_ns)
 431     return;
 432
 433   resolve_formal_arglist (sym);
 434 }
 435
 436
 437 /* Given a namespace, resolve all formal argument lists within the namespace.
 438  */
 439
 440 static void
 441 resolve_formal_arglists (gfc_namespace *ns)
 442 {
 443   if (ns == NULL)
 444     return;
 445
 446   gfc_traverse_ns (ns, find_arglists);
 447 }
 448
 449
 450 static void
 451 resolve_contained_fntype (gfc_symbol *sym, gfc_namespace *ns)
 452 {
 453   gfc_try t;
 454
 455   /* If this namespace is not a function or an entry master function,
 456      ignore it.  */
 457   if (! sym || !(sym->attr.function || sym->attr.flavor == FL_VARIABLE)
 458       || sym->attr.entry_master)
 459     return;
 460
 461   /* Try to find out of what the return type is.  */
 462   if (sym->result->ts.type == BT_UNKNOWN && sym->result->ts.interface == NULL)
 463     {
 464       t = gfc_set_default_type (sym->result, 0, ns);
 465
 466       if (t == FAILURE && !sym->result->attr.untyped)
 467         {
 468           if (sym->result == sym)
 469             gfc_error ("Contained function '%s' at %L has no IMPLICIT type",
 470                        sym->name, &sym->declared_at);
 471           else if (!sym->result->attr.proc_pointer)
 472             gfc_error ("Result '%s' of contained function '%s' at %L has "
 473                        "no IMPLICIT type", sym->result->name, sym->name,
 474                        &sym->result->declared_at);
 475           sym->result->attr.untyped = 1;
 476         }
 477     }
 478
 479   /* Fortran 95 Draft Standard, page 51, Section 5.1.1.5, on the Character
 480      type, lists the only ways a character length value of * can be used:
 481      dummy arguments of procedures, named constants, and function results
 482      in external functions.  Internal function results and results of module
 483      procedures are not on this list, ergo, not permitted.  */
 484
 485   if (sym->result->ts.type == BT_CHARACTER)
 486     {
 487       gfc_charlen *cl = sym->result->ts.u.cl;
 488       if (!cl || !cl->length)
 489         {
 490           /* See if this is a module-procedure and adapt error message
 491              accordingly.  */
 492           bool module_proc;
 493           gcc_assert (ns->parent && ns->parent->proc_name);
 494           module_proc = (ns->parent->proc_name->attr.flavor == FL_MODULE);
 495
 496           gfc_error ("Character-valued %s '%s' at %L must not be"
 497                      " assumed length",
 498                      module_proc ? _("module procedure")
 499                                  : _("internal function"),
 500                      sym->name, &sym->declared_at);
 501         }
 502     }
 503 }
 504
 505
 506 /* Add NEW_ARGS to the formal argument list of PROC, taking care not to
 507    introduce duplicates.  */
 508
 509 static void
 510 merge_argument_lists (gfc_symbol *proc, gfc_formal_arglist *new_args)
 511 {
 512   gfc_formal_arglist *f, *new_arglist;
 513   gfc_symbol *new_sym;
 514
 515   for (; new_args != NULL; new_args = new_args->next)
 516     {
 517       new_sym = new_args->sym;
 518       /* See if this arg is already in the formal argument list.  */
 519       for (f = proc->formal; f; f = f->next)
 520         {
 521           if (new_sym == f->sym)
 522             break;
 523         }
 524
 525       if (f)
 526         continue;
 527
 528       /* Add a new argument.  Argument order is not important.  */
 529       new_arglist = gfc_get_formal_arglist ();
 530       new_arglist->sym = new_sym;
 531       new_arglist->next = proc->formal;
 532       proc->formal  = new_arglist;
 533     }
 534 }
 535
 536
 537 /* Flag the arguments that are not present in all entries.  */
 538
 539 static void
 540 check_argument_lists (gfc_symbol *proc, gfc_formal_arglist *new_args)
 541 {
 542   gfc_formal_arglist *f, *head;
 543   head = new_args;
 544
 545   for (f = proc->formal; f; f = f->next)
 546     {
 547       if (f->sym == NULL)
 548         continue;
 549
 550       for (new_args = head; new_args; new_args = new_args->next)
 551         {
 552           if (new_args->sym == f->sym)
 553             break;
 554         }
 555
 556       if (new_args)
 557         continue;
 558
 559       f->sym->attr.not_always_present = 1;
 560     }
 561 }
 562
 563
 564 /* Resolve alternate entry points.  If a symbol has multiple entry points we
 565    create a new master symbol for the main routine, and turn the existing
 566    symbol into an entry point.  */
 567
 568 static void
 569 resolve_entries (gfc_namespace *ns)
 570 {
 571   gfc_namespace *old_ns;
 572   gfc_code *c;
 573   gfc_symbol *proc;
 574   gfc_entry_list *el;
 575   char name[GFC_MAX_SYMBOL_LEN + 1];
 576   static int master_count = 0;
 577
 578   if (ns->proc_name == NULL)
 579     return;
 580
 581   /* No need to do anything if this procedure doesn't have alternate entry
 582      points.  */
 583   if (!ns->entries)
 584     return;
 585
 586   /* We may already have resolved alternate entry points.  */
 587   if (ns->proc_name->attr.entry_master)
 588     return;
 589
 590   /* If this isn't a procedure something has gone horribly wrong.  */
 591   gcc_assert (ns->proc_name->attr.flavor == FL_PROCEDURE);
 592
 593   /* Remember the current namespace.  */
 594   old_ns = gfc_current_ns;
 595
 596   gfc_current_ns = ns;
 597
 598   /* Add the main entry point to the list of entry points.  */
 599   el = gfc_get_entry_list ();
 600   el->sym = ns->proc_name;
 601   el->id = 0;
 602   el->next = ns->entries;
 603   ns->entries = el;
 604   ns->proc_name->attr.entry = 1;
 605
 606   /* If it is a module function, it needs to be in the right namespace
 607      so that gfc_get_fake_result_decl can gather up the results. The
 608      need for this arose in get_proc_name, where these beasts were
 609      left in their own namespace, to keep prior references linked to
 610      the entry declaration.*/
 611   if (ns->proc_name->attr.function
 612       && ns->parent && ns->parent->proc_name->attr.flavor == FL_MODULE)
 613     el->sym->ns = ns;
 614
 615   /* Do the same for entries where the master is not a module
 616      procedure.  These are retained in the module namespace because
 617      of the module procedure declaration.  */
 618   for (el = el->next; el; el = el->next)
 619     if (el->sym->ns->proc_name->attr.flavor == FL_MODULE
 620           && el->sym->attr.mod_proc)
 621       el->sym->ns = ns;
 622   el = ns->entries;
 623
 624   /* Add an entry statement for it.  */
 625   c = gfc_get_code ();
 626   c->op = EXEC_ENTRY;
 627   c->ext.entry = el;
 628   c->next = ns->code;
 629   ns->code = c;
 630
 631   /* Create a new symbol for the master function.  */
 632   /* Give the internal function a unique name (within this file).
 633      Also include the function name so the user has some hope of figuring
 634      out what is going on.  */
 635   snprintf (name, GFC_MAX_SYMBOL_LEN, "master.%d.%s",
 636             master_count++, ns->proc_name->name);
 637   gfc_get_ha_symbol (name, &proc);
 638   gcc_assert (proc != NULL);
 639
 640   gfc_add_procedure (&proc->attr, PROC_INTERNAL, proc->name, NULL);
 641   if (ns->proc_name->attr.subroutine)
 642     gfc_add_subroutine (&proc->attr, proc->name, NULL);
 643   else
 644     {
 645       gfc_symbol *sym;
 646       gfc_typespec *ts, *fts;
 647       gfc_array_spec *as, *fas;
 648       gfc_add_function (&proc->attr, proc->name, NULL);
 649       proc->result = proc;
 650       fas = ns->entries->sym->as;
 651       fas = fas ? fas : ns->entries->sym->result->as;
 652       fts = &ns->entries->sym->result->ts;
 653       if (fts->type == BT_UNKNOWN)
 654         fts = gfc_get_default_type (ns->entries->sym->result->name, NULL);
 655       for (el = ns->entries->next; el; el = el->next)
 656         {
 657           ts = &el->sym->result->ts;
 658           as = el->sym->as;
 659           as = as ? as : el->sym->result->as;
 660           if (ts->type == BT_UNKNOWN)
 661             ts = gfc_get_default_type (el->sym->result->name, NULL);
 662
 663           if (! gfc_compare_types (ts, fts)
 664               || (el->sym->result->attr.dimension
 665                   != ns->entries->sym->result->attr.dimension)
 666               || (el->sym->result->attr.pointer
 667                   != ns->entries->sym->result->attr.pointer))
 668             break;
 669           else if (as && fas && ns->entries->sym->result != el->sym->result
 670                       && gfc_compare_array_spec (as, fas) == 0)
 671             gfc_error ("Function %s at %L has entries with mismatched "
 672                        "array specifications", ns->entries->sym->name,
 673                        &ns->entries->sym->declared_at);
 674           /* The characteristics need to match and thus both need to have
 675              the same string length, i.e. both len=*, or both len=4.
 676              Having both len=<variable> is also possible, but difficult to
 677              check at compile time.  */
 678           else if (ts->type == BT_CHARACTER && ts->u.cl && fts->u.cl
 679                    && (((ts->u.cl->length && !fts->u.cl->length)
 680                         ||(!ts->u.cl->length && fts->u.cl->length))
 681                        || (ts->u.cl->length
 682                            && ts->u.cl->length->expr_type
 683                               != fts->u.cl->length->expr_type)
 684                        || (ts->u.cl->length
 685                            && ts->u.cl->length->expr_type == EXPR_CONSTANT
 686                            && mpz_cmp (ts->u.cl->length->value.integer,
 687                                        fts->u.cl->length->value.integer) != 0)))
 688             gfc_notify_std (GFC_STD_GNU, "Extension: Function %s at %L with "
 689                             "entries returning variables of different "
 690                             "string lengths", ns->entries->sym->name,
 691                             &ns->entries->sym->declared_at);
 692         }
 693
 694       if (el == NULL)
 695         {
 696           sym = ns->entries->sym->result;
 697           /* All result types the same.  */
 698           proc->ts = *fts;
 699           if (sym->attr.dimension)
 700             gfc_set_array_spec (proc, gfc_copy_array_spec (sym->as), NULL);
 701           if (sym->attr.pointer)
 702             gfc_add_pointer (&proc->attr, NULL);
 703         }
 704       else
 705         {
 706           /* Otherwise the result will be passed through a union by
 707              reference.  */
 708           proc->attr.mixed_entry_master = 1;
 709           for (el = ns->entries; el; el = el->next)
 710             {
 711               sym = el->sym->result;
 712               if (sym->attr.dimension)
 713                 {
 714                   if (el == ns->entries)
 715                     gfc_error ("FUNCTION result %s can't be an array in "
 716                                "FUNCTION %s at %L", sym->name,
 717                                ns->entries->sym->name, &sym->declared_at);
 718                   else
 719                     gfc_error ("ENTRY result %s can't be an array in "
 720                                "FUNCTION %s at %L", sym->name,
 721                                ns->entries->sym->name, &sym->declared_at);
 722                 }
 723               else if (sym->attr.pointer)
 724                 {
 725                   if (el == ns->entries)
 726                     gfc_error ("FUNCTION result %s can't be a POINTER in "
 727                                "FUNCTION %s at %L", sym->name,
 728                                ns->entries->sym->name, &sym->declared_at);
 729                   else
 730                     gfc_error ("ENTRY result %s can't be a POINTER in "
 731                                "FUNCTION %s at %L", sym->name,
 732                                ns->entries->sym->name, &sym->declared_at);
 733                 }
 734               else
 735                 {
 736                   ts = &sym->ts;
 737                   if (ts->type == BT_UNKNOWN)
 738                     ts = gfc_get_default_type (sym->name, NULL);
 739                   switch (ts->type)
 740                     {
 741                     case BT_INTEGER:
 742                       if (ts->kind == gfc_default_integer_kind)
 743                         sym = NULL;
 744                       break;
 745                     case BT_REAL:
 746                       if (ts->kind == gfc_default_real_kind
 747                           || ts->kind == gfc_default_double_kind)
 748                         sym = NULL;
 749                       break;
 750                     case BT_COMPLEX:
 751                       if (ts->kind == gfc_default_complex_kind)
 752                         sym = NULL;
 753                       break;
 754                     case BT_LOGICAL:
 755                       if (ts->kind == gfc_default_logical_kind)
 756                         sym = NULL;
 757                       break;
 758                     case BT_UNKNOWN:
 759                       /* We will issue error elsewhere.  */
 760                       sym = NULL;
 761                       break;
 762                     default:
 763                       break;
 764                     }
 765                   if (sym)
 766                     {
 767                       if (el == ns->entries)
 768                         gfc_error ("FUNCTION result %s can't be of type %s "
 769                                    "in FUNCTION %s at %L", sym->name,
 770                                    gfc_typename (ts), ns->entries->sym->name,
 771                                    &sym->declared_at);
 772                       else
 773                         gfc_error ("ENTRY result %s can't be of type %s "
 774                                    "in FUNCTION %s at %L", sym->name,
 775                                    gfc_typename (ts), ns->entries->sym->name,
 776                                    &sym->declared_at);
 777                     }
 778                 }
 779             }
 780         }
 781     }
 782   proc->attr.access = ACCESS_PRIVATE;
 783   proc->attr.entry_master = 1;
 784
 785   /* Merge all the entry point arguments.  */
 786   for (el = ns->entries; el; el = el->next)
 787     merge_argument_lists (proc, el->sym->formal);
 788
 789   /* Check the master formal arguments for any that are not
 790      present in all entry points.  */
 791   for (el = ns->entries; el; el = el->next)
 792     check_argument_lists (proc, el->sym->formal);
 793
 794   /* Use the master function for the function body.  */
 795   ns->proc_name = proc;
 796
 797   /* Finalize the new symbols.  */
 798   gfc_commit_symbols ();
 799
 800   /* Restore the original namespace.  */
 801   gfc_current_ns = old_ns;
 802 }
 803
 804
 805 /* Resolve common variables.  */
 806 static void
 807 resolve_common_vars (gfc_symbol *sym, bool named_common)
 808 {
 809   gfc_symbol *csym = sym;
 810
 811   for (; csym; csym = csym->common_next)
 812     {
 813       if (csym->value || csym->attr.data)
 814         {
 815           if (!csym->ns->is_block_data)
 816             gfc_notify_std (GFC_STD_GNU, "Variable '%s' at %L is in COMMON "
 817                             "but only in BLOCK DATA initialization is "
 818                             "allowed", csym->name, &csym->declared_at);
 819           else if (!named_common)
 820             gfc_notify_std (GFC_STD_GNU, "Initialized variable '%s' at %L is "
 821                             "in a blank COMMON but initialization is only "
 822                             "allowed in named common blocks", csym->name,
 823                             &csym->declared_at);
 824         }
 825
 826       if (csym->ts.type != BT_DERIVED)
 827         continue;
 828
 829       if (!(csym->ts.u.derived->attr.sequence
 830             || csym->ts.u.derived->attr.is_bind_c))
 831         gfc_error_now ("Derived type variable '%s' in COMMON at %L "
 832                        "has neither the SEQUENCE nor the BIND(C) "
 833                        "attribute", csym->name, &csym->declared_at);
 834       if (csym->ts.u.derived->attr.alloc_comp)
 835         gfc_error_now ("Derived type variable '%s' in COMMON at %L "
 836                        "has an ultimate component that is "
 837                        "allocatable", csym->name, &csym->declared_at);
 838       if (gfc_has_default_initializer (csym->ts.u.derived))
 839         gfc_error_now ("Derived type variable '%s' in COMMON at %L "
 840                        "may not have default initializer", csym->name,
 841                        &csym->declared_at);
 842
 843       if (csym->attr.flavor == FL_UNKNOWN && !csym->attr.proc_pointer)
 844         gfc_add_flavor (&csym->attr, FL_VARIABLE, csym->name, &csym->declared_at);
 845     }
 846 }
 847
 848 /* Resolve common blocks.  */
 849 static void
 850 resolve_common_blocks (gfc_symtree *common_root)
 851 {
 852   gfc_symbol *sym;
 853
 854   if (common_root == NULL)
 855     return;
 856
 857   if (common_root->left)
 858     resolve_common_blocks (common_root->left);
 859   if (common_root->right)
 860     resolve_common_blocks (common_root->right);
 861
 862   resolve_common_vars (common_root->n.common->head, true);
 863
 864   gfc_find_symbol (common_root->name, gfc_current_ns, 0, &sym);
 865   if (sym == NULL)
 866     return;
 867
 868   if (sym->attr.flavor == FL_PARAMETER)
 869     gfc_error ("COMMON block '%s' at %L is used as PARAMETER at %L",
 870                sym->name, &common_root->n.common->where, &sym->declared_at);
 871
 872   if (sym->attr.intrinsic)
 873     gfc_error ("COMMON block '%s' at %L is also an intrinsic procedure",
 874                sym->name, &common_root->n.common->where);
 875   else if (sym->attr.result
 876            || gfc_is_function_return_value (sym, gfc_current_ns))
 877     gfc_notify_std (GFC_STD_F2003, "Fortran 2003: COMMON block '%s' at %L "
 878                     "that is also a function result", sym->name,
 879                     &common_root->n.common->where);
 880   else if (sym->attr.flavor == FL_PROCEDURE && sym->attr.proc != PROC_INTERNAL
 881            && sym->attr.proc != PROC_ST_FUNCTION)
 882     gfc_notify_std (GFC_STD_F2003, "Fortran 2003: COMMON block '%s' at %L "
 883                     "that is also a global procedure", sym->name,
 884                     &common_root->n.common->where);
 885 }
 886
 887
 888 /* Resolve contained function types.  Because contained functions can call one
 889    another, they have to be worked out before any of the contained procedures
 890    can be resolved.
 891
 892    The good news is that if a function doesn't already have a type, the only
 893    way it can get one is through an IMPLICIT type or a RESULT variable, because
 894    by definition contained functions are contained namespace they're contained
 895    in, not in a sibling or parent namespace.  */
 896
 897 static void
 898 resolve_contained_functions (gfc_namespace *ns)
 899 {
 900   gfc_namespace *child;
 901   gfc_entry_list *el;
 902
 903   resolve_formal_arglists (ns);
 904
 905   for (child = ns->contained; child; child = child->sibling)
 906     {
 907       /* Resolve alternate entry points first.  */
 908       resolve_entries (child);
 909
 910       /* Then check function return types.  */
 911       resolve_contained_fntype (child->proc_name, child);
 912       for (el = child->entries; el; el = el->next)
 913         resolve_contained_fntype (el->sym, child);
 914     }
 915 }
 916
 917
 918 /* Resolve all of the elements of a structure constructor and make sure that
 919    the types are correct. The 'init' flag indicates that the given
 920    constructor is an initializer.  */
 921
 922 static gfc_try
 923 resolve_structure_cons (gfc_expr *expr, int init)
 924 {
 925   gfc_constructor *cons;
 926   gfc_component *comp;
 927   gfc_try t;
 928   symbol_attribute a;
 929
 930   t = SUCCESS;
 931
 932   if (expr->ts.type == BT_DERIVED)
 933     resolve_symbol (expr->ts.u.derived);
 934
 935   cons = gfc_constructor_first (expr->value.constructor);
 936   /* A constructor may have references if it is the result of substituting a
 937      parameter variable.  In this case we just pull out the component we
 938      want.  */
 939   if (expr->ref)
 940     comp = expr->ref->u.c.sym->components;
 941   else
 942     comp = expr->ts.u.derived->components;
 943
 944   /* See if the user is trying to invoke a structure constructor for one of
 945      the iso_c_binding derived types.  */
 946   if (expr->ts.type == BT_DERIVED && expr->ts.u.derived
 947       && expr->ts.u.derived->ts.is_iso_c && cons
 948       && (cons->expr == NULL || cons->expr->expr_type != EXPR_NULL))
 949     {
 950       gfc_error ("Components of structure constructor '%s' at %L are PRIVATE",
 951                  expr->ts.u.derived->name, &(expr->where));
 952       return FAILURE;
 953     }
 954
 955   /* Return if structure constructor is c_null_(fun)prt.  */
 956   if (expr->ts.type == BT_DERIVED && expr->ts.u.derived
 957       && expr->ts.u.derived->ts.is_iso_c && cons
 958       && cons->expr && cons->expr->expr_type == EXPR_NULL)
 959     return SUCCESS;
 960
 961   for (; comp && cons; comp = comp->next, cons = gfc_constructor_next (cons))
 962     {
 963       int rank;
 964
 965       if (!cons->expr)
 966         continue;
 967
 968       if (gfc_resolve_expr (cons->expr) == FAILURE)
 969         {
 970           t = FAILURE;
 971           continue;
 972         }
 973
 974       rank = comp->as ? comp->as->rank : 0;
 975       if (cons->expr->expr_type != EXPR_NULL && rank != cons->expr->rank
 976           && (comp->attr.allocatable || cons->expr->rank))
 977         {
 978           gfc_error ("The rank of the element in the derived type "
 979                      "constructor at %L does not match that of the "
 980                      "component (%d/%d)", &cons->expr->where,
 981                      cons->expr->rank, rank);
 982           t = FAILURE;
 983         }
 984
 985       /* If we don't have the right type, try to convert it.  */
 986
 987       if (!comp->attr.proc_pointer &&
 988           !gfc_compare_types (&cons->expr->ts, &comp->ts))
 989         {
 990           t = FAILURE;
 991           if (strcmp (comp->name, "$extends") == 0)
 992             {
 993               /* Can afford to be brutal with the $extends initializer.
 994                  The derived type can get lost because it is PRIVATE
 995                  but it is not usage constrained by the standard.  */
 996               cons->expr->ts = comp->ts;
 997               t = SUCCESS;
 998             }
 999           else if (comp->attr.pointer && cons->expr->ts.type != BT_UNKNOWN)
1000             gfc_error ("The element in the derived type constructor at %L, "
1001                        "for pointer component '%s', is %s but should be %s",
1002                        &cons->expr->where, comp->name,
1003                        gfc_basic_typename (cons->expr->ts.type),
1004                        gfc_basic_typename (comp->ts.type));
1005           else
1006             t = gfc_convert_type (cons->expr, &comp->ts, 1);
1007         }
1008
1009       /* For strings, the length of the constructor should be the same as
1010          the one of the structure, ensure this if the lengths are known at
1011          compile time and when we are dealing with PARAMETER or structure
1012          constructors.  */
1013       if (cons->expr->ts.type == BT_CHARACTER && comp->ts.u.cl
1014           && comp->ts.u.cl->length
1015           && comp->ts.u.cl->length->expr_type == EXPR_CONSTANT
1016           && cons->expr->ts.u.cl && cons->expr->ts.u.cl->length
1017           && cons->expr->ts.u.cl->length->expr_type == EXPR_CONSTANT
1018           && mpz_cmp (cons->expr->ts.u.cl->length->value.integer,
1019                       comp->ts.u.cl->length->value.integer) != 0)
1020         {
1021           if (cons->expr->expr_type == EXPR_VARIABLE
1022               && cons->expr->symtree->n.sym->attr.flavor == FL_PARAMETER)
1023             {
1024               /* Wrap the parameter in an array constructor (EXPR_ARRAY)
1025                  to make use of the gfc_resolve_character_array_constructor
1026                  machinery.  The expression is later simplified away to
1027                  an array of string literals.  */
1028               gfc_expr *para = cons->expr;
1029               cons->expr = gfc_get_expr ();
1030               cons->expr->ts = para->ts;
1031               cons->expr->where = para->where;
1032               cons->expr->expr_type = EXPR_ARRAY;
1033               cons->expr->rank = para->rank;
1034               cons->expr->shape = gfc_copy_shape (para->shape, para->rank);
1035               gfc_constructor_append_expr (&cons->expr->value.constructor,
1036                                            para, &cons->expr->where);
1037             }
1038           if (cons->expr->expr_type == EXPR_ARRAY)
1039             {
1040               gfc_constructor *p;
1041               p = gfc_constructor_first (cons->expr->value.constructor);
1042               if (cons->expr->ts.u.cl != p->expr->ts.u.cl)
1043                 {
1044                   gfc_charlen *cl, *cl2;
1045
1046                   cl2 = NULL;
1047                   for (cl = gfc_current_ns->cl_list; cl; cl = cl->next)
1048                     {
1049                       if (cl == cons->expr->ts.u.cl)
1050                         break;
1051                       cl2 = cl;
1052                     }
1053
1054                   gcc_assert (cl);
1055
1056                   if (cl2)
1057                     cl2->next = cl->next;
1058
1059                   gfc_free_expr (cl->length);
1060                   gfc_free (cl);
1061                 }
1062
1063               cons->expr->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
1064               cons->expr->ts.u.cl->length_from_typespec = true;
1065               cons->expr->ts.u.cl->length = gfc_copy_expr (comp->ts.u.cl->length);
1066               gfc_resolve_character_array_constructor (cons->expr);
1067             }
1068         }
1069
1070       if (cons->expr->expr_type == EXPR_NULL
1071           && !(comp->attr.pointer || comp->attr.allocatable
1072                || comp->attr.proc_pointer
1073                || (comp->ts.type == BT_CLASS
1074                    && (CLASS_DATA (comp)->attr.class_pointer
1075                        || CLASS_DATA (comp)->attr.allocatable))))
1076         {
1077           t = FAILURE;
1078           gfc_error ("The NULL in the derived type constructor at %L is "
1079                      "being applied to component '%s', which is neither "
1080                      "a POINTER nor ALLOCATABLE", &cons->expr->where,
1081                      comp->name);
1082         }
1083
1084       if (!comp->attr.pointer || comp->attr.proc_pointer
1085           || cons->expr->expr_type == EXPR_NULL)
1086         continue;
1087
1088       a = gfc_expr_attr (cons->expr);
1089
1090       if (!a.pointer && !a.target)
1091         {
1092           t = FAILURE;
1093           gfc_error ("The element in the derived type constructor at %L, "
1094                      "for pointer component '%s' should be a POINTER or "
1095                      "a TARGET", &cons->expr->where, comp->name);
1096         }
1097
1098       if (init)
1099         {
1100           /* F08:C461. Additional checks for pointer initialization.  */
1101           if (a.allocatable)
1102             {
1103               t = FAILURE;
1104               gfc_error ("Pointer initialization target at %L "
1105                          "must not be ALLOCATABLE ", &cons->expr->where);
1106             }
1107           if (!a.save)
1108             {
1109               t = FAILURE;
1110               gfc_error ("Pointer initialization target at %L "
1111                          "must have the SAVE attribute", &cons->expr->where);
1112             }
1113         }
1114
1115       /* F2003, C1272 (3).  */
1116       if (gfc_pure (NULL) && cons->expr->expr_type == EXPR_VARIABLE
1117           && (gfc_impure_variable (cons->expr->symtree->n.sym)
1118               || gfc_is_coindexed (cons->expr)))
1119         {
1120           t = FAILURE;
1121           gfc_error ("Invalid expression in the derived type constructor for "
1122                      "pointer component '%s' at %L in PURE procedure",
1123                      comp->name, &cons->expr->where);
1124         }
1125
1126     }
1127
1128   return t;
1129 }
1130
1131
1132 /****************** Expression name resolution ******************/
1133
1134 /* Returns 0 if a symbol was not declared with a type or
1135    attribute declaration statement, nonzero otherwise.  */
1136
1137 static int
1138 was_declared (gfc_symbol *sym)
1139 {
1140   symbol_attribute a;
1141
1142   a = sym->attr;
1143
1144   if (!a.implicit_type && sym->ts.type != BT_UNKNOWN)
1145     return 1;
1146
1147   if (a.allocatable || a.dimension || a.dummy || a.external || a.intrinsic
1148       || a.optional || a.pointer || a.save || a.target || a.volatile_
1149       || a.value || a.access != ACCESS_UNKNOWN || a.intent != INTENT_UNKNOWN
1150       || a.asynchronous || a.codimension)
1151     return 1;
1152
1153   return 0;
1154 }
1155
1156
1157 /* Determine if a symbol is generic or not.  */
1158
1159 static int
1160 generic_sym (gfc_symbol *sym)
1161 {
1162   gfc_symbol *s;
1163
1164   if (sym->attr.generic ||
1165       (sym->attr.intrinsic && gfc_generic_intrinsic (sym->name)))
1166     return 1;
1167
1168   if (was_declared (sym) || sym->ns->parent == NULL)
1169     return 0;
1170
1171   gfc_find_symbol (sym->name, sym->ns->parent, 1, &s);
1172
1173   if (s != NULL)
1174     {
1175       if (s == sym)
1176         return 0;
1177       else
1178         return generic_sym (s);
1179     }
1180
1181   return 0;
1182 }
1183
1184
1185 /* Determine if a symbol is specific or not.  */
1186
1187 static int
1188 specific_sym (gfc_symbol *sym)
1189 {
1190   gfc_symbol *s;
1191
1192   if (sym->attr.if_source == IFSRC_IFBODY
1193       || sym->attr.proc == PROC_MODULE
1194       || sym->attr.proc == PROC_INTERNAL
1195       || sym->attr.proc == PROC_ST_FUNCTION
1196       || (sym->attr.intrinsic && gfc_specific_intrinsic (sym->name))
1197       || sym->attr.external)
1198     return 1;
1199
1200   if (was_declared (sym) || sym->ns->parent == NULL)
1201     return 0;
1202
1203   gfc_find_symbol (sym->name, sym->ns->parent, 1, &s);
1204
1205   return (s == NULL) ? 0 : specific_sym (s);
1206 }
1207
1208
1209 /* Figure out if the procedure is specific, generic or unknown.  */
1210
1211 typedef enum
1212 { PTYPE_GENERIC = 1, PTYPE_SPECIFIC, PTYPE_UNKNOWN }
1213 proc_type;
1214
1215 static proc_type
1216 procedure_kind (gfc_symbol *sym)
1217 {
1218   if (generic_sym (sym))
1219     return PTYPE_GENERIC;
1220
1221   if (specific_sym (sym))
1222     return PTYPE_SPECIFIC;
1223
1224   return PTYPE_UNKNOWN;
1225 }
1226
1227 /* Check references to assumed size arrays.  The flag need_full_assumed_size
1228    is nonzero when matching actual arguments.  */
1229
1230 static int need_full_assumed_size = 0;
1231
1232 static bool
1233 check_assumed_size_reference (gfc_symbol *sym, gfc_expr *e)
1234 {
1235   if (need_full_assumed_size || !(sym->as && sym->as->type == AS_ASSUMED_SIZE))
1236       return false;
1237
1238   /* FIXME: The comparison "e->ref->u.ar.type == AR_FULL" is wrong.
1239      What should it be?  */
1240   if ((e->ref->u.ar.end[e->ref->u.ar.as->rank - 1] == NULL)
1241           && (e->ref->u.ar.as->type == AS_ASSUMED_SIZE)
1242                && (e->ref->u.ar.type == AR_FULL))
1243     {
1244       gfc_error ("The upper bound in the last dimension must "
1245                  "appear in the reference to the assumed size "
1246                  "array '%s' at %L", sym->name, &e->where);
1247       return true;
1248     }
1249   return false;
1250 }
1251
1252
1253 /* Look for bad assumed size array references in argument expressions
1254   of elemental and array valued intrinsic procedures.  Since this is
1255   called from procedure resolution functions, it only recurses at
1256   operators.  */
1257
1258 static bool
1259 resolve_assumed_size_actual (gfc_expr *e)
1260 {
1261   if (e == NULL)
1262    return false;
1263
1264   switch (e->expr_type)
1265     {
1266     case EXPR_VARIABLE:
1267       if (e->symtree && check_assumed_size_reference (e->symtree->n.sym, e))
1268         return true;
1269       break;
1270
1271     case EXPR_OP:
1272       if (resolve_assumed_size_actual (e->value.op.op1)
1273           || resolve_assumed_size_actual (e->value.op.op2))
1274         return true;
1275       break;
1276
1277     default:
1278       break;
1279     }
1280   return false;
1281 }
1282
1283
1284 /* Check a generic procedure, passed as an actual argument, to see if
1285    there is a matching specific name.  If none, it is an error, and if
1286    more than one, the reference is ambiguous.  */
1287 static int
1288 count_specific_procs (gfc_expr *e)
1289 {
1290   int n;
1291   gfc_interface *p;
1292   gfc_symbol *sym;
1293
1294   n = 0;
1295   sym = e->symtree->n.sym;
1296
1297   for (p = sym->generic; p; p = p->next)
1298     if (strcmp (sym->name, p->sym->name) == 0)
1299       {
1300         e->symtree = gfc_find_symtree (p->sym->ns->sym_root,
1301                                        sym->name);
1302         n++;
1303       }
1304
1305   if (n > 1)
1306     gfc_error ("'%s' at %L is ambiguous", e->symtree->n.sym->name,
1307                &e->where);
1308
1309   if (n == 0)
1310     gfc_error ("GENERIC procedure '%s' is not allowed as an actual "
1311                "argument at %L", sym->name, &e->where);
1312
1313   return n;
1314 }
1315
1316
1317 /* See if a call to sym could possibly be a not allowed RECURSION because of
1318    a missing RECURIVE declaration.  This means that either sym is the current
1319    context itself, or sym is the parent of a contained procedure calling its
1320    non-RECURSIVE containing procedure.
1321    This also works if sym is an ENTRY.  */
1322
1323 static bool
1324 is_illegal_recursion (gfc_symbol* sym, gfc_namespace* context)
1325 {
1326   gfc_symbol* proc_sym;
1327   gfc_symbol* context_proc;
1328   gfc_namespace* real_context;
1329
1330   if (sym->attr.flavor == FL_PROGRAM)
1331     return false;
1332
1333   gcc_assert (sym->attr.flavor == FL_PROCEDURE);
1334
1335   /* If we've got an ENTRY, find real procedure.  */
1336   if (sym->attr.entry && sym->ns->entries)
1337     proc_sym = sym->ns->entries->sym;
1338   else
1339     proc_sym = sym;
1340
1341   /* If sym is RECURSIVE, all is well of course.  */
1342   if (proc_sym->attr.recursive || gfc_option.flag_recursive)
1343     return false;
1344
1345   /* Find the context procedure's "real" symbol if it has entries.
1346      We look for a procedure symbol, so recurse on the parents if we don't
1347      find one (like in case of a BLOCK construct).  */
1348   for (real_context = context; ; real_context = real_context->parent)
1349     {
1350       /* We should find something, eventually!  */
1351       gcc_assert (real_context);
1352
1353       context_proc = (real_context->entries ? real_context->entries->sym
1354                                             : real_context->proc_name);
1355
1356       /* In some special cases, there may not be a proc_name, like for this
1357          invalid code:
1358          real(bad_kind()) function foo () ...
1359          when checking the call to bad_kind ().
1360          In these cases, we simply return here and assume that the
1361          call is ok.  */
1362       if (!context_proc)
1363         return false;
1364
1365       if (context_proc->attr.flavor != FL_LABEL)
1366         break;
1367     }
1368
1369   /* A call from sym's body to itself is recursion, of course.  */
1370   if (context_proc == proc_sym)
1371     return true;
1372
1373   /* The same is true if context is a contained procedure and sym the
1374      containing one.  */
1375   if (context_proc->attr.contained)
1376     {
1377       gfc_symbol* parent_proc;
1378
1379       gcc_assert (context->parent);
1380       parent_proc = (context->parent->entries ? context->parent->entries->sym
1381                                               : context->parent->proc_name);
1382
1383       if (parent_proc == proc_sym)
1384         return true;
1385     }
1386
1387   return false;
1388 }
1389
1390
1391 /* Resolve an intrinsic procedure: Set its function/subroutine attribute,
1392    its typespec and formal argument list.  */
1393
1394 static gfc_try
1395 resolve_intrinsic (gfc_symbol *sym, locus *loc)
1396 {
1397   gfc_intrinsic_sym* isym = NULL;
1398   const char* symstd;
1399
1400   if (sym->formal)
1401     return SUCCESS;
1402
1403   /* We already know this one is an intrinsic, so we don't call
1404      gfc_is_intrinsic for full checking but rather use gfc_find_function and
1405      gfc_find_subroutine directly to check whether it is a function or
1406      subroutine.  */
1407
1408   if (sym->intmod_sym_id)
1409     isym = gfc_intrinsic_function_by_id ((gfc_isym_id) sym->intmod_sym_id);
1410   else
1411     isym = gfc_find_function (sym->name);
1412
1413   if (isym)
1414     {
1415       if (sym->ts.type != BT_UNKNOWN && gfc_option.warn_surprising
1416           && !sym->attr.implicit_type)
1417         gfc_warning ("Type specified for intrinsic function '%s' at %L is"
1418                       " ignored", sym->name, &sym->declared_at);
1419
1420       if (!sym->attr.function &&
1421           gfc_add_function (&sym->attr, sym->name, loc) == FAILURE)
1422         return FAILURE;
1423
1424       sym->ts = isym->ts;
1425     }
1426   else if ((isym = gfc_find_subroutine (sym->name)))
1427     {
1428       if (sym->ts.type != BT_UNKNOWN && !sym->attr.implicit_type)
1429         {
1430           gfc_error ("Intrinsic subroutine '%s' at %L shall not have a type"
1431                       " specifier", sym->name, &sym->declared_at);
1432           return FAILURE;
1433         }
1434
1435       if (!sym->attr.subroutine &&
1436           gfc_add_subroutine (&sym->attr, sym->name, loc) == FAILURE)
1437         return FAILURE;
1438     }
1439   else
1440     {
1441       gfc_error ("'%s' declared INTRINSIC at %L does not exist", sym->name,
1442                  &sym->declared_at);
1443       return FAILURE;
1444     }
1445
1446   gfc_copy_formal_args_intr (sym, isym);
1447
1448   /* Check it is actually available in the standard settings.  */
1449   if (gfc_check_intrinsic_standard (isym, &symstd, false, sym->declared_at)
1450       == FAILURE)
1451     {
1452       gfc_error ("The intrinsic '%s' declared INTRINSIC at %L is not"
1453                  " available in the current standard settings but %s.  Use"
1454                  " an appropriate -std=* option or enable -fall-intrinsics"
1455                  " in order to use it.",
1456                  sym->name, &sym->declared_at, symstd);
1457       return FAILURE;
1458     }
1459
1460   return SUCCESS;
1461 }
1462
1463
1464 /* Resolve a procedure expression, like passing it to a called procedure or as
1465    RHS for a procedure pointer assignment.  */
1466
1467 static gfc_try
1468 resolve_procedure_expression (gfc_expr* expr)
1469 {
1470   gfc_symbol* sym;
1471
1472   if (expr->expr_type != EXPR_VARIABLE)
1473     return SUCCESS;
1474   gcc_assert (expr->symtree);
1475
1476   sym = expr->symtree->n.sym;
1477
1478   if (sym->attr.intrinsic)
1479     resolve_intrinsic (sym, &expr->where);
1480
1481   if (sym->attr.flavor != FL_PROCEDURE
1482       || (sym->attr.function && sym->result == sym))
1483     return SUCCESS;
1484
1485   /* A non-RECURSIVE procedure that is used as procedure expression within its
1486      own body is in danger of being called recursively.  */
1487   if (is_illegal_recursion (sym, gfc_current_ns))
1488     gfc_warning ("Non-RECURSIVE procedure '%s' at %L is possibly calling"
1489                  " itself recursively.  Declare it RECURSIVE or use"
1490                  " -frecursive", sym->name, &expr->where);
1491
1492   return SUCCESS;
1493 }
1494
1495
1496 /* Resolve an actual argument list.  Most of the time, this is just
1497    resolving the expressions in the list.
1498    The exception is that we sometimes have to decide whether arguments
1499    that look like procedure arguments are really simple variable
1500    references.  */
1501
1502 static gfc_try
1503 resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype,
1504                         bool no_formal_args)
1505 {
1506   gfc_symbol *sym;
1507   gfc_symtree *parent_st;
1508   gfc_expr *e;
1509   int save_need_full_assumed_size;
1510   gfc_component *comp;
1511
1512   for (; arg; arg = arg->next)
1513     {
1514       e = arg->expr;
1515       if (e == NULL)
1516         {
1517           /* Check the label is a valid branching target.  */
1518           if (arg->label)
1519             {
1520               if (arg->label->defined == ST_LABEL_UNKNOWN)
1521                 {
1522                   gfc_error ("Label %d referenced at %L is never defined",
1523                              arg->label->value, &arg->label->where);
1524                   return FAILURE;
1525                 }
1526             }
1527           continue;
1528         }
1529
1530       if (gfc_is_proc_ptr_comp (e, &comp))
1531         {
1532           e->ts = comp->ts;
1533           if (e->expr_type == EXPR_PPC)
1534             {
1535               if (comp->as != NULL)
1536                 e->rank = comp->as->rank;
1537               e->expr_type = EXPR_FUNCTION;
1538             }
1539           if (gfc_resolve_expr (e) == FAILURE)
1540             return FAILURE;
1541           goto argument_list;
1542         }
1543
1544       if (e->expr_type == EXPR_VARIABLE
1545             && e->symtree->n.sym->attr.generic
1546             && no_formal_args
1547             && count_specific_procs (e) != 1)
1548         return FAILURE;
1549
1550       if (e->ts.type != BT_PROCEDURE)
1551         {
1552           save_need_full_assumed_size = need_full_assumed_size;
1553           if (e->expr_type != EXPR_VARIABLE)
1554             need_full_assumed_size = 0;
1555           if (gfc_resolve_expr (e) != SUCCESS)
1556             return FAILURE;
1557           need_full_assumed_size = save_need_full_assumed_size;
1558           goto argument_list;
1559         }
1560
1561       /* See if the expression node should really be a variable reference.  */
1562
1563       sym = e->symtree->n.sym;
1564
1565       if (sym->attr.flavor == FL_PROCEDURE
1566           || sym->attr.intrinsic
1567           || sym->attr.external)
1568         {
1569           int actual_ok;
1570
1571           /* If a procedure is not already determined to be something else
1572              check if it is intrinsic.  */
1573           if (!sym->attr.intrinsic
1574               && !(sym->attr.external || sym->attr.use_assoc
1575                    || sym->attr.if_source == IFSRC_IFBODY)
1576               && gfc_is_intrinsic (sym, sym->attr.subroutine, e->where))
1577             sym->attr.intrinsic = 1;
1578
1579           if (sym->attr.proc == PROC_ST_FUNCTION)
1580             {
1581               gfc_error ("Statement function '%s' at %L is not allowed as an "
1582                          "actual argument", sym->name, &e->where);
1583             }
1584
1585           actual_ok = gfc_intrinsic_actual_ok (sym->name,
1586                                                sym->attr.subroutine);
1587           if (sym->attr.intrinsic && actual_ok == 0)
1588             {
1589               gfc_error ("Intrinsic '%s' at %L is not allowed as an "
1590                          "actual argument", sym->name, &e->where);
1591             }
1592
1593           if (sym->attr.contained && !sym->attr.use_assoc
1594               && sym->ns->proc_name->attr.flavor != FL_MODULE)
1595             {
1596               if (gfc_notify_std (GFC_STD_F2008,
1597                                   "Fortran 2008: Internal procedure '%s' is"
1598                                   " used as actual argument at %L",
1599                                   sym->name, &e->where) == FAILURE)
1600                 return FAILURE;
1601             }
1602
1603           if (sym->attr.elemental && !sym->attr.intrinsic)
1604             {
1605               gfc_error ("ELEMENTAL non-INTRINSIC procedure '%s' is not "
1606                          "allowed as an actual argument at %L", sym->name,
1607                          &e->where);
1608             }
1609
1610           /* Check if a generic interface has a specific procedure
1611             with the same name before emitting an error.  */
1612           if (sym->attr.generic && count_specific_procs (e) != 1)
1613             return FAILURE;
1614
1615           /* Just in case a specific was found for the expression.  */
1616           sym = e->symtree->n.sym;
1617
1618           /* If the symbol is the function that names the current (or
1619              parent) scope, then we really have a variable reference.  */
1620
1621           if (gfc_is_function_return_value (sym, sym->ns))
1622             goto got_variable;
1623
1624           /* If all else fails, see if we have a specific intrinsic.  */
1625           if (sym->ts.type == BT_UNKNOWN && sym->attr.intrinsic)
1626             {
1627               gfc_intrinsic_sym *isym;
1628
1629               isym = gfc_find_function (sym->name);
1630               if (isym == NULL || !isym->specific)
1631                 {
1632                   gfc_error ("Unable to find a specific INTRINSIC procedure "
1633                              "for the reference '%s' at %L", sym->name,
1634                              &e->where);
1635                   return FAILURE;
1636                 }
1637               sym->ts = isym->ts;
1638               sym->attr.intrinsic = 1;
1639               sym->attr.function = 1;
1640             }
1641
1642           if (gfc_resolve_expr (e) == FAILURE)
1643             return FAILURE;
1644           goto argument_list;
1645         }
1646
1647       /* See if the name is a module procedure in a parent unit.  */
1648
1649       if (was_declared (sym) || sym->ns->parent == NULL)
1650         goto got_variable;
1651
1652       if (gfc_find_sym_tree (sym->name, sym->ns->parent, 1, &parent_st))
1653         {
1654           gfc_error ("Symbol '%s' at %L is ambiguous", sym->name, &e->where);
1655           return FAILURE;
1656         }
1657
1658       if (parent_st == NULL)
1659         goto got_variable;
1660
1661       sym = parent_st->n.sym;
1662       e->symtree = parent_st;           /* Point to the right thing.  */
1663
1664       if (sym->attr.flavor == FL_PROCEDURE
1665           || sym->attr.intrinsic
1666           || sym->attr.external)
1667         {
1668           if (gfc_resolve_expr (e) == FAILURE)
1669             return FAILURE;
1670           goto argument_list;
1671         }
1672
1673     got_variable:
1674       e->expr_type = EXPR_VARIABLE;
1675       e->ts = sym->ts;
1676       if (sym->as != NULL)
1677         {
1678           e->rank = sym->as->rank;
1679           e->ref = gfc_get_ref ();
1680           e->ref->type = REF_ARRAY;
1681           e->ref->u.ar.type = AR_FULL;
1682           e->ref->u.ar.as = sym->as;
1683         }
1684
1685       /* Expressions are assigned a default ts.type of BT_PROCEDURE in
1686          primary.c (match_actual_arg). If above code determines that it
1687          is a  variable instead, it needs to be resolved as it was not
1688          done at the beginning of this function.  */
1689       save_need_full_assumed_size = need_full_assumed_size;
1690       if (e->expr_type != EXPR_VARIABLE)
1691         need_full_assumed_size = 0;
1692       if (gfc_resolve_expr (e) != SUCCESS)
1693         return FAILURE;
1694       need_full_assumed_size = save_need_full_assumed_size;
1695
1696     argument_list:
1697       /* Check argument list functions %VAL, %LOC and %REF.  There is
1698          nothing to do for %REF.  */
1699       if (arg->name && arg->name[0] == '%')
1700         {
1701           if (strncmp ("%VAL", arg->name, 4) == 0)
1702             {
1703               if (e->ts.type == BT_CHARACTER || e->ts.type == BT_DERIVED)
1704                 {
1705                   gfc_error ("By-value argument at %L is not of numeric "
1706                              "type", &e->where);
1707                   return FAILURE;
1708                 }
1709
1710               if (e->rank)
1711                 {
1712                   gfc_error ("By-value argument at %L cannot be an array or "
1713                              "an array section", &e->where);
1714                 return FAILURE;
1715                 }
1716
1717               /* Intrinsics are still PROC_UNKNOWN here.  However,
1718                  since same file external procedures are not resolvable
1719                  in gfortran, it is a good deal easier to leave them to
1720                  intrinsic.c.  */
1721               if (ptype != PROC_UNKNOWN
1722                   && ptype != PROC_DUMMY
1723                   && ptype != PROC_EXTERNAL
1724                   && ptype != PROC_MODULE)
1725                 {
1726                   gfc_error ("By-value argument at %L is not allowed "
1727                              "in this context", &e->where);
1728                   return FAILURE;
1729                 }
1730             }
1731
1732           /* Statement functions have already been excluded above.  */
1733           else if (strncmp ("%LOC", arg->name, 4) == 0
1734                    && e->ts.type == BT_PROCEDURE)
1735             {
1736               if (e->symtree->n.sym->attr.proc == PROC_INTERNAL)
1737                 {
1738                   gfc_error ("Passing internal procedure at %L by location "
1739                              "not allowed", &e->where);
1740                   return FAILURE;
1741                 }
1742             }
1743         }
1744
1745       /* Fortran 2008, C1237.  */
1746       if (e->expr_type == EXPR_VARIABLE && gfc_is_coindexed (e)
1747           && gfc_has_ultimate_pointer (e))
1748         {
1749           gfc_error ("Coindexed actual argument at %L with ultimate pointer "
1750                      "component", &e->where);
1751           return FAILURE;
1752         }
1753     }
1754
1755   return SUCCESS;
1756 }
1757
1758
1759 /* Do the checks of the actual argument list that are specific to elemental
1760    procedures.  If called with c == NULL, we have a function, otherwise if
1761    expr == NULL, we have a subroutine.  */
1762
1763 static gfc_try
1764 resolve_elemental_actual (gfc_expr *expr, gfc_code *c)
1765 {
1766   gfc_actual_arglist *arg0;
1767   gfc_actual_arglist *arg;
1768   gfc_symbol *esym = NULL;
1769   gfc_intrinsic_sym *isym = NULL;
1770   gfc_expr *e = NULL;
1771   gfc_intrinsic_arg *iformal = NULL;
1772   gfc_formal_arglist *eformal = NULL;
1773   bool formal_optional = false;
1774   bool set_by_optional = false;
1775   int i;
1776   int rank = 0;
1777
1778   /* Is this an elemental procedure?  */
1779   if (expr && expr->value.function.actual != NULL)
1780     {
1781       if (expr->value.function.esym != NULL
1782           && expr->value.function.esym->attr.elemental)
1783         {
1784           arg0 = expr->value.function.actual;
1785           esym = expr->value.function.esym;
1786         }
1787       else if (expr->value.function.isym != NULL
1788                && expr->value.function.isym->elemental)
1789         {
1790           arg0 = expr->value.function.actual;
1791           isym = expr->value.function.isym;
1792         }
1793       else
1794         return SUCCESS;
1795     }
1796   else if (c && c->ext.actual != NULL)
1797     {
1798       arg0 = c->ext.actual;
1799
1800       if (c->resolved_sym)
1801         esym = c->resolved_sym;
1802       else
1803         esym = c->symtree->n.sym;
1804       gcc_assert (esym);
1805
1806       if (!esym->attr.elemental)
1807         return SUCCESS;
1808     }
1809   else
1810     return SUCCESS;
1811
1812   /* The rank of an elemental is the rank of its array argument(s).  */
1813   for (arg = arg0; arg; arg = arg->next)
1814     {
1815       if (arg->expr != NULL && arg->expr->rank > 0)
1816         {
1817           rank = arg->expr->rank;
1818           if (arg->expr->expr_type == EXPR_VARIABLE
1819               && arg->expr->symtree->n.sym->attr.optional)
1820             set_by_optional = true;
1821
1822           /* Function specific; set the result rank and shape.  */
1823           if (expr)
1824             {
1825               expr->rank = rank;
1826               if (!expr->shape && arg->expr->shape)
1827                 {
1828                   expr->shape = gfc_get_shape (rank);
1829                   for (i = 0; i < rank; i++)
1830                     mpz_init_set (expr->shape[i], arg->expr->shape[i]);
1831                 }
1832             }
1833           break;
1834         }
1835     }
1836
1837   /* If it is an array, it shall not be supplied as an actual argument
1838      to an elemental procedure unless an array of the same rank is supplied
1839      as an actual argument corresponding to a nonoptional dummy argument of
1840      that elemental procedure(12.4.1.5).  */
1841   formal_optional = false;
1842   if (isym)
1843     iformal = isym->formal;
1844   else
1845     eformal = esym->formal;
1846
1847   for (arg = arg0; arg; arg = arg->next)
1848     {
1849       if (eformal)
1850         {
1851           if (eformal->sym && eformal->sym->attr.optional)
1852             formal_optional = true;
1853           eformal = eformal->next;
1854         }
1855       else if (isym && iformal)
1856         {
1857           if (iformal->optional)
1858             formal_optional = true;
1859           iformal = iformal->next;
1860         }
1861       else if (isym)
1862         formal_optional = true;
1863
1864       if (pedantic && arg->expr != NULL
1865           && arg->expr->expr_type == EXPR_VARIABLE
1866           && arg->expr->symtree->n.sym->attr.optional
1867           && formal_optional
1868           && arg->expr->rank
1869           && (set_by_optional || arg->expr->rank != rank)
1870           && !(isym && isym->id == GFC_ISYM_CONVERSION))
1871         {
1872           gfc_warning ("'%s' at %L is an array and OPTIONAL; IF IT IS "
1873                        "MISSING, it cannot be the actual argument of an "
1874                        "ELEMENTAL procedure unless there is a non-optional "
1875                        "argument with the same rank (12.4.1.5)",
1876                        arg->expr->symtree->n.sym->name, &arg->expr->where);
1877           return FAILURE;
1878         }
1879     }
1880
1881   for (arg = arg0; arg; arg = arg->next)
1882     {
1883       if (arg->expr == NULL || arg->expr->rank == 0)
1884         continue;
1885
1886       /* Being elemental, the last upper bound of an assumed size array
1887          argument must be present.  */
1888       if (resolve_assumed_size_actual (arg->expr))
1889         return FAILURE;
1890
1891       /* Elemental procedure's array actual arguments must conform.  */
1892       if (e != NULL)
1893         {
1894           if (gfc_check_conformance (arg->expr, e,
1895                                      "elemental procedure") == FAILURE)
1896             return FAILURE;
1897         }
1898       else
1899         e = arg->expr;
1900     }
1901
1902   /* INTENT(OUT) is only allowed for subroutines; if any actual argument
1903      is an array, the intent inout/out variable needs to be also an array.  */
1904   if (rank > 0 && esym && expr == NULL)
1905     for (eformal = esym->formal, arg = arg0; arg && eformal;
1906          arg = arg->next, eformal = eformal->next)
1907       if ((eformal->sym->attr.intent == INTENT_OUT
1908            || eformal->sym->attr.intent == INTENT_INOUT)
1909           && arg->expr && arg->expr->rank == 0)
1910         {
1911           gfc_error ("Actual argument at %L for INTENT(%s) dummy '%s' of "
1912                      "ELEMENTAL subroutine '%s' is a scalar, but another "
1913                      "actual argument is an array", &arg->expr->where,
1914                      (eformal->sym->attr.intent == INTENT_OUT) ? "OUT"
1915                      : "INOUT", eformal->sym->name, esym->name);
1916           return FAILURE;
1917         }
1918   return SUCCESS;
1919 }
1920
1921
1922 /* This function does the checking of references to global procedures
1923    as defined in sections 18.1 and 14.1, respectively, of the Fortran
1924    77 and 95 standards.  It checks for a gsymbol for the name, making
1925    one if it does not already exist.  If it already exists, then the
1926    reference being resolved must correspond to the type of gsymbol.
1927    Otherwise, the new symbol is equipped with the attributes of the
1928    reference.  The corresponding code that is called in creating
1929    global entities is parse.c.
1930
1931    In addition, for all but -std=legacy, the gsymbols are used to
1932    check the interfaces of external procedures from the same file.
1933    The namespace of the gsymbol is resolved and then, once this is
1934    done the interface is checked.  */
1935
1936
1937 static bool
1938 not_in_recursive (gfc_symbol *sym, gfc_namespace *gsym_ns)
1939 {
1940   if (!gsym_ns->proc_name->attr.recursive)
1941     return true;
1942
1943   if (sym->ns == gsym_ns)
1944     return false;
1945
1946   if (sym->ns->parent && sym->ns->parent == gsym_ns)
1947     return false;
1948
1949   return true;
1950 }
1951
1952 static bool
1953 not_entry_self_reference  (gfc_symbol *sym, gfc_namespace *gsym_ns)
1954 {
1955   if (gsym_ns->entries)
1956     {
1957       gfc_entry_list *entry = gsym_ns->entries;
1958
1959       for (; entry; entry = entry->next)
1960         {
1961           if (strcmp (sym->name, entry->sym->name) == 0)
1962             {
1963               if (strcmp (gsym_ns->proc_name->name,
1964                           sym->ns->proc_name->name) == 0)
1965                 return false;
1966
1967               if (sym->ns->parent
1968                   && strcmp (gsym_ns->proc_name->name,
1969                              sym->ns->parent->proc_name->name) == 0)
1970                 return false;
1971             }
1972         }
1973     }
1974   return true;
1975 }
1976
1977 static void
1978 resolve_global_procedure (gfc_symbol *sym, locus *where,
1979                           gfc_actual_arglist **actual, int sub)
1980 {
1981   gfc_gsymbol * gsym;
1982   gfc_namespace *ns;
1983   enum gfc_symbol_type type;
1984
1985   type = sub ? GSYM_SUBROUTINE : GSYM_FUNCTION;
1986
1987   gsym = gfc_get_gsymbol (sym->name);
1988
1989   if ((gsym->type != GSYM_UNKNOWN && gsym->type != type))
1990     gfc_global_used (gsym, where);
1991
1992   if (gfc_option.flag_whole_file
1993         && (sym->attr.if_source == IFSRC_UNKNOWN
1994             || sym->attr.if_source == IFSRC_IFBODY)
1995         && gsym->type != GSYM_UNKNOWN
1996         && gsym->ns
1997         && gsym->ns->resolved != -1
1998         && gsym->ns->proc_name
1999         && not_in_recursive (sym, gsym->ns)
2000         && not_entry_self_reference (sym, gsym->ns))
2001     {
2002       gfc_symbol *def_sym;
2003
2004       /* Resolve the gsymbol namespace if needed.  */
2005       if (!gsym->ns->resolved)
2006         {
2007           gfc_dt_list *old_dt_list;
2008
2009           /* Stash away derived types so that the backend_decls do not
2010              get mixed up.  */
2011           old_dt_list = gfc_derived_types;
2012           gfc_derived_types = NULL;
2013
2014           gfc_resolve (gsym->ns);
2015
2016           /* Store the new derived types with the global namespace.  */
2017           if (gfc_derived_types)
2018             gsym->ns->derived_types = gfc_derived_types;
2019
2020           /* Restore the derived types of this namespace.  */
2021           gfc_derived_types = old_dt_list;
2022         }
2023
2024       /* Make sure that translation for the gsymbol occurs before
2025          the procedure currently being resolved.  */
2026       ns = gfc_global_ns_list;
2027       for (; ns && ns != gsym->ns; ns = ns->sibling)
2028         {
2029           if (ns->sibling == gsym->ns)
2030             {
2031               ns->sibling = gsym->ns->sibling;
2032               gsym->ns->sibling = gfc_global_ns_list;
2033               gfc_global_ns_list = gsym->ns;
2034               break;
2035             }
2036         }
2037
2038       def_sym = gsym->ns->proc_name;
2039       if (def_sym->attr.entry_master)
2040         {
2041           gfc_entry_list *entry;
2042           for (entry = gsym->ns->entries; entry; entry = entry->next)
2043             if (strcmp (entry->sym->name, sym->name) == 0)
2044               {
2045                 def_sym = entry->sym;
2046                 break;
2047               }
2048         }
2049
2050       /* Differences in constant character lengths.  */
2051       if (sym->attr.function && sym->ts.type == BT_CHARACTER)
2052         {
2053           long int l1 = 0, l2 = 0;
2054           gfc_charlen *cl1 = sym->ts.u.cl;
2055           gfc_charlen *cl2 = def_sym->ts.u.cl;
2056
2057           if (cl1 != NULL
2058               && cl1->length != NULL
2059               && cl1->length->expr_type == EXPR_CONSTANT)
2060             l1 = mpz_get_si (cl1->length->value.integer);
2061
2062           if (cl2 != NULL
2063               && cl2->length != NULL
2064               && cl2->length->expr_type == EXPR_CONSTANT)
2065             l2 = mpz_get_si (cl2->length->value.integer);
2066
2067           if (l1 && l2 && l1 != l2)
2068             gfc_error ("Character length mismatch in return type of "
2069                        "function '%s' at %L (%ld/%ld)", sym->name,
2070                        &sym->declared_at, l1, l2);
2071         }
2072
2073      /* Type mismatch of function return type and expected type.  */
2074      if (sym->attr.function
2075          && !gfc_compare_types (&sym->ts, &def_sym->ts))
2076         gfc_error ("Return type mismatch of function '%s' at %L (%s/%s)",
2077                    sym->name, &sym->declared_at, gfc_typename (&sym->ts),
2078                    gfc_typename (&def_sym->ts));
2079
2080       if (def_sym->formal && sym->attr.if_source != IFSRC_IFBODY)
2081         {
2082           gfc_formal_arglist *arg = def_sym->formal;
2083           for ( ; arg; arg = arg->next)
2084             if (!arg->sym)
2085               continue;
2086             /* F2003, 12.3.1.1 (2a); F2008, 12.4.2.2 (2a)  */
2087             else if (arg->sym->attr.allocatable
2088                      || arg->sym->attr.asynchronous
2089                      || arg->sym->attr.optional
2090                      || arg->sym->attr.pointer
2091                      || arg->sym->attr.target
2092                      || arg->sym->attr.value
2093                      || arg->sym->attr.volatile_)
2094               {
2095                 gfc_error ("Dummy argument '%s' of procedure '%s' at %L "
2096                            "has an attribute that requires an explicit "
2097                            "interface for this procedure", arg->sym->name,
2098                            sym->name, &sym->declared_at);
2099                 break;
2100               }
2101             /* F2003, 12.3.1.1 (2b); F2008, 12.4.2.2 (2b)  */
2102             else if (arg->sym && arg->sym->as
2103                      && arg->sym->as->type == AS_ASSUMED_SHAPE)
2104               {
2105                 gfc_error ("Procedure '%s' at %L with assumed-shape dummy "
2106                            "argument '%s' must have an explicit interface",
2107                            sym->name, &sym->declared_at, arg->sym->name);
2108                 break;
2109               }
2110             /* F2008, 12.4.2.2 (2c)  */
2111             else if (arg->sym->attr.codimension)
2112               {
2113                 gfc_error ("Procedure '%s' at %L with coarray dummy argument "
2114                            "'%s' must have an explicit interface",
2115                            sym->name, &sym->declared_at, arg->sym->name);
2116                 break;
2117               }
2118             /* F2003, 12.3.1.1 (2c); F2008, 12.4.2.2 (2d)   */
2119             else if (false) /* TODO: is a parametrized derived type  */
2120               {
2121                 gfc_error ("Procedure '%s' at %L with parametrized derived "
2122                            "type argument '%s' must have an explicit "
2123                            "interface", sym->name, &sym->declared_at,
2124                            arg->sym->name);
2125                 break;
2126               }
2127             /* F2003, 12.3.1.1 (2d); F2008, 12.4.2.2 (2e)   */
2128             else if (arg->sym->ts.type == BT_CLASS)
2129               {
2130                 gfc_error ("Procedure '%s' at %L with polymorphic dummy "
2131                            "argument '%s' must have an explicit interface",
2132                            sym->name, &sym->declared_at, arg->sym->name);
2133                 break;
2134               }
2135         }
2136
2137       if (def_sym->attr.function)
2138         {
2139           /* F2003, 12.3.1.1 (3a); F2008, 12.4.2.2 (3a) */
2140           if (def_sym->as && def_sym->as->rank
2141               && (!sym->as || sym->as->rank != def_sym->as->rank))
2142             gfc_error ("The reference to function '%s' at %L either needs an "
2143                        "explicit INTERFACE or the rank is incorrect", sym->name,
2144                        where);
2145
2146           /* F2003, 12.3.1.1 (3b); F2008, 12.4.2.2 (3b) */
2147           if ((def_sym->result->attr.pointer
2148                || def_sym->result->attr.allocatable)
2149                && (sym->attr.if_source != IFSRC_IFBODY
2150                    || def_sym->result->attr.pointer
2151                         != sym->result->attr.pointer
2152                    || def_sym->result->attr.allocatable
2153                         != sym->result->attr.allocatable))
2154             gfc_error ("Function '%s' at %L with a POINTER or ALLOCATABLE "
2155                        "result must have an explicit interface", sym->name,
2156                        where);
2157
2158           /* F2003, 12.3.1.1 (3c); F2008, 12.4.2.2 (3c)  */
2159           if (sym->ts.type == BT_CHARACTER && sym->attr.if_source != IFSRC_IFBODY
2160               && def_sym->ts.u.cl->length != NULL)
2161             {
2162               gfc_charlen *cl = sym->ts.u.cl;
2163
2164               if (!sym->attr.entry_master && sym->attr.if_source == IFSRC_UNKNOWN
2165                   && cl && cl->length && cl->length->expr_type != EXPR_CONSTANT)
2166                 {
2167                   gfc_error ("Nonconstant character-length function '%s' at %L "
2168                              "must have an explicit interface", sym->name,
2169                              &sym->declared_at);
2170                 }
2171             }
2172         }
2173
2174       /* F2003, 12.3.1.1 (4); F2008, 12.4.2.2 (4) */
2175       if (def_sym->attr.elemental && !sym->attr.elemental)
2176         {
2177           gfc_error ("ELEMENTAL procedure '%s' at %L must have an explicit "
2178                      "interface", sym->name, &sym->declared_at);
2179         }
2180
2181       /* F2003, 12.3.1.1 (5); F2008, 12.4.2.2 (5) */
2182       if (def_sym->attr.is_bind_c && !sym->attr.is_bind_c)
2183         {
2184           gfc_error ("Procedure '%s' at %L with BIND(C) attribute must have "
2185                      "an explicit interface", sym->name, &sym->declared_at);
2186         }
2187
2188       if (gfc_option.flag_whole_file == 1
2189           || ((gfc_option.warn_std & GFC_STD_LEGACY)
2190               && !(gfc_option.warn_std & GFC_STD_GNU)))
2191         gfc_errors_to_warnings (1);
2192
2193       if (sym->attr.if_source != IFSRC_IFBODY)
2194         gfc_procedure_use (def_sym, actual, where);
2195
2196       gfc_errors_to_warnings (0);
2197     }
2198
2199   if (gsym->type == GSYM_UNKNOWN)
2200     {
2201       gsym->type = type;
2202       gsym->where = *where;
2203     }
2204
2205   gsym->used = 1;
2206 }
2207
2208
2209 /************* Function resolution *************/
2210
2211 /* Resolve a function call known to be generic.
2212    Section 14.1.2.4.1.  */
2213
2214 static match
2215 resolve_generic_f0 (gfc_expr *expr, gfc_symbol *sym)
2216 {
2217   gfc_symbol *s;
2218
2219   if (sym->attr.generic)
2220     {
2221       s = gfc_search_interface (sym->generic, 0, &expr->value.function.actual);
2222       if (s != NULL)
2223         {
2224           expr->value.function.name = s->name;
2225           expr->value.function.esym = s;
2226
2227           if (s->ts.type != BT_UNKNOWN)
2228             expr->ts = s->ts;
2229           else if (s->result != NULL && s->result->ts.type != BT_UNKNOWN)
2230             expr->ts = s->result->ts;
2231
2232           if (s->as != NULL)
2233             expr->rank = s->as->rank;
2234           else if (s->result != NULL && s->result->as != NULL)
2235             expr->rank = s->result->as->rank;
2236
2237           gfc_set_sym_referenced (expr->value.function.esym);
2238
2239           return MATCH_YES;
2240         }
2241
2242       /* TODO: Need to search for elemental references in generic
2243          interface.  */
2244     }
2245
2246   if (sym->attr.intrinsic)
2247     return gfc_intrinsic_func_interface (expr, 0);
2248
2249   return MATCH_NO;
2250 }
2251
2252
2253 static gfc_try
2254 resolve_generic_f (gfc_expr *expr)
2255 {
2256   gfc_symbol *sym;
2257   match m;
2258
2259   sym = expr->symtree->n.sym;
2260
2261   for (;;)
2262     {
2263       m = resolve_generic_f0 (expr, sym);
2264       if (m == MATCH_YES)
2265         return SUCCESS;
2266       else if (m == MATCH_ERROR)
2267         return FAILURE;
2268
2269 generic:
2270       if (sym->ns->parent == NULL)
2271         break;
2272       gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
2273
2274       if (sym == NULL)
2275         break;
2276       if (!generic_sym (sym))
2277         goto generic;
2278     }
2279
2280   /* Last ditch attempt.  See if the reference is to an intrinsic
2281      that possesses a matching interface.  14.1.2.4  */
2282   if (sym && !gfc_is_intrinsic (sym, 0, expr->where))
2283     {
2284       gfc_error ("There is no specific function for the generic '%s' at %L",
2285                  expr->symtree->n.sym->name, &expr->where);
2286       return FAILURE;
2287     }
2288
2289   m = gfc_intrinsic_func_interface (expr, 0);
2290   if (m == MATCH_YES)
2291     return SUCCESS;
2292   if (m == MATCH_NO)
2293     gfc_error ("Generic function '%s' at %L is not consistent with a "
2294                "specific intrinsic interface", expr->symtree->n.sym->name,
2295                &expr->where);
2296
2297   return FAILURE;
2298 }
2299
2300
2301 /* Resolve a function call known to be specific.  */
2302
2303 static match
2304 resolve_specific_f0 (gfc_symbol *sym, gfc_expr *expr)
2305 {
2306   match m;
2307
2308   if (sym->attr.external || sym->attr.if_source == IFSRC_IFBODY)
2309     {
2310       if (sym->attr.dummy)
2311         {
2312           sym->attr.proc = PROC_DUMMY;
2313           goto found;
2314         }
2315
2316       sym->attr.proc = PROC_EXTERNAL;
2317       goto found;
2318     }
2319
2320   if (sym->attr.proc == PROC_MODULE
2321       || sym->attr.proc == PROC_ST_FUNCTION
2322       || sym->attr.proc == PROC_INTERNAL)
2323     goto found;
2324
2325   if (sym->attr.intrinsic)
2326     {
2327       m = gfc_intrinsic_func_interface (expr, 1);
2328       if (m == MATCH_YES)
2329         return MATCH_YES;
2330       if (m == MATCH_NO)
2331         gfc_error ("Function '%s' at %L is INTRINSIC but is not compatible "
2332                    "with an intrinsic", sym->name, &expr->where);
2333
2334       return MATCH_ERROR;
2335     }
2336
2337   return MATCH_NO;
2338
2339 found:
2340   gfc_procedure_use (sym, &expr->value.function.actual, &expr->where);
2341
2342   if (sym->result)
2343     expr->ts = sym->result->ts;
2344   else
2345     expr->ts = sym->ts;
2346   expr->value.function.name = sym->name;
2347   expr->value.function.esym = sym;
2348   if (sym->as != NULL)
2349     expr->rank = sym->as->rank;
2350
2351   return MATCH_YES;
2352 }
2353
2354
2355 static gfc_try
2356 resolve_specific_f (gfc_expr *expr)
2357 {
2358   gfc_symbol *sym;
2359   match m;
2360
2361   sym = expr->symtree->n.sym;
2362
2363   for (;;)
2364     {
2365       m = resolve_specific_f0 (sym, expr);
2366       if (m == MATCH_YES)
2367         return SUCCESS;
2368       if (m == MATCH_ERROR)
2369         return FAILURE;
2370
2371       if (sym->ns->parent == NULL)
2372         break;
2373
2374       gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
2375
2376       if (sym == NULL)
2377         break;
2378     }
2379
2380   gfc_error ("Unable to resolve the specific function '%s' at %L",
2381              expr->symtree->n.sym->name, &expr->where);
2382
2383   return SUCCESS;
2384 }
2385
2386
2387 /* Resolve a procedure call not known to be generic nor specific.  */
2388
2389 static gfc_try
2390 resolve_unknown_f (gfc_expr *expr)
2391 {
2392   gfc_symbol *sym;
2393   gfc_typespec *ts;
2394
2395   sym = expr->symtree->n.sym;
2396
2397   if (sym->attr.dummy)
2398     {
2399       sym->attr.proc = PROC_DUMMY;
2400       expr->value.function.name = sym->name;
2401       goto set_type;
2402     }
2403
2404   /* See if we have an intrinsic function reference.  */
2405
2406   if (gfc_is_intrinsic (sym, 0, expr->where))
2407     {
2408       if (gfc_intrinsic_func_interface (expr, 1) == MATCH_YES)
2409         return SUCCESS;
2410       return FAILURE;
2411     }
2412
2413   /* The reference is to an external name.  */
2414
2415   sym->attr.proc = PROC_EXTERNAL;
2416   expr->value.function.name = sym->name;
2417   expr->value.function.esym = expr->symtree->n.sym;
2418
2419   if (sym->as != NULL)
2420     expr->rank = sym->as->rank;
2421
2422   /* Type of the expression is either the type of the symbol or the
2423      default type of the symbol.  */
2424
2425 set_type:
2426   gfc_procedure_use (sym, &expr->value.function.actual, &expr->where);
2427
2428   if (sym->ts.type != BT_UNKNOWN)
2429     expr->ts = sym->ts;
2430   else
2431     {
2432       ts = gfc_get_default_type (sym->name, sym->ns);
2433
2434       if (ts->type == BT_UNKNOWN)
2435         {
2436           gfc_error ("Function '%s' at %L has no IMPLICIT type",
2437                      sym->name, &expr->where);
2438           return FAILURE;
2439         }
2440       else
2441         expr->ts = *ts;
2442     }
2443
2444   return SUCCESS;
2445 }
2446
2447
2448 /* Return true, if the symbol is an external procedure.  */
2449 static bool
2450 is_external_proc (gfc_symbol *sym)
2451 {
2452   if (!sym->attr.dummy && !sym->attr.contained
2453         && !(sym->attr.intrinsic
2454               || gfc_is_intrinsic (sym, sym->attr.subroutine, sym->declared_at))
2455         && sym->attr.proc != PROC_ST_FUNCTION
2456         && !sym->attr.proc_pointer
2457         && !sym->attr.use_assoc
2458         && sym->name)
2459     return true;
2460
2461   return false;
2462 }
2463
2464
2465 /* Figure out if a function reference is pure or not.  Also set the name
2466    of the function for a potential error message.  Return nonzero if the
2467    function is PURE, zero if not.  */
2468 static int
2469 pure_stmt_function (gfc_expr *, gfc_symbol *);
2470
2471 static int
2472 pure_function (gfc_expr *e, const char **name)
2473 {
2474   int pure;
2475
2476   *name = NULL;
2477
2478   if (e->symtree != NULL
2479         && e->symtree->n.sym != NULL
2480         && e->symtree->n.sym->attr.proc == PROC_ST_FUNCTION)
2481     return pure_stmt_function (e, e->symtree->n.sym);
2482
2483   if (e->value.function.esym)
2484     {
2485       pure = gfc_pure (e->value.function.esym);
2486       *name = e->value.function.esym->name;
2487     }
2488   else if (e->value.function.isym)
2489     {
2490       pure = e->value.function.isym->pure
2491              || e->value.function.isym->elemental;
2492       *name = e->value.function.isym->name;
2493     }
2494   else
2495     {
2496       /* Implicit functions are not pure.  */
2497       pure = 0;
2498       *name = e->value.function.name;
2499     }
2500
2501   return pure;
2502 }
2503
2504
2505 static bool
2506 impure_stmt_fcn (gfc_expr *e, gfc_symbol *sym,
2507                  int *f ATTRIBUTE_UNUSED)
2508 {
2509   const char *name;
2510
2511   /* Don't bother recursing into other statement functions
2512      since they will be checked individually for purity.  */
2513   if (e->expr_type != EXPR_FUNCTION
2514         || !e->symtree
2515         || e->symtree->n.sym == sym
2516         || e->symtree->n.sym->attr.proc == PROC_ST_FUNCTION)
2517     return false;
2518
2519   return pure_function (e, &name) ? false : true;
2520 }
2521
2522
2523 static int
2524 pure_stmt_function (gfc_expr *e, gfc_symbol *sym)
2525 {
2526   return gfc_traverse_expr (e, sym, impure_stmt_fcn, 0) ? 0 : 1;
2527 }
2528
2529
2530 static gfc_try
2531 is_scalar_expr_ptr (gfc_expr *expr)
2532 {
2533   gfc_try retval = SUCCESS;
2534   gfc_ref *ref;
2535   int start;
2536   int end;
2537
2538   /* See if we have a gfc_ref, which means we have a substring, array
2539      reference, or a component.  */
2540   if (expr->ref != NULL)
2541     {
2542       ref = expr->ref;
2543       while (ref->next != NULL)
2544         ref = ref->next;
2545
2546       switch (ref->type)
2547         {
2548         case REF_SUBSTRING:
2549           if (ref->u.ss.length != NULL
2550               && ref->u.ss.length->length != NULL
2551               && ref->u.ss.start
2552               && ref->u.ss.start->expr_type == EXPR_CONSTANT
2553               && ref->u.ss.end
2554               && ref->u.ss.end->expr_type == EXPR_CONSTANT)
2555             {
2556               start = (int) mpz_get_si (ref->u.ss.start->value.integer);
2557               end = (int) mpz_get_si (ref->u.ss.end->value.integer);
2558               if (end - start + 1 != 1)
2559                 retval = FAILURE;
2560             }
2561           else
2562             retval = FAILURE;
2563           break;
2564         case REF_ARRAY:
2565           if (ref->u.ar.type == AR_ELEMENT)
2566             retval = SUCCESS;
2567           else if (ref->u.ar.type == AR_FULL)
2568             {
2569               /* The user can give a full array if the array is of size 1.  */
2570               if (ref->u.ar.as != NULL
2571                   && ref->u.ar.as->rank == 1
2572                   && ref->u.ar.as->type == AS_EXPLICIT
2573                   && ref->u.ar.as->lower[0] != NULL
2574                   && ref->u.ar.as->lower[0]->expr_type == EXPR_CONSTANT
2575                   && ref->u.ar.as->upper[0] != NULL
2576                   && ref->u.ar.as->upper[0]->expr_type == EXPR_CONSTANT)
2577                 {
2578                   /* If we have a character string, we need to check if
2579                      its length is one.  */
2580                   if (expr->ts.type == BT_CHARACTER)
2581                     {
2582                       if (expr->ts.u.cl == NULL
2583                           || expr->ts.u.cl->length == NULL
2584                           || mpz_cmp_si (expr->ts.u.cl->length->value.integer, 1)
2585                           != 0)
2586                         retval = FAILURE;
2587                     }
2588                   else
2589                     {
2590                       /* We have constant lower and upper bounds.  If the
2591                          difference between is 1, it can be considered a
2592                          scalar.  */
2593                       start = (int) mpz_get_si
2594                                 (ref->u.ar.as->lower[0]->value.integer);
2595                       end = (int) mpz_get_si
2596                                 (ref->u.ar.as->upper[0]->value.integer);
2597                       if (end - start + 1 != 1)
2598                         retval = FAILURE;
2599                    }
2600                 }
2601               else
2602                 retval = FAILURE;
2603             }
2604           else
2605             retval = FAILURE;
2606           break;
2607         default:
2608           retval = SUCCESS;
2609           break;
2610         }
2611     }
2612   else if (expr->ts.type == BT_CHARACTER && expr->rank == 0)
2613     {
2614       /* Character string.  Make sure it's of length 1.  */
2615       if (expr->ts.u.cl == NULL
2616           || expr->ts.u.cl->length == NULL
2617           || mpz_cmp_si (expr->ts.u.cl->length->value.integer, 1) != 0)
2618         retval = FAILURE;
2619     }
2620   else if (expr->rank != 0)
2621     retval = FAILURE;
2622
2623   return retval;
2624 }
2625
2626
2627 /* Match one of the iso_c_binding functions (c_associated or c_loc)
2628    and, in the case of c_associated, set the binding label based on
2629    the arguments.  */
2630
2631 static gfc_try
2632 gfc_iso_c_func_interface (gfc_symbol *sym, gfc_actual_arglist *args,
2633                           gfc_symbol **new_sym)
2634 {
2635   char name[GFC_MAX_SYMBOL_LEN + 1];
2636   char binding_label[GFC_MAX_BINDING_LABEL_LEN + 1];
2637   int optional_arg = 0;
2638   gfc_try retval = SUCCESS;
2639   gfc_symbol *args_sym;
2640   gfc_typespec *arg_ts;
2641   symbol_attribute arg_attr;
2642
2643   if (args->expr->expr_type == EXPR_CONSTANT
2644       || args->expr->expr_type == EXPR_OP
2645       || args->expr->expr_type == EXPR_NULL)
2646     {
2647       gfc_error ("Argument to '%s' at %L is not a variable",
2648                  sym->name, &(args->expr->where));
2649       return FAILURE;
2650     }
2651
2652   args_sym = args->expr->symtree->n.sym;
2653
2654   /* The typespec for the actual arg should be that stored in the expr
2655      and not necessarily that of the expr symbol (args_sym), because
2656      the actual expression could be a part-ref of the expr symbol.  */
2657   arg_ts = &(args->expr->ts);
2658   arg_attr = gfc_expr_attr (args->expr);
2659
2660   if (sym->intmod_sym_id == ISOCBINDING_ASSOCIATED)
2661     {
2662       /* If the user gave two args then they are providing something for
2663          the optional arg (the second cptr).  Therefore, set the name and
2664          binding label to the c_associated for two cptrs.  Otherwise,
2665          set c_associated to expect one cptr.  */
2666       if (args->next)
2667         {
2668           /* two args.  */
2669           sprintf (name, "%s_2", sym->name);
2670           sprintf (binding_label, "%s_2", sym->binding_label);
2671           optional_arg = 1;
2672         }
2673       else
2674         {
2675           /* one arg.  */
2676           sprintf (name, "%s_1", sym->name);
2677           sprintf (binding_label, "%s_1", sym->binding_label);
2678           optional_arg = 0;
2679         }
2680
2681       /* Get a new symbol for the version of c_associated that
2682          will get called.  */
2683       *new_sym = get_iso_c_sym (sym, name, binding_label, optional_arg);
2684     }
2685   else if (sym->intmod_sym_id == ISOCBINDING_LOC
2686            || sym->intmod_sym_id == ISOCBINDING_FUNLOC)
2687     {
2688       sprintf (name, "%s", sym->name);
2689       sprintf (binding_label, "%s", sym->binding_label);
2690
2691       /* Error check the call.  */
2692       if (args->next != NULL)
2693         {
2694           gfc_error_now ("More actual than formal arguments in '%s' "
2695                          "call at %L", name, &(args->expr->where));
2696           retval = FAILURE;
2697         }
2698       else if (sym->intmod_sym_id == ISOCBINDING_LOC)
2699         {
2700           /* Make sure we have either the target or pointer attribute.  */
2701           if (!arg_attr.target && !arg_attr.pointer)
2702             {
2703               gfc_error_now ("Parameter '%s' to '%s' at %L must be either "
2704                              "a TARGET or an associated pointer",
2705                              args_sym->name,
2706                              sym->name, &(args->expr->where));
2707               retval = FAILURE;
2708             }
2709
2710           /* See if we have interoperable type and type param.  */
2711           if (verify_c_interop (arg_ts) == SUCCESS
2712               || gfc_check_any_c_kind (arg_ts) == SUCCESS)
2713             {
2714               if (args_sym->attr.target == 1)
2715                 {
2716                   /* Case 1a, section 15.1.2.5, J3/04-007: variable that
2717                      has the target attribute and is interoperable.  */
2718                   /* Case 1b, section 15.1.2.5, J3/04-007: allocated
2719                      allocatable variable that has the TARGET attribute and
2720                      is not an array of zero size.  */
2721                   if (args_sym->attr.allocatable == 1)
2722                     {
2723                       if (args_sym->attr.dimension != 0
2724                           && (args_sym->as && args_sym->as->rank == 0))
2725                         {
2726                           gfc_error_now ("Allocatable variable '%s' used as a "
2727                                          "parameter to '%s' at %L must not be "
2728                                          "an array of zero size",
2729                                          args_sym->name, sym->name,
2730                                          &(args->expr->where));
2731                           retval = FAILURE;
2732                         }
2733                     }
2734                   else
2735                     {
2736                       /* A non-allocatable target variable with C
2737                          interoperable type and type parameters must be
2738                          interoperable.  */
2739                       if (args_sym && args_sym->attr.dimension)
2740                         {
2741                           if (args_sym->as->type == AS_ASSUMED_SHAPE)
2742                             {
2743                               gfc_error ("Assumed-shape array '%s' at %L "
2744                                          "cannot be an argument to the "
2745                                          "procedure '%s' because "
2746                                          "it is not C interoperable",
2747                                          args_sym->name,
2748                                          &(args->expr->where), sym->name);
2749                               retval = FAILURE;
2750                             }
2751                           else if (args_sym->as->type == AS_DEFERRED)
2752                             {
2753                               gfc_error ("Deferred-shape array '%s' at %L "
2754                                          "cannot be an argument to the "
2755                                          "procedure '%s' because "
2756                                          "it is not C interoperable",
2757                                          args_sym->name,
2758                                          &(args->expr->where), sym->name);
2759                               retval = FAILURE;
2760                             }
2761                         }
2762
2763                       /* Make sure it's not a character string.  Arrays of
2764                          any type should be ok if the variable is of a C
2765                          interoperable type.  */
2766                       if (arg_ts->type == BT_CHARACTER)
2767                         if (arg_ts->u.cl != NULL
2768                             && (arg_ts->u.cl->length == NULL
2769                                 || arg_ts->u.cl->length->expr_type
2770                                    != EXPR_CONSTANT
2771                                 || mpz_cmp_si
2772                                     (arg_ts->u.cl->length->value.integer, 1)
2773                                    != 0)
2774                             && is_scalar_expr_ptr (args->expr) != SUCCESS)
2775                           {
2776                             gfc_error_now ("CHARACTER argument '%s' to '%s' "
2777                                            "at %L must have a length of 1",
2778                                            args_sym->name, sym->name,
2779                                            &(args->expr->where));
2780                             retval = FAILURE;
2781                           }
2782                     }
2783                 }
2784               else if (arg_attr.pointer
2785                        && is_scalar_expr_ptr (args->expr) != SUCCESS)
2786                 {
2787                   /* Case 1c, section 15.1.2.5, J3/04-007: an associated
2788                      scalar pointer.  */
2789                   gfc_error_now ("Argument '%s' to '%s' at %L must be an "
2790                                  "associated scalar POINTER", args_sym->name,
2791                                  sym->name, &(args->expr->where));
2792                   retval = FAILURE;
2793                 }
2794             }
2795           else
2796             {
2797               /* The parameter is not required to be C interoperable.  If it
2798                  is not C interoperable, it must be a nonpolymorphic scalar
2799                  with no length type parameters.  It still must have either
2800                  the pointer or target attribute, and it can be
2801                  allocatable (but must be allocated when c_loc is called).  */
2802               if (args->expr->rank != 0
2803                   && is_scalar_expr_ptr (args->expr) != SUCCESS)
2804                 {
2805                   gfc_error_now ("Parameter '%s' to '%s' at %L must be a "
2806                                  "scalar", args_sym->name, sym->name,
2807                                  &(args->expr->where));
2808                   retval = FAILURE;
2809                 }
2810               else if (arg_ts->type == BT_CHARACTER
2811                        && is_scalar_expr_ptr (args->expr) != SUCCESS)
2812                 {
2813                   gfc_error_now ("CHARACTER argument '%s' to '%s' at "
2814                                  "%L must have a length of 1",
2815                                  args_sym->name, sym->name,
2816                                  &(args->expr->where));
2817                   retval = FAILURE;
2818                 }
2819               else if (arg_ts->type == BT_CLASS)
2820                 {
2821                   gfc_error_now ("Parameter '%s' to '%s' at %L must not be "
2822                                  "polymorphic", args_sym->name, sym->name,
2823                                  &(args->expr->where));
2824                   retval = FAILURE;
2825                 }
2826             }
2827         }
2828       else if (sym->intmod_sym_id == ISOCBINDING_FUNLOC)
2829         {
2830           if (args_sym->attr.flavor != FL_PROCEDURE)
2831             {
2832               /* TODO: Update this error message to allow for procedure
2833                  pointers once they are implemented.  */
2834               gfc_error_now ("Parameter '%s' to '%s' at %L must be a "
2835                              "procedure",
2836                              args_sym->name, sym->name,
2837                              &(args->expr->where));
2838               retval = FAILURE;
2839             }
2840           else if (args_sym->attr.is_bind_c != 1)
2841             {
2842               gfc_error_now ("Parameter '%s' to '%s' at %L must be "
2843                              "BIND(C)",
2844                              args_sym->name, sym->name,
2845                              &(args->expr->where));
2846               retval = FAILURE;
2847             }
2848         }
2849
2850       /* for c_loc/c_funloc, the new symbol is the same as the old one */
2851       *new_sym = sym;
2852     }
2853   else
2854     {
2855       gfc_internal_error ("gfc_iso_c_func_interface(): Unhandled "
2856                           "iso_c_binding function: '%s'!\n", sym->name);
2857     }
2858
2859   return retval;
2860 }
2861
2862
2863 /* Resolve a function call, which means resolving the arguments, then figuring
2864    out which entity the name refers to.  */
2865
2866 static gfc_try
2867 resolve_function (gfc_expr *expr)
2868 {
2869   gfc_actual_arglist *arg;
2870   gfc_symbol *sym;
2871   const char *name;
2872   gfc_try t;
2873   int temp;
2874   procedure_type p = PROC_INTRINSIC;
2875   bool no_formal_args;
2876
2877   sym = NULL;
2878   if (expr->symtree)
2879     sym = expr->symtree->n.sym;
2880
2881   /* If this is a procedure pointer component, it has already been resolved.  */
2882   if (gfc_is_proc_ptr_comp (expr, NULL))
2883     return SUCCESS;
2884
2885   if (sym && sym->attr.intrinsic
2886       && resolve_intrinsic (sym, &expr->where) == FAILURE)
2887     return FAILURE;
2888
2889   if (sym && (sym->attr.flavor == FL_VARIABLE || sym->attr.subroutine))
2890     {
2891       gfc_error ("'%s' at %L is not a function", sym->name, &expr->where);
2892       return FAILURE;
2893     }
2894
2895   /* If this ia a deferred TBP with an abstract interface (which may
2896      of course be referenced), expr->value.function.esym will be set.  */
2897   if (sym && sym->attr.abstract && !expr->value.function.esym)
2898     {
2899       gfc_error ("ABSTRACT INTERFACE '%s' must not be referenced at %L",
2900                  sym->name, &expr->where);
2901       return FAILURE;
2902     }
2903
2904   /* Switch off assumed size checking and do this again for certain kinds
2905      of procedure, once the procedure itself is resolved.  */
2906   need_full_assumed_size++;
2907
2908   if (expr->symtree && expr->symtree->n.sym)
2909     p = expr->symtree->n.sym->attr.proc;
2910
2911   if (expr->value.function.isym && expr->value.function.isym->inquiry)
2912     inquiry_argument = true;
2913   no_formal_args = sym && is_external_proc (sym) && sym->formal == NULL;
2914
2915   if (resolve_actual_arglist (expr->value.function.actual,
2916                               p, no_formal_args) == FAILURE)
2917     {
2918       inquiry_argument = false;
2919       return FAILURE;
2920     }
2921
2922   inquiry_argument = false;
2923
2924   /* Need to setup the call to the correct c_associated, depending on
2925      the number of cptrs to user gives to compare.  */
2926   if (sym && sym->attr.is_iso_c == 1)
2927     {
2928       if (gfc_iso_c_func_interface (sym, expr->value.function.actual, &sym)
2929           == FAILURE)
2930         return FAILURE;
2931
2932       /* Get the symtree for the new symbol (resolved func).
2933          the old one will be freed later, when it's no longer used.  */
2934       gfc_find_sym_tree (sym->name, sym->ns, 1, &(expr->symtree));
2935     }
2936
2937   /* Resume assumed_size checking.  */
2938   need_full_assumed_size--;
2939
2940   /* If the procedure is external, check for usage.  */
2941   if (sym && is_external_proc (sym))
2942     resolve_global_procedure (sym, &expr->where,
2943                               &expr->value.function.actual, 0);
2944
2945   if (sym && sym->ts.type == BT_CHARACTER
2946       && sym->ts.u.cl
2947       && sym->ts.u.cl->length == NULL
2948       && !sym->attr.dummy
2949       && expr->value.function.esym == NULL
2950       && !sym->attr.contained)
2951     {
2952       /* Internal procedures are taken care of in resolve_contained_fntype.  */
2953       gfc_error ("Function '%s' is declared CHARACTER(*) and cannot "
2954                  "be used at %L since it is not a dummy argument",
2955                  sym->name, &expr->where);
2956       return FAILURE;
2957     }
2958
2959   /* See if function is already resolved.  */
2960
2961   if (expr->value.function.name != NULL)
2962     {
2963       if (expr->ts.type == BT_UNKNOWN)
2964         expr->ts = sym->ts;
2965       t = SUCCESS;
2966     }
2967   else
2968     {
2969       /* Apply the rules of section 14.1.2.  */
2970
2971       switch (procedure_kind (sym))
2972         {
2973         case PTYPE_GENERIC:
2974           t = resolve_generic_f (expr);
2975           break;
2976
2977         case PTYPE_SPECIFIC:
2978           t = resolve_specific_f (expr);
2979           break;
2980
2981         case PTYPE_UNKNOWN:
2982           t = resolve_unknown_f (expr);
2983           break;
2984
2985         default:
2986           gfc_internal_error ("resolve_function(): bad function type");
2987         }
2988     }
2989
2990   /* If the expression is still a function (it might have simplified),
2991      then we check to see if we are calling an elemental function.  */
2992
2993   if (expr->expr_type != EXPR_FUNCTION)
2994     return t;
2995
2996   temp = need_full_assumed_size;
2997   need_full_assumed_size = 0;
2998
2999   if (resolve_elemental_actual (expr, NULL) == FAILURE)
3000     return FAILURE;
3001
3002   if (omp_workshare_flag
3003       && expr->value.function.esym
3004       && ! gfc_elemental (expr->value.function.esym))
3005     {
3006       gfc_error ("User defined non-ELEMENTAL function '%s' at %L not allowed "
3007                  "in WORKSHARE construct", expr->value.function.esym->name,
3008                  &expr->where);
3009       t = FAILURE;
3010     }
3011
3012 #define GENERIC_ID expr->value.function.isym->id
3013   else if (expr->value.function.actual != NULL
3014            && expr->value.function.isym != NULL
3015            && GENERIC_ID != GFC_ISYM_LBOUND
3016            && GENERIC_ID != GFC_ISYM_LEN
3017            && GENERIC_ID != GFC_ISYM_LOC
3018            && GENERIC_ID != GFC_ISYM_PRESENT)
3019     {
3020       /* Array intrinsics must also have the last upper bound of an
3021          assumed size array argument.  UBOUND and SIZE have to be
3022          excluded from the check if the second argument is anything
3023          than a constant.  */
3024
3025       for (arg = expr->value.function.actual; arg; arg = arg->next)
3026         {
3027           if ((GENERIC_ID == GFC_ISYM_UBOUND || GENERIC_ID == GFC_ISYM_SIZE)
3028               && arg->next != NULL && arg->next->expr)
3029             {
3030               if (arg->next->expr->expr_type != EXPR_CONSTANT)
3031                 break;
3032
3033               if (arg->next->name && strncmp(arg->next->name, "kind", 4) == 0)
3034                 break;
3035
3036               if ((int)mpz_get_si (arg->next->expr->value.integer)
3037                         < arg->expr->rank)
3038                 break;
3039             }
3040
3041           if (arg->expr != NULL
3042               && arg->expr->rank > 0
3043               && resolve_assumed_size_actual (arg->expr))
3044             return FAILURE;
3045         }
3046     }
3047 #undef GENERIC_ID
3048
3049   need_full_assumed_size = temp;
3050   name = NULL;
3051
3052   if (!pure_function (expr, &name) && name)
3053     {
3054       if (forall_flag)
3055         {
3056           gfc_error ("reference to non-PURE function '%s' at %L inside a "
3057                      "FORALL %s", name, &expr->where,
3058                      forall_flag == 2 ? "mask" : "block");
3059           t = FAILURE;
3060         }
3061       else if (gfc_pure (NULL))
3062         {
3063           gfc_error ("Function reference to '%s' at %L is to a non-PURE "
3064                      "procedure within a PURE procedure", name, &expr->where);
3065           t = FAILURE;
3066         }
3067     }
3068
3069   /* Functions without the RECURSIVE attribution are not allowed to
3070    * call themselves.  */
3071   if (expr->value.function.esym && !expr->value.function.esym->attr.recursive)
3072     {
3073       gfc_symbol *esym;
3074       esym = expr->value.function.esym;
3075
3076       if (is_illegal_recursion (esym, gfc_current_ns))
3077       {
3078         if (esym->attr.entry && esym->ns->entries)
3079           gfc_error ("ENTRY '%s' at %L cannot be called recursively, as"
3080                      " function '%s' is not RECURSIVE",
3081                      esym->name, &expr->where, esym->ns->entries->sym->name);
3082         else
3083           gfc_error ("Function '%s' at %L cannot be called recursively, as it"
3084                      " is not RECURSIVE", esym->name, &expr->where);
3085
3086         t = FAILURE;
3087       }
3088     }
3089
3090   /* Character lengths of use associated functions may contains references to
3091      symbols not referenced from the current program unit otherwise.  Make sure
3092      those symbols are marked as referenced.  */
3093
3094   if (expr->ts.type == BT_CHARACTER && expr->value.function.esym
3095       && expr->value.function.esym->attr.use_assoc)
3096     {
3097       gfc_expr_set_symbols_referenced (expr->ts.u.cl->length);
3098     }
3099
3100   /* Make sure that the expression has a typespec that works.  */
3101   if (expr->ts.type == BT_UNKNOWN)
3102     {
3103       if (expr->symtree->n.sym->result
3104             && expr->symtree->n.sym->result->ts.type != BT_UNKNOWN
3105             && !expr->symtree->n.sym->result->attr.proc_pointer)
3106         expr->ts = expr->symtree->n.sym->result->ts;
3107     }
3108
3109   return t;
3110 }
3111
3112
3113 /************* Subroutine resolution *************/
3114
3115 static void
3116 pure_subroutine (gfc_code *c, gfc_symbol *sym)
3117 {
3118   if (gfc_pure (sym))
3119     return;
3120
3121   if (forall_flag)
3122     gfc_error ("Subroutine call to '%s' in FORALL block at %L is not PURE",
3123                sym->name, &c->loc);
3124   else if (gfc_pure (NULL))
3125     gfc_error ("Subroutine call to '%s' at %L is not PURE", sym->name,
3126                &c->loc);
3127 }
3128
3129
3130 static match
3131 resolve_generic_s0 (gfc_code *c, gfc_symbol *sym)
3132 {
3133   gfc_symbol *s;
3134
3135   if (sym->attr.generic)
3136     {
3137       s = gfc_search_interface (sym->generic, 1, &c->ext.actual);
3138       if (s != NULL)
3139         {
3140           c->resolved_sym = s;
3141           pure_subroutine (c, s);
3142           return MATCH_YES;
3143         }
3144
3145       /* TODO: Need to search for elemental references in generic interface.  */
3146     }
3147
3148   if (sym->attr.intrinsic)
3149     return gfc_intrinsic_sub_interface (c, 0);
3150
3151   return MATCH_NO;
3152 }
3153
3154
3155 static gfc_try
3156 resolve_generic_s (gfc_code *c)
3157 {
3158   gfc_symbol *sym;
3159   match m;
3160
3161   sym = c->symtree->n.sym;
3162
3163   for (;;)
3164     {
3165       m = resolve_generic_s0 (c, sym);
3166       if (m == MATCH_YES)
3167         return SUCCESS;
3168       else if (m == MATCH_ERROR)
3169         return FAILURE;
3170
3171 generic:
3172       if (sym->ns->parent == NULL)
3173         break;
3174       gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
3175
3176       if (sym == NULL)
3177         break;
3178       if (!generic_sym (sym))
3179         goto generic;
3180     }
3181
3182   /* Last ditch attempt.  See if the reference is to an intrinsic
3183      that possesses a matching interface.  14.1.2.4  */
3184   sym = c->symtree->n.sym;
3185
3186   if (!gfc_is_intrinsic (sym, 1, c->loc))
3187     {
3188       gfc_error ("There is no specific subroutine for the generic '%s' at %L",
3189                  sym->name, &c->loc);
3190       return FAILURE;
3191     }
3192
3193   m = gfc_intrinsic_sub_interface (c, 0);
3194   if (m == MATCH_YES)
3195     return SUCCESS;
3196   if (m == MATCH_NO)
3197     gfc_error ("Generic subroutine '%s' at %L is not consistent with an "
3198                "intrinsic subroutine interface", sym->name, &c->loc);
3199
3200   return FAILURE;
3201 }
3202
3203
3204 /* Set the name and binding label of the subroutine symbol in the call
3205    expression represented by 'c' to include the type and kind of the
3206    second parameter.  This function is for resolving the appropriate
3207    version of c_f_pointer() and c_f_procpointer().  For example, a
3208    call to c_f_pointer() for a default integer pointer could have a
3209    name of c_f_pointer_i4.  If no second arg exists, which is an error
3210    for these two functions, it defaults to the generic symbol's name
3211    and binding label.  */
3212
3213 static void
3214 set_name_and_label (gfc_code *c, gfc_symbol *sym,
3215                     char *name, char *binding_label)
3216 {
3217   gfc_expr *arg = NULL;
3218   char type;
3219   int kind;
3220
3221   /* The second arg of c_f_pointer and c_f_procpointer determines
3222      the type and kind for the procedure name.  */
3223   arg = c->ext.actual->next->expr;
3224
3225   if (arg != NULL)
3226     {
3227       /* Set up the name to have the given symbol's name,
3228          plus the type and kind.  */
3229       /* a derived type is marked with the type letter 'u' */
3230       if (arg->ts.type == BT_DERIVED)
3231         {
3232           type = 'd';
3233           kind = 0; /* set the kind as 0 for now */
3234         }
3235       else
3236         {
3237           type = gfc_type_letter (arg->ts.type);
3238           kind = arg->ts.kind;
3239         }
3240
3241       if (arg->ts.type == BT_CHARACTER)
3242         /* Kind info for character strings not needed.  */
3243         kind = 0;
3244
3245       sprintf (name, "%s_%c%d", sym->name, type, kind);
3246       /* Set up the binding label as the given symbol's label plus
3247          the type and kind.  */
3248       sprintf (binding_label, "%s_%c%d", sym->binding_label, type, kind);
3249     }
3250   else
3251     {
3252       /* If the second arg is missing, set the name and label as
3253          was, cause it should at least be found, and the missing
3254          arg error will be caught by compare_parameters().  */
3255       sprintf (name, "%s", sym->name);
3256       sprintf (binding_label, "%s", sym->binding_label);
3257     }
3258
3259   return;
3260 }
3261
3262
3263 /* Resolve a generic version of the iso_c_binding procedure given
3264    (sym) to the specific one based on the type and kind of the
3265    argument(s).  Currently, this function resolves c_f_pointer() and
3266    c_f_procpointer based on the type and kind of the second argument
3267    (FPTR).  Other iso_c_binding procedures aren't specially handled.
3268    Upon successfully exiting, c->resolved_sym will hold the resolved
3269    symbol.  Returns MATCH_ERROR if an error occurred; MATCH_YES
3270    otherwise.  */
3271
3272 match
3273 gfc_iso_c_sub_interface (gfc_code *c, gfc_symbol *sym)
3274 {
3275   gfc_symbol *new_sym;
3276   /* this is fine, since we know the names won't use the max */
3277   char name[GFC_MAX_SYMBOL_LEN + 1];
3278   char binding_label[GFC_MAX_BINDING_LABEL_LEN + 1];
3279   /* default to success; will override if find error */
3280   match m = MATCH_YES;
3281
3282   /* Make sure the actual arguments are in the necessary order (based on the
3283      formal args) before resolving.  */
3284   gfc_procedure_use (sym, &c->ext.actual, &(c->loc));
3285
3286   if ((sym->intmod_sym_id == ISOCBINDING_F_POINTER) ||
3287       (sym->intmod_sym_id == ISOCBINDING_F_PROCPOINTER))
3288     {
3289       set_name_and_label (c, sym, name, binding_label);
3290
3291       if (sym->intmod_sym_id == ISOCBINDING_F_POINTER)
3292         {
3293           if (c->ext.actual != NULL && c->ext.actual->next != NULL)
3294             {
3295               /* Make sure we got a third arg if the second arg has non-zero
3296                  rank.  We must also check that the type and rank are
3297                  correct since we short-circuit this check in
3298                  gfc_procedure_use() (called above to sort actual args).  */
3299               if (c->ext.actual->next->expr->rank != 0)
3300                 {
3301                   if(c->ext.actual->next->next == NULL
3302                      || c->ext.actual->next->next->expr == NULL)
3303                     {
3304                       m = MATCH_ERROR;
3305                       gfc_error ("Missing SHAPE parameter for call to %s "
3306                                  "at %L", sym->name, &(c->loc));
3307                     }
3308                   else if (c->ext.actual->next->next->expr->ts.type
3309                            != BT_INTEGER
3310                            || c->ext.actual->next->next->expr->rank != 1)
3311                     {
3312                       m = MATCH_ERROR;
3313                       gfc_error ("SHAPE parameter for call to %s at %L must "
3314                                  "be a rank 1 INTEGER array", sym->name,
3315                                  &(c->loc));
3316                     }
3317                 }
3318             }
3319         }
3320
3321       if (m != MATCH_ERROR)
3322         {
3323           /* the 1 means to add the optional arg to formal list */
3324           new_sym = get_iso_c_sym (sym, name, binding_label, 1);
3325
3326           /* for error reporting, say it's declared where the original was */
3327           new_sym->declared_at = sym->declared_at;
3328         }
3329     }
3330   else