gcc/fortran/resolve.c

   1 /* Perform type resolution on the various structures.
   2    Copyright (C) 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009,
   3    2010, 2011
   4    Free Software Foundation, Inc.
   5    Contributed by Andy Vaught
   6
   7 This file is part of GCC.
   8
   9 GCC is free software; you can redistribute it and/or modify it under
  10 the terms of the GNU General Public License as published by the Free
  11 Software Foundation; either version 3, or (at your option) any later
  12 version.
  13
  14 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
  15 WARRANTY; without even the implied warranty of MERCHANTABILITY or
  16 FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
  17 for more details.
  18
  19 You should have received a copy of the GNU General Public License
  20 along with GCC; see the file COPYING3.  If not see
  21 <http://www.gnu.org/licenses/>.  */
  22
  23 #include "config.h"
  24 #include "system.h"
  25 #include "flags.h"
  26 #include "gfortran.h"
  27 #include "obstack.h"
  28 #include "bitmap.h"
  29 #include "arith.h"  /* For gfc_compare_expr().  */
  30 #include "dependency.h"
  31 #include "data.h"
  32 #include "target-memory.h" /* for gfc_simplify_transfer */
  33 #include "constructor.h"
  34
  35 /* Types used in equivalence statements.  */
  36
  37 typedef enum seq_type
  38 {
  39   SEQ_NONDEFAULT, SEQ_NUMERIC, SEQ_CHARACTER, SEQ_MIXED
  40 }
  41 seq_type;
  42
  43 /* Stack to keep track of the nesting of blocks as we move through the
  44    code.  See resolve_branch() and resolve_code().  */
  45
  46 typedef struct code_stack
  47 {
  48   struct gfc_code *head, *current;
  49   struct code_stack *prev;
  50
  51   /* This bitmap keeps track of the targets valid for a branch from
  52      inside this block except for END {IF|SELECT}s of enclosing
  53      blocks.  */
  54   bitmap reachable_labels;
  55 }
  56 code_stack;
  57
  58 static code_stack *cs_base = NULL;
  59
  60
  61 /* Nonzero if we're inside a FORALL or DO CONCURRENT block.  */
  62
  63 static int forall_flag;
  64 static int do_concurrent_flag;
  65
  66 /* Nonzero if we're inside a OpenMP WORKSHARE or PARALLEL WORKSHARE block.  */
  67
  68 static int omp_workshare_flag;
  69
  70 /* Nonzero if we are processing a formal arglist. The corresponding function
  71    resets the flag each time that it is read.  */
  72 static int formal_arg_flag = 0;
  73
  74 /* True if we are resolving a specification expression.  */
  75 static int specification_expr = 0;
  76
  77 /* The id of the last entry seen.  */
  78 static int current_entry_id;
  79
  80 /* We use bitmaps to determine if a branch target is valid.  */
  81 static bitmap_obstack labels_obstack;
  82
  83 /* True when simplifying a EXPR_VARIABLE argument to an inquiry function.  */
  84 static bool inquiry_argument = false;
  85
  86 int
  87 gfc_is_formal_arg (void)
  88 {
  89   return formal_arg_flag;
  90 }
  91
  92 /* Is the symbol host associated?  */
  93 static bool
  94 is_sym_host_assoc (gfc_symbol *sym, gfc_namespace *ns)
  95 {
  96   for (ns = ns->parent; ns; ns = ns->parent)
  97     {
  98       if (sym->ns == ns)
  99         return true;
 100     }
 101
 102   return false;
 103 }
 104
 105 /* Ensure a typespec used is valid; for instance, TYPE(t) is invalid if t is
 106    an ABSTRACT derived-type.  If where is not NULL, an error message with that
 107    locus is printed, optionally using name.  */
 108
 109 static gfc_try
 110 resolve_typespec_used (gfc_typespec* ts, locus* where, const char* name)
 111 {
 112   if (ts->type == BT_DERIVED && ts->u.derived->attr.abstract)
 113     {
 114       if (where)
 115         {
 116           if (name)
 117             gfc_error ("'%s' at %L is of the ABSTRACT type '%s'",
 118                        name, where, ts->u.derived->name);
 119           else
 120             gfc_error ("ABSTRACT type '%s' used at %L",
 121                        ts->u.derived->name, where);
 122         }
 123
 124       return FAILURE;
 125     }
 126
 127   return SUCCESS;
 128 }
 129
 130
 131 static void resolve_symbol (gfc_symbol *sym);
 132 static gfc_try resolve_intrinsic (gfc_symbol *sym, locus *loc);
 133
 134
 135 /* Resolve the interface for a PROCEDURE declaration or procedure pointer.  */
 136
 137 static gfc_try
 138 resolve_procedure_interface (gfc_symbol *sym)
 139 {
 140   if (sym->ts.interface == sym)
 141     {
 142       gfc_error ("PROCEDURE '%s' at %L may not be used as its own interface",
 143                  sym->name, &sym->declared_at);
 144       return FAILURE;
 145     }
 146   if (sym->ts.interface->attr.procedure)
 147     {
 148       gfc_error ("Interface '%s', used by procedure '%s' at %L, is declared "
 149                  "in a later PROCEDURE statement", sym->ts.interface->name,
 150                  sym->name, &sym->declared_at);
 151       return FAILURE;
 152     }
 153
 154   /* Get the attributes from the interface (now resolved).  */
 155   if (sym->ts.interface->attr.if_source || sym->ts.interface->attr.intrinsic)
 156     {
 157       gfc_symbol *ifc = sym->ts.interface;
 158       resolve_symbol (ifc);
 159
 160       if (ifc->attr.intrinsic)
 161         resolve_intrinsic (ifc, &ifc->declared_at);
 162
 163       if (ifc->result)
 164         {
 165           sym->ts = ifc->result->ts;
 166           sym->result = sym;
 167         }
 168       else
 169         sym->ts = ifc->ts;
 170       sym->ts.interface = ifc;
 171       sym->attr.function = ifc->attr.function;
 172       sym->attr.subroutine = ifc->attr.subroutine;
 173       gfc_copy_formal_args (sym, ifc);
 174
 175       sym->attr.allocatable = ifc->attr.allocatable;
 176       sym->attr.pointer = ifc->attr.pointer;
 177       sym->attr.pure = ifc->attr.pure;
 178       sym->attr.elemental = ifc->attr.elemental;
 179       sym->attr.dimension = ifc->attr.dimension;
 180       sym->attr.contiguous = ifc->attr.contiguous;
 181       sym->attr.recursive = ifc->attr.recursive;
 182       sym->attr.always_explicit = ifc->attr.always_explicit;
 183       sym->attr.ext_attr |= ifc->attr.ext_attr;
 184       sym->attr.is_bind_c = ifc->attr.is_bind_c;
 185       /* Copy array spec.  */
 186       sym->as = gfc_copy_array_spec (ifc->as);
 187       if (sym->as)
 188         {
 189           int i;
 190           for (i = 0; i < sym->as->rank; i++)
 191             {
 192               gfc_expr_replace_symbols (sym->as->lower[i], sym);
 193               gfc_expr_replace_symbols (sym->as->upper[i], sym);
 194             }
 195         }
 196       /* Copy char length.  */
 197       if (ifc->ts.type == BT_CHARACTER && ifc->ts.u.cl)
 198         {
 199           sym->ts.u.cl = gfc_new_charlen (sym->ns, ifc->ts.u.cl);
 200           gfc_expr_replace_symbols (sym->ts.u.cl->length, sym);
 201           if (sym->ts.u.cl->length && !sym->ts.u.cl->resolved
 202               && gfc_resolve_expr (sym->ts.u.cl->length) == FAILURE)
 203             return FAILURE;
 204         }
 205     }
 206   else if (sym->ts.interface->name[0] != '\0')
 207     {
 208       gfc_error ("Interface '%s' of procedure '%s' at %L must be explicit",
 209                  sym->ts.interface->name, sym->name, &sym->declared_at);
 210       return FAILURE;
 211     }
 212
 213   return SUCCESS;
 214 }
 215
 216
 217 /* Resolve types of formal argument lists.  These have to be done early so that
 218    the formal argument lists of module procedures can be copied to the
 219    containing module before the individual procedures are resolved
 220    individually.  We also resolve argument lists of procedures in interface
 221    blocks because they are self-contained scoping units.
 222
 223    Since a dummy argument cannot be a non-dummy procedure, the only
 224    resort left for untyped names are the IMPLICIT types.  */
 225
 226 static void
 227 resolve_formal_arglist (gfc_symbol *proc)
 228 {
 229   gfc_formal_arglist *f;
 230   gfc_symbol *sym;
 231   int i;
 232
 233   if (proc->result != NULL)
 234     sym = proc->result;
 235   else
 236     sym = proc;
 237
 238   if (gfc_elemental (proc)
 239       || sym->attr.pointer || sym->attr.allocatable
 240       || (sym->as && sym->as->rank > 0))
 241     {
 242       proc->attr.always_explicit = 1;
 243       sym->attr.always_explicit = 1;
 244     }
 245
 246   formal_arg_flag = 1;
 247
 248   for (f = proc->formal; f; f = f->next)
 249     {
 250       sym = f->sym;
 251
 252       if (sym == NULL)
 253         {
 254           /* Alternate return placeholder.  */
 255           if (gfc_elemental (proc))
 256             gfc_error ("Alternate return specifier in elemental subroutine "
 257                        "'%s' at %L is not allowed", proc->name,
 258                        &proc->declared_at);
 259           if (proc->attr.function)
 260             gfc_error ("Alternate return specifier in function "
 261                        "'%s' at %L is not allowed", proc->name,
 262                        &proc->declared_at);
 263           continue;
 264         }
 265       else if (sym->attr.procedure && sym->ts.interface
 266                && sym->attr.if_source != IFSRC_DECL)
 267         resolve_procedure_interface (sym);
 268
 269       if (sym->attr.if_source != IFSRC_UNKNOWN)
 270         resolve_formal_arglist (sym);
 271
 272       if (sym->attr.subroutine || sym->attr.external)
 273         {
 274           if (sym->attr.flavor == FL_UNKNOWN)
 275             gfc_add_flavor (&sym->attr, FL_PROCEDURE, sym->name, &sym->declared_at);
 276         }
 277       else
 278         {
 279           if (sym->ts.type == BT_UNKNOWN && !proc->attr.intrinsic
 280               && (!sym->attr.function || sym->result == sym))
 281             gfc_set_default_type (sym, 1, sym->ns);
 282         }
 283
 284       gfc_resolve_array_spec (sym->as, 0);
 285
 286       /* We can't tell if an array with dimension (:) is assumed or deferred
 287          shape until we know if it has the pointer or allocatable attributes.
 288       */
 289       if (sym->as && sym->as->rank > 0 && sym->as->type == AS_DEFERRED
 290           && !(sym->attr.pointer || sym->attr.allocatable)
 291           && sym->attr.flavor != FL_PROCEDURE)
 292         {
 293           sym->as->type = AS_ASSUMED_SHAPE;
 294           for (i = 0; i < sym->as->rank; i++)
 295             sym->as->lower[i] = gfc_get_int_expr (gfc_default_integer_kind,
 296                                                   NULL, 1);
 297         }
 298
 299       if ((sym->as && sym->as->rank > 0 && sym->as->type == AS_ASSUMED_SHAPE)
 300           || sym->attr.pointer || sym->attr.allocatable || sym->attr.target
 301           || sym->attr.optional)
 302         {
 303           proc->attr.always_explicit = 1;
 304           if (proc->result)
 305             proc->result->attr.always_explicit = 1;
 306         }
 307
 308       /* If the flavor is unknown at this point, it has to be a variable.
 309          A procedure specification would have already set the type.  */
 310
 311       if (sym->attr.flavor == FL_UNKNOWN)
 312         gfc_add_flavor (&sym->attr, FL_VARIABLE, sym->name, &sym->declared_at);
 313
 314       if (gfc_pure (proc))
 315         {
 316           if (sym->attr.flavor == FL_PROCEDURE)
 317             {
 318               /* F08:C1279.  */
 319               if (!gfc_pure (sym))
 320                 {
 321                   gfc_error ("Dummy procedure '%s' of PURE procedure at %L must "
 322                             "also be PURE", sym->name, &sym->declared_at);
 323                   continue;
 324                 }
 325             }
 326           else if (!sym->attr.pointer)
 327             {
 328               if (proc->attr.function && sym->attr.intent != INTENT_IN)
 329                 {
 330                   if (sym->attr.value)
 331                     gfc_notify_std (GFC_STD_F2008, "Fortran 2008: Argument '%s'"
 332                                     " of pure function '%s' at %L with VALUE "
 333                                     "attribute but without INTENT(IN)",
 334                                     sym->name, proc->name, &sym->declared_at);
 335                   else
 336                     gfc_error ("Argument '%s' of pure function '%s' at %L must "
 337                                "be INTENT(IN) or VALUE", sym->name, proc->name,
 338                                &sym->declared_at);
 339                 }
 340
 341               if (proc->attr.subroutine && sym->attr.intent == INTENT_UNKNOWN)
 342                 {
 343                   if (sym->attr.value)
 344                     gfc_notify_std (GFC_STD_F2008, "Fortran 2008: Argument '%s'"
 345                                     " of pure subroutine '%s' at %L with VALUE "
 346                                     "attribute but without INTENT", sym->name,
 347                                     proc->name, &sym->declared_at);
 348                   else
 349                     gfc_error ("Argument '%s' of pure subroutine '%s' at %L "
 350                                "must have its INTENT specified or have the "
 351                                "VALUE attribute", sym->name, proc->name,
 352                                &sym->declared_at);
 353                 }
 354             }
 355         }
 356
 357       if (proc->attr.implicit_pure)
 358         {
 359           if (sym->attr.flavor == FL_PROCEDURE)
 360             {
 361               if (!gfc_pure(sym))
 362                 proc->attr.implicit_pure = 0;
 363             }
 364           else if (!sym->attr.pointer)
 365             {
 366               if (proc->attr.function && sym->attr.intent != INTENT_IN)
 367                 proc->attr.implicit_pure = 0;
 368
 369               if (proc->attr.subroutine && sym->attr.intent == INTENT_UNKNOWN)
 370                 proc->attr.implicit_pure = 0;
 371             }
 372         }
 373
 374       if (gfc_elemental (proc))
 375         {
 376           /* F08:C1289.  */
 377           if (sym->attr.codimension)
 378             {
 379               gfc_error ("Coarray dummy argument '%s' at %L to elemental "
 380                          "procedure", sym->name, &sym->declared_at);
 381               continue;
 382             }
 383
 384           if (sym->as != NULL)
 385             {
 386               gfc_error ("Argument '%s' of elemental procedure at %L must "
 387                          "be scalar", sym->name, &sym->declared_at);
 388               continue;
 389             }
 390
 391           if (sym->attr.allocatable)
 392             {
 393               gfc_error ("Argument '%s' of elemental procedure at %L cannot "
 394                          "have the ALLOCATABLE attribute", sym->name,
 395                          &sym->declared_at);
 396               continue;
 397             }
 398
 399           if (sym->attr.pointer)
 400             {
 401               gfc_error ("Argument '%s' of elemental procedure at %L cannot "
 402                          "have the POINTER attribute", sym->name,
 403                          &sym->declared_at);
 404               continue;
 405             }
 406
 407           if (sym->attr.flavor == FL_PROCEDURE)
 408             {
 409               gfc_error ("Dummy procedure '%s' not allowed in elemental "
 410                          "procedure '%s' at %L", sym->name, proc->name,
 411                          &sym->declared_at);
 412               continue;
 413             }
 414
 415           if (sym->attr.intent == INTENT_UNKNOWN)
 416             {
 417               gfc_error ("Argument '%s' of elemental procedure '%s' at %L must "
 418                          "have its INTENT specified", sym->name, proc->name,
 419                          &sym->declared_at);
 420               continue;
 421             }
 422         }
 423
 424       /* Each dummy shall be specified to be scalar.  */
 425       if (proc->attr.proc == PROC_ST_FUNCTION)
 426         {
 427           if (sym->as != NULL)
 428             {
 429               gfc_error ("Argument '%s' of statement function at %L must "
 430                          "be scalar", sym->name, &sym->declared_at);
 431               continue;
 432             }
 433
 434           if (sym->ts.type == BT_CHARACTER)
 435             {
 436               gfc_charlen *cl = sym->ts.u.cl;
 437               if (!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT)
 438                 {
 439                   gfc_error ("Character-valued argument '%s' of statement "
 440                              "function at %L must have constant length",
 441                              sym->name, &sym->declared_at);
 442                   continue;
 443                 }
 444             }
 445         }
 446     }
 447   formal_arg_flag = 0;
 448 }
 449
 450
 451 /* Work function called when searching for symbols that have argument lists
 452    associated with them.  */
 453
 454 static void
 455 find_arglists (gfc_symbol *sym)
 456 {
 457   if (sym->attr.if_source == IFSRC_UNKNOWN || sym->ns != gfc_current_ns)
 458     return;
 459
 460   resolve_formal_arglist (sym);
 461 }
 462
 463
 464 /* Given a namespace, resolve all formal argument lists within the namespace.
 465  */
 466
 467 static void
 468 resolve_formal_arglists (gfc_namespace *ns)
 469 {
 470   if (ns == NULL)
 471     return;
 472
 473   gfc_traverse_ns (ns, find_arglists);
 474 }
 475
 476
 477 static void
 478 resolve_contained_fntype (gfc_symbol *sym, gfc_namespace *ns)
 479 {
 480   gfc_try t;
 481
 482   /* If this namespace is not a function or an entry master function,
 483      ignore it.  */
 484   if (! sym || !(sym->attr.function || sym->attr.flavor == FL_VARIABLE)
 485       || sym->attr.entry_master)
 486     return;
 487
 488   /* Try to find out of what the return type is.  */
 489   if (sym->result->ts.type == BT_UNKNOWN && sym->result->ts.interface == NULL)
 490     {
 491       t = gfc_set_default_type (sym->result, 0, ns);
 492
 493       if (t == FAILURE && !sym->result->attr.untyped)
 494         {
 495           if (sym->result == sym)
 496             gfc_error ("Contained function '%s' at %L has no IMPLICIT type",
 497                        sym->name, &sym->declared_at);
 498           else if (!sym->result->attr.proc_pointer)
 499             gfc_error ("Result '%s' of contained function '%s' at %L has "
 500                        "no IMPLICIT type", sym->result->name, sym->name,
 501                        &sym->result->declared_at);
 502           sym->result->attr.untyped = 1;
 503         }
 504     }
 505
 506   /* Fortran 95 Draft Standard, page 51, Section 5.1.1.5, on the Character
 507      type, lists the only ways a character length value of * can be used:
 508      dummy arguments of procedures, named constants, and function results
 509      in external functions.  Internal function results and results of module
 510      procedures are not on this list, ergo, not permitted.  */
 511
 512   if (sym->result->ts.type == BT_CHARACTER)
 513     {
 514       gfc_charlen *cl = sym->result->ts.u.cl;
 515       if ((!cl || !cl->length) && !sym->result->ts.deferred)
 516         {
 517           /* See if this is a module-procedure and adapt error message
 518              accordingly.  */
 519           bool module_proc;
 520           gcc_assert (ns->parent && ns->parent->proc_name);
 521           module_proc = (ns->parent->proc_name->attr.flavor == FL_MODULE);
 522
 523           gfc_error ("Character-valued %s '%s' at %L must not be"
 524                      " assumed length",
 525                      module_proc ? _("module procedure")
 526                                  : _("internal function"),
 527                      sym->name, &sym->declared_at);
 528         }
 529     }
 530 }
 531
 532
 533 /* Add NEW_ARGS to the formal argument list of PROC, taking care not to
 534    introduce duplicates.  */
 535
 536 static void
 537 merge_argument_lists (gfc_symbol *proc, gfc_formal_arglist *new_args)
 538 {
 539   gfc_formal_arglist *f, *new_arglist;
 540   gfc_symbol *new_sym;
 541
 542   for (; new_args != NULL; new_args = new_args->next)
 543     {
 544       new_sym = new_args->sym;
 545       /* See if this arg is already in the formal argument list.  */
 546       for (f = proc->formal; f; f = f->next)
 547         {
 548           if (new_sym == f->sym)
 549             break;
 550         }
 551
 552       if (f)
 553         continue;
 554
 555       /* Add a new argument.  Argument order is not important.  */
 556       new_arglist = gfc_get_formal_arglist ();
 557       new_arglist->sym = new_sym;
 558       new_arglist->next = proc->formal;
 559       proc->formal  = new_arglist;
 560     }
 561 }
 562
 563
 564 /* Flag the arguments that are not present in all entries.  */
 565
 566 static void
 567 check_argument_lists (gfc_symbol *proc, gfc_formal_arglist *new_args)
 568 {
 569   gfc_formal_arglist *f, *head;
 570   head = new_args;
 571
 572   for (f = proc->formal; f; f = f->next)
 573     {
 574       if (f->sym == NULL)
 575         continue;
 576
 577       for (new_args = head; new_args; new_args = new_args->next)
 578         {
 579           if (new_args->sym == f->sym)
 580             break;
 581         }
 582
 583       if (new_args)
 584         continue;
 585
 586       f->sym->attr.not_always_present = 1;
 587     }
 588 }
 589
 590
 591 /* Resolve alternate entry points.  If a symbol has multiple entry points we
 592    create a new master symbol for the main routine, and turn the existing
 593    symbol into an entry point.  */
 594
 595 static void
 596 resolve_entries (gfc_namespace *ns)
 597 {
 598   gfc_namespace *old_ns;
 599   gfc_code *c;
 600   gfc_symbol *proc;
 601   gfc_entry_list *el;
 602   char name[GFC_MAX_SYMBOL_LEN + 1];
 603   static int master_count = 0;
 604
 605   if (ns->proc_name == NULL)
 606     return;
 607
 608   /* No need to do anything if this procedure doesn't have alternate entry
 609      points.  */
 610   if (!ns->entries)
 611     return;
 612
 613   /* We may already have resolved alternate entry points.  */
 614   if (ns->proc_name->attr.entry_master)
 615     return;
 616
 617   /* If this isn't a procedure something has gone horribly wrong.  */
 618   gcc_assert (ns->proc_name->attr.flavor == FL_PROCEDURE);
 619
 620   /* Remember the current namespace.  */
 621   old_ns = gfc_current_ns;
 622
 623   gfc_current_ns = ns;
 624
 625   /* Add the main entry point to the list of entry points.  */
 626   el = gfc_get_entry_list ();
 627   el->sym = ns->proc_name;
 628   el->id = 0;
 629   el->next = ns->entries;
 630   ns->entries = el;
 631   ns->proc_name->attr.entry = 1;
 632
 633   /* If it is a module function, it needs to be in the right namespace
 634      so that gfc_get_fake_result_decl can gather up the results. The
 635      need for this arose in get_proc_name, where these beasts were
 636      left in their own namespace, to keep prior references linked to
 637      the entry declaration.*/
 638   if (ns->proc_name->attr.function
 639       && ns->parent && ns->parent->proc_name->attr.flavor == FL_MODULE)
 640     el->sym->ns = ns;
 641
 642   /* Do the same for entries where the master is not a module
 643      procedure.  These are retained in the module namespace because
 644      of the module procedure declaration.  */
 645   for (el = el->next; el; el = el->next)
 646     if (el->sym->ns->proc_name->attr.flavor == FL_MODULE
 647           && el->sym->attr.mod_proc)
 648       el->sym->ns = ns;
 649   el = ns->entries;
 650
 651   /* Add an entry statement for it.  */
 652   c = gfc_get_code ();
 653   c->op = EXEC_ENTRY;
 654   c->ext.entry = el;
 655   c->next = ns->code;
 656   ns->code = c;
 657
 658   /* Create a new symbol for the master function.  */
 659   /* Give the internal function a unique name (within this file).
 660      Also include the function name so the user has some hope of figuring
 661      out what is going on.  */
 662   snprintf (name, GFC_MAX_SYMBOL_LEN, "master.%d.%s",
 663             master_count++, ns->proc_name->name);
 664   gfc_get_ha_symbol (name, &proc);
 665   gcc_assert (proc != NULL);
 666
 667   gfc_add_procedure (&proc->attr, PROC_INTERNAL, proc->name, NULL);
 668   if (ns->proc_name->attr.subroutine)
 669     gfc_add_subroutine (&proc->attr, proc->name, NULL);
 670   else
 671     {
 672       gfc_symbol *sym;
 673       gfc_typespec *ts, *fts;
 674       gfc_array_spec *as, *fas;
 675       gfc_add_function (&proc->attr, proc->name, NULL);
 676       proc->result = proc;
 677       fas = ns->entries->sym->as;
 678       fas = fas ? fas : ns->entries->sym->result->as;
 679       fts = &ns->entries->sym->result->ts;
 680       if (fts->type == BT_UNKNOWN)
 681         fts = gfc_get_default_type (ns->entries->sym->result->name, NULL);
 682       for (el = ns->entries->next; el; el = el->next)
 683         {
 684           ts = &el->sym->result->ts;
 685           as = el->sym->as;
 686           as = as ? as : el->sym->result->as;
 687           if (ts->type == BT_UNKNOWN)
 688             ts = gfc_get_default_type (el->sym->result->name, NULL);
 689
 690           if (! gfc_compare_types (ts, fts)
 691               || (el->sym->result->attr.dimension
 692                   != ns->entries->sym->result->attr.dimension)
 693               || (el->sym->result->attr.pointer
 694                   != ns->entries->sym->result->attr.pointer))
 695             break;
 696           else if (as && fas && ns->entries->sym->result != el->sym->result
 697                       && gfc_compare_array_spec (as, fas) == 0)
 698             gfc_error ("Function %s at %L has entries with mismatched "
 699                        "array specifications", ns->entries->sym->name,
 700                        &ns->entries->sym->declared_at);
 701           /* The characteristics need to match and thus both need to have
 702              the same string length, i.e. both len=*, or both len=4.
 703              Having both len=<variable> is also possible, but difficult to
 704              check at compile time.  */
 705           else if (ts->type == BT_CHARACTER && ts->u.cl && fts->u.cl
 706                    && (((ts->u.cl->length && !fts->u.cl->length)
 707                         ||(!ts->u.cl->length && fts->u.cl->length))
 708                        || (ts->u.cl->length
 709                            && ts->u.cl->length->expr_type
 710                               != fts->u.cl->length->expr_type)
 711                        || (ts->u.cl->length
 712                            && ts->u.cl->length->expr_type == EXPR_CONSTANT
 713                            && mpz_cmp (ts->u.cl->length->value.integer,
 714                                        fts->u.cl->length->value.integer) != 0)))
 715             gfc_notify_std (GFC_STD_GNU, "Extension: Function %s at %L with "
 716                             "entries returning variables of different "
 717                             "string lengths", ns->entries->sym->name,
 718                             &ns->entries->sym->declared_at);
 719         }
 720
 721       if (el == NULL)
 722         {
 723           sym = ns->entries->sym->result;
 724           /* All result types the same.  */
 725           proc->ts = *fts;
 726           if (sym->attr.dimension)
 727             gfc_set_array_spec (proc, gfc_copy_array_spec (sym->as), NULL);
 728           if (sym->attr.pointer)
 729             gfc_add_pointer (&proc->attr, NULL);
 730         }
 731       else
 732         {
 733           /* Otherwise the result will be passed through a union by
 734              reference.  */
 735           proc->attr.mixed_entry_master = 1;
 736           for (el = ns->entries; el; el = el->next)
 737             {
 738               sym = el->sym->result;
 739               if (sym->attr.dimension)
 740                 {
 741                   if (el == ns->entries)
 742                     gfc_error ("FUNCTION result %s can't be an array in "
 743                                "FUNCTION %s at %L", sym->name,
 744                                ns->entries->sym->name, &sym->declared_at);
 745                   else
 746                     gfc_error ("ENTRY result %s can't be an array in "
 747                                "FUNCTION %s at %L", sym->name,
 748                                ns->entries->sym->name, &sym->declared_at);
 749                 }
 750               else if (sym->attr.pointer)
 751                 {
 752                   if (el == ns->entries)
 753                     gfc_error ("FUNCTION result %s can't be a POINTER in "
 754                                "FUNCTION %s at %L", sym->name,
 755                                ns->entries->sym->name, &sym->declared_at);
 756                   else
 757                     gfc_error ("ENTRY result %s can't be a POINTER in "
 758                                "FUNCTION %s at %L", sym->name,
 759                                ns->entries->sym->name, &sym->declared_at);
 760                 }
 761               else
 762                 {
 763                   ts = &sym->ts;
 764                   if (ts->type == BT_UNKNOWN)
 765                     ts = gfc_get_default_type (sym->name, NULL);
 766                   switch (ts->type)
 767                     {
 768                     case BT_INTEGER:
 769                       if (ts->kind == gfc_default_integer_kind)
 770                         sym = NULL;
 771                       break;
 772                     case BT_REAL:
 773                       if (ts->kind == gfc_default_real_kind
 774                           || ts->kind == gfc_default_double_kind)
 775                         sym = NULL;
 776                       break;
 777                     case BT_COMPLEX:
 778                       if (ts->kind == gfc_default_complex_kind)
 779                         sym = NULL;
 780                       break;
 781                     case BT_LOGICAL:
 782                       if (ts->kind == gfc_default_logical_kind)
 783                         sym = NULL;
 784                       break;
 785                     case BT_UNKNOWN:
 786                       /* We will issue error elsewhere.  */
 787                       sym = NULL;
 788                       break;
 789                     default:
 790                       break;
 791                     }
 792                   if (sym)
 793                     {
 794                       if (el == ns->entries)
 795                         gfc_error ("FUNCTION result %s can't be of type %s "
 796                                    "in FUNCTION %s at %L", sym->name,
 797                                    gfc_typename (ts), ns->entries->sym->name,
 798                                    &sym->declared_at);
 799                       else
 800                         gfc_error ("ENTRY result %s can't be of type %s "
 801                                    "in FUNCTION %s at %L", sym->name,
 802                                    gfc_typename (ts), ns->entries->sym->name,
 803                                    &sym->declared_at);
 804                     }
 805                 }
 806             }
 807         }
 808     }
 809   proc->attr.access = ACCESS_PRIVATE;
 810   proc->attr.entry_master = 1;
 811
 812   /* Merge all the entry point arguments.  */
 813   for (el = ns->entries; el; el = el->next)
 814     merge_argument_lists (proc, el->sym->formal);
 815
 816   /* Check the master formal arguments for any that are not
 817      present in all entry points.  */
 818   for (el = ns->entries; el; el = el->next)
 819     check_argument_lists (proc, el->sym->formal);
 820
 821   /* Use the master function for the function body.  */
 822   ns->proc_name = proc;
 823
 824   /* Finalize the new symbols.  */
 825   gfc_commit_symbols ();
 826
 827   /* Restore the original namespace.  */
 828   gfc_current_ns = old_ns;
 829 }
 830
 831
 832 /* Resolve common variables.  */
 833 static void
 834 resolve_common_vars (gfc_symbol *sym, bool named_common)
 835 {
 836   gfc_symbol *csym = sym;
 837
 838   for (; csym; csym = csym->common_next)
 839     {
 840       if (csym->value || csym->attr.data)
 841         {
 842           if (!csym->ns->is_block_data)
 843             gfc_notify_std (GFC_STD_GNU, "Variable '%s' at %L is in COMMON "
 844                             "but only in BLOCK DATA initialization is "
 845                             "allowed", csym->name, &csym->declared_at);
 846           else if (!named_common)
 847             gfc_notify_std (GFC_STD_GNU, "Initialized variable '%s' at %L is "
 848                             "in a blank COMMON but initialization is only "
 849                             "allowed in named common blocks", csym->name,
 850                             &csym->declared_at);
 851         }
 852
 853       if (csym->ts.type != BT_DERIVED)
 854         continue;
 855
 856       if (!(csym->ts.u.derived->attr.sequence
 857             || csym->ts.u.derived->attr.is_bind_c))
 858         gfc_error_now ("Derived type variable '%s' in COMMON at %L "
 859                        "has neither the SEQUENCE nor the BIND(C) "
 860                        "attribute", csym->name, &csym->declared_at);
 861       if (csym->ts.u.derived->attr.alloc_comp)
 862         gfc_error_now ("Derived type variable '%s' in COMMON at %L "
 863                        "has an ultimate component that is "
 864                        "allocatable", csym->name, &csym->declared_at);
 865       if (gfc_has_default_initializer (csym->ts.u.derived))
 866         gfc_error_now ("Derived type variable '%s' in COMMON at %L "
 867                        "may not have default initializer", csym->name,
 868                        &csym->declared_at);
 869
 870       if (csym->attr.flavor == FL_UNKNOWN && !csym->attr.proc_pointer)
 871         gfc_add_flavor (&csym->attr, FL_VARIABLE, csym->name, &csym->declared_at);
 872     }
 873 }
 874
 875 /* Resolve common blocks.  */
 876 static void
 877 resolve_common_blocks (gfc_symtree *common_root)
 878 {
 879   gfc_symbol *sym;
 880
 881   if (common_root == NULL)
 882     return;
 883
 884   if (common_root->left)
 885     resolve_common_blocks (common_root->left);
 886   if (common_root->right)
 887     resolve_common_blocks (common_root->right);
 888
 889   resolve_common_vars (common_root->n.common->head, true);
 890
 891   gfc_find_symbol (common_root->name, gfc_current_ns, 0, &sym);
 892   if (sym == NULL)
 893     return;
 894
 895   if (sym->attr.flavor == FL_PARAMETER)
 896     gfc_error ("COMMON block '%s' at %L is used as PARAMETER at %L",
 897                sym->name, &common_root->n.common->where, &sym->declared_at);
 898
 899   if (sym->attr.external)
 900     gfc_error ("COMMON block '%s' at %L can not have the EXTERNAL attribute",
 901                sym->name, &common_root->n.common->where);
 902
 903   if (sym->attr.intrinsic)
 904     gfc_error ("COMMON block '%s' at %L is also an intrinsic procedure",
 905                sym->name, &common_root->n.common->where);
 906   else if (sym->attr.result
 907            || gfc_is_function_return_value (sym, gfc_current_ns))
 908     gfc_notify_std (GFC_STD_F2003, "Fortran 2003: COMMON block '%s' at %L "
 909                     "that is also a function result", sym->name,
 910                     &common_root->n.common->where);
 911   else if (sym->attr.flavor == FL_PROCEDURE && sym->attr.proc != PROC_INTERNAL
 912            && sym->attr.proc != PROC_ST_FUNCTION)
 913     gfc_notify_std (GFC_STD_F2003, "Fortran 2003: COMMON block '%s' at %L "
 914                     "that is also a global procedure", sym->name,
 915                     &common_root->n.common->where);
 916 }
 917
 918
 919 /* Resolve contained function types.  Because contained functions can call one
 920    another, they have to be worked out before any of the contained procedures
 921    can be resolved.
 922
 923    The good news is that if a function doesn't already have a type, the only
 924    way it can get one is through an IMPLICIT type or a RESULT variable, because
 925    by definition contained functions are contained namespace they're contained
 926    in, not in a sibling or parent namespace.  */
 927
 928 static void
 929 resolve_contained_functions (gfc_namespace *ns)
 930 {
 931   gfc_namespace *child;
 932   gfc_entry_list *el;
 933
 934   resolve_formal_arglists (ns);
 935
 936   for (child = ns->contained; child; child = child->sibling)
 937     {
 938       /* Resolve alternate entry points first.  */
 939       resolve_entries (child);
 940
 941       /* Then check function return types.  */
 942       resolve_contained_fntype (child->proc_name, child);
 943       for (el = child->entries; el; el = el->next)
 944         resolve_contained_fntype (el->sym, child);
 945     }
 946 }
 947
 948
 949 static gfc_try resolve_fl_derived0 (gfc_symbol *sym);
 950
 951
 952 /* Resolve all of the elements of a structure constructor and make sure that
 953    the types are correct. The 'init' flag indicates that the given
 954    constructor is an initializer.  */
 955
 956 static gfc_try
 957 resolve_structure_cons (gfc_expr *expr, int init)
 958 {
 959   gfc_constructor *cons;
 960   gfc_component *comp;
 961   gfc_try t;
 962   symbol_attribute a;
 963
 964   t = SUCCESS;
 965
 966   if (expr->ts.type == BT_DERIVED)
 967     resolve_fl_derived0 (expr->ts.u.derived);
 968
 969   cons = gfc_constructor_first (expr->value.constructor);
 970   /* A constructor may have references if it is the result of substituting a
 971      parameter variable.  In this case we just pull out the component we
 972      want.  */
 973   if (expr->ref)
 974     comp = expr->ref->u.c.sym->components;
 975   else
 976     comp = expr->ts.u.derived->components;
 977
 978   /* See if the user is trying to invoke a structure constructor for one of
 979      the iso_c_binding derived types.  */
 980   if (expr->ts.type == BT_DERIVED && expr->ts.u.derived
 981       && expr->ts.u.derived->ts.is_iso_c && cons
 982       && (cons->expr == NULL || cons->expr->expr_type != EXPR_NULL))
 983     {
 984       gfc_error ("Components of structure constructor '%s' at %L are PRIVATE",
 985                  expr->ts.u.derived->name, &(expr->where));
 986       return FAILURE;
 987     }
 988
 989   /* Return if structure constructor is c_null_(fun)prt.  */
 990   if (expr->ts.type == BT_DERIVED && expr->ts.u.derived
 991       && expr->ts.u.derived->ts.is_iso_c && cons
 992       && cons->expr && cons->expr->expr_type == EXPR_NULL)
 993     return SUCCESS;
 994
 995   for (; comp && cons; comp = comp->next, cons = gfc_constructor_next (cons))
 996     {
 997       int rank;
 998
 999       if (!cons->expr)
1000         continue;
1001
1002       if (gfc_resolve_expr (cons->expr) == FAILURE)
1003         {
1004           t = FAILURE;
1005           continue;
1006         }
1007
1008       rank = comp->as ? comp->as->rank : 0;
1009       if (cons->expr->expr_type != EXPR_NULL && rank != cons->expr->rank
1010           && (comp->attr.allocatable || cons->expr->rank))
1011         {
1012           gfc_error ("The rank of the element in the structure "
1013                      "constructor at %L does not match that of the "
1014                      "component (%d/%d)", &cons->expr->where,
1015                      cons->expr->rank, rank);
1016           t = FAILURE;
1017         }
1018
1019       /* If we don't have the right type, try to convert it.  */
1020
1021       if (!comp->attr.proc_pointer &&
1022           !gfc_compare_types (&cons->expr->ts, &comp->ts))
1023         {
1024           t = FAILURE;
1025           if (strcmp (comp->name, "_extends") == 0)
1026             {
1027               /* Can afford to be brutal with the _extends initializer.
1028                  The derived type can get lost because it is PRIVATE
1029                  but it is not usage constrained by the standard.  */
1030               cons->expr->ts = comp->ts;
1031               t = SUCCESS;
1032             }
1033           else if (comp->attr.pointer && cons->expr->ts.type != BT_UNKNOWN)
1034             gfc_error ("The element in the structure constructor at %L, "
1035                        "for pointer component '%s', is %s but should be %s",
1036                        &cons->expr->where, comp->name,
1037                        gfc_basic_typename (cons->expr->ts.type),
1038                        gfc_basic_typename (comp->ts.type));
1039           else
1040             t = gfc_convert_type (cons->expr, &comp->ts, 1);
1041         }
1042
1043       /* For strings, the length of the constructor should be the same as
1044          the one of the structure, ensure this if the lengths are known at
1045          compile time and when we are dealing with PARAMETER or structure
1046          constructors.  */
1047       if (cons->expr->ts.type == BT_CHARACTER && comp->ts.u.cl
1048           && comp->ts.u.cl->length
1049           && comp->ts.u.cl->length->expr_type == EXPR_CONSTANT
1050           && cons->expr->ts.u.cl && cons->expr->ts.u.cl->length
1051           && cons->expr->ts.u.cl->length->expr_type == EXPR_CONSTANT
1052           && mpz_cmp (cons->expr->ts.u.cl->length->value.integer,
1053                       comp->ts.u.cl->length->value.integer) != 0)
1054         {
1055           if (cons->expr->expr_type == EXPR_VARIABLE
1056               && cons->expr->symtree->n.sym->attr.flavor == FL_PARAMETER)
1057             {
1058               /* Wrap the parameter in an array constructor (EXPR_ARRAY)
1059                  to make use of the gfc_resolve_character_array_constructor
1060                  machinery.  The expression is later simplified away to
1061                  an array of string literals.  */
1062               gfc_expr *para = cons->expr;
1063               cons->expr = gfc_get_expr ();
1064               cons->expr->ts = para->ts;
1065               cons->expr->where = para->where;
1066               cons->expr->expr_type = EXPR_ARRAY;
1067               cons->expr->rank = para->rank;
1068               cons->expr->shape = gfc_copy_shape (para->shape, para->rank);
1069               gfc_constructor_append_expr (&cons->expr->value.constructor,
1070                                            para, &cons->expr->where);
1071             }
1072           if (cons->expr->expr_type == EXPR_ARRAY)
1073             {
1074               gfc_constructor *p;
1075               p = gfc_constructor_first (cons->expr->value.constructor);
1076               if (cons->expr->ts.u.cl != p->expr->ts.u.cl)
1077                 {
1078                   gfc_charlen *cl, *cl2;
1079
1080                   cl2 = NULL;
1081                   for (cl = gfc_current_ns->cl_list; cl; cl = cl->next)
1082                     {
1083                       if (cl == cons->expr->ts.u.cl)
1084                         break;
1085                       cl2 = cl;
1086                     }
1087
1088                   gcc_assert (cl);
1089
1090                   if (cl2)
1091                     cl2->next = cl->next;
1092
1093                   gfc_free_expr (cl->length);
1094                   free (cl);
1095                 }
1096
1097               cons->expr->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
1098               cons->expr->ts.u.cl->length_from_typespec = true;
1099               cons->expr->ts.u.cl->length = gfc_copy_expr (comp->ts.u.cl->length);
1100               gfc_resolve_character_array_constructor (cons->expr);
1101             }
1102         }
1103
1104       if (cons->expr->expr_type == EXPR_NULL
1105           && !(comp->attr.pointer || comp->attr.allocatable
1106                || comp->attr.proc_pointer
1107                || (comp->ts.type == BT_CLASS
1108                    && (CLASS_DATA (comp)->attr.class_pointer
1109                        || CLASS_DATA (comp)->attr.allocatable))))
1110         {
1111           t = FAILURE;
1112           gfc_error ("The NULL in the structure constructor at %L is "
1113                      "being applied to component '%s', which is neither "
1114                      "a POINTER nor ALLOCATABLE", &cons->expr->where,
1115                      comp->name);
1116         }
1117
1118       if (comp->attr.proc_pointer && comp->ts.interface)
1119         {
1120           /* Check procedure pointer interface.  */
1121           gfc_symbol *s2 = NULL;
1122           gfc_component *c2;
1123           const char *name;
1124           char err[200];
1125
1126           if (gfc_is_proc_ptr_comp (cons->expr, &c2))
1127             {
1128               s2 = c2->ts.interface;
1129               name = c2->name;
1130             }
1131           else if (cons->expr->expr_type == EXPR_FUNCTION)
1132             {
1133               s2 = cons->expr->symtree->n.sym->result;
1134               name = cons->expr->symtree->n.sym->result->name;
1135             }
1136           else if (cons->expr->expr_type != EXPR_NULL)
1137             {
1138               s2 = cons->expr->symtree->n.sym;
1139               name = cons->expr->symtree->n.sym->name;
1140             }
1141
1142           if (s2 && !gfc_compare_interfaces (comp->ts.interface, s2, name, 0, 1,
1143                                              err, sizeof (err)))
1144             {
1145               gfc_error ("Interface mismatch for procedure-pointer component "
1146                          "'%s' in structure constructor at %L: %s",
1147                          comp->name, &cons->expr->where, err);
1148               return FAILURE;
1149             }
1150         }
1151
1152       if (!comp->attr.pointer || comp->attr.proc_pointer
1153           || cons->expr->expr_type == EXPR_NULL)
1154         continue;
1155
1156       a = gfc_expr_attr (cons->expr);
1157
1158       if (!a.pointer && !a.target)
1159         {
1160           t = FAILURE;
1161           gfc_error ("The element in the structure constructor at %L, "
1162                      "for pointer component '%s' should be a POINTER or "
1163                      "a TARGET", &cons->expr->where, comp->name);
1164         }
1165
1166       if (init)
1167         {
1168           /* F08:C461. Additional checks for pointer initialization.  */
1169           if (a.allocatable)
1170             {
1171               t = FAILURE;
1172               gfc_error ("Pointer initialization target at %L "
1173                          "must not be ALLOCATABLE ", &cons->expr->where);
1174             }
1175           if (!a.save)
1176             {
1177               t = FAILURE;
1178               gfc_error ("Pointer initialization target at %L "
1179                          "must have the SAVE attribute", &cons->expr->where);
1180             }
1181         }
1182
1183       /* F2003, C1272 (3).  */
1184       if (gfc_pure (NULL) && cons->expr->expr_type == EXPR_VARIABLE
1185           && (gfc_impure_variable (cons->expr->symtree->n.sym)
1186               || gfc_is_coindexed (cons->expr)))
1187         {
1188           t = FAILURE;
1189           gfc_error ("Invalid expression in the structure constructor for "
1190                      "pointer component '%s' at %L in PURE procedure",
1191                      comp->name, &cons->expr->where);
1192         }
1193
1194       if (gfc_implicit_pure (NULL)
1195             && cons->expr->expr_type == EXPR_VARIABLE
1196             && (gfc_impure_variable (cons->expr->symtree->n.sym)
1197                 || gfc_is_coindexed (cons->expr)))
1198         gfc_current_ns->proc_name->attr.implicit_pure = 0;
1199
1200     }
1201
1202   return t;
1203 }
1204
1205
1206 /****************** Expression name resolution ******************/
1207
1208 /* Returns 0 if a symbol was not declared with a type or
1209    attribute declaration statement, nonzero otherwise.  */
1210
1211 static int
1212 was_declared (gfc_symbol *sym)
1213 {
1214   symbol_attribute a;
1215
1216   a = sym->attr;
1217
1218   if (!a.implicit_type && sym->ts.type != BT_UNKNOWN)
1219     return 1;
1220
1221   if (a.allocatable || a.dimension || a.dummy || a.external || a.intrinsic
1222       || a.optional || a.pointer || a.save || a.target || a.volatile_
1223       || a.value || a.access != ACCESS_UNKNOWN || a.intent != INTENT_UNKNOWN
1224       || a.asynchronous || a.codimension)
1225     return 1;
1226
1227   return 0;
1228 }
1229
1230
1231 /* Determine if a symbol is generic or not.  */
1232
1233 static int
1234 generic_sym (gfc_symbol *sym)
1235 {
1236   gfc_symbol *s;
1237
1238   if (sym->attr.generic ||
1239       (sym->attr.intrinsic && gfc_generic_intrinsic (sym->name)))
1240     return 1;
1241
1242   if (was_declared (sym) || sym->ns->parent == NULL)
1243     return 0;
1244
1245   gfc_find_symbol (sym->name, sym->ns->parent, 1, &s);
1246
1247   if (s != NULL)
1248     {
1249       if (s == sym)
1250         return 0;
1251       else
1252         return generic_sym (s);
1253     }
1254
1255   return 0;
1256 }
1257
1258
1259 /* Determine if a symbol is specific or not.  */
1260
1261 static int
1262 specific_sym (gfc_symbol *sym)
1263 {
1264   gfc_symbol *s;
1265
1266   if (sym->attr.if_source == IFSRC_IFBODY
1267       || sym->attr.proc == PROC_MODULE
1268       || sym->attr.proc == PROC_INTERNAL
1269       || sym->attr.proc == PROC_ST_FUNCTION
1270       || (sym->attr.intrinsic && gfc_specific_intrinsic (sym->name))
1271       || sym->attr.external)
1272     return 1;
1273
1274   if (was_declared (sym) || sym->ns->parent == NULL)
1275     return 0;
1276
1277   gfc_find_symbol (sym->name, sym->ns->parent, 1, &s);
1278
1279   return (s == NULL) ? 0 : specific_sym (s);
1280 }
1281
1282
1283 /* Figure out if the procedure is specific, generic or unknown.  */
1284
1285 typedef enum
1286 { PTYPE_GENERIC = 1, PTYPE_SPECIFIC, PTYPE_UNKNOWN }
1287 proc_type;
1288
1289 static proc_type
1290 procedure_kind (gfc_symbol *sym)
1291 {
1292   if (generic_sym (sym))
1293     return PTYPE_GENERIC;
1294
1295   if (specific_sym (sym))
1296     return PTYPE_SPECIFIC;
1297
1298   return PTYPE_UNKNOWN;
1299 }
1300
1301 /* Check references to assumed size arrays.  The flag need_full_assumed_size
1302    is nonzero when matching actual arguments.  */
1303
1304 static int need_full_assumed_size = 0;
1305
1306 static bool
1307 check_assumed_size_reference (gfc_symbol *sym, gfc_expr *e)
1308 {
1309   if (need_full_assumed_size || !(sym->as && sym->as->type == AS_ASSUMED_SIZE))
1310       return false;
1311
1312   /* FIXME: The comparison "e->ref->u.ar.type == AR_FULL" is wrong.
1313      What should it be?  */
1314   if ((e->ref->u.ar.end[e->ref->u.ar.as->rank - 1] == NULL)
1315           && (e->ref->u.ar.as->type == AS_ASSUMED_SIZE)
1316                && (e->ref->u.ar.type == AR_FULL))
1317     {
1318       gfc_error ("The upper bound in the last dimension must "
1319                  "appear in the reference to the assumed size "
1320                  "array '%s' at %L", sym->name, &e->where);
1321       return true;
1322     }
1323   return false;
1324 }
1325
1326
1327 /* Look for bad assumed size array references in argument expressions
1328   of elemental and array valued intrinsic procedures.  Since this is
1329   called from procedure resolution functions, it only recurses at
1330   operators.  */
1331
1332 static bool
1333 resolve_assumed_size_actual (gfc_expr *e)
1334 {
1335   if (e == NULL)
1336    return false;
1337
1338   switch (e->expr_type)
1339     {
1340     case EXPR_VARIABLE:
1341       if (e->symtree && check_assumed_size_reference (e->symtree->n.sym, e))
1342         return true;
1343       break;
1344
1345     case EXPR_OP:
1346       if (resolve_assumed_size_actual (e->value.op.op1)
1347           || resolve_assumed_size_actual (e->value.op.op2))
1348         return true;
1349       break;
1350
1351     default:
1352       break;
1353     }
1354   return false;
1355 }
1356
1357
1358 /* Check a generic procedure, passed as an actual argument, to see if
1359    there is a matching specific name.  If none, it is an error, and if
1360    more than one, the reference is ambiguous.  */
1361 static int
1362 count_specific_procs (gfc_expr *e)
1363 {
1364   int n;
1365   gfc_interface *p;
1366   gfc_symbol *sym;
1367
1368   n = 0;
1369   sym = e->symtree->n.sym;
1370
1371   for (p = sym->generic; p; p = p->next)
1372     if (strcmp (sym->name, p->sym->name) == 0)
1373       {
1374         e->symtree = gfc_find_symtree (p->sym->ns->sym_root,
1375                                        sym->name);
1376         n++;
1377       }
1378
1379   if (n > 1)
1380     gfc_error ("'%s' at %L is ambiguous", e->symtree->n.sym->name,
1381                &e->where);
1382
1383   if (n == 0)
1384     gfc_error ("GENERIC procedure '%s' is not allowed as an actual "
1385                "argument at %L", sym->name, &e->where);
1386
1387   return n;
1388 }
1389
1390
1391 /* See if a call to sym could possibly be a not allowed RECURSION because of
1392    a missing RECURIVE declaration.  This means that either sym is the current
1393    context itself, or sym is the parent of a contained procedure calling its
1394    non-RECURSIVE containing procedure.
1395    This also works if sym is an ENTRY.  */
1396
1397 static bool
1398 is_illegal_recursion (gfc_symbol* sym, gfc_namespace* context)
1399 {
1400   gfc_symbol* proc_sym;
1401   gfc_symbol* context_proc;
1402   gfc_namespace* real_context;
1403
1404   if (sym->attr.flavor == FL_PROGRAM)
1405     return false;
1406
1407   gcc_assert (sym->attr.flavor == FL_PROCEDURE);
1408
1409   /* If we've got an ENTRY, find real procedure.  */
1410   if (sym->attr.entry && sym->ns->entries)
1411     proc_sym = sym->ns->entries->sym;
1412   else
1413     proc_sym = sym;
1414
1415   /* If sym is RECURSIVE, all is well of course.  */
1416   if (proc_sym->attr.recursive || gfc_option.flag_recursive)
1417     return false;
1418
1419   /* Find the context procedure's "real" symbol if it has entries.
1420      We look for a procedure symbol, so recurse on the parents if we don't
1421      find one (like in case of a BLOCK construct).  */
1422   for (real_context = context; ; real_context = real_context->parent)
1423     {
1424       /* We should find something, eventually!  */
1425       gcc_assert (real_context);
1426
1427       context_proc = (real_context->entries ? real_context->entries->sym
1428                                             : real_context->proc_name);
1429
1430       /* In some special cases, there may not be a proc_name, like for this
1431          invalid code:
1432          real(bad_kind()) function foo () ...
1433          when checking the call to bad_kind ().
1434          In these cases, we simply return here and assume that the
1435          call is ok.  */
1436       if (!context_proc)
1437         return false;
1438
1439       if (context_proc->attr.flavor != FL_LABEL)
1440         break;
1441     }
1442
1443   /* A call from sym's body to itself is recursion, of course.  */
1444   if (context_proc == proc_sym)
1445     return true;
1446
1447   /* The same is true if context is a contained procedure and sym the
1448      containing one.  */
1449   if (context_proc->attr.contained)
1450     {
1451       gfc_symbol* parent_proc;
1452
1453       gcc_assert (context->parent);
1454       parent_proc = (context->parent->entries ? context->parent->entries->sym
1455                                               : context->parent->proc_name);
1456
1457       if (parent_proc == proc_sym)
1458         return true;
1459     }
1460
1461   return false;
1462 }
1463
1464
1465 /* Resolve an intrinsic procedure: Set its function/subroutine attribute,
1466    its typespec and formal argument list.  */
1467
1468 static gfc_try
1469 resolve_intrinsic (gfc_symbol *sym, locus *loc)
1470 {
1471   gfc_intrinsic_sym* isym = NULL;
1472   const char* symstd;
1473
1474   if (sym->formal)
1475     return SUCCESS;
1476
1477   /* Already resolved.  */
1478   if (sym->from_intmod && sym->ts.type != BT_UNKNOWN)
1479     return SUCCESS;
1480
1481   /* We already know this one is an intrinsic, so we don't call
1482      gfc_is_intrinsic for full checking but rather use gfc_find_function and
1483      gfc_find_subroutine directly to check whether it is a function or
1484      subroutine.  */
1485
1486   if (sym->intmod_sym_id)
1487     isym = gfc_intrinsic_function_by_id ((gfc_isym_id) sym->intmod_sym_id);
1488   else
1489     isym = gfc_find_function (sym->name);
1490
1491   if (isym)
1492     {
1493       if (sym->ts.type != BT_UNKNOWN && gfc_option.warn_surprising
1494           && !sym->attr.implicit_type)
1495         gfc_warning ("Type specified for intrinsic function '%s' at %L is"
1496                       " ignored", sym->name, &sym->declared_at);
1497
1498       if (!sym->attr.function &&
1499           gfc_add_function (&sym->attr, sym->name, loc) == FAILURE)
1500         return FAILURE;
1501
1502       sym->ts = isym->ts;
1503     }
1504   else if ((isym = gfc_find_subroutine (sym->name)))
1505     {
1506       if (sym->ts.type != BT_UNKNOWN && !sym->attr.implicit_type)
1507         {
1508           gfc_error ("Intrinsic subroutine '%s' at %L shall not have a type"
1509                       " specifier", sym->name, &sym->declared_at);
1510           return FAILURE;
1511         }
1512
1513       if (!sym->attr.subroutine &&
1514           gfc_add_subroutine (&sym->attr, sym->name, loc) == FAILURE)
1515         return FAILURE;
1516     }
1517   else
1518     {
1519       gfc_error ("'%s' declared INTRINSIC at %L does not exist", sym->name,
1520                  &sym->declared_at);
1521       return FAILURE;
1522     }
1523
1524   gfc_copy_formal_args_intr (sym, isym);
1525
1526   /* Check it is actually available in the standard settings.  */
1527   if (gfc_check_intrinsic_standard (isym, &symstd, false, sym->declared_at)
1528       == FAILURE)
1529     {
1530       gfc_error ("The intrinsic '%s' declared INTRINSIC at %L is not"
1531                  " available in the current standard settings but %s.  Use"
1532                  " an appropriate -std=* option or enable -fall-intrinsics"
1533                  " in order to use it.",
1534                  sym->name, &sym->declared_at, symstd);
1535       return FAILURE;
1536     }
1537
1538   return SUCCESS;
1539 }
1540
1541
1542 /* Resolve a procedure expression, like passing it to a called procedure or as
1543    RHS for a procedure pointer assignment.  */
1544
1545 static gfc_try
1546 resolve_procedure_expression (gfc_expr* expr)
1547 {
1548   gfc_symbol* sym;
1549
1550   if (expr->expr_type != EXPR_VARIABLE)
1551     return SUCCESS;
1552   gcc_assert (expr->symtree);
1553
1554   sym = expr->symtree->n.sym;
1555
1556   if (sym->attr.intrinsic)
1557     resolve_intrinsic (sym, &expr->where);
1558
1559   if (sym->attr.flavor != FL_PROCEDURE
1560       || (sym->attr.function && sym->result == sym))
1561     return SUCCESS;
1562
1563   /* A non-RECURSIVE procedure that is used as procedure expression within its
1564      own body is in danger of being called recursively.  */
1565   if (is_illegal_recursion (sym, gfc_current_ns))
1566     gfc_warning ("Non-RECURSIVE procedure '%s' at %L is possibly calling"
1567                  " itself recursively.  Declare it RECURSIVE or use"
1568                  " -frecursive", sym->name, &expr->where);
1569
1570   return SUCCESS;
1571 }
1572
1573
1574 /* Resolve an actual argument list.  Most of the time, this is just
1575    resolving the expressions in the list.
1576    The exception is that we sometimes have to decide whether arguments
1577    that look like procedure arguments are really simple variable
1578    references.  */
1579
1580 static gfc_try
1581 resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype,
1582                         bool no_formal_args)
1583 {
1584   gfc_symbol *sym;
1585   gfc_symtree *parent_st;
1586   gfc_expr *e;
1587   int save_need_full_assumed_size;
1588
1589   for (; arg; arg = arg->next)
1590     {
1591       e = arg->expr;
1592       if (e == NULL)
1593         {
1594           /* Check the label is a valid branching target.  */
1595           if (arg->label)
1596             {
1597               if (arg->label->defined == ST_LABEL_UNKNOWN)
1598                 {
1599                   gfc_error ("Label %d referenced at %L is never defined",
1600                              arg->label->value, &arg->label->where);
1601                   return FAILURE;
1602                 }
1603             }
1604           continue;
1605         }
1606
1607       if (e->expr_type == EXPR_VARIABLE
1608             && e->symtree->n.sym->attr.generic
1609             && no_formal_args
1610             && count_specific_procs (e) != 1)
1611         return FAILURE;
1612
1613       if (e->ts.type != BT_PROCEDURE)
1614         {
1615           save_need_full_assumed_size = need_full_assumed_size;
1616           if (e->expr_type != EXPR_VARIABLE)
1617             need_full_assumed_size = 0;
1618           if (gfc_resolve_expr (e) != SUCCESS)
1619             return FAILURE;
1620           need_full_assumed_size = save_need_full_assumed_size;
1621           goto argument_list;
1622         }
1623
1624       /* See if the expression node should really be a variable reference.  */
1625
1626       sym = e->symtree->n.sym;
1627
1628       if (sym->attr.flavor == FL_PROCEDURE
1629           || sym->attr.intrinsic
1630           || sym->attr.external)
1631         {
1632           int actual_ok;
1633
1634           /* If a procedure is not already determined to be something else
1635              check if it is intrinsic.  */
1636           if (!sym->attr.intrinsic
1637               && !(sym->attr.external || sym->attr.use_assoc
1638                    || sym->attr.if_source == IFSRC_IFBODY)
1639               && gfc_is_intrinsic (sym, sym->attr.subroutine, e->where))
1640             sym->attr.intrinsic = 1;
1641
1642           if (sym->attr.proc == PROC_ST_FUNCTION)
1643             {
1644               gfc_error ("Statement function '%s' at %L is not allowed as an "
1645                          "actual argument", sym->name, &e->where);
1646             }
1647
1648           actual_ok = gfc_intrinsic_actual_ok (sym->name,
1649                                                sym->attr.subroutine);
1650           if (sym->attr.intrinsic && actual_ok == 0)
1651             {
1652               gfc_error ("Intrinsic '%s' at %L is not allowed as an "
1653                          "actual argument", sym->name, &e->where);
1654             }
1655
1656           if (sym->attr.contained && !sym->attr.use_assoc
1657               && sym->ns->proc_name->attr.flavor != FL_MODULE)
1658             {
1659               if (gfc_notify_std (GFC_STD_F2008,
1660                                   "Fortran 2008: Internal procedure '%s' is"
1661                                   " used as actual argument at %L",
1662                                   sym->name, &e->where) == FAILURE)
1663                 return FAILURE;
1664             }
1665
1666           if (sym->attr.elemental && !sym->attr.intrinsic)
1667             {
1668               gfc_error ("ELEMENTAL non-INTRINSIC procedure '%s' is not "
1669                          "allowed as an actual argument at %L", sym->name,
1670                          &e->where);
1671             }
1672
1673           /* Check if a generic interface has a specific procedure
1674             with the same name before emitting an error.  */
1675           if (sym->attr.generic && count_specific_procs (e) != 1)
1676             return FAILURE;
1677
1678           /* Just in case a specific was found for the expression.  */
1679           sym = e->symtree->n.sym;
1680
1681           /* If the symbol is the function that names the current (or
1682              parent) scope, then we really have a variable reference.  */
1683
1684           if (gfc_is_function_return_value (sym, sym->ns))
1685             goto got_variable;
1686
1687           /* If all else fails, see if we have a specific intrinsic.  */
1688           if (sym->ts.type == BT_UNKNOWN && sym->attr.intrinsic)
1689             {
1690               gfc_intrinsic_sym *isym;
1691
1692               isym = gfc_find_function (sym->name);
1693               if (isym == NULL || !isym->specific)
1694                 {
1695                   gfc_error ("Unable to find a specific INTRINSIC procedure "
1696                              "for the reference '%s' at %L", sym->name,
1697                              &e->where);
1698                   return FAILURE;
1699                 }
1700               sym->ts = isym->ts;
1701               sym->attr.intrinsic = 1;
1702               sym->attr.function = 1;
1703             }
1704
1705           if (gfc_resolve_expr (e) == FAILURE)
1706             return FAILURE;
1707           goto argument_list;
1708         }
1709
1710       /* See if the name is a module procedure in a parent unit.  */
1711
1712       if (was_declared (sym) || sym->ns->parent == NULL)
1713         goto got_variable;
1714
1715       if (gfc_find_sym_tree (sym->name, sym->ns->parent, 1, &parent_st))
1716         {
1717           gfc_error ("Symbol '%s' at %L is ambiguous", sym->name, &e->where);
1718           return FAILURE;
1719         }
1720
1721       if (parent_st == NULL)
1722         goto got_variable;
1723
1724       sym = parent_st->n.sym;
1725       e->symtree = parent_st;           /* Point to the right thing.  */
1726
1727       if (sym->attr.flavor == FL_PROCEDURE
1728           || sym->attr.intrinsic
1729           || sym->attr.external)
1730         {
1731           if (gfc_resolve_expr (e) == FAILURE)
1732             return FAILURE;
1733           goto argument_list;
1734         }
1735
1736     got_variable:
1737       e->expr_type = EXPR_VARIABLE;
1738       e->ts = sym->ts;
1739       if (sym->as != NULL)
1740         {
1741           e->rank = sym->as->rank;
1742           e->ref = gfc_get_ref ();
1743           e->ref->type = REF_ARRAY;
1744           e->ref->u.ar.type = AR_FULL;
1745           e->ref->u.ar.as = sym->as;
1746         }
1747
1748       /* Expressions are assigned a default ts.type of BT_PROCEDURE in
1749          primary.c (match_actual_arg). If above code determines that it
1750          is a  variable instead, it needs to be resolved as it was not
1751          done at the beginning of this function.  */
1752       save_need_full_assumed_size = need_full_assumed_size;
1753       if (e->expr_type != EXPR_VARIABLE)
1754         need_full_assumed_size = 0;
1755       if (gfc_resolve_expr (e) != SUCCESS)
1756         return FAILURE;
1757       need_full_assumed_size = save_need_full_assumed_size;
1758
1759     argument_list:
1760       /* Check argument list functions %VAL, %LOC and %REF.  There is
1761          nothing to do for %REF.  */
1762       if (arg->name && arg->name[0] == '%')
1763         {
1764           if (strncmp ("%VAL", arg->name, 4) == 0)
1765             {
1766               if (e->ts.type == BT_CHARACTER || e->ts.type == BT_DERIVED)
1767                 {
1768                   gfc_error ("By-value argument at %L is not of numeric "
1769                              "type", &e->where);
1770                   return FAILURE;
1771                 }
1772
1773               if (e->rank)
1774                 {
1775                   gfc_error ("By-value argument at %L cannot be an array or "
1776                              "an array section", &e->where);
1777                 return FAILURE;
1778                 }
1779
1780               /* Intrinsics are still PROC_UNKNOWN here.  However,
1781                  since same file external procedures are not resolvable
1782                  in gfortran, it is a good deal easier to leave them to
1783                  intrinsic.c.  */
1784               if (ptype != PROC_UNKNOWN
1785                   && ptype != PROC_DUMMY
1786                   && ptype != PROC_EXTERNAL
1787                   && ptype != PROC_MODULE)
1788                 {
1789                   gfc_error ("By-value argument at %L is not allowed "
1790                              "in this context", &e->where);
1791                   return FAILURE;
1792                 }
1793             }
1794
1795           /* Statement functions have already been excluded above.  */
1796           else if (strncmp ("%LOC", arg->name, 4) == 0
1797                    && e->ts.type == BT_PROCEDURE)
1798             {
1799               if (e->symtree->n.sym->attr.proc == PROC_INTERNAL)
1800                 {
1801                   gfc_error ("Passing internal procedure at %L by location "
1802                              "not allowed", &e->where);
1803                   return FAILURE;
1804                 }
1805             }
1806         }
1807
1808       /* Fortran 2008, C1237.  */
1809       if (e->expr_type == EXPR_VARIABLE && gfc_is_coindexed (e)
1810           && gfc_has_ultimate_pointer (e))
1811         {
1812           gfc_error ("Coindexed actual argument at %L with ultimate pointer "
1813                      "component", &e->where);
1814           return FAILURE;
1815         }
1816     }
1817
1818   return SUCCESS;
1819 }
1820
1821
1822 /* Do the checks of the actual argument list that are specific to elemental
1823    procedures.  If called with c == NULL, we have a function, otherwise if
1824    expr == NULL, we have a subroutine.  */
1825
1826 static gfc_try
1827 resolve_elemental_actual (gfc_expr *expr, gfc_code *c)
1828 {
1829   gfc_actual_arglist *arg0;
1830   gfc_actual_arglist *arg;
1831   gfc_symbol *esym = NULL;
1832   gfc_intrinsic_sym *isym = NULL;
1833   gfc_expr *e = NULL;
1834   gfc_intrinsic_arg *iformal = NULL;
1835   gfc_formal_arglist *eformal = NULL;
1836   bool formal_optional = false;
1837   bool set_by_optional = false;
1838   int i;
1839   int rank = 0;
1840
1841   /* Is this an elemental procedure?  */
1842   if (expr && expr->value.function.actual != NULL)
1843     {
1844       if (expr->value.function.esym != NULL
1845           && expr->value.function.esym->attr.elemental)
1846         {
1847           arg0 = expr->value.function.actual;
1848           esym = expr->value.function.esym;
1849         }
1850       else if (expr->value.function.isym != NULL
1851                && expr->value.function.isym->elemental)
1852         {
1853           arg0 = expr->value.function.actual;
1854           isym = expr->value.function.isym;
1855         }
1856       else
1857         return SUCCESS;
1858     }
1859   else if (c && c->ext.actual != NULL)
1860     {
1861       arg0 = c->ext.actual;
1862
1863       if (c->resolved_sym)
1864         esym = c->resolved_sym;
1865       else
1866         esym = c->symtree->n.sym;
1867       gcc_assert (esym);
1868
1869       if (!esym->attr.elemental)
1870         return SUCCESS;
1871     }
1872   else
1873     return SUCCESS;
1874
1875   /* The rank of an elemental is the rank of its array argument(s).  */
1876   for (arg = arg0; arg; arg = arg->next)
1877     {
1878       if (arg->expr != NULL && arg->expr->rank > 0)
1879         {
1880           rank = arg->expr->rank;
1881           if (arg->expr->expr_type == EXPR_VARIABLE
1882               && arg->expr->symtree->n.sym->attr.optional)
1883             set_by_optional = true;
1884
1885           /* Function specific; set the result rank and shape.  */
1886           if (expr)
1887             {
1888               expr->rank = rank;
1889               if (!expr->shape && arg->expr->shape)
1890                 {
1891                   expr->shape = gfc_get_shape (rank);
1892                   for (i = 0; i < rank; i++)
1893                     mpz_init_set (expr->shape[i], arg->expr->shape[i]);
1894                 }
1895             }
1896           break;
1897         }
1898     }
1899
1900   /* If it is an array, it shall not be supplied as an actual argument
1901      to an elemental procedure unless an array of the same rank is supplied
1902      as an actual argument corresponding to a nonoptional dummy argument of
1903      that elemental procedure(12.4.1.5).  */
1904   formal_optional = false;
1905   if (isym)
1906     iformal = isym->formal;
1907   else
1908     eformal = esym->formal;
1909
1910   for (arg = arg0; arg; arg = arg->next)
1911     {
1912       if (eformal)
1913         {
1914           if (eformal->sym && eformal->sym->attr.optional)
1915             formal_optional = true;
1916           eformal = eformal->next;
1917         }
1918       else if (isym && iformal)
1919         {
1920           if (iformal->optional)
1921             formal_optional = true;
1922           iformal = iformal->next;
1923         }
1924       else if (isym)
1925         formal_optional = true;
1926
1927       if (pedantic && arg->expr != NULL
1928           && arg->expr->expr_type == EXPR_VARIABLE
1929           && arg->expr->symtree->n.sym->attr.optional
1930           && formal_optional
1931           && arg->expr->rank
1932           && (set_by_optional || arg->expr->rank != rank)
1933           && !(isym && isym->id == GFC_ISYM_CONVERSION))
1934         {
1935           gfc_warning ("'%s' at %L is an array and OPTIONAL; IF IT IS "
1936                        "MISSING, it cannot be the actual argument of an "
1937                        "ELEMENTAL procedure unless there is a non-optional "
1938                        "argument with the same rank (12.4.1.5)",
1939                        arg->expr->symtree->n.sym->name, &arg->expr->where);
1940           return FAILURE;
1941         }
1942     }
1943
1944   for (arg = arg0; arg; arg = arg->next)
1945     {
1946       if (arg->expr == NULL || arg->expr->rank == 0)
1947         continue;
1948
1949       /* Being elemental, the last upper bound of an assumed size array
1950          argument must be present.  */
1951       if (resolve_assumed_size_actual (arg->expr))
1952         return FAILURE;
1953
1954       /* Elemental procedure's array actual arguments must conform.  */
1955       if (e != NULL)
1956         {
1957           if (gfc_check_conformance (arg->expr, e,
1958                                      "elemental procedure") == FAILURE)
1959             return FAILURE;
1960         }
1961       else
1962         e = arg->expr;
1963     }
1964
1965   /* INTENT(OUT) is only allowed for subroutines; if any actual argument
1966      is an array, the intent inout/out variable needs to be also an array.  */
1967   if (rank > 0 && esym && expr == NULL)
1968     for (eformal = esym->formal, arg = arg0; arg && eformal;
1969          arg = arg->next, eformal = eformal->next)
1970       if ((eformal->sym->attr.intent == INTENT_OUT
1971            || eformal->sym->attr.intent == INTENT_INOUT)
1972           && arg->expr && arg->expr->rank == 0)
1973         {
1974           gfc_error ("Actual argument at %L for INTENT(%s) dummy '%s' of "
1975                      "ELEMENTAL subroutine '%s' is a scalar, but another "
1976                      "actual argument is an array", &arg->expr->where,
1977                      (eformal->sym->attr.intent == INTENT_OUT) ? "OUT"
1978                      : "INOUT", eformal->sym->name, esym->name);
1979           return FAILURE;
1980         }
1981   return SUCCESS;
1982 }
1983
1984
1985 /* This function does the checking of references to global procedures
1986    as defined in sections 18.1 and 14.1, respectively, of the Fortran
1987    77 and 95 standards.  It checks for a gsymbol for the name, making
1988    one if it does not already exist.  If it already exists, then the
1989    reference being resolved must correspond to the type of gsymbol.
1990    Otherwise, the new symbol is equipped with the attributes of the
1991    reference.  The corresponding code that is called in creating
1992    global entities is parse.c.
1993
1994    In addition, for all but -std=legacy, the gsymbols are used to
1995    check the interfaces of external procedures from the same file.
1996    The namespace of the gsymbol is resolved and then, once this is
1997    done the interface is checked.  */
1998
1999
2000 static bool
2001 not_in_recursive (gfc_symbol *sym, gfc_namespace *gsym_ns)
2002 {
2003   if (!gsym_ns->proc_name->attr.recursive)
2004     return true;
2005
2006   if (sym->ns == gsym_ns)
2007     return false;
2008
2009   if (sym->ns->parent && sym->ns->parent == gsym_ns)
2010     return false;
2011
2012   return true;
2013 }
2014
2015 static bool
2016 not_entry_self_reference  (gfc_symbol *sym, gfc_namespace *gsym_ns)
2017 {
2018   if (gsym_ns->entries)
2019     {
2020       gfc_entry_list *entry = gsym_ns->entries;
2021
2022       for (; entry; entry = entry->next)
2023         {
2024           if (strcmp (sym->name, entry->sym->name) == 0)
2025             {
2026               if (strcmp (gsym_ns->proc_name->name,
2027                           sym->ns->proc_name->name) == 0)
2028                 return false;
2029
2030               if (sym->ns->parent
2031                   && strcmp (gsym_ns->proc_name->name,
2032                              sym->ns->parent->proc_name->name) == 0)
2033                 return false;
2034             }
2035         }
2036     }
2037   return true;
2038 }
2039
2040 static void
2041 resolve_global_procedure (gfc_symbol *sym, locus *where,
2042                           gfc_actual_arglist **actual, int sub)
2043 {
2044   gfc_gsymbol * gsym;
2045   gfc_namespace *ns;
2046   enum gfc_symbol_type type;
2047
2048   type = sub ? GSYM_SUBROUTINE : GSYM_FUNCTION;
2049
2050   gsym = gfc_get_gsymbol (sym->name);
2051
2052   if ((gsym->type != GSYM_UNKNOWN && gsym->type != type))
2053     gfc_global_used (gsym, where);
2054
2055   if (gfc_option.flag_whole_file
2056         && (sym->attr.if_source == IFSRC_UNKNOWN
2057             || sym->attr.if_source == IFSRC_IFBODY)
2058         && gsym->type != GSYM_UNKNOWN
2059         && gsym->ns
2060         && gsym->ns->resolved != -1
2061         && gsym->ns->proc_name
2062         && not_in_recursive (sym, gsym->ns)
2063         && not_entry_self_reference (sym, gsym->ns))
2064     {
2065       gfc_symbol *def_sym;
2066
2067       /* Resolve the gsymbol namespace if needed.  */
2068       if (!gsym->ns->resolved)
2069         {
2070           gfc_dt_list *old_dt_list;
2071           struct gfc_omp_saved_state old_omp_state;
2072
2073           /* Stash away derived types so that the backend_decls do not
2074              get mixed up.  */
2075           old_dt_list = gfc_derived_types;
2076           gfc_derived_types = NULL;
2077           /* And stash away openmp state.  */
2078           gfc_omp_save_and_clear_state (&old_omp_state);
2079
2080           gfc_resolve (gsym->ns);
2081
2082           /* Store the new derived types with the global namespace.  */
2083           if (gfc_derived_types)
2084             gsym->ns->derived_types = gfc_derived_types;
2085
2086           /* Restore the derived types of this namespace.  */
2087           gfc_derived_types = old_dt_list;
2088           /* And openmp state.  */
2089           gfc_omp_restore_state (&old_omp_state);
2090         }
2091
2092       /* Make sure that translation for the gsymbol occurs before
2093          the procedure currently being resolved.  */
2094       ns = gfc_global_ns_list;
2095       for (; ns && ns != gsym->ns; ns = ns->sibling)
2096         {
2097           if (ns->sibling == gsym->ns)
2098             {
2099               ns->sibling = gsym->ns->sibling;
2100               gsym->ns->sibling = gfc_global_ns_list;
2101               gfc_global_ns_list = gsym->ns;
2102               break;
2103             }
2104         }
2105
2106       def_sym = gsym->ns->proc_name;
2107       if (def_sym->attr.entry_master)
2108         {
2109           gfc_entry_list *entry;
2110           for (entry = gsym->ns->entries; entry; entry = entry->next)
2111             if (strcmp (entry->sym->name, sym->name) == 0)
2112               {
2113                 def_sym = entry->sym;
2114                 break;
2115               }
2116         }
2117
2118       /* Differences in constant character lengths.  */
2119       if (sym->attr.function && sym->ts.type == BT_CHARACTER)
2120         {
2121           long int l1 = 0, l2 = 0;
2122           gfc_charlen *cl1 = sym->ts.u.cl;
2123           gfc_charlen *cl2 = def_sym->ts.u.cl;
2124
2125           if (cl1 != NULL
2126               && cl1->length != NULL
2127               && cl1->length->expr_type == EXPR_CONSTANT)
2128             l1 = mpz_get_si (cl1->length->value.integer);
2129
2130           if (cl2 != NULL
2131               && cl2->length != NULL
2132               && cl2->length->expr_type == EXPR_CONSTANT)
2133             l2 = mpz_get_si (cl2->length->value.integer);
2134
2135           if (l1 && l2 && l1 != l2)
2136             gfc_error ("Character length mismatch in return type of "
2137                        "function '%s' at %L (%ld/%ld)", sym->name,
2138                        &sym->declared_at, l1, l2);
2139         }
2140
2141      /* Type mismatch of function return type and expected type.  */
2142      if (sym->attr.function
2143          && !gfc_compare_types (&sym->ts, &def_sym->ts))
2144         gfc_error ("Return type mismatch of function '%s' at %L (%s/%s)",
2145                    sym->name, &sym->declared_at, gfc_typename (&sym->ts),
2146                    gfc_typename (&def_sym->ts));
2147
2148       if (def_sym->formal && sym->attr.if_source != IFSRC_IFBODY)
2149         {
2150           gfc_formal_arglist *arg = def_sym->formal;
2151           for ( ; arg; arg = arg->next)
2152             if (!arg->sym)
2153               continue;
2154             /* F2003, 12.3.1.1 (2a); F2008, 12.4.2.2 (2a)  */
2155             else if (arg->sym->attr.allocatable
2156                      || arg->sym->attr.asynchronous
2157                      || arg->sym->attr.optional
2158                      || arg->sym->attr.pointer
2159                      || arg->sym->attr.target
2160                      || arg->sym->attr.value
2161                      || arg->sym->attr.volatile_)
2162               {
2163                 gfc_error ("Dummy argument '%s' of procedure '%s' at %L "
2164                            "has an attribute that requires an explicit "
2165                            "interface for this procedure", arg->sym->name,
2166                            sym->name, &sym->declared_at);
2167                 break;
2168               }
2169             /* F2003, 12.3.1.1 (2b); F2008, 12.4.2.2 (2b)  */
2170             else if (arg->sym && arg->sym->as
2171                      && arg->sym->as->type == AS_ASSUMED_SHAPE)
2172               {
2173                 gfc_error ("Procedure '%s' at %L with assumed-shape dummy "
2174                            "argument '%s' must have an explicit interface",
2175                            sym->name, &sym->declared_at, arg->sym->name);
2176                 break;
2177               }
2178             /* F2008, 12.4.2.2 (2c)  */
2179             else if (arg->sym->attr.codimension)
2180               {
2181                 gfc_error ("Procedure '%s' at %L with coarray dummy argument "
2182                            "'%s' must have an explicit interface",
2183                            sym->name, &sym->declared_at, arg->sym->name);
2184                 break;
2185               }
2186             /* F2003, 12.3.1.1 (2c); F2008, 12.4.2.2 (2d)   */
2187             else if (false) /* TODO: is a parametrized derived type  */
2188               {
2189                 gfc_error ("Procedure '%s' at %L with parametrized derived "
2190                            "type argument '%s' must have an explicit "
2191                            "interface", sym->name, &sym->declared_at,
2192                            arg->sym->name);
2193                 break;
2194               }
2195             /* F2003, 12.3.1.1 (2d); F2008, 12.4.2.2 (2e)   */
2196             else if (arg->sym->ts.type == BT_CLASS)
2197               {
2198                 gfc_error ("Procedure '%s' at %L with polymorphic dummy "
2199                            "argument '%s' must have an explicit interface",
2200                            sym->name, &sym->declared_at, arg->sym->name);
2201                 break;
2202               }
2203         }
2204
2205       if (def_sym->attr.function)
2206         {
2207           /* F2003, 12.3.1.1 (3a); F2008, 12.4.2.2 (3a) */
2208           if (def_sym->as && def_sym->as->rank
2209               && (!sym->as || sym->as->rank != def_sym->as->rank))
2210             gfc_error ("The reference to function '%s' at %L either needs an "
2211                        "explicit INTERFACE or the rank is incorrect", sym->name,
2212                        where);
2213
2214           /* F2003, 12.3.1.1 (3b); F2008, 12.4.2.2 (3b) */
2215           if ((def_sym->result->attr.pointer
2216                || def_sym->result->attr.allocatable)
2217                && (sym->attr.if_source != IFSRC_IFBODY
2218                    || def_sym->result->attr.pointer
2219                         != sym->result->attr.pointer
2220                    || def_sym->result->attr.allocatable
2221                         != sym->result->attr.allocatable))
2222             gfc_error ("Function '%s' at %L with a POINTER or ALLOCATABLE "
2223                        "result must have an explicit interface", sym->name,
2224                        where);
2225
2226           /* F2003, 12.3.1.1 (3c); F2008, 12.4.2.2 (3c)  */
2227           if (sym->ts.type == BT_CHARACTER && sym->attr.if_source != IFSRC_IFBODY
2228               && def_sym->ts.type == BT_CHARACTER && def_sym->ts.u.cl->length != NULL)
2229             {
2230               gfc_charlen *cl = sym->ts.u.cl;
2231
2232               if (!sym->attr.entry_master && sym->attr.if_source == IFSRC_UNKNOWN
2233                   && cl && cl->length && cl->length->expr_type != EXPR_CONSTANT)
2234                 {
2235                   gfc_error ("Nonconstant character-length function '%s' at %L "
2236                              "must have an explicit interface", sym->name,
2237                              &sym->declared_at);
2238                 }
2239             }
2240         }
2241
2242       /* F2003, 12.3.1.1 (4); F2008, 12.4.2.2 (4) */
2243       if (def_sym->attr.elemental && !sym->attr.elemental)
2244         {
2245           gfc_error ("ELEMENTAL procedure '%s' at %L must have an explicit "
2246                      "interface", sym->name, &sym->declared_at);
2247         }
2248
2249       /* F2003, 12.3.1.1 (5); F2008, 12.4.2.2 (5) */
2250       if (def_sym->attr.is_bind_c && !sym->attr.is_bind_c)
2251         {
2252           gfc_error ("Procedure '%s' at %L with BIND(C) attribute must have "
2253                      "an explicit interface", sym->name, &sym->declared_at);
2254         }
2255
2256       if (gfc_option.flag_whole_file == 1
2257           || ((gfc_option.warn_std & GFC_STD_LEGACY)
2258               && !(gfc_option.warn_std & GFC_STD_GNU)))
2259         gfc_errors_to_warnings (1);
2260
2261       if (sym->attr.if_source != IFSRC_IFBODY)
2262         gfc_procedure_use (def_sym, actual, where);
2263
2264       gfc_errors_to_warnings (0);
2265     }
2266
2267   if (gsym->type == GSYM_UNKNOWN)
2268     {
2269       gsym->type = type;
2270       gsym->where = *where;
2271     }
2272
2273   gsym->used = 1;
2274 }
2275
2276
2277 /************* Function resolution *************/
2278
2279 /* Resolve a function call known to be generic.
2280    Section 14.1.2.4.1.  */
2281
2282 static match
2283 resolve_generic_f0 (gfc_expr *expr, gfc_symbol *sym)
2284 {
2285   gfc_symbol *s;
2286
2287   if (sym->attr.generic)
2288     {
2289       s = gfc_search_interface (sym->generic, 0, &expr->value.function.actual);
2290       if (s != NULL)
2291         {
2292           expr->value.function.name = s->name;
2293           expr->value.function.esym = s;
2294
2295           if (s->ts.type != BT_UNKNOWN)
2296             expr->ts = s->ts;
2297           else if (s->result != NULL && s->result->ts.type != BT_UNKNOWN)
2298             expr->ts = s->result->ts;
2299
2300           if (s->as != NULL)
2301             expr->rank = s->as->rank;
2302           else if (s->result != NULL && s->result->as != NULL)
2303             expr->rank = s->result->as->rank;
2304
2305           gfc_set_sym_referenced (expr->value.function.esym);
2306
2307           return MATCH_YES;
2308         }
2309
2310       /* TODO: Need to search for elemental references in generic
2311          interface.  */
2312     }
2313
2314   if (sym->attr.intrinsic)
2315     return gfc_intrinsic_func_interface (expr, 0);
2316
2317   return MATCH_NO;
2318 }
2319
2320
2321 static gfc_try
2322 resolve_generic_f (gfc_expr *expr)
2323 {
2324   gfc_symbol *sym;
2325   match m;
2326
2327   sym = expr->symtree->n.sym;
2328
2329   for (;;)
2330     {
2331       m = resolve_generic_f0 (expr, sym);
2332       if (m == MATCH_YES)
2333         return SUCCESS;
2334       else if (m == MATCH_ERROR)
2335         return FAILURE;
2336
2337 generic:
2338       if (sym->ns->parent == NULL)
2339         break;
2340       gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
2341
2342       if (sym == NULL)
2343         break;
2344       if (!generic_sym (sym))
2345         goto generic;
2346     }
2347
2348   /* Last ditch attempt.  See if the reference is to an intrinsic
2349      that possesses a matching interface.  14.1.2.4  */
2350   if (sym && !gfc_is_intrinsic (sym, 0, expr->where))
2351     {
2352       gfc_error ("There is no specific function for the generic '%s' at %L",
2353                  expr->symtree->n.sym->name, &expr->where);
2354       return FAILURE;
2355     }
2356
2357   m = gfc_intrinsic_func_interface (expr, 0);
2358   if (m == MATCH_YES)
2359     return SUCCESS;
2360   if (m == MATCH_NO)
2361     gfc_error ("Generic function '%s' at %L is not consistent with a "
2362                "specific intrinsic interface", expr->symtree->n.sym->name,
2363                &expr->where);
2364
2365   return FAILURE;
2366 }
2367
2368
2369 /* Resolve a function call known to be specific.  */
2370
2371 static match
2372 resolve_specific_f0 (gfc_symbol *sym, gfc_expr *expr)
2373 {
2374   match m;
2375
2376   if (sym->attr.external || sym->attr.if_source == IFSRC_IFBODY)
2377     {
2378       if (sym->attr.dummy)
2379         {
2380           sym->attr.proc = PROC_DUMMY;
2381           goto found;
2382         }
2383
2384       sym->attr.proc = PROC_EXTERNAL;
2385       goto found;
2386     }
2387
2388   if (sym->attr.proc == PROC_MODULE
2389       || sym->attr.proc == PROC_ST_FUNCTION
2390       || sym->attr.proc == PROC_INTERNAL)
2391     goto found;
2392
2393   if (sym->attr.intrinsic)
2394     {
2395       m = gfc_intrinsic_func_interface (expr, 1);
2396       if (m == MATCH_YES)
2397         return MATCH_YES;
2398       if (m == MATCH_NO)
2399         gfc_error ("Function '%s' at %L is INTRINSIC but is not compatible "
2400                    "with an intrinsic", sym->name, &expr->where);
2401
2402       return MATCH_ERROR;
2403     }
2404
2405   return MATCH_NO;
2406
2407 found:
2408   gfc_procedure_use (sym, &expr->value.function.actual, &expr->where);
2409
2410   if (sym->result)
2411     expr->ts = sym->result->ts;
2412   else
2413     expr->ts = sym->ts;
2414   expr->value.function.name = sym->name;
2415   expr->value.function.esym = sym;
2416   if (sym->as != NULL)
2417     expr->rank = sym->as->rank;
2418
2419   return MATCH_YES;
2420 }
2421
2422
2423 static gfc_try
2424 resolve_specific_f (gfc_expr *expr)
2425 {
2426   gfc_symbol *sym;
2427   match m;
2428
2429   sym = expr->symtree->n.sym;
2430
2431   for (;;)
2432     {
2433       m = resolve_specific_f0 (sym, expr);
2434       if (m == MATCH_YES)
2435         return SUCCESS;
2436       if (m == MATCH_ERROR)
2437         return FAILURE;
2438
2439       if (sym->ns->parent == NULL)
2440         break;
2441
2442       gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
2443
2444       if (sym == NULL)
2445         break;
2446     }
2447
2448   gfc_error ("Unable to resolve the specific function '%s' at %L",
2449              expr->symtree->n.sym->name, &expr->where);
2450
2451   return SUCCESS;
2452 }
2453
2454
2455 /* Resolve a procedure call not known to be generic nor specific.  */
2456
2457 static gfc_try
2458 resolve_unknown_f (gfc_expr *expr)
2459 {
2460   gfc_symbol *sym;
2461   gfc_typespec *ts;
2462
2463   sym = expr->symtree->n.sym;
2464
2465   if (sym->attr.dummy)
2466     {
2467       sym->attr.proc = PROC_DUMMY;
2468       expr->value.function.name = sym->name;
2469       goto set_type;
2470     }
2471
2472   /* See if we have an intrinsic function reference.  */
2473
2474   if (gfc_is_intrinsic (sym, 0, expr->where))
2475     {
2476       if (gfc_intrinsic_func_interface (expr, 1) == MATCH_YES)
2477         return SUCCESS;
2478       return FAILURE;
2479     }
2480
2481   /* The reference is to an external name.  */
2482
2483   sym->attr.proc = PROC_EXTERNAL;
2484   expr->value.function.name = sym->name;
2485   expr->value.function.esym = expr->symtree->n.sym;
2486
2487   if (sym->as != NULL)
2488     expr->rank = sym->as->rank;
2489
2490   /* Type of the expression is either the type of the symbol or the
2491      default type of the symbol.  */
2492
2493 set_type:
2494   gfc_procedure_use (sym, &expr->value.function.actual, &expr->where);
2495
2496   if (sym->ts.type != BT_UNKNOWN)
2497     expr->ts = sym->ts;
2498   else
2499     {
2500       ts = gfc_get_default_type (sym->name, sym->ns);
2501
2502       if (ts->type == BT_UNKNOWN)
2503         {
2504           gfc_error ("Function '%s' at %L has no IMPLICIT type",
2505                      sym->name, &expr->where);
2506           return FAILURE;
2507         }
2508       else
2509         expr->ts = *ts;
2510     }
2511
2512   return SUCCESS;
2513 }
2514
2515
2516 /* Return true, if the symbol is an external procedure.  */
2517 static bool
2518 is_external_proc (gfc_symbol *sym)
2519 {
2520   if (!sym->attr.dummy && !sym->attr.contained
2521         && !(sym->attr.intrinsic
2522               || gfc_is_intrinsic (sym, sym->attr.subroutine, sym->declared_at))
2523         && sym->attr.proc != PROC_ST_FUNCTION
2524         && !sym->attr.proc_pointer
2525         && !sym->attr.use_assoc
2526         && sym->name)
2527     return true;
2528
2529   return false;
2530 }
2531
2532
2533 /* Figure out if a function reference is pure or not.  Also set the name
2534    of the function for a potential error message.  Return nonzero if the
2535    function is PURE, zero if not.  */
2536 static int
2537 pure_stmt_function (gfc_expr *, gfc_symbol *);
2538
2539 static int
2540 pure_function (gfc_expr *e, const char **name)
2541 {
2542   int pure;
2543
2544   *name = NULL;
2545
2546   if (e->symtree != NULL
2547         && e->symtree->n.sym != NULL
2548         && e->symtree->n.sym->attr.proc == PROC_ST_FUNCTION)
2549     return pure_stmt_function (e, e->symtree->n.sym);
2550
2551   if (e->value.function.esym)
2552     {
2553       pure = gfc_pure (e->value.function.esym);
2554       *name = e->value.function.esym->name;
2555     }
2556   else if (e->value.function.isym)
2557     {
2558       pure = e->value.function.isym->pure
2559              || e->value.function.isym->elemental;
2560       *name = e->value.function.isym->name;
2561     }
2562   else
2563     {
2564       /* Implicit functions are not pure.  */
2565       pure = 0;
2566       *name = e->value.function.name;
2567     }
2568
2569   return pure;
2570 }
2571
2572
2573 static bool
2574 impure_stmt_fcn (gfc_expr *e, gfc_symbol *sym,
2575                  int *f ATTRIBUTE_UNUSED)
2576 {
2577   const char *name;
2578
2579   /* Don't bother recursing into other statement functions
2580      since they will be checked individually for purity.  */
2581   if (e->expr_type != EXPR_FUNCTION
2582         || !e->symtree
2583         || e->symtree->n.sym == sym
2584         || e->symtree->n.sym->attr.proc == PROC_ST_FUNCTION)
2585     return false;
2586
2587   return pure_function (e, &name) ? false : true;
2588 }
2589
2590
2591 static int
2592 pure_stmt_function (gfc_expr *e, gfc_symbol *sym)
2593 {
2594   return gfc_traverse_expr (e, sym, impure_stmt_fcn, 0) ? 0 : 1;
2595 }
2596
2597
2598 static gfc_try
2599 is_scalar_expr_ptr (gfc_expr *expr)
2600 {
2601   gfc_try retval = SUCCESS;
2602   gfc_ref *ref;
2603   int start;
2604   int end;
2605
2606   /* See if we have a gfc_ref, which means we have a substring, array
2607      reference, or a component.  */
2608   if (expr->ref != NULL)
2609     {
2610       ref = expr->ref;
2611       while (ref->next != NULL)
2612         ref = ref->next;
2613
2614       switch (ref->type)
2615         {
2616         case REF_SUBSTRING:
2617           if (ref->u.ss.start == NULL || ref->u.ss.end == NULL
2618               || gfc_dep_compare_expr (ref->u.ss.start, ref->u.ss.end) != 0)
2619             retval = FAILURE;
2620           break;
2621
2622         case REF_ARRAY:
2623           if (ref->u.ar.type == AR_ELEMENT)
2624             retval = SUCCESS;
2625           else if (ref->u.ar.type == AR_FULL)
2626             {
2627               /* The user can give a full array if the array is of size 1.  */
2628               if (ref->u.ar.as != NULL
2629                   && ref->u.ar.as->rank == 1
2630                   && ref->u.ar.as->type == AS_EXPLICIT
2631                   && ref->u.ar.as->lower[0] != NULL
2632                   && ref->u.ar.as->lower[0]->expr_type == EXPR_CONSTANT
2633                   && ref->u.ar.as->upper[0] != NULL
2634                   && ref->u.ar.as->upper[0]->expr_type == EXPR_CONSTANT)
2635                 {
2636                   /* If we have a character string, we need to check if
2637                      its length is one.  */
2638                   if (expr->ts.type == BT_CHARACTER)
2639                     {
2640                       if (expr->ts.u.cl == NULL
2641                           || expr->ts.u.cl->length == NULL
2642                           || mpz_cmp_si (expr->ts.u.cl->length->value.integer, 1)
2643                           != 0)
2644                         retval = FAILURE;
2645                     }
2646                   else
2647                     {
2648                       /* We have constant lower and upper bounds.  If the
2649                          difference between is 1, it can be considered a
2650                          scalar.
2651                          FIXME: Use gfc_dep_compare_expr instead.  */
2652                       start = (int) mpz_get_si
2653                                 (ref->u.ar.as->lower[0]->value.integer);
2654                       end = (int) mpz_get_si
2655                                 (ref->u.ar.as->upper[0]->value.integer);
2656                       if (end - start + 1 != 1)
2657                         retval = FAILURE;
2658                    }
2659                 }
2660               else
2661                 retval = FAILURE;
2662             }
2663           else
2664             retval = FAILURE;
2665           break;
2666         default:
2667           retval = SUCCESS;
2668           break;
2669         }
2670     }
2671   else if (expr->ts.type == BT_CHARACTER && expr->rank == 0)
2672     {
2673       /* Character string.  Make sure it's of length 1.  */
2674       if (expr->ts.u.cl == NULL
2675           || expr->ts.u.cl->length == NULL
2676           || mpz_cmp_si (expr->ts.u.cl->length->value.integer, 1) != 0)
2677         retval = FAILURE;
2678     }
2679   else if (expr->rank != 0)
2680     retval = FAILURE;
2681
2682   return retval;
2683 }
2684
2685
2686 /* Match one of the iso_c_binding functions (c_associated or c_loc)
2687    and, in the case of c_associated, set the binding label based on
2688    the arguments.  */
2689
2690 static gfc_try
2691 gfc_iso_c_func_interface (gfc_symbol *sym, gfc_actual_arglist *args,
2692                           gfc_symbol **new_sym)
2693 {
2694   char name[GFC_MAX_SYMBOL_LEN + 1];
2695   char binding_label[GFC_MAX_BINDING_LABEL_LEN + 1];
2696   int optional_arg = 0;
2697   gfc_try retval = SUCCESS;
2698   gfc_symbol *args_sym;
2699   gfc_typespec *arg_ts;
2700   symbol_attribute arg_attr;
2701
2702   if (args->expr->expr_type == EXPR_CONSTANT
2703       || args->expr->expr_type == EXPR_OP
2704       || args->expr->expr_type == EXPR_NULL)
2705     {
2706       gfc_error ("Argument to '%s' at %L is not a variable",
2707                  sym->name, &(args->expr->where));
2708       return FAILURE;
2709     }
2710
2711   args_sym = args->expr->symtree->n.sym;
2712
2713   /* The typespec for the actual arg should be that stored in the expr
2714      and not necessarily that of the expr symbol (args_sym), because
2715      the actual expression could be a part-ref of the expr symbol.  */
2716   arg_ts = &(args->expr->ts);
2717   arg_attr = gfc_expr_attr (args->expr);
2718
2719   if (sym->intmod_sym_id == ISOCBINDING_ASSOCIATED)
2720     {
2721       /* If the user gave two args then they are providing something for
2722          the optional arg (the second cptr).  Therefore, set the name and
2723          binding label to the c_associated for two cptrs.  Otherwise,
2724          set c_associated to expect one cptr.  */
2725       if (args->next)
2726         {
2727           /* two args.  */
2728           sprintf (name, "%s_2", sym->name);
2729           sprintf (binding_label, "%s_2", sym->binding_label);
2730           optional_arg = 1;
2731         }
2732       else
2733         {
2734           /* one arg.  */
2735           sprintf (name, "%s_1", sym->name);
2736           sprintf (binding_label, "%s_1", sym->binding_label);
2737           optional_arg = 0;
2738         }
2739
2740       /* Get a new symbol for the version of c_associated that
2741          will get called.  */
2742       *new_sym = get_iso_c_sym (sym, name, binding_label, optional_arg);
2743     }
2744   else if (sym->intmod_sym_id == ISOCBINDING_LOC
2745            || sym->intmod_sym_id == ISOCBINDING_FUNLOC)
2746     {
2747       sprintf (name, "%s", sym->name);
2748       sprintf (binding_label, "%s", sym->binding_label);
2749
2750       /* Error check the call.  */
2751       if (args->next != NULL)
2752         {
2753           gfc_error_now ("More actual than formal arguments in '%s' "
2754                          "call at %L", name, &(args->expr->where));
2755           retval = FAILURE;
2756         }
2757       else if (sym->intmod_sym_id == ISOCBINDING_LOC)
2758         {
2759           gfc_ref *ref;
2760           bool seen_section;
2761
2762           /* Make sure we have either the target or pointer attribute.  */
2763           if (!arg_attr.target && !arg_attr.pointer)
2764             {
2765               gfc_error_now ("Parameter '%s' to '%s' at %L must be either "
2766                              "a TARGET or an associated pointer",
2767                              args_sym->name,
2768                              sym->name, &(args->expr->where));
2769               retval = FAILURE;
2770             }
2771
2772           if (gfc_is_coindexed (args->expr))
2773             {
2774               gfc_error_now ("Coindexed argument not permitted"
2775                              " in '%s' call at %L", name,
2776                              &(args->expr->where));
2777               retval = FAILURE;
2778             }
2779
2780           /* Follow references to make sure there are no array
2781              sections.  */
2782           seen_section = false;
2783
2784           for (ref=args->expr->ref; ref; ref = ref->next)
2785             {
2786               if (ref->type == REF_ARRAY)
2787                 {
2788                   if (ref->u.ar.type == AR_SECTION)
2789                     seen_section = true;
2790
2791                   if (ref->u.ar.type != AR_ELEMENT)
2792                     {
2793                       gfc_ref *r;
2794                       for (r = ref->next; r; r=r->next)
2795                         if (r->type == REF_COMPONENT)
2796                           {
2797                             gfc_error_now ("Array section not permitted"
2798                                            " in '%s' call at %L", name,
2799                                            &(args->expr->where));
2800                             retval = FAILURE;
2801                             break;
2802                           }
2803                     }
2804                 }
2805             }
2806
2807           if (seen_section && retval == SUCCESS)
2808             gfc_warning ("Array section in '%s' call at %L", name,
2809                          &(args->expr->where));
2810
2811           /* See if we have interoperable type and type param.  */
2812           if (gfc_verify_c_interop (arg_ts) == SUCCESS
2813               || gfc_check_any_c_kind (arg_ts) == SUCCESS)
2814             {
2815               if (args_sym->attr.target == 1)
2816                 {
2817                   /* Case 1a, section 15.1.2.5, J3/04-007: variable that
2818                      has the target attribute and is interoperable.  */
2819                   /* Case 1b, section 15.1.2.5, J3/04-007: allocated
2820                      allocatable variable that has the TARGET attribute and
2821                      is not an array of zero size.  */
2822                   if (args_sym->attr.allocatable == 1)
2823                     {
2824                       if (args_sym->attr.dimension != 0
2825                           && (args_sym->as && args_sym->as->rank == 0))
2826                         {
2827                           gfc_error_now ("Allocatable variable '%s' used as a "
2828                                          "parameter to '%s' at %L must not be "
2829                                          "an array of zero size",
2830                                          args_sym->name, sym->name,
2831                                          &(args->expr->where));
2832                           retval = FAILURE;
2833                         }
2834                     }
2835                   else
2836                     {
2837                       /* A non-allocatable target variable with C
2838                          interoperable type and type parameters must be
2839                          interoperable.  */
2840                       if (args_sym && args_sym->attr.dimension)
2841                         {
2842                           if (args_sym->as->type == AS_ASSUMED_SHAPE)
2843                             {
2844                               gfc_error ("Assumed-shape array '%s' at %L "
2845                                          "cannot be an argument to the "
2846                                          "procedure '%s' because "
2847                                          "it is not C interoperable",
2848                                          args_sym->name,
2849                                          &(args->expr->where), sym->name);
2850                               retval = FAILURE;
2851                             }
2852                           else if (args_sym->as->type == AS_DEFERRED)
2853                             {
2854                               gfc_error ("Deferred-shape array '%s' at %L "
2855                                          "cannot be an argument to the "
2856                                          "procedure '%s' because "
2857                                          "it is not C interoperable",
2858                                          args_sym->name,
2859                                          &(args->expr->where), sym->name);
2860                               retval = FAILURE;
2861                             }
2862                         }
2863
2864                       /* Make sure it's not a character string.  Arrays of
2865                          any type should be ok if the variable is of a C
2866                          interoperable type.  */
2867                       if (arg_ts->type == BT_CHARACTER)
2868                         if (arg_ts->u.cl != NULL
2869                             && (arg_ts->u.cl->length == NULL
2870                                 || arg_ts->u.cl->length->expr_type
2871                                    != EXPR_CONSTANT
2872                                 || mpz_cmp_si
2873                                     (arg_ts->u.cl->length->value.integer, 1)
2874                                    != 0)
2875                             && is_scalar_expr_ptr (args->expr) != SUCCESS)
2876                           {
2877                             gfc_error_now ("CHARACTER argument '%s' to '%s' "
2878                                            "at %L must have a length of 1",
2879                                            args_sym->name, sym->name,
2880                                            &(args->expr->where));
2881                             retval = FAILURE;
2882                           }
2883                     }
2884                 }
2885               else if (arg_attr.pointer
2886                        && is_scalar_expr_ptr (args->expr) != SUCCESS)
2887                 {
2888                   /* Case 1c, section 15.1.2.5, J3/04-007: an associated
2889                      scalar pointer.  */
2890                   gfc_error_now ("Argument '%s' to '%s' at %L must be an "
2891                                  "associated scalar POINTER", args_sym->name,
2892                                  sym->name, &(args->expr->where));
2893                   retval = FAILURE;
2894                 }
2895             }
2896           else
2897             {
2898               /* The parameter is not required to be C interoperable.  If it
2899                  is not C interoperable, it must be a nonpolymorphic scalar
2900                  with no length type parameters.  It still must have either
2901                  the pointer or target attribute, and it can be
2902                  allocatable (but must be allocated when c_loc is called).  */
2903               if (args->expr->rank != 0
2904                   && is_scalar_expr_ptr (args->expr) != SUCCESS)
2905                 {
2906                   gfc_error_now ("Parameter '%s' to '%s' at %L must be a "
2907                                  "scalar", args_sym->name, sym->name,
2908                                  &(args->expr->where));
2909                   retval = FAILURE;
2910                 }
2911               else if (arg_ts->type == BT_CHARACTER
2912                        && is_scalar_expr_ptr (args->expr) != SUCCESS)
2913                 {
2914                   gfc_error_now ("CHARACTER argument '%s' to '%s' at "
2915                                  "%L must have a length of 1",
2916                                  args_sym->name, sym->name,
2917                                  &(args->expr->where));
2918                   retval = FAILURE;
2919                 }
2920               else if (arg_ts->type == BT_CLASS)
2921                 {
2922                   gfc_error_now ("Parameter '%s' to '%s' at %L must not be "
2923                                  "polymorphic", args_sym->name, sym->name,
2924                                  &(args->expr->where));
2925                   retval = FAILURE;
2926                 }
2927             }
2928         }
2929       else if (sym->intmod_sym_id == ISOCBINDING_FUNLOC)
2930         {
2931           if (args_sym->attr.flavor != FL_PROCEDURE)
2932             {
2933               /* TODO: Update this error message to allow for procedure
2934                  pointers once they are implemented.  */
2935               gfc_error_now ("Parameter '%s' to '%s' at %L must be a "
2936                              "procedure",
2937                              args_sym->name, sym->name,
2938                              &(args->expr->where));
2939               retval = FAILURE;
2940             }
2941           else if (args_sym->attr.is_bind_c != 1)
2942             {
2943               gfc_error_now ("Parameter '%s' to '%s' at %L must be "
2944                              "BIND(C)",
2945                              args_sym->name, sym->name,
2946                              &(args->expr->where));
2947               retval = FAILURE;
2948             }
2949         }
2950
2951       /* for c_loc/c_funloc, the new symbol is the same as the old one */
2952       *new_sym = sym;
2953     }
2954   else
2955     {
2956       gfc_internal_error ("gfc_iso_c_func_interface(): Unhandled "
2957                           "iso_c_binding function: '%s'!\n", sym->name);
2958     }
2959
2960   return retval;
2961 }
2962
2963
2964 /* Resolve a function call, which means resolving the arguments, then figuring
2965    out which entity the name refers to.  */
2966
2967 static gfc_try
2968 resolve_function (gfc_expr *expr)
2969 {
2970   gfc_actual_arglist *arg;
2971   gfc_symbol *sym;
2972   const char *name;
2973   gfc_try t;
2974   int temp;
2975   procedure_type p = PROC_INTRINSIC;
2976   bool no_formal_args;
2977
2978   sym = NULL;
2979   if (expr->symtree)
2980     sym = expr->symtree->n.sym;
2981
2982   /* If this is a procedure pointer component, it has already been resolved.  */
2983   if (gfc_is_proc_ptr_comp (expr, NULL))
2984     return SUCCESS;
2985
2986   if (sym && sym->attr.intrinsic
2987       && resolve_intrinsic (sym, &expr->where) == FAILURE)
2988     return FAILURE;
2989
2990   if (sym && (sym->attr.flavor == FL_VARIABLE || sym->attr.subroutine))
2991     {
2992       gfc_error ("'%s' at %L is not a function", sym->name, &expr->where);
2993       return FAILURE;
2994     }
2995
2996   /* If this ia a deferred TBP with an abstract interface (which may
2997      of course be referenced), expr->value.function.esym will be set.  */
2998   if (sym && sym->attr.abstract && !expr->value.function.esym)
2999     {
3000       gfc_error ("ABSTRACT INTERFACE '%s' must not be referenced at %L",
3001                  sym->name, &expr->where);
3002       return FAILURE;
3003     }
3004
3005   /* Switch off assumed size checking and do this again for certain kinds
3006      of procedure, once the procedure itself is resolved.  */
3007   need_full_assumed_size++;
3008
3009   if (expr->symtree && expr->symtree->n.sym)
3010     p = expr->symtree->n.sym->attr.proc;
3011
3012   if (expr->value.function.isym && expr->value.function.isym->inquiry)
3013     inquiry_argument = true;
3014   no_formal_args = sym && is_external_proc (sym) && sym->formal == NULL;
3015
3016   if (resolve_actual_arglist (expr->value.function.actual,
3017                               p, no_formal_args) == FAILURE)
3018     {
3019       inquiry_argument = false;
3020       return FAILURE;
3021     }
3022
3023   inquiry_argument = false;
3024
3025   /* Need to setup the call to the correct c_associated, depending on
3026      the number of cptrs to user gives to compare.  */
3027   if (sym && sym->attr.is_iso_c == 1)
3028     {
3029       if (gfc_iso_c_func_interface (sym, expr->value.function.actual, &sym)
3030           == FAILURE)
3031         return FAILURE;
3032
3033       /* Get the symtree for the new symbol (resolved func).
3034          the old one will be freed later, when it's no longer used.  */
3035       gfc_find_sym_tree (sym->name, sym->ns, 1, &(expr->symtree));
3036     }
3037
3038   /* Resume assumed_size checking.  */
3039   need_full_assumed_size--;
3040
3041   /* If the procedure is external, check for usage.  */
3042   if (sym && is_external_proc (sym))
3043     resolve_global_procedure (sym, &expr->where,
3044                               &expr->value.function.actual, 0);
3045
3046   if (sym && sym->ts.type == BT_CHARACTER
3047       && sym->ts.u.cl
3048       && sym->ts.u.cl->length == NULL
3049       && !sym->attr.dummy
3050       && !sym->ts.deferred
3051       && expr->value.function.esym == NULL
3052       && !sym->attr.contained)
3053     {
3054       /* Internal procedures are taken care of in resolve_contained_fntype.  */
3055       gfc_error ("Function '%s' is declared CHARACTER(*) and cannot "
3056                  "be used at %L since it is not a dummy argument",
3057                  sym->name, &expr->where);
3058       return FAILURE;
3059     }
3060
3061   /* See if function is already resolved.  */
3062
3063   if (expr->value.function.name != NULL)
3064     {
3065       if (expr->ts.type == BT_UNKNOWN)
3066         expr->ts = sym->ts;
3067       t = SUCCESS;
3068     }
3069   else
3070     {
3071       /* Apply the rules of section 14.1.2.  */
3072
3073       switch (procedure_kind (sym))
3074         {
3075         case PTYPE_GENERIC:
3076           t = resolve_generic_f (expr);
3077           break;
3078
3079         case PTYPE_SPECIFIC:
3080           t = resolve_specific_f (expr);
3081           break;
3082
3083         case PTYPE_UNKNOWN:
3084           t = resolve_unknown_f (expr);
3085           break;
3086
3087         default:
3088           gfc_internal_error ("resolve_function(): bad function type");
3089         }
3090     }
3091
3092   /* If the expression is still a function (it might have simplified),
3093      then we check to see if we are calling an elemental function.  */
3094
3095   if (expr->expr_type != EXPR_FUNCTION)
3096     return t;
3097
3098   temp = need_full_assumed_size;
3099   need_full_assumed_size = 0;
3100
3101   if (resolve_elemental_actual (expr, NULL) == FAILURE)
3102     return FAILURE;
3103
3104   if (omp_workshare_flag
3105       && expr->value.function.esym
3106       && ! gfc_elemental (expr->value.function.esym))
3107     {
3108       gfc_error ("User defined non-ELEMENTAL function '%s' at %L not allowed "
3109                  "in WORKSHARE construct", expr->value.function.esym->name,
3110                  &expr->where);
3111       t = FAILURE;
3112     }
3113
3114 #define GENERIC_ID expr->value.function.isym->id
3115   else if (expr->value.function.actual != NULL
3116            && expr->value.function.isym != NULL
3117            && GENERIC_ID != GFC_ISYM_LBOUND
3118            && GENERIC_ID != GFC_ISYM_LEN
3119            && GENERIC_ID != GFC_ISYM_LOC
3120            && GENERIC_ID != GFC_ISYM_PRESENT)
3121     {
3122       /* Array intrinsics must also have the last upper bound of an
3123          assumed size array argument.  UBOUND and SIZE have to be
3124          excluded from the check if the second argument is anything
3125          than a constant.  */
3126
3127       for (arg = expr->value.function.actual; arg; arg = arg->next)
3128         {
3129           if ((GENERIC_ID == GFC_ISYM_UBOUND || GENERIC_ID == GFC_ISYM_SIZE)
3130               && arg->next != NULL && arg->next->expr)
3131             {
3132               if (arg->next->expr->expr_type != EXPR_CONSTANT)
3133                 break;
3134
3135               if (arg->next->name && strncmp(arg->next->name, "kind", 4) == 0)
3136                 break;
3137
3138               if ((int)mpz_get_si (arg->next->expr->value.integer)
3139                         < arg->expr->rank)
3140                 break;
3141             }
3142
3143           if (arg->expr != NULL
3144               && arg->expr->rank > 0
3145               && resolve_assumed_size_actual (arg->expr))
3146             return FAILURE;
3147         }
3148     }
3149 #undef GENERIC_ID
3150
3151   need_full_assumed_size = temp;
3152   name = NULL;
3153
3154   if (!pure_function (expr, &name) && name)
3155     {
3156       if (forall_flag)
3157         {
3158           gfc_error ("Reference to non-PURE function '%s' at %L inside a "
3159                      "FORALL %s", name, &expr->where,
3160                      forall_flag == 2 ? "mask" : "block");
3161           t = FAILURE;
3162         }
3163       else if (do_concurrent_flag)
3164         {
3165           gfc_error ("Reference to non-PURE function '%s' at %L inside a "
3166                      "DO CONCURRENT %s", name, &expr->where,
3167                      do_concurrent_flag == 2 ? "mask" : "block");
3168           t = FAILURE;
3169         }
3170       else if (gfc_pure (NULL))
3171         {
3172           gfc_error ("Function reference to '%s' at %L is to a non-PURE "
3173                      "procedure within a PURE procedure", name, &expr->where);
3174           t = FAILURE;
3175         }
3176     }
3177
3178   if (!pure_function (expr, &name) && name && gfc_implicit_pure (NULL))
3179     gfc_current_ns->proc_name->attr.implicit_pure = 0;
3180
3181   /* Functions without the RECURSIVE attribution are not allowed to
3182    * call themselves.  */
3183   if (expr->value.function.esym && !expr->value.function.esym->attr.recursive)
3184     {
3185       gfc_symbol *esym;
3186       esym = expr->value.function.esym;
3187
3188       if (is_illegal_recursion (esym, gfc_current_ns))
3189       {
3190         if (esym->attr.entry && esym->ns->entries)
3191           gfc_error ("ENTRY '%s' at %L cannot be called recursively, as"
3192                      " function '%s' is not RECURSIVE",
3193                      esym->name, &expr->where, esym->ns->entries->sym->name);
3194         else
3195           gfc_error ("Function '%s' at %L cannot be called recursively, as it"
3196                      " is not RECURSIVE", esym->name, &expr->where);
3197
3198         t = FAILURE;
3199       }
3200     }
3201
3202   /* Character lengths of use associated functions may contains references to
3203      symbols not referenced from the current program unit otherwise.  Make sure
3204      those symbols are marked as referenced.  */
3205
3206   if (expr->ts.type == BT_CHARACTER && expr->value.function.esym
3207       && expr->value.function.esym->attr.use_assoc)
3208     {
3209       gfc_expr_set_symbols_referenced (expr->ts.u.cl->length);
3210     }
3211
3212   /* Make sure that the expression has a typespec that works.  */
3213   if (expr->ts.type == BT_UNKNOWN)
3214     {
3215       if (expr->symtree->n.sym->result
3216             && expr->symtree->n.sym->result->ts.type != BT_UNKNOWN
3217             && !expr->symtree->n.sym->result->attr.proc_pointer)
3218         expr->ts = expr->symtree->n.sym->result->ts;
3219     }
3220
3221   return t;
3222 }
3223
3224
3225 /************* Subroutine resolution *************/
3226
3227 static void
3228 pure_subroutine (gfc_code *c, gfc_symbol *sym)
3229 {
3230   if (gfc_pure (sym))
3231     return;
3232
3233   if (forall_flag)
3234     gfc_error ("Subroutine call to '%s' in FORALL block at %L is not PURE",
3235                sym->name, &c->loc);
3236   else if (do_concurrent_flag)
3237     gfc_error ("Subroutine call to '%s' in DO CONCURRENT block at %L is not "
3238                "PURE", sym->name, &c->loc);
3239   else if (gfc_pure (NULL))
3240     gfc_error ("Subroutine call to '%s' at %L is not PURE", sym->name,
3241                &c->loc);
3242 }
3243
3244
3245 static match
3246 resolve_generic_s0 (gfc_code *c, gfc_symbol *sym)
3247 {
3248   gfc_symbol *s;
3249
3250   if (sym->attr.generic)
3251     {
3252       s = gfc_search_interface (sym->generic, 1, &c->ext.actual);
3253       if (s != NULL)
3254         {
3255           c->resolved_sym = s;
3256           pure_subroutine (c, s);
3257           return MATCH_YES;
3258         }
3259
3260       /* TODO: Need to search for elemental references in generic interface.  */
3261     }
3262
3263   if (sym->attr.intrinsic)
3264     return gfc_intrinsic_sub_interface (c, 0);
3265
3266   return MATCH_NO;
3267 }
3268
3269
3270 static gfc_try
3271 resolve_generic_s (gfc_code *c)
3272 {
3273   gfc_symbol *sym;
3274   match m;
3275
3276   sym = c->symtree->n.sym;
3277
3278   for (;;)
3279     {
3280       m = resolve_generic_s0 (c, sym);
3281       if (m == MATCH_YES)
3282         return SUCCESS;
3283       else if (m == MATCH_ERROR)
3284         return FAILURE;
3285
3286 generic:
3287       if (sym->ns->parent == NULL)
3288         break;
3289       gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
3290
3291       if (sym == NULL)
3292         break;
3293       if (!generic_sym (sym))
3294         goto generic;
3295     }
3296
3297   /* Last ditch attempt.  See if the reference is to an intrinsic
3298      that possesses a matching interface.  14.1.2.4  */
3299   sym = c->symtree->n.sym;
3300
3301   if (!gfc_is_intrinsic (sym, 1, c->loc))
3302     {
3303       gfc_error ("There is no specific subroutine for the generic '%s' at %L",
3304                  sym->name, &c->loc);
3305       return FAILURE;
3306     }
3307
3308   m = gfc_intrinsic_sub_interface (c, 0);
3309   if (m == MATCH_YES)
3310     return SUCCESS;
3311   if (m == MATCH_NO)
3312     gfc_error ("Generic subroutine '%s' at %L is not consistent with an "
3313                "intrinsic subroutine interface", sym->name, &c->loc);
3314
3315   return FAILURE;
3316 }
3317
3318
3319 /* Set the name and binding label of the subroutine symbol in the call
3320    expression represented by 'c' to include the type and kind of the
3321    second parameter.  This function is for resolving the appropriate
3322    version of c_f_pointer() and c_f_procpointer().  For example, a
3323    call to c_f_pointer() for a default integer pointer could have a
3324    name of c_f_pointer_i4.  If no second arg exists, which is an error
3325    for these two functions, it defaults to the generic symbol's name
3326    and binding label.  */
3327
3328 static void
3329 set_name_and_label (gfc_code *c, gfc_symbol *sym,
3330                     char *name, char *binding_label)
3331 {
3332   gfc_expr *arg = NULL;
3333   char type;
3334   int kind;
3335
3336   /* The second arg of c_f_pointer and c_f_procpointer determines
3337      the type and kind for the procedure name.  */
3338   arg = c->ext.actual->next->expr;
3339
3340   if (arg != NULL)
3341     {
3342       /* Set up the name to have the given symbol's name,
3343          plus the type and kind.  */
3344       /* a derived type is marked with the type letter 'u' */
3345       if (arg->ts.type == BT_DERIVED)
3346         {
3347           type = 'd';
3348           kind = 0; /* set the kind as 0 for now */
3349         }
3350       else
3351         {
3352           type = gfc_type_letter (arg->ts.type);
3353           kind = arg->ts.kind;
3354         }
3355
3356       if (arg->ts.type == BT_CHARACTER)
3357         /* Kind info for character strings not needed.  */
3358         kind = 0;
3359
3360       sprintf (name, "%s_%c%d", sym->name, type, kind);
3361       /* Set up the binding label as the given symbol's label plus
3362          the type and kind.  */
3363       sprintf (binding_label, "%s_%c%d", sym->binding_label, type, kind);
3364     }
3365   else
3366     {
3367       /* If the second arg is missing, set the name and label as
3368          was, cause it should at least be found, and the missing
3369          arg error will be caught by compare_parameters().  */
3370       sprintf (name, "%s", sym->name);
3371       sprintf (binding_label, "%s", sym->binding_label);
3372     }
3373
3374   return;
3375 }
3376
3377
3378 /* Resolve a generic version of the iso_c_binding procedure given
3379    (sym) to the specific one based on the type and kind of the
3380    argument(s).  Currently, this function resolves c_f_pointer() and
3381    c_f_procpointer based on the type and kind of the second argument
3382    (FPTR).  Other iso_c_binding procedures aren't specially handled.
3383    Upon successfully exiting, c->resolved_sym will hold the resolved
3384    symbol.  Returns MATCH_ERROR if an error occurred; MATCH_YES
3385    otherwise.  */
3386
3387 match
3388 gfc_iso_c_sub_interface (gfc_code *c, gfc_symbol *sym)
3389 {
3390   gfc_symbol *new_sym;
3391   /* this is fine, since we know the names won't use the max */
3392   char name[GFC_MAX_SYMBOL_LEN + 1];
3393   char binding_label[GFC_MAX_BINDING_LABEL_LEN + 1];
3394   /* default to success; will override if find error */
3395   match m = MATCH_YES;
3396
3397   /* Make sure the actual arguments are in the necessary order (based on the
3398      formal args) before resolving.  */
3399   gfc_procedure_use (sym, &c->ext.actual, &(c->loc));
3400
3401   if ((sym->intmod_sym_id == ISOCBINDING_F_POINTER) ||
3402       (sym->intmod_sym_id == ISOCBINDING_F_PROCPOINTER))
3403     {
3404       set_name_and_label (c, sym, name, binding_label);
3405
3406       if (sym->intmod_sym_id == ISOCBINDING_F_POINTER)
3407         {
3408           if (c->ext.actual != NULL && c->ext.actual->next != NULL)
3409             {
3410               /* Make sure we got a third arg if the second arg has non-zero
3411                  rank.  We must also check that the type and rank are
3412                  correct since we short-circuit this check in
3413                  gfc_procedure_use() (called above to sort actual args).  */
3414               if (c->ext.actual->next->expr->rank != 0)
3415                 {
3416                   if(c->ext.actual->next->next == NULL
3417                      || c->ext.actual->next->next->expr == NULL)
3418                     {
3419                       m = MATCH_ERROR;
3420                       gfc_error ("Missing SHAPE parameter for call to %s "
3421                                  "at %L", sym->name, &(c->loc));
3422                     }
3423                   else if (c->ext.actual->next->next->expr->ts.type
3424                            != BT_INTEGER
3425                            || c->ext.actual->next->next->expr->rank != 1)
3426                     {
3427                       m = MATCH_ERROR;
3428                       gfc_error ("SHAPE parameter for call to %s at %L must "
3429                                  "be a rank 1 INTEGER array", sym->name,
3430                                  &(c->loc));
3431                     }
3432                 }
3433             }
3434         }
3435
3436       if (m != MATCH_ERROR)
3437         {
3438           /* the 1 means to add the optional arg to formal list */
3439           new_sym = get_iso_c_sym (sym, name, binding_label, 1);
3440
3441           /* for error reporting, say it's declared where the original was */
3442           new_sym->declared_at = sym->declared_at;
3443         }
3444     }
3445   else
3446     {
3447       /* no differences for c_loc or c_funloc */
3448       new_sym = sym;
3449     }
3450
3451   /* set the resolved symbol */
3452   if (m != MATCH_ERROR)
3453     c->resolved_sym = new_sym;
3454   else
3455     c->resolved_sym = sym;
3456
3457   return m;
3458 }
3459
3460
3461 /* Resolve a subroutine call known to be specific.  */
3462
3463 static match
3464 resolve_specific_s0 (gfc_code *c, gfc_symbol *sym)
3465 {
3466   match m;
3467
3468   if(sym->attr.is_iso_c)
3469     {
3470       m = gfc_iso_c_sub_interface (c,sym);
3471       return m;
3472     }
3473
3474   if (sym->attr.external || sym->attr.if_source == IFSRC_IFBODY)
3475     {
3476       if (sym->attr.dummy)
3477         {
3478           sym->attr.proc = PROC_DUMMY;
3479           goto found;
3480         }
3481
3482       sym->attr.proc = PROC_EXTERNAL;
3483       goto found;
3484     }
3485
3486   if (sym->attr.proc == PROC_MODULE || sym->attr.proc == PROC_INTERNAL)
3487     goto found;
3488
3489   if (sym->attr.intrinsic)
3490     {
3491       m = gfc_intrinsic_sub_interface (c, 1);
3492       if (m == MATCH_YES)
3493         return MATCH_YES;
3494       if (m == MATCH_NO)
3495         gfc_error ("Subroutine '%s' at %L is INTRINSIC but is not compatible "
3496                    "with an intrinsic", sym->name, &c->loc);
3497
3498       return MATCH_ERROR;
3499     }
3500
3501   return MATCH_NO;
3502
3503 found:
3504   gfc_procedure_use (sym, &c->ext.actual, &c->loc);
3505
3506   c->resolved_sym = sym;
3507   pure_subroutine (c, sym);
3508
3509   return MATCH_YES;
3510 }
3511
3512
3513 static gfc_try
3514 resolve_specific_s (gfc_code *c)
3515 {
3516   gfc_symbol *sym;
3517   match m;
3518
3519   sym = c->symtree->n.sym;
3520
3521   for (;;)
3522     {
3523       m = resolve_specific_s0 (c, sym);
3524       if (m == MATCH_YES)
3525         return SUCCESS;
3526       if (m == MATCH_ERROR)
3527         return FAILURE;
3528
3529       if (sym->ns->parent == NULL)
3530         break;
3531
3532       gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
3533
3534       if (sym == NULL)
3535         break;
3536     }
3537
3538   sym = c->symtree->n.sym;
3539   gfc_error ("Unable to resolve the specific subroutine '%s' at %L",
3540              sym->name, &c->loc);
3541
3542   return FAILURE;
3543 }
3544
3545
3546 /* Resolve a subroutine call not known to be generic nor specific.  */
3547
3548 static gfc_try
3549 resolve_unknown_s (gfc_code *c)
3550 {
3551   gfc_symbol *sym;
3552
3553   sym = c->symtree->n.sym;
3554
3555   if (sym->attr.dummy)
3556     {
3557       sym->attr.proc = PROC_DUMMY;
3558       goto found;
3559     }
3560
3561   /* See if we have an intrinsic function reference.  */
3562
3563   if (gfc_is_intrinsic (sym, 1, c->loc))
3564     {
3565       if (gfc_intrinsic_sub_interface (c, 1) == MATCH_YES)
3566         return SUCCESS;
3567       return FAILURE;
3568     }
3569
3570   /* The reference is to an external name.  */
3571
3572 found:
3573   gfc_procedure_use (sym, &c->ext.actual, &c->loc);
3574
3575   c->resolved_sym = sym;
3576
3577   pure_subroutine (c, sym);
3578
3579   return SUCCESS;
3580 }
3581
3582
3583 /* Resolve a subroutine call.  Although it was tempting to use the same code
3584    for functions, subroutines and functions are stored differently and this
3585    makes things awkward.  */
3586
3587 static gfc_try
3588 resolve_call (gfc_code *c)
3589 {
3590   gfc_try t;
3591   procedure_type ptype = PROC_INTRINSIC;
3592   gfc_symbol *csym, *sym;
3593   bool no_formal_args;
3594
3595   csym = c->symtree ? c->symtree->n.sym : NULL;
3596
3597   if (csym && csym->ts.type != BT_UNKNOWN)
3598     {
3599       gfc_error ("'%s' at %L has a type, which is not consistent with "
3600                  "the CALL at %L", csym->name, &csym->declared_at, &c->loc);
3601       return FAILURE;
3602     }
3603
3604   if (csym && gfc_current_ns->parent && csym->ns != gfc_current_ns)
3605     {
3606       gfc_symtree *st;
3607       gfc_find_sym_tree (csym->name, gfc_current_ns, 1, &st);
3608       sym = st ? st->n.sym : NULL;
3609       if (sym && csym != sym
3610               && sym->ns == gfc_current_ns
3611               && sym->attr.flavor == FL_PROCEDURE
3612               && sym->attr.contained)
3613         {
3614           sym->refs++;
3615           if (csym->attr.generic)
3616             c->symtree->n.sym = sym;
3617           else
3618             c->symtree = st;
3619           csym = c->symtree->n.sym;
3620         }
3621     }
3622
3623   /* If this ia a deferred TBP with an abstract interface
3624      (which may of course be referenced), c->expr1 will be set.  */
3625   if (csym && csym->attr.abstract && !c->expr1)
3626     {
3627       gfc_error ("ABSTRACT INTERFACE '%s' must not be referenced at %L",
3628                  csym->name, &c->loc);
3629       return FAILURE;
3630     }
3631
3632   /* Subroutines without the RECURSIVE attribution are not allowed to
3633    * call themselves.  */
3634   if (csym && is_illegal_recursion (csym, gfc_current_ns))
3635     {
3636       if (csym->attr.entry && csym->ns->entries)
3637         gfc_error ("ENTRY '%s' at %L cannot be called recursively, as"
3638                    " subroutine '%s' is not RECURSIVE",
3639                    csym->name, &c->loc, csym->ns->entries->sym->name);
3640       else
3641         gfc_error ("SUBROUTINE '%s' at %L cannot be called recursively, as it"
3642                    " is not RECURSIVE", csym->name, &c->loc);
3643
3644       t = FAILURE;
3645     }
3646
3647   /* Switch off assumed size checking and do this again for certain kinds
3648      of procedure, once the procedure itself is resolved.  */
3649   need_full_assumed_size++;
3650
3651   if (csym)
3652     ptype = csym->attr.proc;
3653
3654   no_formal_args = csym && is_external_proc (csym) && csym->formal == NULL;
3655   if (resolve_actual_arglist (c->ext.actual, ptype,
3656                               no_formal_args) == FAILURE)
3657     return FAILURE;
3658
3659   /* Resume assumed_size checking.  */
3660   need_full_assumed_size--;
3661
3662   /* If external, check for usage.  */
3663   if (csym && is_external_proc (csym))
3664     resolve_global_procedure (csym, &c->loc, &c->ext.actual, 1);
3665
3666   t = SUCCESS;
3667   if (c->resolved_sym == NULL)
3668     {
3669       c->resolved_isym = NULL;
3670       switch (procedure_kind (csym))
3671         {
3672         case PTYPE_GENERIC:
3673           t = resolve_generic_s (c);
3674           break;
3675
3676         case PTYPE_SPECIFIC:
3677           t = resolve_specific_s (c);
3678           break;
3679
3680         case PTYPE_UNKNOWN:
3681           t = resolve_unknown_s (c);
3682           break;
3683
3684         default:
3685           gfc_internal_error ("resolve_subroutine(): bad function type");
3686         }
3687     }
3688
3689   /* Some checks of elemental subroutine actual arguments.  */
3690   if (resolve_elemental_actual (NULL, c) == FAILURE)
3691     return FAILURE;
3692
3693   return t;
3694 }
3695
3696
3697 /* Compare the shapes of two arrays that have non-NULL shapes.  If both
3698    op1->shape and op2->shape are non-NULL return SUCCESS if their shapes
3699    match.  If both op1->shape and op2->shape are non-NULL return FAILURE
3700    if their shapes do not match.  If either op1->shape or op2->shape is
3701    NULL, return SUCCESS.  */
3702
3703 static gfc_try
3704 compare_shapes (gfc_expr *op1, gfc_expr *op2)
3705 {
3706   gfc_try t;
3707   int i;
3708
3709   t = SUCCESS;
3710
3711   if (op1->shape != NULL && op2->shape != NULL)
3712     {
3713       for (i = 0; i < op1->rank; i++)
3714         {
3715           if (mpz_cmp (op1->shape[i], op2->shape[i]) != 0)
3716            {
3717              gfc_error ("Shapes for operands at %L and %L are not conformable",
3718                          &op1->where, &op2->where);
3719              t = FAILURE;
3720              break;
3721            }
3722         }
3723     }
3724
3725   return t;
3726 }
3727
3728
3729 /* Resolve an operator expression node.  This can involve replacing the
3730    operation with a user defined function call.  */
3731
3732 static gfc_try
3733 resolve_operator (gfc_expr *e)
3734 {
3735   gfc_expr *op1, *op2;
3736   char msg[200];
3737   bool dual_locus_error;
3738   gfc_try t;
3739
3740   /* Resolve all subnodes-- give them types.  */
3741
3742   switch (e->value.op.op)
3743     {
3744     default:
3745       if (gfc_resolve_expr (e->value.op.op2) == FAILURE)
3746         return FAILURE;
3747
3748     /* Fall through...  */
3749
3750     case INTRINSIC_NOT:
3751     case INTRINSIC_UPLUS:
3752     case INTRINSIC_UMINUS:
3753     case INTRINSIC_PARENTHESES:
3754       if (gfc_resolve_expr (e->value.op.op1) == FAILURE)
3755         return FAILURE;
3756       break;
3757     }
3758
3759   /* Typecheck the new node.  */
3760
3761   op1 = e->value.op.op1;
3762   op2 = e->value.op.op2;
3763   dual_locus_error = false;
3764
3765   if ((op1 && op1->expr_type == EXPR_NULL)
3766       || (op2 && op2->expr_type == EXPR_NULL))
3767     {
3768       sprintf (msg, _("Invalid context for NULL() pointer at %%L"));
3769       goto bad_op;
3770     }
3771
3772   switch (e->value.op.op)
3773     {
3774     case INTRINSIC_UPLUS:
3775     case INTRINSIC_UMINUS:
3776       if (op1->ts.type == BT_INTEGER
3777           || op1->ts.type == BT_REAL
3778           || op1->ts.type == BT_COMPLEX)
3779         {
3780           e->ts = op1->ts;
3781           break;
3782         }
3783
3784       sprintf (msg, _("Operand of unary numeric operator '%s' at %%L is %s"),
3785                gfc_op2string (e->value.op.op), gfc_typename (&e->ts));
3786       goto bad_op;
3787
3788     case INTRINSIC_PLUS:
3789     case INTRINSIC_MINUS:
3790     case INTRINSIC_TIMES:
3791     case INTRINSIC_DIVIDE:
3792     case INTRINSIC_POWER:
3793       if (gfc_numeric_ts (&op1->ts) && gfc_numeric_ts (&op2->ts))
3794         {
3795           gfc_type_convert_binary (e, 1);
3796           break;
3797         }
3798
3799       sprintf (msg,
3800                _("Operands of binary numeric operator '%s' at %%L are %s/%s"),
3801                gfc_op2string (e->value.op.op), gfc_typename (&op1->ts),
3802                gfc_typename (&op2->ts));
3803       goto bad_op;
3804
3805     case INTRINSIC_CONCAT:
3806       if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER
3807           && op1->ts.kind == op2->ts.kind)
3808         {
3809           e->ts.type = BT_CHARACTER;
3810           e->ts.kind = op1->ts.kind;
3811           break;
3812         }
3813
3814       sprintf (msg,
3815                _("Operands of string concatenation operator at %%L are %s/%s"),
3816                gfc_typename (&op1->ts), gfc_typename (&op2->ts));
3817       goto bad_op;
3818
3819     case INTRINSIC_AND:
3820     case INTRINSIC_OR:
3821     case INTRINSIC_EQV:
3822     case INTRINSIC_NEQV:
3823       if (op1->ts.type == BT_LOGICAL && op2->ts.type == BT_LOGICAL)
3824         {
3825           e->ts.type = BT_LOGICAL;
3826           e->ts.kind = gfc_kind_max (op1, op2);
3827           if (op1->ts.kind < e->ts.kind)
3828             gfc_convert_type (op1, &e->ts, 2);
3829           else if (op2->ts.kind < e->ts.kind)
3830             gfc_convert_type (op2, &e->ts, 2);
3831           break;
3832         }
3833
3834       sprintf (msg, _("Operands of logical operator '%s' at %%L are %s/%s"),
3835                gfc_op2string (e->value.op.op), gfc_typename (&op1->ts),
3836                gfc_typename (&op2->ts));
3837
3838       goto bad_op;
3839
3840     case INTRINSIC_NOT:
3841       if (op1->ts.type == BT_LOGICAL)
3842         {
3843           e->ts.type = BT_LOGICAL;
3844           e->ts.kind = op1->ts.kind;
3845           break;
3846         }
3847
3848       sprintf (msg, _("Operand of .not. operator at %%L is %s"),
3849                gfc_typename (&op1->ts));
3850       goto bad_op;
3851
3852     case INTRINSIC_GT:
3853     case INTRINSIC_GT_OS:
3854     case INTRINSIC_GE:
3855     case INTRINSIC_GE_OS:
3856     case INTRINSIC_LT:
3857     case INTRINSIC_LT_OS:
3858     case INTRINSIC_LE:
3859     case INTRINSIC_LE_OS:
3860       if (op1->ts.type == BT_COMPLEX || op2->ts.type == BT_COMPLEX)
3861         {
3862           strcpy (msg, _("COMPLEX quantities cannot be compared at %L"));
3863           goto bad_op;
3864         }
3865
3866       /* Fall through...  */
3867
3868     case INTRINSIC_EQ:
3869     case INTRINSIC_EQ_OS:
3870     case INTRINSIC_NE:
3871     case INTRINSIC_NE_OS:
3872       if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER
3873           && op1->ts.kind == op2->ts.kind)
3874         {
3875           e->ts.type = BT_LOGICAL;
3876           e->ts.kind = gfc_default_logical_kind;
3877           break;
3878         }
3879
3880       if (gfc_numeric_ts (&op1->ts) && gfc_numeric_ts (&op2->ts))
3881         {
3882           gfc_type_convert_binary (e, 1);
3883
3884           e->ts.type = BT_LOGICAL;
3885           e->ts.kind = gfc_default_logical_kind;
3886           break;
3887         }
3888
3889       if (op1->ts.type == BT_LOGICAL && op2->ts.type == BT_LOGICAL)
3890         sprintf (msg,
3891                  _("Logicals at %%L must be compared with %s instead of %s"),
3892                  (e->value.op.op == INTRINSIC_EQ
3893                   || e->value.op.op == INTRINSIC_EQ_OS)
3894                  ? ".eqv." : ".neqv.", gfc_op2string (e->value.op.op));
3895       else
3896         sprintf (msg,
3897                  _("Operands of comparison operator '%s' at %%L are %s/%s"),
3898                  gfc_op2string (e->value.op.op), gfc_typename (&op1->ts),
3899                  gfc_typename (&op2->ts));
3900
3901       goto bad_op;
3902
3903     case INTRINSIC_USER:
3904       if (e->value.op.uop->op == NULL)
3905         sprintf (msg, _("Unknown operator '%s' at %%L"), e->value.op.uop->name);
3906       else if (op2 == NULL)
3907         sprintf (msg, _("Operand of user operator '%s' at %%L is %s"),
3908                  e->value.op.uop->name, gfc_typename (&op1->ts));
3909       else
3910         {
3911           sprintf (msg, _("Operands of user operator '%s' at %%L are %s/%s"),
3912                    e->value.op.uop->name, gfc_typename (&op1->ts),
3913                    gfc_typename (&op2->ts));
3914           e->value.op.uop->op->sym->attr.referenced = 1;
3915         }
3916
3917       goto bad_op;
3918
3919     case INTRINSIC_PARENTHESES:
3920       e->ts = op1->ts;
3921       if (e->ts.type == BT_CHARACTER)
3922         e->ts.u.cl = op1->ts.u.cl;
3923       break;
3924
3925     default:
3926       gfc_internal_error ("resolve_operator(): Bad intrinsic");
3927     }
3928
3929   /* Deal with arrayness of an operand through an operator.  */
3930
3931   t = SUCCESS;
3932
3933   switch (e->value.op.op)
3934     {
3935     case INTRINSIC_PLUS:
3936     case INTRINSIC_MINUS:
3937     case INTRINSIC_TIMES:
3938     case INTRINSIC_DIVIDE:
3939     case INTRINSIC_POWER:
3940     case INTRINSIC_CONCAT:
3941     case INTRINSIC_AND:
3942     case INTRINSIC_OR:
3943     case INTRINSIC_EQV:
3944     case INTRINSIC_NEQV:
3945     case INTRINSIC_EQ:
3946     case INTRINSIC_EQ_OS:
3947     case INTRINSIC_NE:
3948     case INTRINSIC_NE_OS:
3949     case INTRINSIC_GT:
3950     case INTRINSIC_GT_OS:
3951     case INTRINSIC_GE:
3952     case INTRINSIC_GE_OS:
3953     case INTRINSIC_LT:
3954     case INTRINSIC_LT_OS:
3955     case INTRINSIC_LE:
3956     case INTRINSIC_LE_OS:
3957
3958       if (op1->rank == 0 && op2->rank == 0)
3959         e->rank = 0;
3960
3961       if (op1->rank == 0 && op2->rank != 0)
3962         {
3963           e->rank = op2->rank;
3964
3965           if (e->shape == NULL)
3966             e->shape = gfc_copy_shape (op2->shape, op2->rank);
3967         }
3968
3969       if (op1->rank != 0 && op2->rank == 0)
3970         {
3971           e->rank = op1->rank;
3972
3973           if (e->shape == NULL)
3974             e->shape = gfc_copy_shape (op1->shape, op1->rank);
3975         }
3976
3977       if (op1->rank != 0 && op2->rank != 0)
3978         {
3979           if (op1->rank == op2->rank)
3980             {
3981               e->rank = op1->rank;
3982               if (e->shape == NULL)
3983                 {
3984                   t = compare_shapes (op1, op2);
3985                   if (t == FAILURE)
3986                     e->shape = NULL;
3987                   else
3988                     e->shape = gfc_copy_shape (op1->shape, op1->rank);
3989                 }
3990             }
3991           else
3992             {
3993               /* Allow higher level expressions to work.  */
3994               e->rank = 0;
3995
3996               /* Try user-defined operators, and otherwise throw an error.  */
3997               dual_locus_error = true;
3998               sprintf (msg,
3999                        _("Inconsistent ranks for operator at %%L and %%L"));
4000               goto bad_op;
4001             }
4002         }
4003
4004       break;
4005
4006     case INTRINSIC_PARENTHESES:
4007     case INTRINSIC_NOT:
4008     case INTRINSIC_UPLUS:
4009     case INTRINSIC_UMINUS:
4010       /* Simply copy arrayness attribute */
4011       e->rank = op1->rank;
4012
4013       if (e->shape == NULL)
4014         e->shape = gfc_copy_shape (op1->shape, op1->rank);
4015
4016       break;
4017
4018     default:
4019       break;
4020     }
4021
4022   /* Attempt to simplify the expression.  */
4023   if (t == SUCCESS)
4024     {
4025       t = gfc_simplify_expr (e, 0);
4026       /* Some calls do not succeed in simplification and return FAILURE
4027          even though there is no error; e.g. variable references to
4028          PARAMETER arrays.  */
4029       if (!gfc_is_constant_expr (e))
4030         t = SUCCESS;
4031     }
4032   return t;
4033
4034 bad_op:
4035
4036   {
4037     bool real_error;
4038     if (gfc_extend_expr (e, &real_error) == SUCCESS)
4039       return SUCCESS;
4040
4041     if (real_error)
4042       return FAILURE;
4043   }
4044
4045   if (dual_locus_error)
4046     gfc_error (msg, &op1->where, &op2->where);
4047   else
4048     gfc_error (msg, &e->where);
4049
4050   return FAILURE;
4051 }
4052
4053
4054 /************** Array resolution subroutines **************/
4055
4056 typedef enum
4057 { CMP_LT, CMP_EQ, CMP_GT, CMP_UNKNOWN }
4058 comparison;
4059
4060 /* Compare two integer expressions.  */
4061
4062 static comparison
4063 compare_bound (gfc_expr *a, gfc_expr *b)
4064 {
4065   int i;
4066
4067   if (a == NULL || a->expr_type != EXPR_CONSTANT
4068       || b == NULL || b->expr_type != EXPR_CONSTANT)
4069     return CMP_UNKNOWN;
4070
4071   /* If either of the types isn't INTEGER, we must have
4072      raised an error earlier.  */
4073
4074   if (a->ts.type != BT_INTEGER || b->ts.type != BT_INTEGER)
4075     return CMP_UNKNOWN;
4076
4077   i = mpz_cmp (a->value.integer, b->value.integer);
4078
4079   if (i < 0)
4080     return CMP_LT;
4081   if (i > 0)
4082     return CMP_GT;
4083   return CMP_EQ;
4084 }
4085
4086
4087 /* Compare an integer expression with an integer.  */
4088
4089 static comparison
4090 compare_bound_int (gfc_expr *a, int b)
4091 {
4092   int i;
4093
4094   if (a == NULL || a->expr_type != EXPR_CONSTANT)
4095     return CMP_UNKNOWN;
4096
4097   if (a->ts.type != BT_INTEGER)
4098     gfc_internal_error ("compare_bound_int(): Bad expression");
4099
4100   i = mpz_cmp_si (a->value.integer, b);
4101
4102   if (i < 0)
4103     return CMP_LT;
4104   if (i > 0)
4105     return CMP_GT;
4106   return CMP_EQ;
4107 }
4108
4109
4110 /* Compare an integer expression with a mpz_t.  */
4111
4112 static comparison
4113 compare_bound_mpz_t (gfc_expr *a, mpz_t b)
4114 {
4115   int i;
4116
4117   if (a == NULL || a->expr_type != EXPR_CONSTANT)
4118     return CMP_UNKNOWN;
4119
4120   if (a->ts.type != BT_INTEGER)
4121     gfc_internal_error ("compare_bound_int(): Bad expression");
4122
4123   i = mpz_cmp (a->value.integer, b);
4124
4125   if (i < 0)
4126     return CMP_LT;
4127   if (i > 0)
4128     return CMP_GT;
4129   return CMP_EQ;
4130 }
4131
4132
4133 /* Compute the last value of a sequence given by a triplet.
4134    Return 0 if it wasn't able to compute the last value, or if the
4135    sequence if empty, and 1 otherwise.  */
4136
4137 static int
4138 compute_last_value_for_triplet (gfc_expr *start, gfc_expr *end,
4139                                 gfc_expr *stride, mpz_t last)
4140 {
4141   mpz_t rem;
4142
4143   if (start == NULL || start->expr_type != EXPR_CONSTANT
4144       || end == NULL || end->expr_type != EXPR_CONSTANT
4145       || (stride != NULL && stride->expr_type != EXPR_CONSTANT))
4146     return 0;
4147
4148   if (start->ts.type != BT_INTEGER || end->ts.type != BT_INTEGER
4149       || (stride != NULL && stride->ts.type != BT_INTEGER))
4150     return 0;
4151
4152   if (stride == NULL || compare_bound_int(stride, 1) == CMP_EQ)
4153     {
4154       if (compare_bound (start, end) == CMP_GT)
4155         return 0;
4156       mpz_set (last, end->value.integer);
4157       return 1;
4158     }
4159
4160   if (compare_bound_int (stride, 0) == CMP_GT)
4161     {
4162       /* Stride is positive */
4163       if (mpz_cmp (start->value.integer, end->value.integer) > 0)
4164         return 0;
4165     }
4166   else
4167     {
4168       /* Stride is negative */
4169       if (mpz_cmp (start->value.integer, end->value.integer) < 0)
4170         return 0;
4171     }
4172
4173   mpz_init (rem);
4174   mpz_sub (rem, end->value.integer, start->value.integer);
4175   mpz_tdiv_r (rem, rem, stride->value.integer);
4176   mpz_sub (last, end->value.integer, rem);
4177   mpz_clear (rem);
4178
4179   return 1;
4180 }
4181
4182
4183 /* Compare a single dimension of an array reference to the array
4184    specification.  */
4185
4186 static gfc_try
4187 check_dimension (int i, gfc_array_ref *ar, gfc_array_spec *as)
4188 {
4189   mpz_t last_value;
4190
4191   if (ar->dimen_type[i] == DIMEN_STAR)
4192     {
4193       gcc_assert (ar->stride[i] == NULL);
4194       /* This implies [*] as [*:] and [*:3] are not possible.  */
4195       if (ar->start[i] == NULL)
4196         {
4197           gcc_assert (ar->end[i] == NULL);
4198           return SUCCESS;
4199         }
4200     }
4201
4202 /* Given start, end and stride values, calculate the minimum and
4203    maximum referenced indexes.  */
4204
4205   switch (ar->dimen_type[i])
4206     {
4207     case DIMEN_VECTOR:
4208     case DIMEN_THIS_IMAGE:
4209       break;
4210
4211     case DIMEN_STAR:
4212     case DIMEN_ELEMENT:
4213       if (compare_bound (ar->start[i], as->lower[i]) == CMP_LT)
4214         {
4215           if (i < as->rank)
4216             gfc_warning ("Array reference at %L is out of bounds "
4217                          "(%ld < %ld) in dimension %d", &ar->c_where[i],
4218                          mpz_get_si (ar->start[i]->value.integer),
4219                          mpz_get_si (as->lower[i]->value.integer), i+1);
4220           else
4221             gfc_warning ("Array reference at %L is out of bounds "
4222                          "(%ld < %ld) in codimension %d", &ar->c_where[i],
4223                          mpz_get_si (ar->start[i]->value.integer),
4224                          mpz_get_si (as->lower[i]->value.integer),
4225                          i + 1 - as->rank);
4226           return SUCCESS;
4227         }
4228       if (compare_bound (ar->start[i], as->upper[i]) == CMP_GT)
4229         {
4230           if (i < as->rank)
4231             gfc_warning ("Array reference at %L is out of bounds "
4232                          "(%ld > %ld) in dimension %d", &ar->c_where[i],
4233                          mpz_get_si (ar->start[i]->value.integer),
4234                          mpz_get_si (as->upper[i]->value.integer), i+1);
4235           else
4236             gfc_warning ("Array reference at %L is out of bounds "
4237                          "(%ld > %ld) in codimension %d", &ar->c_where[i],
4238                          mpz_get_si (ar->start[i]->value.integer),
4239                          mpz_get_si (as->upper[i]->value.integer),
4240                          i + 1 - as->rank);
4241           return SUCCESS;
4242         }
4243
4244       break;
4245
4246     case DIMEN_RANGE:
4247       {
4248 #define AR_START (ar->start[i] ? ar->start[i] : as->lower[i])
4249 #define AR_END (ar->end[i] ? ar->end[i] : as->upper[i])
4250
4251         comparison comp_start_end = compare_bound (AR_START, AR_END);
4252
4253         /* Check for zero stride, which is not allowed.  */
4254         if (compare_bound_int (ar->stride[i], 0) == CMP_EQ)
4255           {
4256             gfc_error ("Illegal stride of zero at %L", &ar->c_where[i]);
4257             return FAILURE;
4258           }
4259
4260         /* if start == len || (stride > 0 && start < len)
4261                            || (stride < 0 && start > len),
4262            then the array section contains at least one element.  In this
4263            case, there is an out-of-bounds access if
4264            (start < lower || start > upper).  */
4265         if (compare_bound (AR_START, AR_END) == CMP_EQ
4266             || ((compare_bound_int (ar->stride[i], 0) == CMP_GT
4267                  || ar->stride[i] == NULL) && comp_start_end == CMP_LT)
4268             || (compare_bound_int (ar->stride[i], 0) == CMP_LT
4269                 && comp_start_end == CMP_GT))
4270           {
4271             if (compare_bound (AR_START, as->lower[i]) == CMP_LT)
4272               {
4273                 gfc_warning ("Lower array reference at %L is out of bounds "
4274                        "(%ld < %ld) in dimension %d", &ar->c_where[i],
4275                        mpz_get_si (AR_START->value.integer),
4276                        mpz_get_si (as->lower[i]->value.integer), i+1);
4277                 return SUCCESS;
4278               }
4279             if (compare_bound (AR_START, as->upper[i]) == CMP_GT)
4280               {
4281                 gfc_warning ("Lower array reference at %L is out of bounds "
4282                        "(%ld > %ld) in dimension %d", &ar->c_where[i],
4283                        mpz_get_si (AR_START->value.integer),
4284                        mpz_get_si (as->upper[i]->value.integer), i+1);
4285                 return SUCCESS;
4286               }
4287           }
4288
4289         /* If we can compute the highest index of the array section,
4290            then it also has to be between lower and upper.  */
4291         mpz_init (last_value);
4292         if (compute_last_value_for_triplet (AR_START, AR_END, ar->stride[i],
4293                                             last_value))
4294           {
4295             if (compare_bound_mpz_t (as->lower[i], last_value) == CMP_GT)
4296               {
4297                 gfc_warning ("Upper array reference at %L is out of bounds "
4298                        "(%ld < %ld) in dimension %d", &ar->c_where[i],
4299                        mpz_get_si (last_value),
4300                        mpz_get_si (as->lower[i]->value.integer), i+1);
4301                 mpz_clear (last_value);
4302                 return SUCCESS;
4303               }
4304             if (compare_bound_mpz_t (as->upper[i], last_value) == CMP_LT)
4305               {
4306                 gfc_warning ("Upper array reference at %L is out of bounds "
4307                        "(%ld > %ld) in dimension %d", &ar->c_where[i],
4308                        mpz_get_si (last_value),
4309                        mpz_get_si (as->upper[i]->value.integer), i+1);
4310                 mpz_clear (last_value);
4311                 return SUCCESS;
4312               }
4313           }
4314         mpz_clear (last_value);
4315
4316 #undef AR_START
4317 #undef AR_END
4318       }
4319       break;
4320
4321     default:
4322       gfc_internal_error ("check_dimension(): Bad array reference");
4323     }
4324
4325   return SUCCESS;
4326 }
4327
4328
4329 /* Compare an array reference with an array specification.  */
4330
4331 static gfc_try
4332 compare_spec_to_ref (gfc_array_ref *ar)
4333 {
4334   gfc_array_spec *as;
4335   int i;
4336
4337   as = ar->as;
4338   i = as->rank - 1;
4339   /* TODO: Full array sections are only allowed as actual parameters.  */
4340   if (as->type == AS_ASSUMED_SIZE
4341       && (/*ar->type == AR_FULL
4342           ||*/ (ar->type == AR_SECTION
4343               && ar->dimen_type[i] == DIMEN_RANGE && ar->end[i] == NULL)))
4344     {
4345       gfc_error ("Rightmost upper bound of assumed size array section "
4346                  "not specified at %L", &ar->where);
4347       return FAILURE;
4348     }
4349
4350   if (ar->type == AR_FULL)
4351     return SUCCESS;
4352
4353   if (as->rank != ar->dimen)
4354     {
4355       gfc_error ("Rank mismatch in array reference at %L (%d/%d)",
4356                  &ar->where, ar->dimen, as->rank);
4357       return FAILURE;
4358     }
4359
4360   /* ar->codimen == 0 is a local array.  */
4361   if (as->corank != ar->codimen && ar->codimen != 0)
4362     {
4363       gfc_error ("Coindex rank mismatch in array reference at %L (%d/%d)",
4364                  &ar->where, ar->codimen, as->corank);
4365       return FAILURE;
4366     }
4367
4368   for (i = 0; i < as->rank; i++)
4369     if (check_dimension (i, ar, as) == FAILURE)
4370       return FAILURE;
4371
4372   /* Local access has no coarray spec.  */
4373   if (ar->codimen != 0)
4374     for (i = as->rank; i < as->rank + as->corank; i++)
4375       {
4376         if (ar->dimen_type[i] != DIMEN_ELEMENT && !ar->in_allocate
4377             && ar->dimen_type[i] != DIMEN_THIS_IMAGE)
4378           {
4379             gfc_error ("Coindex of codimension %d must be a scalar at %L",
4380                        i + 1 - as->rank, &ar->where);
4381             return FAILURE;
4382           }
4383         if (check_dimension (i, ar, as) == FAILURE)
4384           return FAILURE;
4385       }
4386
4387   return SUCCESS;
4388 }
4389
4390
4391 /* Resolve one part of an array index.  */
4392
4393 static gfc_try
4394 gfc_resolve_index_1 (gfc_expr *index, int check_scalar,
4395                      int force_index_integer_kind)
4396 {
4397   gfc_typespec ts;
4398
4399   if (index == NULL)
4400     return SUCCESS;
4401
4402   if (gfc_resolve_expr (index) == FAILURE)
4403     return FAILURE;
4404
4405   if (check_scalar && index->rank != 0)
4406     {
4407       gfc_error ("Array index at %L must be scalar", &index->where);
4408       return FAILURE;
4409     }
4410
4411   if (index->ts.type != BT_INTEGER && index->ts.type != BT_REAL)
4412     {
4413       gfc_error ("Array index at %L must be of INTEGER type, found %s",
4414                  &index->where, gfc_basic_typename (index->ts.type));
4415       return FAILURE;
4416     }
4417
4418   if (index->ts.type == BT_REAL)
4419     if (gfc_notify_std (GFC_STD_LEGACY, "Extension: REAL array index at %L",
4420                         &index->where) == FAILURE)
4421       return FAILURE;
4422
4423   if ((index->ts.kind != gfc_index_integer_kind
4424        && force_index_integer_kind)
4425       || index->ts.type != BT_INTEGER)
4426     {
4427       gfc_clear_ts (&ts);
4428       ts.type = BT_INTEGER;
4429       ts.kind = gfc_index_integer_kind;
4430
4431       gfc_convert_type_warn (index, &ts, 2, 0);
4432     }
4433
4434   return SUCCESS;
4435 }
4436
4437 /* Resolve one part of an array index.  */
4438
4439 gfc_try
4440 gfc_resolve_index (gfc_expr *index, int check_scalar)
4441 {
4442   return gfc_resolve_index_1 (index, check_scalar, 1);
4443 }
4444
4445 /* Resolve a dim argument to an intrinsic function.  */
4446
4447 gfc_try
4448 gfc_resolve_dim_arg (gfc_expr *dim)
4449 {
4450   if (dim == NULL)
4451     return SUCCESS;
4452
4453   if (gfc_resolve_expr (dim) == FAILURE)
4454     return FAILURE;
4455
4456   if (dim->rank != 0)
4457     {
4458       gfc_error ("Argument dim at %L must be scalar", &dim->where);
4459       return FAILURE;
4460
4461     }
4462
4463   if (dim->ts.type != BT_INTEGER)
4464     {
4465       gfc_error ("Argument dim at %L must be of INTEGER type", &dim->where);
4466       return FAILURE;
4467     }
4468
4469   if (dim->ts.kind != gfc_index_integer_kind)
4470     {
4471       gfc_typespec ts;
4472
4473       gfc_clear_ts (&ts);
4474       ts.type = BT_INTEGER;
4475       ts.kind = gfc_index_integer_kind;
4476
4477       gfc_convert_type_warn (dim, &ts, 2, 0);
4478     }
4479
4480   return SUCCESS;
4481 }
4482
4483 /* Given an expression that contains array references, update those array
4484    references to point to the right array specifications.  While this is
4485    filled in during matching, this information is difficult to save and load
4486    in a module, so we take care of it here.
4487
4488    The idea here is that the original array reference comes from the
4489    base symbol.  We traverse the list of reference structures, setting
4490    the stored reference to references.  Component references can
4491    provide an additional array specification.  */
4492
4493 static void
4494 find_array_spec (gfc_expr *e)
4495 {
4496   gfc_array_spec *as;
4497   gfc_component *c;
4498   gfc_symbol *derived;
4499   gfc_ref *ref;
4500
4501   if (e->symtree->n.sym->ts.type == BT_CLASS)
4502     as = CLASS_DATA (e->symtree->n.sym)->as;
4503   else
4504     as = e->symtree->n.sym->as;
4505   derived = NULL;
4506
4507   for (ref = e->ref; ref; ref = ref->next)
4508     switch (ref->type)
4509       {
4510       case REF_ARRAY:
4511         if (as == NULL)
4512           gfc_internal_error ("find_array_spec(): Missing spec");
4513
4514         ref->u.ar.as = as;
4515         as = NULL;
4516         break;
4517
4518       case REF_COMPONENT:
4519         if (derived == NULL)
4520           derived = e->symtree->n.sym->ts.u.derived;
4521
4522         if (derived->attr.is_class)
4523           derived = derived->components->ts.u.derived;
4524
4525         c = derived->components;
4526
4527         for (; c; c = c->next)
4528           if (c == ref->u.c.component)
4529             {
4530               /* Track the sequence of component references.  */
4531               if (c->ts.type == BT_DERIVED)
4532                 derived = c->ts.u.derived;
4533               break;
4534             }
4535
4536         if (c == NULL)
4537           gfc_internal_error ("find_array_spec(): Component not found");
4538
4539         if (c->attr.dimension)
4540           {
4541             if (as != NULL)
4542               gfc_internal_error ("find_array_spec(): unused as(1)");
4543             as = c->as;
4544           }
4545
4546         break;
4547
4548       case REF_SUBSTRING:
4549         break;
4550       }
4551
4552   if (as != NULL)
4553     gfc_internal_error ("find_array_spec(): unused as(2)");
4554 }
4555
4556
4557 /* Resolve an array reference.  */
4558
4559 static gfc_try
4560 resolve_array_ref (gfc_array_ref *ar)
4561 {
4562   int i, check_scalar;
4563   gfc_expr *e;
4564
4565   for (i = 0; i < ar->dimen + ar->codimen; i++)
4566     {
4567       check_scalar = ar->dimen_type[i] == DIMEN_RANGE;
4568
4569       /* Do not force gfc_index_integer_kind for the start.  We can
4570          do fine with any integer kind.  This avoids temporary arrays
4571          created for indexing with a vector.  */
4572       if (gfc_resolve_index_1 (ar->start[i], check_scalar, 0) == FAILURE)
4573         return FAILURE;
4574       if (gfc_resolve_index (ar->end[i], check_scalar) == FAILURE)
4575         return FAILURE;
4576       if (gfc_resolve_index (ar->stride[i], check_scalar) == FAILURE)
4577         return FAILURE;
4578
4579       e = ar->start[i];
4580
4581       if (ar->dimen_type[i] == DIMEN_UNKNOWN)
4582         switch (e->rank)
4583           {
4584           case 0:
4585             ar->dimen_type[i] = DIMEN_ELEMENT;
4586             break;
4587
4588           case 1:
4589             ar->dimen_type[i] = DIMEN_VECTOR;
4590             if (e->expr_type == EXPR_VARIABLE
4591                 && e->symtree->n.sym->ts.type == BT_DERIVED)
4592               ar->start[i] = gfc_get_parentheses (e);
4593             break;
4594
4595           default:
4596             gfc_error ("Array index at %L is an array of rank %d",
4597                        &ar->c_where[i], e->rank);
4598             return FAILURE;
4599           }
4600
4601       /* Fill in the upper bound, which may be lower than the
4602          specified one for something like a(2:10:5), which is
4603          identical to a(2:7:5).  Only relevant for strides not equal
4604          to one.  Don't try a division by zero.  */
4605       if (ar->dimen_type[i] == DIMEN_RANGE
4606           && ar->stride[i] != NULL && ar->stride[i]->expr_type == EXPR_CONSTANT
4607           && mpz_cmp_si (ar->stride[i]->value.integer, 1L) != 0
4608           && mpz_cmp_si (ar->stride[i]->value.integer, 0L) != 0)
4609         {
4610           mpz_t size, end;
4611
4612           if (gfc_ref_dimen_size (ar, i, &size, &end) == SUCCESS)
4613             {
4614               if (ar->end[i] == NULL)
4615                 {
4616                   ar->end[i] =
4617                     gfc_get_constant_expr (BT_INTEGER, gfc_index_integer_kind,
4618                                            &ar->where);
4619                   mpz_set (ar->end[i]->value.integer, end);
4620                 }
4621               else if (ar->end[i]->ts.type == BT_INTEGER
4622                        && ar->end[i]->expr_type == EXPR_CONSTANT)
4623                 {
4624                   mpz_set (ar->end[i]->value.integer, end);
4625                 }
4626               else
4627                 gcc_unreachable ();
4628
4629               mpz_clear (size);
4630               mpz_clear (end);
4631             }
4632         }
4633     }
4634
4635   if (ar->type == AR_FULL)
4636     {
4637       if (ar->as->rank == 0)
4638         ar->type = AR_ELEMENT;
4639
4640       /* Make sure array is the same as array(:,:), this way
4641          we don't need to special case all the time.  */
4642       ar->dimen = ar->as->rank;
4643       for (i = 0; i < ar->dimen; i++)
4644         {
4645           ar->dimen_type[i] = DIMEN_RANGE;
4646
4647           gcc_assert (ar->start[i] == NULL);
4648           gcc_assert (ar->end[i] == NULL);
4649           gcc_assert (ar->stride[i] == NULL);
4650         }
4651     }
4652
4653   /* If the reference type is unknown, figure out what kind it is.  */
4654
4655   if (ar->type == AR_UNKNOWN)
4656     {
4657       ar->type = AR_ELEMENT;
4658       for (i = 0; i < ar->dimen; i++)
4659         if (ar->dimen_type[i] == DIMEN_RANGE
4660             || ar->dimen_type[i] == DIMEN_VECTOR)
4661           {
4662             ar->type = AR_SECTION;
4663             break;
4664           }
4665     }
4666
4667   if (!ar->as->cray_pointee && compare_spec_to_ref (ar) == FAILURE)
4668     return FAILURE;
4669
4670   if (ar->as->corank && ar->codimen == 0)
4671     {
4672       int n;
4673       ar->codimen = ar->as->corank;
4674       for (n = ar->dimen; n < ar->dimen + ar->codimen; n++)
4675         ar->dimen_type[n] = DIMEN_THIS_IMAGE;
4676     }
4677
4678   return SUCCESS;
4679 }
4680
4681
4682 static gfc_try
4683 resolve_substring (gfc_ref *ref)
4684 {
4685   int k = gfc_validate_kind (BT_INTEGER, gfc_charlen_int_kind, false);
4686
4687   if (ref->u.ss.start != NULL)
4688     {
4689       if (gfc_resolve_expr (ref->u.ss.start) == FAILURE)
4690         return FAILURE;
4691
4692       if (ref->u.ss.start->ts.type != BT_INTEGER)
4693         {
4694           gfc_error ("Substring start index at %L must be of type INTEGER",
4695                      &ref->u.ss.start->where);
4696           return FAILURE;
4697         }
4698
4699       if (ref->u.ss.start->rank != 0)
4700         {
4701           gfc_error ("Substring start index at %L must be scalar",
4702                      &ref->u.ss.start->where);
4703           return FAILURE;
4704         }
4705
4706       if (compare_bound_int (ref->u.ss.start, 1) == CMP_LT
4707           && (compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_EQ
4708               || compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_GT))
4709         {
4710           gfc_error ("Substring start index at %L is less than one",
4711                      &ref->u.ss.start->where);
4712           return FAILURE;
4713         }
4714     }
4715
4716   if (ref->u.ss.end != NULL)
4717     {
4718       if (gfc_resolve_expr (ref->u.ss.end) == FAILURE)
4719         return FAILURE;
4720
4721       if (ref->u.ss.end->ts.type != BT_INTEGER)
4722         {
4723           gfc_error ("Substring end index at %L must be of type INTEGER",
4724                      &ref->u.ss.end->where);
4725           return FAILURE;
4726         }
4727
4728       if (ref->u.ss.end->rank != 0)
4729         {
4730           gfc_error ("Substring end index at %L must be scalar",
4731                      &ref->u.ss.end->where);
4732           return FAILURE;
4733         }
4734
4735       if (ref->u.ss.length != NULL
4736           && compare_bound (ref->u.ss.end, ref->u.ss.length->length) == CMP_GT
4737           && (compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_EQ
4738               || compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_GT))
4739         {
4740           gfc_error ("Substring end index at %L exceeds the string length",
4741                      &ref->u.ss.start->where);
4742           return FAILURE;
4743         }
4744
4745       if (compare_bound_mpz_t (ref->u.ss.end,
4746                                gfc_integer_kinds[k].huge) == CMP_GT
4747           && (compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_EQ
4748               || compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_GT))
4749         {
4750           gfc_error ("Substring end index at %L is too large",
4751                      &ref->u.ss.end->where);
4752           return FAILURE;
4753         }
4754     }
4755
4756   return SUCCESS;
4757 }
4758
4759
4760 /* This function supplies missing substring charlens.  */
4761
4762 void
4763 gfc_resolve_substring_charlen (gfc_expr *e)
4764 {
4765   gfc_ref *char_ref;
4766   gfc_expr *start, *end;
4767
4768   for (char_ref = e->ref; char_ref; char_ref = char_ref->next)
4769     if (char_ref->type == REF_SUBSTRING)
4770       break;
4771
4772   if (!char_ref)
4773     return;
4774
4775   gcc_assert (char_ref->next == NULL);
4776
4777   if (e->ts.u.cl)
4778     {
4779       if (e->ts.u.cl->length)
4780         gfc_free_expr (e->ts.u.cl->length);
4781       else if (e->expr_type == EXPR_VARIABLE
4782                  && e->symtree->n.sym->attr.dummy)
4783         return;
4784     }
4785
4786   e->ts.type = BT_CHARACTER;
4787   e->ts.kind = gfc_default_character_kind;
4788
4789   if (!e->ts.u.cl)
4790     e->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
4791
4792   if (char_ref->u.ss.start)
4793     start = gfc_copy_expr (char_ref->u.ss.start);
4794   else
4795     start = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1);
4796
4797   if (char_ref->u.ss.end)
4798     end = gfc_copy_expr (char_ref->u.ss.end);
4799   else if (e->expr_type == EXPR_VARIABLE)
4800     end = gfc_copy_expr (e->symtree->n.sym->ts.u.cl->length);
4801   else
4802     end = NULL;
4803
4804   if (!start || !end)
4805     return;
4806
4807   /* Length = (end - start +1).  */
4808   e->ts.u.cl->length = gfc_subtract (end, start);
4809   e->ts.u.cl->length = gfc_add (e->ts.u.cl->length,
4810                                 gfc_get_int_expr (gfc_default_integer_kind,
4811                                                   NULL, 1));
4812
4813   e->ts.u.cl->length->ts.type = BT_INTEGER;
4814   e->ts.u.cl->length->ts.kind = gfc_charlen_int_kind;
4815
4816   /* Make sure that the length is simplified.  */
4817   gfc_simplify_expr (e->ts.u.cl->length, 1);
4818   gfc_resolve_expr (e->ts.u.cl->length);
4819 }
4820
4821
4822 /* Resolve subtype references.  */
4823
4824 static gfc_try
4825 resolve_ref (gfc_expr *expr)
4826 {
4827   int current_part_dimension, n_components, seen_part_dimension;
4828   gfc_ref *ref;
4829
4830   for (ref = expr->ref; ref; ref = ref->next)
4831     if (ref->type == REF_ARRAY && ref->u.ar.as == NULL)
4832       {
4833         find_array_spec (expr);
4834         break;
4835       }
4836
4837   for (ref = expr->ref; ref; ref = ref->next)
4838     switch (ref->type)
4839       {
4840       case REF_ARRAY:
4841         if (resolve_array_ref (&ref->u.ar) == FAILURE)
4842           return FAILURE;
4843         break;
4844
4845       case REF_COMPONENT:
4846         break;
4847
4848       case REF_SUBSTRING:
4849         if (resolve_substring (ref) == FAILURE)
4850           return FAILURE;
4851         break;
4852       }
4853
4854   /* Check constraints on part references.  */
4855
4856   current_part_dimension = 0;
4857   seen_part_dimension = 0;
4858   n_components = 0;
4859
4860   for (ref = expr->ref; ref; ref = ref->next)
4861     {
4862       switch (ref->type)
4863         {
4864         case REF_ARRAY:
4865           switch (ref->u.ar.type)
4866             {
4867             case AR_FULL:
4868               /* Coarray scalar.  */
4869               if (ref->u.ar.as->rank == 0)
4870                 {
4871                   current_part_dimension = 0;
4872                   break;
4873                 }
4874               /* Fall through.  */
4875             case AR_SECTION:
4876               current_part_dimension = 1;
4877               break;
4878
4879             case AR_ELEMENT:
4880               current_part_dimension = 0;
4881               break;
4882
4883             case AR_UNKNOWN:
4884               gfc_internal_error ("resolve_ref(): Bad array reference");
4885             }
4886
4887           break;
4888
4889         case REF_COMPONENT:
4890           if (current_part_dimension || seen_part_dimension)
4891             {
4892               /* F03:C614.  */
4893               if (ref->u.c.component->attr.pointer
4894                   || ref->u.c.component->attr.proc_pointer)
4895                 {
4896                   gfc_error ("Component to the right of a part reference "
4897                              "with nonzero rank must not have the POINTER "
4898                              "attribute at %L", &expr->where);
4899                   return FAILURE;
4900                 }
4901               else if (ref->u.c.component->attr.allocatable)
4902                 {
4903                   gfc_error ("Component to the right of a part reference "
4904                              "with nonzero rank must not have the ALLOCATABLE "
4905                              "attribute at %L", &expr->where);
4906                   return FAILURE;
4907                 }
4908             }
4909
4910           n_components++;
4911           break;
4912
4913         case REF_SUBSTRING:
4914           break;
4915         }
4916
4917       if (((ref->type == REF_COMPONENT && n_components > 1)
4918            || ref->next == NULL)
4919           && current_part_dimension
4920           && seen_part_dimension)
4921         {
4922           gfc_error ("Two or more part references with nonzero rank must "
4923                      "not be specified at %L", &expr->where);
4924           return FAILURE;
4925         }
4926
4927       if (ref->type == REF_COMPONENT)
4928         {
4929           if (current_part_dimension)
4930             seen_part_dimension = 1;
4931
4932           /* reset to make sure */
4933           current_part_dimension = 0;
4934         }
4935     }
4936
4937   return SUCCESS;
4938 }
4939
4940
4941 /* Given an expression, determine its shape.  This is easier than it sounds.
4942    Leaves the shape array NULL if it is not possible to determine the shape.  */
4943
4944 static void
4945 expression_shape (gfc_expr *e)
4946 {
4947   mpz_t array[GFC_MAX_DIMENSIONS];
4948   int i;
4949
4950   if (e->rank == 0 || e->shape != NULL)
4951     return;
4952
4953   for (i = 0; i < e->rank; i++)
4954     if (gfc_array_dimen_size (e, i, &array[i]) == FAILURE)
4955       goto fail;
4956
4957   e->shape = gfc_get_shape (e->rank);
4958
4959   memcpy (e->shape, array, e->rank * sizeof (mpz_t));
4960
4961   return;
4962
4963 fail:
4964   for (i--; i >= 0; i--)
4965     mpz_clear (array[i]);
4966 }
4967
4968
4969 /* Given a variable expression node, compute the rank of the expression by
4970    examining the base symbol and any reference structures it may have.  */
4971
4972 static void
4973 expression_rank (gfc_expr *e)
4974 {
4975   gfc_ref *ref;
4976   int i, rank;
4977
4978   /* Just to make sure, because EXPR_COMPCALL's also have an e->ref and that
4979      could lead to serious confusion...  */
4980   gcc_assert (e->expr_type != EXPR_COMPCALL);
4981
4982   if (e->ref == NULL)
4983     {
4984       if (e->expr_type == EXPR_ARRAY)
4985         goto done;
4986       /* Constructors can have a rank different from one via RESHAPE().  */
4987
4988       if (e->symtree == NULL)
4989         {
4990           e->rank = 0;
4991           goto done;
4992         }
4993
4994       e->rank = (e->symtree->n.sym->as == NULL)
4995                 ? 0 : e->symtree->n.sym->as->rank;
4996       goto done;
4997     }
4998
4999   rank = 0;
5000
5001   for (ref = e->ref; ref; ref = ref->next)
5002     {
5003       if (ref->type == REF_COMPONENT && ref->u.c.component->attr.proc_pointer
5004           && ref->u.c.component->attr.function && !ref->next)
5005         rank = ref->u.c.component->as ? ref->u.c.component->as->rank : 0;
5006
5007       if (ref->type != REF_ARRAY)
5008         continue;
5009
5010       if (ref->u.ar.type == AR_FULL)
5011         {
5012           rank = ref->u.ar.as->rank;
5013           break;
5014         }
5015
5016       if (ref->u.ar.type == AR_SECTION)
5017         {
5018           /* Figure out the rank of the section.  */
5019           if (rank != 0)
5020             gfc_internal_error ("expression_rank(): Two array specs");
5021
5022           for (i = 0; i < ref->u.ar.dimen; i++)
5023             if (ref->u.ar.dimen_type[i] == DIMEN_RANGE
5024                 || ref->u.ar.dimen_type[i] == DIMEN_VECTOR)
5025               rank++;
5026
5027           break;
5028         }
5029     }
5030
5031   e->rank = rank;
5032
5033 done:
5034   expression_shape (e);
5035 }
5036
5037
5038 /* Resolve a variable expression.  */
5039
5040 static gfc_try
5041 resolve_variable (gfc_expr *e)
5042 {
5043   gfc_symbol *sym;
5044   gfc_try t;
5045
5046   t = SUCCESS;
5047
5048   if (e->symtree == NULL)
5049     return FAILURE;
5050   sym = e->symtree->n.sym;
5051
5052   /* If this is an associate-name, it may be parsed with an array reference
5053      in error even though the target is scalar.  Fail directly in this case.  */
5054   if (sym->assoc && !sym->attr.dimension && e->ref && e->ref->type == REF_ARRAY)
5055     return FAILURE;
5056
5057   /* On the other hand, the parser may not have known this is an array;
5058      in this case, we have to add a FULL reference.  */
5059   if (sym->assoc && sym->attr.dimension && !e->ref)
5060     {
5061       e->ref = gfc_get_ref ();
5062       e->ref->type = REF_ARRAY;
5063       e->ref->u.ar.type = AR_FULL;
5064       e->ref->u.ar.dimen = 0;
5065     }
5066
5067   if (e->ref && resolve_ref (e) == FAILURE)
5068     return FAILURE;
5069
5070   if (sym->attr.flavor == FL_PROCEDURE
5071       && (!sym->attr.function
5072           || (sym->attr.function && sym->result
5073               && sym->result->attr.proc_pointer
5074               && !sym->result->attr.function)))
5075     {
5076       e->ts.type = BT_PROCEDURE;
5077       goto resolve_procedure;
5078     }
5079
5080   if (sym->ts.type != BT_UNKNOWN)
5081     gfc_variable_attr (e, &e->ts);
5082   else
5083     {
5084       /* Must be a simple variable reference.  */
5085       if (gfc_set_default_type (sym, 1, sym->ns) == FAILURE)
5086         return FAILURE;
5087       e->ts = sym->ts;
5088     }
5089
5090   if (check_assumed_size_reference (sym, e))
5091     return FAILURE;
5092
5093   /* Deal with forward references to entries during resolve_code, to
5094      satisfy, at least partially, 12.5.2.5.  */
5095   if (gfc_current_ns->entries
5096       && current_entry_id == sym->entry_id
5097       && cs_base
5098       && cs_base->current
5099       && cs_base->current->op != EXEC_ENTRY)
5100     {
5101       gfc_entry_list *entry;
5102       gfc_formal_arglist *formal;
5103       int n;
5104       bool seen;
5105
5106       /* If the symbol is a dummy...  */
5107       if (sym->attr.dummy && sym->ns == gfc_current_ns)
5108         {
5109           entry = gfc_current_ns->entries;
5110           seen = false;
5111
5112           /* ...test if the symbol is a parameter of previous entries.  */
5113           for (; entry && entry->id <= current_entry_id; entry = entry->next)
5114             for (formal = entry->sym->formal; formal; formal = formal->next)
5115               {
5116                 if (formal->sym && sym->name == formal->sym->name)
5117                   seen = true;
5118               }
5119
5120           /*  If it has not been seen as a dummy, this is an error.  */
5121           if (!seen)
5122             {
5123               if (specification_expr)
5124                 gfc_error ("Variable '%s', used in a specification expression"
5125                            ", is referenced at %L before the ENTRY statement "
5126                            "in which it is a parameter",
5127                            sym->name, &cs_base->current->loc);
5128               else
5129                 gfc_error ("Variable '%s' is used at %L before the ENTRY "
5130                            "statement in which it is a parameter",
5131                            sym->name, &cs_base->current->loc);
5132               t = FAILURE;
5133             }
5134         }
5135
5136       /* Now do the same check on the specification expressions.  */
5137       specification_expr = 1;
5138       if (sym->ts.type == BT_CHARACTER
5139           && gfc_resolve_expr (sym->ts.u.cl->length) == FAILURE)
5140         t = FAILURE;
5141
5142       if (sym->as)
5143         for (n = 0; n < sym->as->rank; n++)
5144           {
5145              specification_expr = 1;
5146              if (gfc_resolve_expr (sym->as->lower[n]) == FAILURE)
5147                t = FAILURE;
5148              specification_expr = 1;
5149              if (gfc_resolve_expr (sym->as->upper[n]) == FAILURE)
5150                t = FAILURE;
5151           }
5152       specification_expr = 0;
5153
5154       if (t == SUCCESS)
5155         /* Update the symbol's entry level.  */
5156         sym->entry_id = current_entry_id + 1;
5157     }
5158
5159   /* If a symbol has been host_associated mark it.  This is used latter,
5160      to identify if aliasing is possible via host association.  */
5161   if (sym->attr.flavor == FL_VARIABLE
5162         && gfc_current_ns->parent
5163         && (gfc_current_ns->parent == sym->ns
5164               || (gfc_current_ns->parent->parent
5165                     && gfc_current_ns->parent->parent == sym->ns)))
5166     sym->attr.host_assoc = 1;
5167
5168 resolve_procedure:
5169   if (t == SUCCESS && resolve_procedure_expression (e) == FAILURE)
5170     t = FAILURE;
5171
5172   /* F2008, C617 and C1229.  */
5173   if (!inquiry_argument && (e->ts.type == BT_CLASS || e->ts.type == BT_DERIVED)
5174       && gfc_is_coindexed (e))
5175     {
5176       gfc_ref *ref, *ref2 = NULL;
5177
5178       for (ref = e->ref; ref; ref = ref->next)
5179         {
5180           if (ref->type == REF_COMPONENT)
5181             ref2 = ref;
5182           if (ref->type == REF_ARRAY && ref->u.ar.codimen > 0)
5183             break;
5184         }
5185
5186       for ( ; ref; ref = ref->next)
5187         if (ref->type == REF_COMPONENT)
5188           break;
5189
5190       /* Expression itself is not coindexed object.  */
5191       if (ref && e->ts.type == BT_CLASS)
5192         {
5193           gfc_error ("Polymorphic subobject of coindexed object at %L",
5194                      &e->where);
5195           t = FAILURE;
5196         }
5197
5198       /* Expression itself is coindexed object.  */
5199       if (ref == NULL)
5200         {
5201           gfc_component *c;
5202           c = ref2 ? ref2->u.c.component : e->symtree->n.sym->components;
5203           for ( ; c; c = c->next)
5204             if (c->attr.allocatable && c->ts.type == BT_CLASS)
5205               {
5206                 gfc_error ("Coindexed object with polymorphic allocatable "
5207                          "subcomponent at %L", &e->where);
5208                 t = FAILURE;
5209                 break;
5210               }
5211         }
5212     }
5213
5214   return t;
5215 }
5216
5217
5218 /* Checks to see that the correct symbol has been host associated.
5219    The only situation where this arises is that in which a twice
5220    contained function is parsed after the host association is made.
5221    Therefore, on detecting this, change the symbol in the expression
5222    and convert the array reference into an actual arglist if the old
5223    symbol is a variable.  */
5224 static bool
5225 check_host_association (gfc_expr *e)
5226 {
5227   gfc_symbol *sym, *old_sym;
5228   gfc_symtree *st;
5229   int n;
5230   gfc_ref *ref;
5231   gfc_actual_arglist *arg, *tail = NULL;
5232   bool retval = e->expr_type == EXPR_FUNCTION;
5233
5234   /*  If the expression is the result of substitution in
5235       interface.c(gfc_extend_expr) because there is no way in
5236       which the host association can be wrong.  */
5237   if (e->symtree == NULL
5238         || e->symtree->n.sym == NULL
5239         || e->user_operator)
5240     return retval;
5241
5242   old_sym = e->symtree->n.sym;
5243
5244   if (gfc_current_ns->parent
5245         && old_sym->ns != gfc_current_ns)
5246     {
5247       /* Use the 'USE' name so that renamed module symbols are
5248          correctly handled.  */
5249       gfc_find_symbol (e->symtree->name, gfc_current_ns, 1, &sym);
5250
5251       if (sym && old_sym != sym
5252               && sym->ts.type == old_sym->ts.type
5253               && sym->attr.flavor == FL_PROCEDURE
5254               && sym->attr.contained)
5255         {
5256           /* Clear the shape, since it might not be valid.  */
5257           gfc_free_shape (&e->shape, e->rank);
5258
5259           /* Give the expression the right symtree!  */
5260           gfc_find_sym_tree (e->symtree->name, NULL, 1, &st);
5261           gcc_assert (st != NULL);
5262
5263           if (old_sym->attr.flavor == FL_PROCEDURE
5264                 || e->expr_type == EXPR_FUNCTION)
5265             {
5266               /* Original was function so point to the new symbol, since
5267                  the actual argument list is already attached to the
5268                  expression. */
5269               e->value.function.esym = NULL;
5270               e->symtree = st;
5271             }
5272           else
5273             {
5274               /* Original was variable so convert array references into
5275                  an actual arglist. This does not need any checking now
5276                  since resolve_function will take care of it.  */
5277               e->value.function.actual = NULL;
5278               e->expr_type = EXPR_FUNCTION;
5279               e->symtree = st;
5280
5281               /* Ambiguity will not arise if the array reference is not
5282                  the last reference.  */
5283               for (ref = e->ref; ref; ref = ref->next)
5284                 if (ref->type == REF_ARRAY && ref->next == NULL)
5285                   break;
5286
5287               gcc_assert (ref->type == REF_ARRAY);
5288
5289               /* Grab the start expressions from the array ref and
5290                  copy them into actual arguments.  */
5291               for (n = 0; n < ref->u.ar.dimen; n++)
5292                 {
5293                   arg = gfc_get_actual_arglist ();
5294                   arg->expr = gfc_copy_expr (ref->u.ar.start[n]);
5295                   if (e->value.function.actual == NULL)
5296                     tail = e->value.function.actual = arg;
5297                   else
5298                     {
5299                       tail->next = arg;
5300                       tail = arg;
5301                     }
5302                 }
5303
5304               /* Dump the reference list and set the rank.  */
5305               gfc_free_ref_list (e->ref);
5306               e->ref = NULL;
5307               e->rank = sym->as ? sym->as->rank : 0;
5308             }
5309
5310           gfc_resolve_expr (e);
5311           sym->refs++;
5312         }
5313     }
5314   /* This might have changed!  */
5315   return e->expr_type == EXPR_FUNCTION;
5316 }
5317
5318
5319 static void
5320 gfc_resolve_character_operator (gfc_expr *e)
5321 {
5322   gfc_expr *op1 = e->value.op.op1;
5323   gfc_expr *op2 = e->value.op.op2;
5324   gfc_expr *e1 = NULL;
5325   gfc_expr *e2 = NULL;
5326
5327   gcc_assert (e->value.op.op == INTRINSIC_CONCAT);
5328
5329   if (op1->ts.u.cl && op1->ts.u.cl->length)
5330     e1 = gfc_copy_expr (op1->ts.u.cl->length);
5331   else if (op1->expr_type == EXPR_CONSTANT)
5332     e1 = gfc_get_int_expr (gfc_default_integer_kind, NULL,
5333                            op1->value.character.length);
5334
5335   if (op2->ts.u.cl && op2->ts.u.cl->length)
5336     e2 = gfc_copy_expr (op2->ts.u.cl->length);
5337   else if (op2->expr_type == EXPR_CONSTANT)
5338     e2 = gfc_get_int_expr (gfc_default_integer_kind, NULL,
5339                            op2->value.character.length);
5340
5341   e->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
5342
5343   if (!e1 || !e2)
5344     return;
5345
5346   e->ts.u.cl->length = gfc_add (e1, e2);
5347   e->ts.u.cl->length->ts.type = BT_INTEGER;
5348   e->ts.u.cl->length->ts.kind = gfc_charlen_int_kind;
5349   gfc_simplify_expr (e->ts.u.cl->length, 0);
5350   gfc_resolve_expr (e->ts.u.cl->length);
5351
5352   return;
5353 }
5354
5355
5356 /*  Ensure that an character expression has a charlen and, if possible, a
5357     length expression.  */
5358
5359 static void
5360 fixup_charlen (gfc_expr *e)
5361 {
5362   /* The cases fall through so that changes in expression type and the need
5363      for multiple fixes are picked up.  In all circumstances, a charlen should
5364      be available for the middle end to hang a backend_decl on.  */
5365   switch (e->expr_type)
5366     {
5367     case EXPR_OP:
5368       gfc_resolve_character_operator (e);
5369
5370     case EXPR_ARRAY:
5371       if (e->expr_type == EXPR_ARRAY)
5372         gfc_resolve_character_array_constructor (e);
5373
5374     case EXPR_SUBSTRING:
5375       if (!e->ts.u.cl && e->ref)
5376         gfc_resolve_substring_charlen (e);
5377
5378     default:
5379       if (!e->ts.u.cl)
5380         e->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
5381
5382       break;
5383     }
5384 }
5385
5386
5387 /* Update an actual argument to include the passed-object for type-bound
5388    procedures at the right position.  */
5389
5390 static gfc_actual_arglist*
5391 update_arglist_pass (gfc_actual_arglist* lst, gfc_expr* po, unsigned argpos,
5392                      const char *name)
5393 {
5394   gcc_assert (argpos > 0);
5395
5396   if (argpos == 1)
5397     {
5398       gfc_actual_arglist* result;
5399
5400       result = gfc_get_actual_arglist ();
5401       result->expr = po;
5402       result->next = lst;
5403       if (name)
5404         result->name = name;
5405
5406       return result;
5407     }
5408
5409   if (lst)
5410     lst->next = update_arglist_pass (lst->next, po, argpos - 1, name);
5411   else
5412     lst = update_arglist_pass (NULL, po, argpos - 1, name);
5413   return lst;
5414 }
5415
5416
5417 /* Extract the passed-object from an EXPR_COMPCALL (a copy of it).  */
5418
5419 static gfc_expr*
5420 extract_compcall_passed_object (gfc_expr* e)
5421 {
5422   gfc_expr* po;
5423
5424   gcc_assert (e->expr_type == EXPR_COMPCALL);
5425
5426   if (e->value.compcall.base_object)
5427     po = gfc_copy_expr (e->value.compcall.base_object);
5428   else
5429     {
5430       po = gfc_get_expr ();
5431       po->expr_type = EXPR_VARIABLE;
5432       po->symtree = e->symtree;
5433       po->ref = gfc_copy_ref (e->ref);
5434       po->where = e->where;
5435     }
5436
5437   if (gfc_resolve_expr (po) == FAILURE)
5438     return NULL;
5439
5440   return po;
5441 }
5442
5443
5444 /* Update the arglist of an EXPR_COMPCALL expression to include the
5445    passed-object.  */
5446
5447 static gfc_try
5448 update_compcall_arglist (gfc_expr* e)
5449 {
5450   gfc_expr* po;
5451   gfc_typebound_proc* tbp;
5452
5453   tbp = e->value.compcall.tbp;
5454
5455   if (tbp->error)
5456     return FAILURE;
5457
5458   po = extract_compcall_passed_object (e);
5459   if (!po)
5460     return FAILURE;
5461
5462   if (tbp->nopass || e->value.compcall.ignore_pass)
5463     {
5464       gfc_free_expr (po);
5465       return SUCCESS;
5466     }
5467
5468   gcc_assert (tbp->pass_arg_num > 0);
5469   e->value.compcall.actual = update_arglist_pass (e->value.compcall.actual, po,
5470                                                   tbp->pass_arg_num,
5471                                                   tbp->pass_arg);
5472
5473   return SUCCESS;
5474 }
5475
5476
5477 /* Extract the passed object from a PPC call (a copy of it).  */
5478
5479 static gfc_expr*
5480 extract_ppc_passed_object (gfc_expr *e)
5481 {
5482   gfc_expr *po;
5483   gfc_ref **ref;
5484
5485   po = gfc_get_expr ();
5486   po->expr_type = EXPR_VARIABLE;
5487   po->symtree = e->symtree;
5488   po->ref = gfc_copy_ref (e->ref);
5489   po->where = e->where;
5490
5491   /* Remove PPC reference.  */
5492   ref = &po->ref;
5493   while ((*ref)->next)
5494     ref = &(*ref)->next;
5495   gfc_free_ref_list (*ref);
5496   *ref = NULL;
5497
5498   if (gfc_resolve_expr (po) == FAILURE)
5499     return NULL;
5500
5501   return po;
5502 }
5503
5504
5505 /* Update the actual arglist of a procedure pointer component to include the
5506    passed-object.  */
5507
5508 static gfc_try
5509 update_ppc_arglist (gfc_expr* e)
5510 {
5511   gfc_expr* po;
5512   gfc_component *ppc;
5513   gfc_typebound_proc* tb;
5514
5515   if (!gfc_is_proc_ptr_comp (e, &ppc))
5516     return FAILURE;
5517
5518   tb = ppc->tb;
5519
5520   if (tb->error)
5521     return FAILURE;
5522   else if (tb->nopass)
5523     return SUCCESS;
5524
5525   po = extract_ppc_passed_object (e);
5526   if (!po)
5527     return FAILURE;
5528
5529   /* F08:R739.  */
5530   if (po->rank > 0)
5531     {
5532       gfc_error ("Passed-object at %L must be scalar", &e->where);
5533       return FAILURE;
5534     }
5535
5536   /* F08:C611.  */
5537   if (po->ts.type == BT_DERIVED && po->ts.u.derived->attr.abstract)
5538     {
5539       gfc_error ("Base object for procedure-pointer component call at %L is of"
5540                  " ABSTRACT type '%s'", &e->where, po->ts.u.derived->name);
5541       return FAILURE;
5542     }
5543
5544   gcc_assert (tb->pass_arg_num > 0);
5545   e->value.compcall.actual = update_arglist_pass (e->value.compcall.actual, po,
5546                                                   tb->pass_arg_num,
5547                                                   tb->pass_arg);
5548
5549   return SUCCESS;
5550 }
5551
5552
5553 /* Check that the object a TBP is called on is valid, i.e. it must not be
5554    of ABSTRACT type (as in subobject%abstract_parent%tbp()).  */
5555
5556 static gfc_try
5557 check_typebound_baseobject (gfc_expr* e)
5558 {
5559   gfc_expr* base;
5560   gfc_try return_value = FAILURE;
5561
5562   base = extract_compcall_passed_object (e);
5563   if (!base)
5564     return FAILURE;
5565
5566   gcc_assert (base->ts.type == BT_DERIVED || base->ts.type == BT_CLASS);
5567
5568   /* F08:C611.  */
5569   if (base->ts.type == BT_DERIVED && base->ts.u.derived->attr.abstract)
5570     {
5571       gfc_error ("Base object for type-bound procedure call at %L is of"
5572                  " ABSTRACT type '%s'", &e->where, base->ts.u.derived->name);
5573       goto cleanup;
5574     }
5575
5576   /* F08:C1230. If the procedure called is NOPASS,
5577      the base object must be scalar.  */
5578   if (e->value.compcall.tbp->nopass && base->rank > 0)
5579     {
5580       gfc_error ("Base object for NOPASS type-bound procedure call at %L must"
5581                  " be scalar", &e->where);
5582       goto cleanup;
5583     }
5584
5585   /* FIXME: Remove once PR 43214 is fixed (TBP with non-scalar PASS).  */
5586   if (base->rank > 0)
5587     {
5588       gfc_error ("Non-scalar base object at %L currently not implemented",
5589                  &e->where);
5590       goto cleanup;
5591     }
5592
5593   return_value = SUCCESS;
5594
5595 cleanup:
5596   gfc_free_expr (base);
5597   return return_value;
5598 }
5599
5600
5601 /* Resolve a call to a type-bound procedure, either function or subroutine,
5602    statically from the data in an EXPR_COMPCALL expression.  The adapted
5603    arglist and the target-procedure symtree are returned.  */
5604
5605 static gfc_try
5606 resolve_typebound_static (gfc_expr* e, gfc_symtree** target,
5607                           gfc_actual_arglist** actual)
5608 {
5609   gcc_assert (e->expr_type == EXPR_COMPCALL);
5610   gcc_assert (!e->value.compcall.tbp->is_generic);
5611
5612   /* Update the actual arglist for PASS.  */
5613   if (update_compcall_arglist (e) == FAILURE)
5614     return FAILURE;
5615
5616   *actual = e->value.compcall.actual;
5617   *target = e->value.compcall.tbp->u.specific;
5618
5619   gfc_free_ref_list (e->ref);
5620   e->ref = NULL;
5621   e->value.compcall.actual = NULL;
5622
5623   return SUCCESS;
5624 }
5625
5626
5627 /* Get the ultimate declared type from an expression.  In addition,
5628    return the last class/derived type reference and the copy of the
5629    reference list.  */
5630 static gfc_symbol*
5631 get_declared_from_expr (gfc_ref **class_ref, gfc_ref **new_ref,
5632                         gfc_expr *e)
5633 {
5634   gfc_symbol *declared;
5635   gfc_ref *ref;
5636
5637   declared = NULL;
5638   if (class_ref)
5639     *class_ref = NULL;
5640   if (new_ref)
5641     *new_ref = gfc_copy_ref (e->ref);
5642
5643   for (ref = e->ref; ref; ref = ref->next)
5644     {
5645       if (ref->type != REF_COMPONENT)
5646         continue;
5647
5648       if (ref->u.c.component->ts.type == BT_CLASS
5649             || ref->u.c.component->ts.type == BT_DERIVED)
5650         {
5651           declared = ref->u.c.component->ts.u.derived;
5652           if (class_ref)
5653             *class_ref = ref;
5654         }
5655     }
5656
5657   if (declared == NULL)
5658     declared = e->symtree->n.sym->ts.u.derived;
5659
5660   return declared;
5661 }
5662
5663
5664 /* Given an EXPR_COMPCALL calling a GENERIC typebound procedure, figure out
5665    which of the specific bindings (if any) matches the arglist and transform
5666    the expression into a call of that binding.  */
5667
5668 static gfc_try
5669 resolve_typebound_generic_call (gfc_expr* e, const char **name)
5670 {
5671   gfc_typebound_proc* genproc;
5672   const char* genname;
5673   gfc_symtree *st;
5674   gfc_symbol *derived;
5675
5676   gcc_assert (e->expr_type == EXPR_COMPCALL);
5677   genname = e->value.compcall.name;
5678   genproc = e->value.compcall.tbp;
5679
5680   if (!genproc->is_generic)
5681     return SUCCESS;
5682
5683   /* Try the bindings on this type and in the inheritance hierarchy.  */
5684   for (; genproc; genproc = genproc->overridden)
5685     {
5686       gfc_tbp_generic* g;
5687
5688       gcc_assert (genproc->is_generic);
5689       for (g = genproc->u.generic; g; g = g->next)
5690         {
5691           gfc_symbol* target;
5692           gfc_actual_arglist* args;
5693           bool matches;
5694
5695           gcc_assert (g->specific);
5696
5697           if (g->specific->error)
5698             continue;
5699
5700           target = g->specific->u.specific->n.sym;
5701
5702           /* Get the right arglist by handling PASS/NOPASS.  */
5703           args = gfc_copy_actual_arglist (e->value.compcall.actual);
5704           if (!g->specific->nopass)
5705             {
5706               gfc_expr* po;
5707               po = extract_compcall_passed_object (e);
5708               if (!po)
5709                 return FAILURE;
5710
5711               gcc_assert (g->specific->pass_arg_num > 0);
5712               gcc_assert (!g->specific->error);
5713               args = update_arglist_pass (args, po, g->specific->pass_arg_num,
5714                                           g->specific->pass_arg);
5715             }
5716           resolve_actual_arglist (args, target->attr.proc,
5717                                   is_external_proc (target) && !target->formal);
5718
5719           /* Check if this arglist matches the formal.  */
5720           matches = gfc_arglist_matches_symbol (&args, target);
5721
5722           /* Clean up and break out of the loop if we've found it.  */
5723           gfc_free_actual_arglist (args);
5724           if (matches)
5725             {
5726               e->value.compcall.tbp = g->specific;
5727               genname = g->specific_st->name;
5728               /* Pass along the name for CLASS methods, where the vtab
5729                  procedure pointer component has to be referenced.  */
5730               if (name)
5731                 *name = genname;
5732               goto success;
5733             }
5734         }
5735     }
5736
5737   /* Nothing matching found!  */
5738   gfc_error ("Found no matching specific binding for the call to the GENERIC"
5739              " '%s' at %L", genname, &e->where);
5740   return FAILURE;
5741
5742 success:
5743   /* Make sure that we have the right specific instance for the name.  */
5744   derived = get_declared_from_expr (NULL, NULL, e);
5745
5746   st = gfc_find_typebound_proc (derived, NULL, genname, true, &e->where);
5747   if (st)
5748     e->value.compcall.tbp = st->n.tb;
5749
5750   return SUCCESS;
5751 }
5752
5753
5754 /* Resolve a call to a type-bound subroutine.  */
5755
5756 static gfc_try
5757 resolve_typebound_call (gfc_code* c, const char **name)
5758 {
5759   gfc_actual_arglist* newactual;
5760   gfc_symtree* target;
5761
5762   /* Check that's really a SUBROUTINE.  */
5763   if (!c->expr1->value.compcall.tbp->subroutine)
5764     {
5765       gfc_error ("'%s' at %L should be a SUBROUTINE",
5766                  c->expr1->value.compcall.name, &c->loc);
5767       return FAILURE;
5768     }
5769
5770   if (check_typebound_baseobject (c->expr1) == FAILURE)
5771     return FAILURE;
5772
5773   /* Pass along the name for CLASS methods, where the vtab
5774      procedure pointer component has to be referenced.  */
5775   if (name)
5776     *name = c->expr1->value.compcall.name;
5777
5778   if (resolve_typebound_generic_call (c->expr1, name) == FAILURE)
5779     return FAILURE;
5780
5781   /* Transform into an ordinary EXEC_CALL for now.  */
5782
5783   if (resolve_typebound_static (c->expr1, &target, &newactual) == FAILURE)
5784     return FAILURE;
5785
5786   c->ext.actual = newactual;
5787   c->symtree = target;
5788   c->op = (c->expr1->value.compcall.assign ? EXEC_ASSIGN_CALL : EXEC_CALL);
5789
5790   gcc_assert (!c->expr1->ref && !c->expr1->value.compcall.actual);
5791
5792   gfc_free_expr (c->expr1);
5793   c->expr1 = gfc_get_expr ();
5794   c->expr1->expr_type = EXPR_FUNCTION;
5795   c->expr1->symtree = target;
5796   c->expr1->where = c->loc;
5797
5798   return resolve_call (c);
5799 }
5800
5801
5802 /* Resolve a component-call expression.  */
5803 static gfc_try
5804 resolve_compcall (gfc_expr* e, const char **name)
5805 {
5806   gfc_actual_arglist* newactual;
5807   gfc_symtree* target;
5808
5809   /* Check that's really a FUNCTION.  */
5810   if (!e->value.compcall.tbp->function)
5811     {
5812       gfc_error ("'%s' at %L should be a FUNCTION",
5813                  e->value.compcall.name, &e->where);
5814       return FAILURE;
5815     }
5816
5817   /* These must not be assign-calls!  */
5818   gcc_assert (!e->value.compcall.assign);
5819
5820   if (check_typebound_baseobject (e) == FAILURE)
5821     return FAILURE;
5822
5823   /* Pass along the name for CLASS methods, where the vtab
5824      procedure pointer component has to be referenced.  */
5825   if (name)
5826     *name = e->value.compcall.name;
5827
5828   if (resolve_typebound_generic_call (e, name) == FAILURE)
5829     return FAILURE;
5830   gcc_assert (!e->value.compcall.tbp->is_generic);
5831
5832   /* Take the rank from the function's symbol.  */
5833   if (e->value.compcall.tbp->u.specific->n.sym->as)
5834     e->rank = e->value.compcall.tbp->u.specific->n.sym->as->rank;
5835
5836   /* For now, we simply transform it into an EXPR_FUNCTION call with the same
5837      arglist to the TBP's binding target.  */
5838
5839   if (resolve_typebound_static (e, &target, &newactual) == FAILURE)
5840     return FAILURE;
5841
5842   e->value.function.actual = newactual;
5843   e->value.function.name = NULL;
5844   e->value.function.esym = target->n.sym;
5845   e->value.function.isym = NULL;
5846   e->symtree = target;
5847   e->ts = target->n.sym->ts;
5848   e->expr_type = EXPR_FUNCTION;
5849
5850   /* Resolution is not necessary if this is a class subroutine; this
5851      function only has to identify the specific proc. Resolution of
5852      the call will be done next in resolve_typebound_call.  */
5853   return gfc_resolve_expr (e);
5854 }
5855
5856
5857
5858 /* Resolve a typebound function, or 'method'. First separate all
5859    the non-CLASS references by calling resolve_compcall directly.  */
5860
5861 static gfc_try
5862 resolve_typebound_function (gfc_expr* e)
5863 {
5864   gfc_symbol *declared;
5865   gfc_component *c;
5866   gfc_ref *new_ref;
5867   gfc_ref *class_ref;
5868   gfc_symtree *st;
5869   const char *name;
5870   gfc_typespec ts;
5871   gfc_expr *expr;
5872
5873   st = e->symtree;
5874
5875   /* Deal with typebound operators for CLASS objects.  */
5876   expr = e->value.compcall.base_object;
5877   if (expr && expr->ts.type == BT_CLASS && e->value.compcall.name)
5878     {
5879       /* Since the typebound operators are generic, we have to ensure
5880          that any delays in resolution are corrected and that the vtab
5881          is present.  */
5882       ts = expr->ts;
5883       declared = ts.u.derived;
5884       c = gfc_find_component (declared, "_vptr", true, true);
5885       if (c->ts.u.derived == NULL)
5886         c->ts.u.derived = gfc_find_derived_vtab (declared);
5887
5888       if (resolve_compcall (e, &name) == FAILURE)
5889         return FAILURE;
5890
5891       /* Use the generic name if it is there.  */
5892       name = name ? name : e->value.function.esym->name;
5893       e->symtree = expr->symtree;
5894       e->ref = gfc_copy_ref (expr->ref);
5895       gfc_add_vptr_component (e);
5896       gfc_add_component_ref (e, name);
5897       e->value.function.esym = NULL;
5898       return SUCCESS;
5899     }
5900
5901   if (st == NULL)
5902     return resolve_compcall (e, NULL);
5903
5904   if (resolve_ref (e) == FAILURE)
5905     return FAILURE;
5906
5907   /* Get the CLASS declared type.  */
5908   declared = get_declared_from_expr (&class_ref, &new_ref, e);
5909
5910   /* Weed out cases of the ultimate component being a derived type.  */
5911   if ((class_ref && class_ref->u.c.component->ts.type == BT_DERIVED)
5912          || (!class_ref && st->n.sym->ts.type != BT_CLASS))
5913     {
5914       gfc_free_ref_list (new_ref);
5915       return resolve_compcall (e, NULL);
5916     }
5917
5918   c = gfc_find_component (declared, "_data", true, true);
5919   declared = c->ts.u.derived;
5920
5921   /* Treat the call as if it is a typebound procedure, in order to roll
5922      out the correct name for the specific function.  */
5923   if (resolve_compcall (e, &name) == FAILURE)
5924     return FAILURE;
5925   ts = e->ts;
5926
5927   /* Then convert the expression to a procedure pointer component call.  */
5928   e->value.function.esym = NULL;
5929   e->symtree = st;
5930
5931   if (new_ref)
5932     e->ref = new_ref;
5933
5934   /* '_vptr' points to the vtab, which contains the procedure pointers.  */
5935   gfc_add_vptr_component (e);
5936   gfc_add_component_ref (e, name);
5937
5938   /* Recover the typespec for the expression.  This is really only
5939      necessary for generic procedures, where the additional call
5940      to gfc_add_component_ref seems to throw the collection of the
5941      correct typespec.  */
5942   e->ts = ts;
5943   return SUCCESS;
5944 }
5945
5946 /* Resolve a typebound subroutine, or 'method'. First separate all
5947    the non-CLASS references by calling resolve_typebound_call
5948    directly.  */
5949
5950 static gfc_try
5951 resolve_typebound_subroutine (gfc_code *code)
5952 {
5953   gfc_symbol *declared;
5954   gfc_component *c;
5955   gfc_ref *new_ref;
5956   gfc_ref *class_ref;
5957   gfc_symtree *st;
5958   const char *name;
5959   gfc_typespec ts;
5960   gfc_expr *expr;
5961
5962   st = code->expr1->symtree;
5963
5964   /* Deal with typebound operators for CLASS objects.  */
5965   expr = code->expr1->value.compcall.base_object;
5966   if (expr && expr->ts.type == BT_CLASS && code->expr1->value.compcall.name)
5967     {
5968       /* Since the typebound operators are generic, we have to ensure
5969          that any delays in resolution are corrected and that the vtab
5970          is present.  */
5971       declared = expr->ts.u.derived;
5972       c = gfc_find_component (declared, "_vptr", true, true);
5973       if (c->ts.u.derived == NULL)
5974         c->ts.u.derived = gfc_find_derived_vtab (declared);
5975
5976       if (resolve_typebound_call (code, &name) == FAILURE)
5977         return FAILURE;
5978
5979       /* Use the generic name if it is there.  */
5980       name = name ? name : code->expr1->value.function.esym->name;
5981       code->expr1->symtree = expr->symtree;
5982       code->expr1->ref = gfc_copy_ref (expr->ref);
5983       gfc_add_vptr_component (code->expr1);
5984       gfc_add_component_ref (code->expr1, name);
5985       code->expr1->value.function.esym = NULL;
5986       return SUCCESS;
5987     }
5988
5989   if (st == NULL)
5990     return resolve_typebound_call (code, NULL);
5991
5992   if (resolve_ref (code->expr1) == FAILURE)
5993     return FAILURE;
5994
5995   /* Get the CLASS declared type.  */
5996   get_declared_from_expr (&class_ref, &new_ref, code->expr1);
5997
5998   /* Weed out cases of the ultimate component being a derived type.  */
5999   if ((class_ref && class_ref->u.c.component->ts.type == BT_DERIVED)
6000          || (!class_ref && st->n.sym->ts.type != BT_CLASS))
6001     {
6002       gfc_free_ref_list (new_ref);
6003       return resolve_typebound_call (code, NULL);
6004     }
6005
6006   if (resolve_typebound_call (code, &name) == FAILURE)
6007     return FAILURE;
6008   ts = code->expr1->ts;
6009
6010   /* Then convert the expression to a procedure pointer component call.  */
6011   code->expr1->value.function.esym = NULL;
6012   code->expr1->symtree = st;
6013
6014   if (new_ref)
6015     code->expr1->ref = new_ref;
6016
6017   /* '_vptr' points to the vtab, which contains the procedure pointers.  */
6018   gfc_add_vptr_component (code->expr1);
6019   gfc_add_component_ref (code->expr1, name);
6020
6021   /* Recover the typespec for the expression.  This is really only
6022      necessary for generic procedures, where the additional call
6023      to gfc_add_component_ref seems to throw the collection of the
6024      correct typespec.  */
6025   code->expr1->ts = ts;
6026   return SUCCESS;
6027 }
6028
6029
6030 /* Resolve a CALL to a Procedure Pointer Component (Subroutine).  */
6031
6032 static gfc_try
6033 resolve_ppc_call (gfc_code* c)
6034 {
6035   gfc_component *comp;
6036   bool b;
6037
6038   b = gfc_is_proc_ptr_comp (c->expr1, &comp);
6039   gcc_assert (b);
6040
6041   c->resolved_sym = c->expr1->symtree->n.sym;
6042   c->expr1->expr_type = EXPR_VARIABLE;
6043
6044   if (!comp->attr.subroutine)
6045     gfc_add_subroutine (&comp->attr, comp->name, &c->expr1->where);
6046
6047   if (resolve_ref (c->expr1) == FAILURE)
6048     return FAILURE;
6049
6050   if (update_ppc_arglist (c->expr1) == FAILURE)
6051     return FAILURE;
6052
6053   c->ext.actual = c->expr1->value.compcall.actual;
6054
6055   if (resolve_actual_arglist (c->ext.actual, comp->attr.proc,
6056                               comp->formal == NULL) == FAILURE)
6057     return FAILURE;
6058
6059   gfc_ppc_use (comp, &c->expr1->value.compcall.actual, &c->expr1->where);
6060
6061   return SUCCESS;
6062 }
6063
6064
6065 /* Resolve a Function Call to a Procedure Pointer Component (Function).  */
6066
6067 static gfc_try
6068 resolve_expr_ppc (gfc_expr* e)
6069 {
6070   gfc_component *comp;
6071   bool b;
6072
6073   b = gfc_is_proc_ptr_comp (e, &comp);
6074   gcc_assert (b);
6075
6076   /* Convert to EXPR_FUNCTION.  */
6077   e->expr_type = EXPR_FUNCTION;
6078   e->value.function.isym = NULL;
6079   e->value.function.actual = e->value.compcall.actual;
6080   e->ts = comp->ts;
6081   if (comp->as != NULL)
6082     e->rank = comp->as->rank;
6083
6084   if (!comp->attr.function)
6085     gfc_add_function (&comp->attr, comp->name, &e->where);
6086
6087   if (resolve_ref (e) == FAILURE)
6088     return FAILURE;
6089
6090   if (resolve_actual_arglist (e->value.function.actual, comp->attr.proc,
6091                               comp->formal == NULL) == FAILURE)
6092     return FAILURE;
6093
6094   if (update_ppc_arglist (e) == FAILURE)
6095     return FAILURE;
6096
6097   gfc_ppc_use (comp, &e->value.compcall.actual, &e->where);
6098
6099   return SUCCESS;
6100 }
6101
6102
6103 static bool
6104 gfc_is_expandable_expr (gfc_expr *e)
6105 {
6106   gfc_constructor *con;
6107
6108   if (e->expr_type == EXPR_ARRAY)
6109     {
6110       /* Traverse the constructor looking for variables that are flavor
6111          parameter.  Parameters must be expanded since they are fully used at
6112          compile time.  */
6113       con = gfc_constructor_first (e->value.constructor);
6114       for (; con; con = gfc_constructor_next (con))
6115         {
6116           if (con->expr->expr_type == EXPR_VARIABLE
6117               && con->expr->symtree
6118               && (con->expr->symtree->n.sym->attr.flavor == FL_PARAMETER
6119               || con->expr->symtree->n.sym->attr.flavor == FL_VARIABLE))
6120             return true;
6121           if (con->expr->expr_type == EXPR_ARRAY
6122               && gfc_is_expandable_expr (con->expr))
6123             return true;
6124         }
6125     }
6126
6127   return false;
6128 }
6129
6130 /* Resolve an expression.  That is, make sure that types of operands agree
6131    with their operators, intrinsic operators are converted to function calls
6132    for overloaded types and unresolved function references are resolved.  */
6133
6134 gfc_try
6135 gfc_resolve_expr (gfc_expr *e)
6136 {
6137   gfc_try t;
6138   bool inquiry_save;
6139
6140   if (e == NULL)
6141     return SUCCESS;
6142
6143   /* inquiry_argument only applies to variables.  */
6144   inquiry_save = inquiry_argument;
6145   if (e->expr_type != EXPR_VARIABLE)
6146     inquiry_argument = false;
6147
6148   switch (e->expr_type)
6149     {
6150     case EXPR_OP:
6151       t = resolve_operator (e);
6152       break;
6153
6154     case EXPR_FUNCTION:
6155     case EXPR_VARIABLE:
6156
6157       if (check_host_association (e))
6158         t = resolve_function (e);
6159       else
6160         {
6161           t = resolve_variable (e);
6162           if (t == SUCCESS)
6163             expression_rank (e);
6164         }
6165
6166       if (e->ts.type == BT_CHARACTER && e->ts.u.cl == NULL && e->ref
6167           && e->ref->type != REF_SUBSTRING)
6168         gfc_resolve_substring_charlen (e);
6169
6170       break;
6171
6172     case EXPR_COMPCALL:
6173       t = resolve_typebound_function (e);
6174       break;
6175
6176     case EXPR_SUBSTRING:
6177       t = resolve_ref (e);
6178       break;
6179
6180     case EXPR_CONSTANT:
6181     case EXPR_NULL:
6182       t = SUCCESS;
6183       break;
6184
6185     case EXPR_PPC:
6186       t = resolve_expr_ppc (e);
6187       break;
6188
6189     case EXPR_ARRAY:
6190       t = FAILURE;
6191       if (resolve_ref (e) == FAILURE)
6192         break;
6193
6194       t = gfc_resolve_array_constructor (e);
6195       /* Also try to expand a constructor.  */
6196       if (t == SUCCESS)
6197         {
6198           expression_rank (e);
6199           if (gfc_is_constant_expr (e) || gfc_is_expandable_expr (e))
6200             gfc_expand_constructor (e, false);
6201         }
6202
6203       /* This provides the opportunity for the length of constructors with
6204          character valued function elements to propagate the string length
6205          to the expression.  */
6206       if (t == SUCCESS && e->ts.type == BT_CHARACTER)
6207         {
6208           /* For efficiency, we call gfc_expand_constructor for BT_CHARACTER
6209              here rather then add a duplicate test for it above.  */
6210           gfc_expand_constructor (e, false);
6211           t = gfc_resolve_character_array_constructor (e);
6212         }
6213
6214       break;
6215
6216     case EXPR_STRUCTURE:
6217       t = resolve_ref (e);
6218       if (t == FAILURE)
6219         break;
6220
6221       t = resolve_structure_cons (e, 0);
6222       if (t == FAILURE)
6223         break;
6224
6225       t = gfc_simplify_expr (e, 0);
6226       break;
6227
6228     default:
6229       gfc_internal_error ("gfc_resolve_expr(): Bad expression type");
6230     }
6231
6232   if (e->ts.type == BT_CHARACTER && t == SUCCESS && !e->ts.u.cl)
6233     fixup_charlen (e);
6234
6235   inquiry_argument = inquiry_save;
6236
6237   return t;
6238 }
6239
6240
6241 /* Resolve an expression from an iterator.  They must be scalar and have
6242    INTEGER or (optionally) REAL type.  */
6243
6244 static gfc_try
6245 gfc_resolve_iterator_expr (gfc_expr *expr, bool real_ok,
6246                            const char *name_msgid)
6247 {
6248   if (gfc_resolve_expr (expr) == FAILURE)
6249     return FAILURE;
6250
6251   if (expr->rank != 0)
6252     {
6253       gfc_error ("%s at %L must be a scalar", _(name_msgid), &expr->where);
6254       return FAILURE;
6255     }
6256
6257   if (expr->ts.type != BT_INTEGER)
6258     {
6259       if (expr->ts.type == BT_REAL)
6260         {
6261           if (real_ok)
6262             return gfc_notify_std (GFC_STD_F95_DEL,
6263                                    "Deleted feature: %s at %L must be integer",
6264                                    _(name_msgid), &expr->where);
6265           else
6266             {
6267               gfc_error ("%s at %L must be INTEGER", _(name_msgid),
6268                          &expr->where);
6269               return FAILURE;
6270             }
6271         }
6272       else
6273         {
6274           gfc_error ("%s at %L must be INTEGER", _(name_msgid), &expr->where);
6275           return FAILURE;
6276         }
6277     }
6278   return SUCCESS;
6279 }
6280
6281
6282 /* Resolve the expressions in an iterator structure.  If REAL_OK is
6283    false allow only INTEGER type iterators, otherwise allow REAL types.  */
6284
6285 gfc_try
6286 gfc_resolve_iterator (gfc_iterator *iter, bool real_ok)
6287 {
6288   if (gfc_resolve_iterator_expr (iter->var, real_ok, "Loop variable")
6289       == FAILURE)
6290     return FAILURE;
6291
6292   if (gfc_check_vardef_context (iter->var, false, false, _("iterator variable"))
6293       == FAILURE)
6294     return FAILURE;
6295
6296   if (gfc_resolve_iterator_expr (iter->start, real_ok,
6297                                  "Start expression in DO loop") == FAILURE)
6298     return FAILURE;
6299
6300   if (gfc_resolve_iterator_expr (iter->end, real_ok,
6301                                  "End expression in DO loop") == FAILURE)
6302     return FAILURE;
6303
6304   if (gfc_resolve_iterator_expr (iter->step, real_ok,
6305                                  "Step expression in DO loop") == FAILURE)
6306     return FAILURE;
6307
6308   if (iter->step->expr_type == EXPR_CONSTANT)
6309     {
6310       if ((iter->step->ts.type == BT_INTEGER
6311            && mpz_cmp_ui (iter->step->value.integer, 0) == 0)
6312           || (iter->step->ts.type == BT_REAL
6313               && mpfr_sgn (iter->step->value.real) == 0))
6314         {
6315           gfc_error ("Step expression in DO loop at %L cannot be zero",
6316                      &iter->step->where);
6317           return FAILURE;
6318         }
6319     }
6320
6321   /* Convert start, end, and step to the same type as var.  */
6322   if (iter->start->ts.kind != iter->var->ts.kind
6323       || iter->start->ts.type != iter->var->ts.type)
6324     gfc_convert_type (iter->start, &iter->var->ts, 2);
6325
6326   if (iter->end->ts.kind != iter->var->ts.kind
6327       || iter->end->ts.type != iter->var->ts.type)
6328     gfc_convert_type (iter->end, &iter->var->ts, 2);
6329
6330   if (iter->step->ts.kind != iter->var->ts.kind
6331       || iter->step->ts.type != iter->var->ts.type)
6332     gfc_convert_type (iter->step, &iter->var->ts, 2);
6333
6334   if (iter->start->expr_type == EXPR_CONSTANT
6335       && iter->end->expr_type == EXPR_CONSTANT
6336       && iter->step->expr_type == EXPR_CONSTANT)
6337     {
6338       int sgn, cmp;
6339       if (iter->start->ts.type == BT_INTEGER)
6340         {
6341           sgn = mpz_cmp_ui (iter->step->value.integer, 0);
6342           cmp = mpz_cmp (iter->end->value.integer, iter->start->value.integer);
6343         }
6344       else
6345         {
6346           sgn = mpfr_sgn (iter->step->value.real);
6347           cmp = mpfr_cmp (iter->end->value.real, iter->start->value.real);
6348         }
6349       if ((sgn > 0 && cmp < 0) || (sgn < 0 && cmp > 0))
6350         gfc_warning ("DO loop at %L will be executed zero times",
6351                      &iter->step->where);
6352     }
6353
6354   return SUCCESS;
6355 }
6356
6357
6358 /* Traversal function for find_forall_index.  f == 2 signals that
6359    that variable itself is not to be checked - only the references.  */
6360
6361 static bool
6362 forall_index (gfc_expr *expr, gfc_symbol *sym, int *f)
6363 {
6364   if (expr->expr_type != EXPR_VARIABLE)
6365     return false;
6366
6367   /* A scalar assignment  */
6368   if (!expr->ref || *f == 1)
6369     {
6370       if (expr->symtree->n.sym == sym)
6371         return true;
6372       else
6373         return false;
6374     }
6375
6376   if (*f == 2)
6377     *f = 1;
6378   return false;
6379 }
6380
6381
6382 /* Check whether the FORALL index appears in the expression or not.
6383    Returns SUCCESS if SYM is found in EXPR.  */
6384
6385 gfc_try
6386 find_forall_index (gfc_expr *expr, gfc_symbol *sym, int f)
6387 {
6388   if (gfc_traverse_expr (expr, sym, forall_index, f))
6389     return SUCCESS;
6390   else
6391     return FAILURE;
6392 }
6393
6394
6395 /* Resolve a list of FORALL iterators.  The FORALL index-name is constrained
6396    to be a scalar INTEGER variable.  The subscripts and stride are scalar
6397    INTEGERs, and if stride is a constant it must be nonzero.
6398    Furthermore "A subscript or stride in a forall-triplet-spec shall
6399    not contain a reference to any index-name in the
6400    forall-triplet-spec-list in which it appears." (7.5.4.1)  */
6401
6402 static void
6403 resolve_forall_iterators (gfc_forall_iterator *it)
6404 {
6405   gfc_forall_iterator *iter, *iter2;
6406
6407   for (iter = it; iter; iter = iter->next)
6408     {
6409       if (gfc_resolve_expr (iter->var) == SUCCESS
6410           && (iter->var->ts.type != BT_INTEGER || iter->var->rank != 0))
6411         gfc_error ("FORALL index-name at %L must be a scalar INTEGER",
6412                    &iter->var->where);
6413
6414       if (gfc_resolve_expr (iter->start) == SUCCESS
6415           && (iter->start->ts.type != BT_INTEGER || iter->start->rank != 0))
6416         gfc_error ("FORALL start expression at %L must be a scalar INTEGER",
6417                    &iter->start->where);
6418       if (iter->var->ts.kind != iter->start->ts.kind)
6419         gfc_convert_type (iter->start, &iter->var->ts, 2);
6420
6421       if (gfc_resolve_expr (iter->end) == SUCCESS
6422           && (iter->end->ts.type != BT_INTEGER || iter->end->rank != 0))
6423         gfc_error ("FORALL end expression at %L must be a scalar INTEGER",
6424                    &iter->end->where);
6425       if (iter->var->ts.kind != iter->end->ts.kind)
6426         gfc_convert_type (iter->end, &iter->var->ts, 2);
6427
6428       if (gfc_resolve_expr (iter->stride) == SUCCESS)
6429         {
6430           if (iter->stride->ts.type != BT_INTEGER || iter->stride->rank != 0)
6431             gfc_error ("FORALL stride expression at %L must be a scalar %s",
6432                        &iter->stride->where, "INTEGER");
6433
6434           if (iter->stride->expr_type == EXPR_CONSTANT
6435               && mpz_cmp_ui(iter->stride->value.integer, 0) == 0)
6436             gfc_error ("FORALL stride expression at %L cannot be zero",
6437                        &iter->stride->where);
6438         }
6439       if (iter->var->ts.kind != iter->stride->ts.kind)
6440         gfc_convert_type (iter->stride, &iter->var->ts, 2);
6441     }
6442
6443   for (iter = it; iter; iter = iter->next)
6444     for (iter2 = iter; iter2; iter2 = iter2->next)
6445       {
6446         if (find_forall_index (iter2->start,
6447                                iter->var->symtree->n.sym, 0) == SUCCESS
6448             || find_forall_index (iter2->end,
6449                                   iter->var->symtree->n.sym, 0) == SUCCESS
6450             || find_forall_index (iter2->stride,
6451                                   iter->var->symtree->n.sym, 0) == SUCCESS)
6452           gfc_error ("FORALL index '%s' may not appear in triplet "
6453                      "specification at %L", iter->var->symtree->name,
6454                      &iter2->start->where);
6455       }
6456 }
6457
6458
6459 /* Given a pointer to a symbol that is a derived type, see if it's
6460    inaccessible, i.e. if it's defined in another module and the components are
6461    PRIVATE.  The search is recursive if necessary.  Returns zero if no
6462    inaccessible components are found, nonzero otherwise.  */
6463
6464 static int
6465 derived_inaccessible (gfc_symbol *sym)
6466 {
6467   gfc_component *c;
6468
6469   if (sym->attr.use_assoc && sym->attr.private_comp)
6470     return 1;
6471
6472   for (c = sym->components; c; c = c->next)
6473     {
6474         if (c->ts.type == BT_DERIVED && derived_inaccessible (c->ts.u.derived))
6475           return 1;
6476     }
6477
6478   return 0;
6479 }
6480
6481
6482 /* Resolve the argument of a deallocate expression.  The expression must be
6483    a pointer or a full array.  */
6484
6485 static gfc_try
6486 resolve_deallocate_expr (gfc_expr *e)
6487 {
6488   symbol_attribute attr;
6489   int allocatable, pointer;
6490   gfc_ref *ref;
6491   gfc_symbol *sym;
6492   gfc_component *c;
6493
6494   if (gfc_resolve_expr (e) == FAILURE)
6495     return FAILURE;
6496
6497   if (e->expr_type != EXPR_VARIABLE)
6498     goto bad;
6499
6500   sym = e->symtree->n.sym;
6501
6502   if (sym->ts.type == BT_CLASS)
6503     {
6504       allocatable = CLASS_DATA (sym)->attr.allocatable;
6505       pointer = CLASS_DATA (sym)->attr.class_pointer;
6506     }
6507   else
6508     {
6509       allocatable = sym->attr.allocatable;
6510       pointer = sym->attr.pointer;
6511     }
6512   for (ref = e->ref; ref; ref = ref->next)
6513     {
6514       switch (ref->type)
6515         {
6516         case REF_ARRAY:
6517           if (ref->u.ar.type != AR_FULL
6518               && !(ref->u.ar.type == AR_ELEMENT && ref->u.ar.as->rank == 0
6519                    && ref->u.ar.codimen && gfc_ref_this_image (ref)))
6520             allocatable = 0;
6521           break;
6522
6523         case REF_COMPONENT:
6524           c = ref->u.c.component;
6525           if (c->ts.type == BT_CLASS)
6526             {
6527               allocatable = CLASS_DATA (c)->attr.allocatable;
6528               pointer = CLASS_DATA (c)->attr.class_pointer;
6529             }
6530           else
6531             {
6532               allocatable = c->attr.allocatable;
6533               pointer = c->attr.pointer;
6534             }
6535           break;
6536
6537         case REF_SUBSTRING:
6538           allocatable = 0;
6539           break;
6540         }
6541     }
6542
6543   attr = gfc_expr_attr (e);
6544
6545   if (allocatable == 0 && attr.pointer == 0)
6546     {
6547     bad:
6548       gfc_error ("Allocate-object at %L must be ALLOCATABLE or a POINTER",
6549                  &e->where);
6550       return FAILURE;
6551     }
6552
6553   /* F2008, C644.  */
6554   if (gfc_is_coindexed (e))
6555     {
6556       gfc_error ("Coindexed allocatable object at %L", &e->where);
6557       return FAILURE;
6558     }
6559
6560   if (pointer
6561       && gfc_check_vardef_context (e, true, true, _("DEALLOCATE object"))
6562          == FAILURE)
6563     return FAILURE;
6564   if (gfc_check_vardef_context (e, false, true, _("DEALLOCATE object"))
6565       == FAILURE)
6566     return FAILURE;
6567
6568   return SUCCESS;
6569 }
6570
6571
6572 /* Returns true if the expression e contains a reference to the symbol sym.  */
6573 static bool
6574 sym_in_expr (gfc_expr *e, gfc_symbol *sym, int *f ATTRIBUTE_UNUSED)
6575 {
6576   if (e->expr_type == EXPR_VARIABLE && e->symtree->n.sym == sym)
6577     return true;
6578
6579   return false;
6580 }
6581
6582 bool
6583 gfc_find_sym_in_expr (gfc_symbol *sym, gfc_expr *e)
6584 {
6585   return gfc_traverse_expr (e, sym, sym_in_expr, 0);
6586 }
6587
6588
6589 /* Given the expression node e for an allocatable/pointer of derived type to be
6590    allocated, get the expression node to be initialized afterwards (needed for
6591    derived types with default initializers, and derived types with allocatable
6592    components that need nullification.)  */
6593
6594 gfc_expr *
6595 gfc_expr_to_initialize (gfc_expr *e)
6596 {
6597   gfc_expr *result;
6598   gfc_ref *ref;
6599   int i;
6600
6601   result = gfc_copy_expr (e);
6602
6603   /* Change the last array reference from AR_ELEMENT to AR_FULL.  */
6604   for (ref = result->ref; ref; ref = ref->next)
6605     if (ref->type == REF_ARRAY && ref->next == NULL)
6606       {
6607         ref->u.ar.type = AR_FULL;
6608
6609         for (i = 0; i < ref->u.ar.dimen; i++)
6610           ref->u.ar.start[i] = ref->u.ar.end[i] = ref->u.ar.stride[i] = NULL;
6611
6612         break;
6613       }
6614
6615   gfc_free_shape (&result->shape, result->rank);
6616
6617   /* Recalculate rank, shape, etc.  */
6618   gfc_resolve_expr (result);
6619   return result;
6620 }
6621
6622
6623 /* If the last ref of an expression is an array ref, return a copy of the
6624    expression with that one removed.  Otherwise, a copy of the original
6625    expression.  This is used for allocate-expressions and pointer assignment
6626    LHS, where there may be an array specification that needs to be stripped
6627    off when using gfc_check_vardef_context.  */
6628
6629 static gfc_expr*
6630 remove_last_array_ref (gfc_expr* e)
6631 {
6632   gfc_expr* e2;
6633   gfc_ref** r;
6634
6635   e2 = gfc_copy_expr (e);
6636   for (r = &e2->ref; *r; r = &(*r)->next)
6637     if ((*r)->type == REF_ARRAY && !(*r)->next)
6638       {
6639         gfc_free_ref_list (*r);
6640         *r = NULL;
6641         break;
6642       }
6643
6644   return e2;
6645 }
6646
6647
6648 /* Used in resolve_allocate_expr to check that a allocation-object and
6649    a source-expr are conformable.  This does not catch all possible
6650    cases; in particular a runtime checking is needed.  */
6651
6652 static gfc_try
6653 conformable_arrays (gfc_expr *e1, gfc_expr *e2)
6654 {
6655   gfc_ref *tail;
6656   for (tail = e2->ref; tail && tail->next; tail = tail->next);
6657
6658   /* First compare rank.  */
6659   if (tail && e1->rank != tail->u.ar.as->rank)
6660     {
6661       gfc_error ("Source-expr at %L must be scalar or have the "
6662                  "same rank as the allocate-object at %L",
6663                  &e1->where, &e2->where);
6664       return FAILURE;
6665     }
6666
6667   if (e1->shape)
6668     {
6669       int i;
6670       mpz_t s;
6671
6672       mpz_init (s);
6673
6674       for (i = 0; i < e1->rank; i++)
6675         {
6676           if (tail->u.ar.end[i])
6677             {
6678               mpz_set (s, tail->u.ar.end[i]->value.integer);
6679               mpz_sub (s, s, tail->u.ar.start[i]->value.integer);
6680               mpz_add_ui (s, s, 1);
6681             }
6682           else
6683             {
6684               mpz_set (s, tail->u.ar.start[i]->value.integer);
6685             }
6686
6687           if (mpz_cmp (e1->shape[i], s) != 0)
6688             {
6689               gfc_error ("Source-expr at %L and allocate-object at %L must "
6690                          "have the same shape", &e1->where, &e2->where);
6691               mpz_clear (s);
6692               return FAILURE;
6693             }
6694         }
6695
6696       mpz_clear (s);
6697     }
6698
6699   return SUCCESS;
6700 }
6701
6702
6703 /* Resolve the expression in an ALLOCATE statement, doing the additional
6704    checks to see whether the expression is OK or not.  The expression must
6705    have a trailing array reference that gives the size of the array.  */
6706
6707 static gfc_try
6708 resolve_allocate_expr (gfc_expr *e, gfc_code *code)
6709 {
6710   int i, pointer, allocatable, dimension, is_abstract;
6711   int codimension;
6712   bool coindexed;
6713   symbol_attribute attr;
6714   gfc_ref *ref, *ref2;
6715   gfc_expr *e2;
6716   gfc_array_ref *ar;
6717   gfc_symbol *sym = NULL;
6718   gfc_alloc *a;
6719   gfc_component *c;
6720   gfc_try t;
6721
6722   /* Mark the ultimost array component as being in allocate to allow DIMEN_STAR
6723      checking of coarrays.  */
6724   for (ref = e->ref; ref; ref = ref->next)
6725     if (ref->next == NULL)
6726       break;
6727
6728   if (ref && ref->type == REF_ARRAY)
6729     ref->u.ar.in_allocate = true;
6730
6731   if (gfc_resolve_expr (e) == FAILURE)
6732     goto failure;
6733
6734   /* Make sure the expression is allocatable or a pointer.  If it is
6735      pointer, the next-to-last reference must be a pointer.  */
6736
6737   ref2 = NULL;
6738   if (e->symtree)
6739     sym = e->symtree->n.sym;
6740
6741   /* Check whether ultimate component is abstract and CLASS.  */
6742   is_abstract = 0;
6743
6744   if (e->expr_type != EXPR_VARIABLE)
6745     {
6746       allocatable = 0;
6747       attr = gfc_expr_attr (e);
6748       pointer = attr.pointer;
6749       dimension = attr.dimension;
6750       codimension = attr.codimension;
6751     }
6752   else
6753     {
6754       if (sym->ts.type == BT_CLASS)
6755         {
6756           allocatable = CLASS_DATA (sym)->attr.allocatable;
6757           pointer = CLASS_DATA (sym)->attr.class_pointer;
6758           dimension = CLASS_DATA (sym)->attr.dimension;
6759           codimension = CLASS_DATA (sym)->attr.codimension;
6760           is_abstract = CLASS_DATA (sym)->attr.abstract;
6761         }
6762       else
6763         {
6764           allocatable = sym->attr.allocatable;
6765           pointer = sym->attr.pointer;
6766           dimension = sym->attr.dimension;
6767           codimension = sym->attr.codimension;
6768         }
6769
6770       coindexed = false;
6771
6772       for (ref = e->ref; ref; ref2 = ref, ref = ref->next)
6773         {
6774           switch (ref->type)
6775             {
6776               case REF_ARRAY:
6777                 if (ref->u.ar.codimen > 0)
6778                   {
6779                     int n;
6780                     for (n = ref->u.ar.dimen;
6781                          n < ref->u.ar.dimen + ref->u.ar.codimen; n++)
6782                       if (ref->u.ar.dimen_type[n] != DIMEN_THIS_IMAGE)
6783                         {
6784                           coindexed = true;
6785                           break;
6786                         }
6787                    }
6788
6789                 if (ref->next != NULL)
6790                   pointer = 0;
6791                 break;
6792
6793               case REF_COMPONENT:
6794                 /* F2008, C644.  */
6795                 if (coindexed)
6796                   {
6797                     gfc_error ("Coindexed allocatable object at %L",
6798                                &e->where);
6799                     goto failure;
6800                   }
6801
6802                 c = ref->u.c.component;
6803                 if (c->ts.type == BT_CLASS)
6804                   {
6805                     allocatable = CLASS_DATA (c)->attr.allocatable;
6806                     pointer = CLASS_DATA (c)->attr.class_pointer;
6807                     dimension = CLASS_DATA (c)->attr.dimension;
6808                     codimension = CLASS_DATA (c)->attr.codimension;
6809                     is_abstract = CLASS_DATA (c)->attr.abstract;
6810                   }
6811                 else
6812                   {
6813                     allocatable = c->attr.allocatable;
6814                     pointer = c->attr.pointer;
6815                     dimension = c->attr.dimension;
6816                     codimension = c->attr.codimension;
6817                     is_abstract = c->attr.abstract;
6818                   }
6819                 break;
6820
6821               case REF_SUBSTRING:
6822                 allocatable = 0;
6823                 pointer = 0;
6824                 break;
6825             }
6826         }
6827     }
6828
6829   if (allocatable == 0 && pointer == 0)
6830     {
6831       gfc_error ("Allocate-object at %L must be ALLOCATABLE or a POINTER",
6832                  &e->where);
6833       goto failure;
6834     }
6835
6836   /* Some checks for the SOURCE tag.  */
6837   if (code->expr3)
6838     {
6839       /* Check F03:C631.  */
6840       if (!gfc_type_compatible (&e->ts, &code->expr3->ts))
6841         {
6842           gfc_error ("Type of entity at %L is type incompatible with "
6843                       "source-expr at %L", &e->where, &code->expr3->where);
6844           goto failure;
6845         }
6846
6847       /* Check F03:C632 and restriction following Note 6.18.  */
6848       if (code->expr3->rank > 0
6849           && conformable_arrays (code->expr3, e) == FAILURE)
6850         goto failure;
6851
6852       /* Check F03:C633.  */
6853       if (code->expr3->ts.kind != e->ts.kind)
6854         {
6855           gfc_error ("The allocate-object at %L and the source-expr at %L "
6856                       "shall have the same kind type parameter",
6857                       &e->where, &code->expr3->where);
6858           goto failure;
6859         }
6860
6861       /* Check F2008, C642.  */
6862       if (code->expr3->ts.type == BT_DERIVED
6863           && ((codimension && gfc_expr_attr (code->expr3).lock_comp)
6864               || (code->expr3->ts.u.derived->from_intmod
6865                      == INTMOD_ISO_FORTRAN_ENV
6866                   && code->expr3->ts.u.derived->intmod_sym_id
6867                      == ISOFORTRAN_LOCK_TYPE)))
6868         {
6869           gfc_error ("The source-expr at %L shall neither be of type "
6870                      "LOCK_TYPE nor have a LOCK_TYPE component if "
6871                       "allocate-object at %L is a coarray",
6872                       &code->expr3->where, &e->where);
6873           goto failure;
6874         }
6875     }
6876
6877   /* Check F08:C629.  */
6878   if (is_abstract && code->ext.alloc.ts.type == BT_UNKNOWN
6879       && !code->expr3)
6880     {
6881       gcc_assert (e->ts.type == BT_CLASS);
6882       gfc_error ("Allocating %s of ABSTRACT base type at %L requires a "
6883                  "type-spec or source-expr", sym->name, &e->where);
6884       goto failure;
6885     }
6886
6887   /* In the variable definition context checks, gfc_expr_attr is used
6888      on the expression.  This is fooled by the array specification
6889      present in e, thus we have to eliminate that one temporarily.  */
6890   e2 = remove_last_array_ref (e);
6891   t = SUCCESS;
6892   if (t == SUCCESS && pointer)
6893     t = gfc_check_vardef_context (e2, true, true, _("ALLOCATE object"));
6894   if (t == SUCCESS)
6895     t = gfc_check_vardef_context (e2, false, true, _("ALLOCATE object"));
6896   gfc_free_expr (e2);
6897   if (t == FAILURE)
6898     goto failure;
6899
6900   if (!code->expr3)
6901     {
6902       /* Set up default initializer if needed.  */
6903       gfc_typespec ts;
6904       gfc_expr *init_e;
6905
6906       if (code->ext.alloc.ts.type == BT_DERIVED)
6907         ts = code->ext.alloc.ts;
6908       else
6909         ts = e->ts;
6910
6911       if (ts.type == BT_CLASS)
6912         ts = ts.u.derived->components->ts;
6913
6914       if (ts.type == BT_DERIVED && (init_e = gfc_default_initializer (&ts)))
6915         {
6916           gfc_code *init_st = gfc_get_code ();
6917           init_st->loc = code->loc;
6918           init_st->op = EXEC_INIT_ASSIGN;
6919           init_st->expr1 = gfc_expr_to_initialize (e);
6920           init_st->expr2 = init_e;
6921           init_st->next = code->next;
6922           code->next = init_st;
6923         }
6924     }
6925   else if (code->expr3->mold && code->expr3->ts.type == BT_DERIVED)
6926     {
6927       /* Default initialization via MOLD (non-polymorphic).  */
6928       gfc_expr *rhs = gfc_default_initializer (&code->expr3->ts);
6929       gfc_resolve_expr (rhs);
6930       gfc_free_expr (code->expr3);
6931       code->expr3 = rhs;
6932     }
6933
6934   if (e->ts.type == BT_CLASS)
6935     {
6936       /* Make sure the vtab symbol is present when
6937          the module variables are generated.  */
6938       gfc_typespec ts = e->ts;
6939       if (code->expr3)
6940         ts = code->expr3->ts;
6941       else if (code->ext.alloc.ts.type == BT_DERIVED)
6942         ts = code->ext.alloc.ts;
6943       gfc_find_derived_vtab (ts.u.derived);
6944     }
6945
6946   if (dimension == 0 && codimension == 0)
6947     goto success;
6948
6949   /* Make sure the last reference node is an array specifiction.  */
6950
6951   if (!ref2 || ref2->type != REF_ARRAY || ref2->u.ar.type == AR_FULL
6952       || (dimension && ref2->u.ar.dimen == 0))
6953     {
6954       gfc_error ("Array specification required in ALLOCATE statement "
6955                  "at %L", &e->where);
6956       goto failure;
6957     }
6958
6959   /* Make sure that the array section reference makes sense in the
6960     context of an ALLOCATE specification.  */
6961
6962   ar = &ref2->u.ar;
6963
6964   if (codimension)
6965     for (i = ar->dimen; i < ar->dimen + ar->codimen; i++)
6966       if (ar->dimen_type[i] == DIMEN_THIS_IMAGE)
6967         {
6968           gfc_error ("Coarray specification required in ALLOCATE statement "
6969                      "at %L", &e->where);
6970           goto failure;
6971         }
6972
6973   for (i = 0; i < ar->dimen; i++)
6974     {
6975       if (ref2->u.ar.type == AR_ELEMENT)
6976         goto check_symbols;
6977
6978       switch (ar->dimen_type[i])
6979         {
6980         case DIMEN_ELEMENT:
6981           break;
6982
6983         case DIMEN_RANGE:
6984           if (ar->start[i] != NULL
6985               && ar->end[i] != NULL
6986               && ar->stride[i] == NULL)
6987             break;
6988
6989           /* Fall Through...  */
6990
6991         case DIMEN_UNKNOWN:
6992         case DIMEN_VECTOR:
6993         case DIMEN_STAR:
6994         case DIMEN_THIS_IMAGE:
6995           gfc_error ("Bad array specification in ALLOCATE statement at %L",
6996                      &e->where);
6997           goto failure;
6998         }
6999
7000 check_symbols:
7001       for (a = code->ext.alloc.list; a; a = a->next)
7002         {
7003           sym = a->expr->symtree->n.sym;
7004
7005           /* TODO - check derived type components.  */
7006           if (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS)
7007             continue;
7008
7009           if ((ar->start[i] != NULL
7010                && gfc_find_sym_in_expr (sym, ar->start[i]))
7011               || (ar->end[i] != NULL
7012                   && gfc_find_sym_in_expr (sym, ar->end[i])))
7013             {
7014               gfc_error ("'%s' must not appear in the array specification at "
7015                          "%L in the same ALLOCATE statement where it is "
7016                          "itself allocated", sym->name, &ar->where);
7017               goto failure;
7018             }
7019         }
7020     }
7021
7022   for (i = ar->dimen; i < ar->codimen + ar->dimen; i++)
7023     {
7024       if (ar->dimen_type[i] == DIMEN_ELEMENT
7025           || ar->dimen_type[i] == DIMEN_RANGE)
7026         {
7027           if (i == (ar->dimen + ar->codimen - 1))
7028             {
7029               gfc_error ("Expected '*' in coindex specification in ALLOCATE "
7030                          "statement at %L", &e->where);
7031               goto failure;
7032             }
7033           break;
7034         }
7035
7036       if (ar->dimen_type[i] == DIMEN_STAR && i == (ar->dimen + ar->codimen - 1)
7037           && ar->stride[i] == NULL)
7038         break;
7039
7040       gfc_error ("Bad coarray specification in ALLOCATE statement at %L",
7041                  &e->where);
7042       goto failure;
7043     }
7044
7045 success:
7046   return SUCCESS;
7047
7048 failure:
7049   return FAILURE;
7050 }
7051
7052 static void
7053 resolve_allocate_deallocate (gfc_code *code, const char *fcn)
7054 {
7055   gfc_expr *stat, *errmsg, *pe, *qe;
7056   gfc_alloc *a, *p, *q;
7057
7058   stat = code->expr1;
7059   errmsg = code->expr2;
7060
7061   /* Check the stat variable.  */
7062   if (stat)
7063     {
7064       gfc_check_vardef_context (stat, false, false, _("STAT variable"));
7065
7066       if ((stat->ts.type != BT_INTEGER
7067            && !(stat->ref && (stat->ref->type == REF_ARRAY
7068                               || stat->ref->type == REF_COMPONENT)))
7069           || stat->rank > 0)
7070         gfc_error ("Stat-variable at %L must be a scalar INTEGER "
7071                    "variable", &stat->where);
7072
7073       for (p = code->ext.alloc.list; p; p = p->next)
7074         if (p->expr->symtree->n.sym->name == stat->symtree->n.sym->name)
7075           {
7076             gfc_ref *ref1, *ref2;
7077             bool found = true;
7078
7079             for (ref1 = p->expr->ref, ref2 = stat->ref; ref1 && ref2;
7080                  ref1 = ref1->next, ref2 = ref2->next)
7081               {
7082                 if (ref1->type != REF_COMPONENT || ref2->type != REF_COMPONENT)
7083                   continue;
7084                 if (ref1->u.c.component->name != ref2->u.c.component->name)
7085                   {
7086                     found = false;
7087                     break;
7088                   }
7089               }
7090
7091             if (found)
7092               {
7093                 gfc_error ("Stat-variable at %L shall not be %sd within "
7094                            "the same %s statement", &stat->where, fcn, fcn);
7095                 break;
7096               }
7097           }
7098     }
7099
7100   /* Check the errmsg variable.  */
7101   if (errmsg)
7102     {
7103       if (!stat)
7104         gfc_warning ("ERRMSG at %L is useless without a STAT tag",
7105                      &errmsg->where);
7106
7107       gfc_check_vardef_context (errmsg, false, false, _("ERRMSG variable"));
7108
7109       if ((errmsg->ts.type != BT_CHARACTER
7110            && !(errmsg->ref
7111                 && (errmsg->ref->type == REF_ARRAY
7112                     || errmsg->ref->type == REF_COMPONENT)))
7113           || errmsg->rank > 0 )
7114         gfc_error ("Errmsg-variable at %L must be a scalar CHARACTER "
7115                    "variable", &errmsg->where);
7116
7117       for (p = code->ext.alloc.list; p; p = p->next)
7118         if (p->expr->symtree->n.sym->name == errmsg->symtree->n.sym->name)
7119           {
7120             gfc_ref *ref1, *ref2;
7121             bool found = true;
7122
7123             for (ref1 = p->expr->ref, ref2 = errmsg->ref; ref1 && ref2;
7124                  ref1 = ref1->next, ref2 = ref2->next)
7125               {
7126                 if (ref1->type != REF_COMPONENT || ref2->type != REF_COMPONENT)
7127                   continue;
7128                 if (ref1->u.c.component->name != ref2->u.c.component->name)
7129                   {
7130                     found = false;
7131                     break;
7132                   }
7133               }
7134
7135             if (found)
7136               {
7137                 gfc_error ("Errmsg-variable at %L shall not be %sd within "
7138                            "the same %s statement", &errmsg->where, fcn, fcn);
7139                 break;
7140               }
7141           }
7142     }
7143
7144   /* Check that an allocate-object appears only once in the statement.
7145      FIXME: Checking derived types is disabled.  */
7146   for (p = code->ext.alloc.list; p; p = p->next)
7147     {
7148       pe = p->expr;
7149       for (q = p->next; q; q = q->next)
7150         {
7151           qe = q->expr;
7152           if (pe->symtree->n.sym->name == qe->symtree->n.sym->name)
7153             {
7154               /* This is a potential collision.  */
7155               gfc_ref *pr = pe->ref;
7156               gfc_ref *qr = qe->ref;
7157
7158               /* Follow the references  until
7159                  a) They start to differ, in which case there is no error;
7160                  you can deallocate a%b and a%c in a single statement
7161                  b) Both of them stop, which is an error
7162                  c) One of them stops, which is also an error.  */
7163               while (1)
7164                 {
7165                   if (pr == NULL && qr == NULL)
7166                     {
7167                       gfc_error ("Allocate-object at %L also appears at %L",
7168                                  &pe->where, &qe->where);
7169                       break;
7170                     }
7171                   else if (pr != NULL && qr == NULL)
7172                     {
7173                       gfc_error ("Allocate-object at %L is subobject of"
7174                                  " object at %L", &pe->where, &qe->where);
7175                       break;
7176                     }
7177                   else if (pr == NULL && qr != NULL)
7178                     {
7179                       gfc_error ("Allocate-object at %L is subobject of"
7180                                  " object at %L", &qe->where, &pe->where);
7181                       break;
7182                     }
7183                   /* Here, pr != NULL && qr != NULL  */
7184                   gcc_assert(pr->type == qr->type);
7185                   if (pr->type == REF_ARRAY)
7186                     {
7187                       /* Handle cases like allocate(v(3)%x(3), v(2)%x(3)),
7188                          which are legal.  */
7189                       gcc_assert (qr->type == REF_ARRAY);
7190
7191                       if (pr->next && qr->next)
7192                         {
7193                           gfc_array_ref *par = &(pr->u.ar);
7194                           gfc_array_ref *qar = &(qr->u.ar);
7195                           if (gfc_dep_compare_expr (par->start[0],
7196                                                     qar->start[0]) != 0)
7197                               break;
7198                         }
7199                     }
7200                   else
7201                     {
7202                       if (pr->u.c.component->name != qr->u.c.component->name)
7203                         break;
7204                     }
7205
7206                   pr = pr->next;
7207                   qr = qr->next;
7208                 }
7209             }
7210         }
7211     }
7212
7213   if (strcmp (fcn, "ALLOCATE") == 0)
7214     {
7215       for (a = code->ext.alloc.list; a; a = a->next)
7216         resolve_allocate_expr (a->expr, code);
7217     }
7218   else
7219     {
7220       for (a = code->ext.alloc.list; a; a = a->next)
7221         resolve_deallocate_expr (a->expr);
7222     }
7223 }
7224
7225
7226 /************ SELECT CASE resolution subroutines ************/
7227
7228 /* Callback function for our mergesort variant.  Determines interval
7229    overlaps for CASEs. Return <0 if op1 < op2, 0 for overlap, >0 for
7230    op1 > op2.  Assumes we're not dealing with the default case.
7231    We have op1 = (:L), (K:L) or (K:) and op2 = (:N), (M:N) or (M:).
7232    There are nine situations to check.  */
7233
7234 static int
7235 compare_cases (const gfc_case *op1, const gfc_case *op2)
7236 {
7237   int retval;
7238
7239   if (op1->low == NULL) /* op1 = (:L)  */
7240     {
7241       /* op2 = (:N), so overlap.  */
7242       retval = 0;
7243       /* op2 = (M:) or (M:N),  L < M  */
7244       if (op2->low != NULL
7245           && gfc_compare_expr (op1->high, op2->low, INTRINSIC_LT) < 0)
7246         retval = -1;
7247     }
7248   else if (op1->high == NULL) /* op1 = (K:)  */
7249     {
7250       /* op2 = (M:), so overlap.  */
7251       retval = 0;
7252       /* op2 = (:N) or (M:N), K > N  */
7253       if (op2->high != NULL
7254           && gfc_compare_expr (op1->low, op2->high, INTRINSIC_GT) > 0)
7255         retval = 1;
7256     }
7257   else /* op1 = (K:L)  */
7258     {
7259       if (op2->low == NULL)       /* op2 = (:N), K > N  */
7260         retval = (gfc_compare_expr (op1->low, op2->high, INTRINSIC_GT) > 0)
7261                  ? 1 : 0;
7262       else if (op2->high == NULL) /* op2 = (M:), L < M  */
7263         retval = (gfc_compare_expr (op1->high, op2->low, INTRINSIC_LT) < 0)
7264                  ? -1 : 0;
7265       else                      /* op2 = (M:N)  */
7266         {
7267           retval =  0;
7268           /* L < M  */
7269           if (gfc_compare_expr (op1->high, op2->low, INTRINSIC_LT) < 0)
7270             retval =  -1;
7271           /* K > N  */
7272           else if (gfc_compare_expr (op1->low, op2->high, INTRINSIC_GT) > 0)
7273             retval =  1;
7274         }
7275     }
7276
7277   return retval;
7278 }
7279
7280
7281 /* Merge-sort a double linked case list, detecting overlap in the
7282    process.  LIST is the head of the double linked case list before it
7283    is sorted.  Returns the head of the sorted list if we don't see any
7284    overlap, or NULL otherwise.  */
7285
7286 static gfc_case *
7287 check_case_overlap (gfc_case *list)
7288 {
7289   gfc_case *p, *q, *e, *tail;
7290   int insize, nmerges, psize, qsize, cmp, overlap_seen;
7291
7292   /* If the passed list was empty, return immediately.  */
7293   if (!list)
7294     return NULL;
7295
7296   overlap_seen = 0;
7297   insize = 1;
7298
7299   /* Loop unconditionally.  The only exit from this loop is a return
7300      statement, when we've finished sorting the case list.  */
7301   for (;;)
7302     {
7303       p = list;
7304       list = NULL;
7305       tail = NULL;
7306
7307       /* Count the number of merges we do in this pass.  */
7308       nmerges = 0;
7309
7310       /* Loop while there exists a merge to be done.  */
7311       while (p)
7312         {
7313           int i;
7314
7315           /* Count this merge.  */
7316           nmerges++;
7317
7318           /* Cut the list in two pieces by stepping INSIZE places
7319              forward in the list, starting from P.  */
7320           psize = 0;
7321           q = p;
7322           for (i = 0; i < insize; i++)
7323             {
7324               psize++;
7325               q = q->right;
7326               if (!q)
7327                 break;
7328             }
7329           qsize = insize;
7330
7331           /* Now we have two lists.  Merge them!  */
7332           while (psize > 0 || (qsize > 0 && q != NULL))
7333             {
7334               /* See from which the next case to merge comes from.  */
7335               if (psize == 0)
7336                 {
7337                   /* P is empty so the next case must come from Q.  */
7338                   e = q;
7339                   q = q->right;
7340                   qsize--;
7341                 }
7342               else if (qsize == 0 || q == NULL)
7343                 {
7344                   /* Q is empty.  */
7345                   e = p;
7346                   p = p->right;
7347                   psize--;
7348                 }
7349               else
7350                 {
7351                   cmp = compare_cases (p, q);
7352                   if (cmp < 0)
7353                     {
7354                       /* The whole case range for P is less than the
7355                          one for Q.  */
7356                       e = p;
7357                       p = p->right;
7358                       psize--;
7359                     }
7360                   else if (cmp > 0)
7361                     {
7362                       /* The whole case range for Q is greater than
7363                          the case range for P.  */
7364                       e = q;
7365                       q = q->right;
7366                       qsize--;
7367                     }
7368                   else
7369                     {
7370                       /* The cases overlap, or they are the same
7371                          element in the list.  Either way, we must
7372                          issue an error and get the next case from P.  */
7373                       /* FIXME: Sort P and Q by line number.  */
7374                       gfc_error ("CASE label at %L overlaps with CASE "
7375                                  "label at %L", &p->where, &q->where);
7376                       overlap_seen = 1;
7377                       e = p;
7378                       p = p->right;
7379                       psize--;
7380                     }
7381                 }
7382
7383                 /* Add the next element to the merged list.  */
7384               if (tail)
7385                 tail->right = e;
7386               else
7387                 list = e;
7388               e->left = tail;
7389               tail = e;
7390             }
7391
7392           /* P has now stepped INSIZE places along, and so has Q.  So
7393              they're the same.  */
7394           p = q;
7395         }
7396       tail->right = NULL;
7397
7398       /* If we have done only one merge or none at all, we've
7399          finished sorting the cases.  */
7400       if (nmerges <= 1)
7401         {
7402           if (!overlap_seen)
7403             return list;
7404           else
7405             return NULL;
7406         }
7407
7408       /* Otherwise repeat, merging lists twice the size.  */
7409       insize *= 2;
7410     }
7411 }
7412
7413
7414 /* Check to see if an expression is suitable for use in a CASE statement.
7415    Makes sure that all case expressions are scalar constants of the same
7416    type.  Return FAILURE if anything is wrong.  */
7417
7418 static gfc_try
7419 validate_case_label_expr (gfc_expr *e, gfc_expr *case_expr)
7420 {
7421   if (e == NULL) return SUCCESS;
7422
7423   if (e->ts.type != case_expr->ts.type)
7424     {
7425       gfc_error ("Expression in CASE statement at %L must be of type %s",
7426                  &e->where, gfc_basic_typename (case_expr->ts.type));
7427       return FAILURE;
7428     }
7429
7430   /* C805 (R808) For a given case-construct, each case-value shall be of
7431      the same type as case-expr.  For character type, length differences
7432      are allowed, but the kind type parameters shall be the same.  */
7433
7434   if (case_expr->ts.type == BT_CHARACTER && e->ts.kind != case_expr->ts.kind)
7435     {
7436       gfc_error ("Expression in CASE statement at %L must be of kind %d",
7437                  &e->where, case_expr->ts.kind);
7438       return FAILURE;
7439     }
7440
7441   /* Convert the case value kind to that of case expression kind,
7442      if needed */
7443
7444   if (e->ts.kind != case_expr->ts.kind)
7445     gfc_convert_type_warn (e, &case_expr->ts, 2, 0);
7446
7447   if (e->rank != 0)
7448     {
7449       gfc_error ("Expression in CASE statement at %L must be scalar",
7450                  &e->where);
7451       return FAILURE;
7452     }
7453
7454   return SUCCESS;
7455 }
7456
7457
7458 /* Given a completely parsed select statement, we:
7459
7460      - Validate all expressions and code within the SELECT.
7461      - Make sure that the selection expression is not of the wrong type.
7462      - Make sure that no case ranges overlap.
7463      - Eliminate unreachable cases and unreachable code resulting from
7464        removing case labels.
7465
7466    The standard does allow unreachable cases, e.g. CASE (5:3).  But
7467    they are a hassle for code generation, and to prevent that, we just
7468    cut them out here.  This is not necessary for overlapping cases
7469    because they are illegal and we never even try to generate code.
7470
7471    We have the additional caveat that a SELECT construct could have
7472    been a computed GOTO in the source code. Fortunately we can fairly
7473    easily work around that here: The case_expr for a "real" SELECT CASE
7474    is in code->expr1, but for a computed GOTO it is in code->expr2. All
7475    we have to do is make sure that the case_expr is a scalar integer
7476    expression.  */
7477
7478 static void
7479 resolve_select (gfc_code *code)
7480 {
7481   gfc_code *body;
7482   gfc_expr *case_expr;
7483   gfc_case *cp, *default_case, *tail, *head;
7484   int seen_unreachable;
7485   int seen_logical;
7486   int ncases;
7487   bt type;
7488   gfc_try t;
7489
7490   if (code->expr1 == NULL)
7491     {
7492       /* This was actually a computed GOTO statement.  */
7493       case_expr = code->expr2;
7494       if (case_expr->ts.type != BT_INTEGER|| case_expr->rank != 0)
7495         gfc_error ("Selection expression in computed GOTO statement "
7496                    "at %L must be a scalar integer expression",
7497                    &case_expr->where);
7498
7499       /* Further checking is not necessary because this SELECT was built
7500          by the compiler, so it should always be OK.  Just move the
7501          case_expr from expr2 to expr so that we can handle computed
7502          GOTOs as normal SELECTs from here on.  */
7503       code->expr1 = code->expr2;
7504       code->expr2 = NULL;
7505       return;
7506     }
7507
7508   case_expr = code->expr1;
7509
7510   type = case_expr->ts.type;
7511   if (type != BT_LOGICAL && type != BT_INTEGER && type != BT_CHARACTER)
7512     {
7513       gfc_error ("Argument of SELECT statement at %L cannot be %s",
7514                  &case_expr->where, gfc_typename (&case_expr->ts));
7515
7516       /* Punt. Going on here just produce more garbage error messages.  */
7517       return;
7518     }
7519
7520   if (case_expr->rank != 0)
7521     {
7522       gfc_error ("Argument of SELECT statement at %L must be a scalar "
7523                  "expression", &case_expr->where);
7524
7525       /* Punt.  */
7526       return;
7527     }
7528
7529
7530   /* Raise a warning if an INTEGER case value exceeds the range of
7531      the case-expr. Later, all expressions will be promoted to the
7532      largest kind of all case-labels.  */
7533
7534   if (type == BT_INTEGER)
7535     for (body = code->block; body; body = body->block)
7536       for (cp = body->ext.block.case_list; cp; cp = cp->next)
7537         {
7538           if (cp->low
7539               && gfc_check_integer_range (cp->low->value.integer,
7540                                           case_expr->ts.kind) != ARITH_OK)
7541             gfc_warning ("Expression in CASE statement at %L is "
7542                          "not in the range of %s", &cp->low->where,
7543                          gfc_typename (&case_expr->ts));
7544
7545           if (cp->high
7546               && cp->low != cp->high
7547               && gfc_check_integer_range (cp->high->value.integer,
7548                                           case_expr->ts.kind) != ARITH_OK)
7549             gfc_warning ("Expression in CASE statement at %L is "
7550                          "not in the range of %s", &cp->high->where,
7551                          gfc_typename (&case_expr->ts));
7552         }
7553
7554   /* PR 19168 has a long discussion concerning a mismatch of the kinds
7555      of the SELECT CASE expression and its CASE values.  Walk the lists
7556      of case values, and if we find a mismatch, promote case_expr to
7557      the appropriate kind.  */
7558
7559   if (type == BT_LOGICAL || type == BT_INTEGER)
7560     {
7561       for (body = code->block; body; body = body->block)
7562         {
7563           /* Walk the case label list.  */
7564           for (cp = body->ext.block.case_list; cp; cp = cp->next)
7565             {
7566               /* Intercept the DEFAULT case.  It does not have a kind.  */
7567               if (cp->low == NULL && cp->high == NULL)
7568                 continue;
7569
7570               /* Unreachable case ranges are discarded, so ignore.  */
7571               if (cp->low != NULL && cp->high != NULL
7572                   && cp->low != cp->high
7573                   && gfc_compare_expr (cp->low, cp->high, INTRINSIC_GT) > 0)
7574                 continue;
7575
7576               if (cp->low != NULL
7577                   && case_expr->ts.kind != gfc_kind_max(case_expr, cp->low))
7578                 gfc_convert_type_warn (case_expr, &cp->low->ts, 2, 0);
7579
7580               if (cp->high != NULL
7581                   && case_expr->ts.kind != gfc_kind_max(case_expr, cp->high))
7582                 gfc_convert_type_warn (case_expr, &cp->high->ts, 2, 0);
7583             }
7584          }
7585     }
7586
7587   /* Assume there is no DEFAULT case.  */
7588   default_case = NULL;
7589   head = tail = NULL;
7590   ncases = 0;
7591   seen_logical = 0;
7592
7593   for (body = code->block; body; body = body->block)
7594     {
7595       /* Assume the CASE list is OK, and all CASE labels can be matched.  */
7596       t = SUCCESS;
7597       seen_unreachable = 0;
7598
7599       /* Walk the case label list, making sure that all case labels
7600          are legal.  */
7601       for (cp = body->ext.block.case_list; cp; cp = cp->next)
7602         {
7603           /* Count the number of cases in the whole construct.  */
7604           ncases++;
7605
7606           /* Intercept the DEFAULT case.  */
7607           if (cp->low == NULL && cp->high == NULL)
7608             {
7609               if (default_case != NULL)
7610                 {
7611                   gfc_error ("The DEFAULT CASE at %L cannot be followed "
7612                              "by a second DEFAULT CASE at %L",
7613                              &default_case->where, &cp->where);
7614                   t = FAILURE;
7615                   break;
7616                 }
7617               else
7618                 {
7619                   default_case = cp;
7620                   continue;
7621                 }
7622             }
7623
7624           /* Deal with single value cases and case ranges.  Errors are
7625              issued from the validation function.  */
7626           if (validate_case_label_expr (cp->low, case_expr) != SUCCESS
7627               || validate_case_label_expr (cp->high, case_expr) != SUCCESS)
7628             {
7629               t = FAILURE;
7630               break;
7631             }
7632
7633           if (type == BT_LOGICAL
7634               && ((cp->low == NULL || cp->high == NULL)
7635                   || cp->low != cp->high))
7636             {
7637               gfc_error ("Logical range in CASE statement at %L is not "
7638                          "allowed", &cp->low->where);
7639               t = FAILURE;
7640               break;
7641             }
7642
7643           if (type == BT_LOGICAL && cp->low->expr_type == EXPR_CONSTANT)
7644             {
7645               int value;
7646               value = cp->low->value.logical == 0 ? 2 : 1;
7647               if (value & seen_logical)
7648                 {
7649                   gfc_error ("Constant logical value in CASE statement "
7650                              "is repeated at %L",
7651                              &cp->low->where);
7652                   t = FAILURE;
7653                   break;
7654                 }
7655               seen_logical |= value;
7656             }
7657
7658           if (cp->low != NULL && cp->high != NULL
7659               && cp->low != cp->high
7660               && gfc_compare_expr (cp->low, cp->high, INTRINSIC_GT) > 0)
7661             {
7662               if (gfc_option.warn_surprising)
7663                 gfc_warning ("Range specification at %L can never "
7664                              "be matched", &cp->where);
7665
7666               cp->unreachable = 1;
7667               seen_unreachable = 1;
7668             }
7669           else
7670             {
7671               /* If the case range can be matched, it can also overlap with
7672                  other cases.  To make sure it does not, we put it in a
7673                  double linked list here.  We sort that with a merge sort
7674                  later on to detect any overlapping cases.  */
7675               if (!head)
7676                 {
7677                   head = tail = cp;
7678                   head->right = head->left = NULL;
7679                 }
7680               else
7681                 {
7682                   tail->right = cp;
7683                   tail->right->left = tail;
7684                   tail = tail->right;
7685                   tail->right = NULL;
7686                 }
7687             }
7688         }
7689
7690       /* It there was a failure in the previous case label, give up
7691          for this case label list.  Continue with the next block.  */
7692       if (t == FAILURE)
7693         continue;
7694
7695       /* See if any case labels that are unreachable have been seen.
7696          If so, we eliminate them.  This is a bit of a kludge because
7697          the case lists for a single case statement (label) is a
7698          single forward linked lists.  */
7699       if (seen_unreachable)
7700       {
7701         /* Advance until the first case in the list is reachable.  */
7702         while (body->ext.block.case_list != NULL
7703                && body->ext.block.case_list->unreachable)
7704           {
7705             gfc_case *n = body->ext.block.case_list;
7706             body->ext.block.case_list = body->ext.block.case_list->next;
7707             n->next = NULL;
7708             gfc_free_case_list (n);
7709           }
7710
7711         /* Strip all other unreachable cases.  */
7712         if (body->ext.block.case_list)
7713           {
7714             for (cp = body->ext.block.case_list; cp->next; cp = cp->next)
7715               {
7716                 if (cp->next->unreachable)
7717                   {
7718                     gfc_case *n = cp->next;
7719                     cp->next = cp->next->next;
7720                     n->next = NULL;
7721                     gfc_free_case_list (n);
7722                   }
7723               }
7724           }
7725       }
7726     }
7727
7728   /* See if there were overlapping cases.  If the check returns NULL,
7729      there was overlap.  In that case we don't do anything.  If head
7730      is non-NULL, we prepend the DEFAULT case.  The sorted list can
7731      then used during code generation for SELECT CASE constructs with
7732      a case expression of a CHARACTER type.  */
7733   if (head)
7734     {
7735       head = check_case_overlap (head);
7736
7737       /* Prepend the default_case if it is there.  */
7738       if (head != NULL && default_case)
7739         {
7740           default_case->left = NULL;
7741           default_case->right = head;
7742           head->left = default_case;
7743         }
7744     }
7745
7746   /* Eliminate dead blocks that may be the result if we've seen
7747      unreachable case labels for a block.  */
7748   for (body = code; body && body->block; body = body->block)
7749     {
7750       if (body->block->ext.block.case_list == NULL)
7751         {
7752           /* Cut the unreachable block from the code chain.  */
7753           gfc_code *c = body->block;
7754           body->block = c->block;
7755
7756           /* Kill the dead block, but not the blocks below it.  */
7757           c->block = NULL;
7758           gfc_free_statements (c);
7759         }
7760     }
7761
7762   /* More than two cases is legal but insane for logical selects.
7763      Issue a warning for it.  */
7764   if (gfc_option.warn_surprising && type == BT_LOGICAL
7765       && ncases > 2)
7766     gfc_warning ("Logical SELECT CASE block at %L has more that two cases",
7767                  &code->loc);
7768 }
7769
7770
7771 /* Check if a derived type is extensible.  */
7772
7773 bool
7774 gfc_type_is_extensible (gfc_symbol *sym)
7775 {
7776   return !(sym->attr.is_bind_c || sym->attr.sequence);
7777 }
7778
7779
7780 /* Resolve an associate name:  Resolve target and ensure the type-spec is
7781    correct as well as possibly the array-spec.  */
7782
7783 static void
7784 resolve_assoc_var (gfc_symbol* sym, bool resolve_target)
7785 {
7786   gfc_expr* target;
7787
7788   gcc_assert (sym->assoc);
7789   gcc_assert (sym->attr.flavor == FL_VARIABLE);
7790
7791   /* If this is for SELECT TYPE, the target may not yet be set.  In that
7792      case, return.  Resolution will be called later manually again when
7793      this is done.  */
7794   target = sym->assoc->target;
7795   if (!target)
7796     return;
7797   gcc_assert (!sym->assoc->dangling);
7798
7799   if (resolve_target && gfc_resolve_expr (target) != SUCCESS)
7800     return;
7801
7802   /* For variable targets, we get some attributes from the target.  */
7803   if (target->expr_type == EXPR_VARIABLE)
7804     {
7805       gfc_symbol* tsym;
7806
7807       gcc_assert (target->symtree);
7808       tsym = target->symtree->n.sym;
7809
7810       sym->attr.asynchronous = tsym->attr.asynchronous;
7811       sym->attr.volatile_ = tsym->attr.volatile_;
7812
7813       sym->attr.target = (tsym->attr.target || tsym->attr.pointer);
7814     }
7815
7816   /* Get type if this was not already set.  Note that it can be
7817      some other type than the target in case this is a SELECT TYPE
7818      selector!  So we must not update when the type is already there.  */
7819   if (sym->ts.type == BT_UNKNOWN)
7820     sym->ts = target->ts;
7821   gcc_assert (sym->ts.type != BT_UNKNOWN);
7822
7823   /* See if this is a valid association-to-variable.  */
7824   sym->assoc->variable = (target->expr_type == EXPR_VARIABLE
7825                           && !gfc_has_vector_subscript (target));
7826
7827   /* Finally resolve if this is an array or not.  */
7828   if (sym->attr.dimension && target->rank == 0)
7829     {
7830       gfc_error ("Associate-name '%s' at %L is used as array",
7831                  sym->name, &sym->declared_at);
7832       sym->attr.dimension = 0;
7833       return;
7834     }
7835   if (target->rank > 0)
7836     sym->attr.dimension = 1;
7837
7838   if (sym->attr.dimension)
7839     {
7840       sym->as = gfc_get_array_spec ();
7841       sym->as->rank = target->rank;
7842       sym->as->type = AS_DEFERRED;
7843
7844       /* Target must not be coindexed, thus the associate-variable
7845          has no corank.  */
7846       sym->as->corank = 0;
7847     }
7848 }
7849
7850
7851 /* Resolve a SELECT TYPE statement.  */
7852
7853 static void
7854 resolve_select_type (gfc_code *code, gfc_namespace *old_ns)
7855 {
7856   gfc_symbol *selector_type;
7857   gfc_code *body, *new_st, *if_st, *tail;
7858   gfc_code *class_is = NULL, *default_case = NULL;
7859   gfc_case *c;
7860   gfc_symtree *st;
7861   char name[GFC_MAX_SYMBOL_LEN];
7862   gfc_namespace *ns;
7863   int error = 0;
7864
7865   ns = code->ext.block.ns;
7866   gfc_resolve (ns);
7867
7868   /* Check for F03:C813.  */
7869   if (code->expr1->ts.type != BT_CLASS
7870       && !(code->expr2 && code->expr2->ts.type == BT_CLASS))
7871     {
7872       gfc_error ("Selector shall be polymorphic in SELECT TYPE statement "
7873                  "at %L", &code->loc);
7874       return;
7875     }
7876
7877   if (code->expr2)
7878     {
7879       if (code->expr1->symtree->n.sym->attr.untyped)
7880         code->expr1->symtree->n.sym->ts = code->expr2->ts;
7881       selector_type = CLASS_DATA (code->expr2)->ts.u.derived;
7882     }
7883   else
7884     selector_type = CLASS_DATA (code->expr1)->ts.u.derived;
7885
7886   /* Loop over TYPE IS / CLASS IS cases.  */
7887   for (body = code->block; body; body = body->block)
7888     {
7889       c = body->ext.block.case_list;
7890
7891       /* Check F03:C815.  */
7892       if ((c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
7893           && !gfc_type_is_extensible (c->ts.u.derived))
7894         {
7895           gfc_error ("Derived type '%s' at %L must be extensible",
7896                      c->ts.u.derived->name, &c->where);
7897           error++;
7898           continue;
7899         }
7900
7901       /* Check F03:C816.  */
7902       if ((c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
7903           && !gfc_type_is_extension_of (selector_type, c->ts.u.derived))
7904         {
7905           gfc_error ("Derived type '%s' at %L must be an extension of '%s'",
7906                      c->ts.u.derived->name, &c->where, selector_type->name);
7907           error++;
7908           continue;
7909         }
7910
7911       /* Intercept the DEFAULT case.  */
7912       if (c->ts.type == BT_UNKNOWN)
7913         {
7914           /* Check F03:C818.  */
7915           if (default_case)
7916             {
7917               gfc_error ("The DEFAULT CASE at %L cannot be followed "
7918                          "by a second DEFAULT CASE at %L",
7919                          &default_case->ext.block.case_list->where, &c->where);
7920               error++;
7921               continue;
7922             }
7923
7924           default_case = body;
7925         }
7926     }
7927
7928   if (error > 0)
7929     return;
7930
7931   /* Transform SELECT TYPE statement to BLOCK and associate selector to
7932      target if present.  If there are any EXIT statements referring to the
7933      SELECT TYPE construct, this is no problem because the gfc_code
7934      reference stays the same and EXIT is equally possible from the BLOCK
7935      it is changed to.  */
7936   code->op = EXEC_BLOCK;
7937   if (code->expr2)
7938     {
7939       gfc_association_list* assoc;
7940
7941       assoc = gfc_get_association_list ();
7942       assoc->st = code->expr1->symtree;
7943       assoc->target = gfc_copy_expr (code->expr2);
7944       /* assoc->variable will be set by resolve_assoc_var.  */
7945
7946       code->ext.block.assoc = assoc;
7947       code->expr1->symtree->n.sym->assoc = assoc;
7948
7949       resolve_assoc_var (code->expr1->symtree->n.sym, false);
7950     }
7951   else
7952     code->ext.block.assoc = NULL;
7953
7954   /* Add EXEC_SELECT to switch on type.  */
7955   new_st = gfc_get_code ();
7956   new_st->op = code->op;
7957   new_st->expr1 = code->expr1;
7958   new_st->expr2 = code->expr2;
7959   new_st->block = code->block;
7960   code->expr1 = code->expr2 =  NULL;
7961   code->block = NULL;
7962   if (!ns->code)
7963     ns->code = new_st;
7964   else
7965     ns->code->next = new_st;
7966   code = new_st;
7967   code->op = EXEC_SELECT;
7968   gfc_add_vptr_component (code->expr1);
7969   gfc_add_hash_component (code->expr1);
7970
7971   /* Loop over TYPE IS / CLASS IS cases.  */
7972   for (body = code->block; body; body = body->block)
7973     {
7974       c = body->ext.block.case_list;
7975
7976       if (c->ts.type == BT_DERIVED)
7977         c->low = c->high = gfc_get_int_expr (gfc_default_integer_kind, NULL,
7978                                              c->ts.u.derived->hash_value);
7979
7980       else if (c->ts.type == BT_UNKNOWN)
7981         continue;
7982
7983       /* Associate temporary to selector.  This should only be done
7984          when this case is actually true, so build a new ASSOCIATE
7985          that does precisely this here (instead of using the
7986          'global' one).  */
7987
7988       if (c->ts.type == BT_CLASS)
7989         sprintf (name, "__tmp_class_%s", c->ts.u.derived->name);
7990       else
7991         sprintf (name, "__tmp_type_%s", c->ts.u.derived->name);
7992       st = gfc_find_symtree (ns->sym_root, name);
7993       gcc_assert (st->n.sym->assoc);
7994       st->n.sym->assoc->target = gfc_get_variable_expr (code->expr1->symtree);
7995       if (c->ts.type == BT_DERIVED)
7996         gfc_add_data_component (st->n.sym->assoc->target);
7997
7998       new_st = gfc_get_code ();
7999       new_st->op = EXEC_BLOCK;
8000       new_st->ext.block.ns = gfc_build_block_ns (ns);
8001       new_st->ext.block.ns->code = body->next;
8002       body->next = new_st;
8003
8004       /* Chain in the new list only if it is marked as dangling.  Otherwise
8005          there is a CASE label overlap and this is already used.  Just ignore,
8006          the error is diagonsed elsewhere.  */
8007       if (st->n.sym->assoc->dangling)
8008         {
8009           new_st->ext.block.assoc = st->n.sym->assoc;
8010           st->n.sym->assoc->dangling = 0;
8011         }
8012
8013       resolve_assoc_var (st->n.sym, false);
8014     }
8015
8016   /* Take out CLASS IS cases for separate treatment.  */
8017   body = code;
8018   while (body && body->block)
8019     {
8020       if (body->block->ext.block.case_list->ts.type == BT_CLASS)
8021         {
8022           /* Add to class_is list.  */
8023           if (class_is == NULL)
8024             {
8025               class_is = body->block;
8026               tail = class_is;
8027             }
8028           else
8029             {
8030               for (tail = class_is; tail->block; tail = tail->block) ;
8031               tail->block = body->block;
8032               tail = tail->block;
8033             }
8034           /* Remove from EXEC_SELECT list.  */
8035           body->block = body->block->block;
8036           tail->block = NULL;
8037         }
8038       else
8039         body = body->block;
8040     }
8041
8042   if (class_is)
8043     {
8044       gfc_symbol *vtab;
8045
8046       if (!default_case)
8047         {
8048           /* Add a default case to hold the CLASS IS cases.  */
8049           for (tail = code; tail->block; tail = tail->block) ;
8050           tail->block = gfc_get_code ();
8051           tail = tail->block;
8052           tail->op = EXEC_SELECT_TYPE;
8053           tail->ext.block.case_list = gfc_get_case ();
8054           tail->ext.block.case_list->ts.type = BT_UNKNOWN;
8055           tail->next = NULL;
8056           default_case = tail;
8057         }
8058
8059       /* More than one CLASS IS block?  */
8060       if (class_is->block)
8061         {
8062           gfc_code **c1,*c2;
8063           bool swapped;
8064           /* Sort CLASS IS blocks by extension level.  */
8065           do
8066             {
8067               swapped = false;
8068               for (c1 = &class_is; (*c1) && (*c1)->block; c1 = &((*c1)->block))
8069                 {
8070                   c2 = (*c1)->block;
8071                   /* F03:C817 (check for doubles).  */
8072                   if ((*c1)->ext.block.case_list->ts.u.derived->hash_value
8073                       == c2->ext.block.case_list->ts.u.derived->hash_value)
8074                     {
8075                       gfc_error ("Double CLASS IS block in SELECT TYPE "
8076                                  "statement at %L",
8077                                  &c2->ext.block.case_list->where);
8078                       return;
8079                     }
8080                   if ((*c1)->ext.block.case_list->ts.u.derived->attr.extension
8081                       < c2->ext.block.case_list->ts.u.derived->attr.extension)
8082                     {
8083                       /* Swap.  */
8084                       (*c1)->block = c2->block;
8085                       c2->block = *c1;
8086                       *c1 = c2;
8087                       swapped = true;
8088                     }
8089                 }
8090             }
8091           while (swapped);
8092         }
8093
8094       /* Generate IF chain.  */
8095       if_st = gfc_get_code ();
8096       if_st->op = EXEC_IF;
8097       new_st = if_st;
8098       for (body = class_is; body; body = body->block)
8099         {
8100           new_st->block = gfc_get_code ();
8101           new_st = new_st->block;
8102           new_st->op = EXEC_IF;
8103           /* Set up IF condition: Call _gfortran_is_extension_of.  */
8104           new_st->expr1 = gfc_get_expr ();
8105           new_st->expr1->expr_type = EXPR_FUNCTION;
8106           new_st->expr1->ts.type = BT_LOGICAL;
8107           new_st->expr1->ts.kind = 4;
8108           new_st->expr1->value.function.name = gfc_get_string (PREFIX ("is_extension_of"));
8109           new_st->expr1->value.function.isym = XCNEW (gfc_intrinsic_sym);
8110           new_st->expr1->value.function.isym->id = GFC_ISYM_EXTENDS_TYPE_OF;
8111           /* Set up arguments.  */
8112           new_st->expr1->value.function.actual = gfc_get_actual_arglist ();
8113           new_st->expr1->value.function.actual->expr = gfc_get_variable_expr (code->expr1->symtree);
8114           new_st->expr1->value.function.actual->expr->where = code->loc;
8115           gfc_add_vptr_component (new_st->expr1->value.function.actual->expr);
8116           vtab = gfc_find_derived_vtab (body->ext.block.case_list->ts.u.derived);
8117           st = gfc_find_symtree (vtab->ns->sym_root, vtab->name);
8118           new_st->expr1->value.function.actual->next = gfc_get_actual_arglist ();
8119           new_st->expr1->value.function.actual->next->expr = gfc_get_variable_expr (st);
8120           new_st->next = body->next;
8121         }
8122         if (default_case->next)
8123           {
8124             new_st->block = gfc_get_code ();
8125             new_st = new_st->block;
8126             new_st->op = EXEC_IF;
8127             new_st->next = default_case->next;
8128           }
8129
8130         /* Replace CLASS DEFAULT code by the IF chain.  */
8131         default_case->next = if_st;
8132     }
8133
8134   /* Resolve the internal code.  This can not be done earlier because
8135      it requires that the sym->assoc of selectors is set already.  */
8136   gfc_current_ns = ns;
8137   gfc_resolve_blocks (code->block, gfc_current_ns);
8138   gfc_current_ns = old_ns;
8139
8140   resolve_select (code);
8141 }
8142
8143
8144 /* Resolve a transfer statement. This is making sure that:
8145    -- a derived type being transferred has only non-pointer components
8146    -- a derived type being transferred doesn't have private components, unless
8147       it's being transferred from the module where the type was defined
8148    -- we're not trying to transfer a whole assumed size array.  */
8149
8150 static void
8151 resolve_transfer (gfc_code *code)
8152 {
8153   gfc_typespec *ts;
8154   gfc_symbol *sym;
8155   gfc_ref *ref;
8156   gfc_expr *exp;
8157
8158   exp = code->expr1;
8159
8160   while (exp != NULL && exp->expr_type == EXPR_OP
8161          && exp->value.op.op == INTRINSIC_PARENTHESES)
8162     exp = exp->value.op.op1;
8163
8164   if (exp && exp->expr_type == EXPR_NULL && exp->ts.type == BT_UNKNOWN)
8165     {
8166       gfc_error ("NULL intrinsic at %L in data transfer statement requires "
8167                  "MOLD=", &exp->where);
8168       return;
8169     }
8170
8171   if (exp == NULL || (exp->expr_type != EXPR_VARIABLE
8172                       && exp->expr_type != EXPR_FUNCTION))
8173     return;
8174
8175   /* If we are reading, the variable will be changed.  Note that
8176      code->ext.dt may be NULL if the TRANSFER is related to
8177      an INQUIRE statement -- but in this case, we are not reading, either.  */
8178   if (code->ext.dt && code->ext.dt->dt_io_kind->value.iokind == M_READ
8179       && gfc_check_vardef_context (exp, false, false, _("item in READ"))
8180          == FAILURE)
8181     return;
8182
8183   sym = exp->symtree->n.sym;
8184   ts = &sym->ts;
8185
8186   /* Go to actual component transferred.  */
8187   for (ref = exp->ref; ref; ref = ref->next)
8188     if (ref->type == REF_COMPONENT)
8189       ts = &ref->u.c.component->ts;
8190
8191   if (ts->type == BT_CLASS)
8192     {
8193       /* FIXME: Test for defined input/output.  */
8194       gfc_error ("Data transfer element at %L cannot be polymorphic unless "
8195                 "it is processed by a defined input/output procedure",
8196                 &code->loc);
8197       return;
8198     }
8199
8200   if (ts->type == BT_DERIVED)
8201     {
8202       /* Check that transferred derived type doesn't contain POINTER
8203          components.  */
8204       if (ts->u.derived->attr.pointer_comp)
8205         {
8206           gfc_error ("Data transfer element at %L cannot have POINTER "
8207                      "components unless it is processed by a defined "
8208                      "input/output procedure", &code->loc);
8209           return;
8210         }
8211
8212       /* F08:C935.  */
8213       if (ts->u.derived->attr.proc_pointer_comp)
8214         {
8215           gfc_error ("Data transfer element at %L cannot have "
8216                      "procedure pointer components", &code->loc);
8217           return;
8218         }
8219
8220       if (ts->u.derived->attr.alloc_comp)
8221         {
8222           gfc_error ("Data transfer element at %L cannot have ALLOCATABLE "
8223                      "components unless it is processed by a defined "
8224                      "input/output procedure", &code->loc);
8225           return;
8226         }
8227
8228       if (derived_inaccessible (ts->u.derived))
8229         {
8230           gfc_error ("Data transfer element at %L cannot have "
8231                      "PRIVATE components",&code->loc);
8232           return;
8233         }
8234     }
8235
8236   if (sym->as != NULL && sym->as->type == AS_ASSUMED_SIZE && exp->ref
8237       && exp->ref->type == REF_ARRAY && exp->ref->u.ar.type == AR_FULL)
8238     {
8239       gfc_error ("Data transfer element at %L cannot be a full reference to "
8240                  "an assumed-size array", &code->loc);
8241       return;
8242     }
8243 }
8244
8245
8246 /*********** Toplevel code resolution subroutines ***********/
8247
8248 /* Find the set of labels that are reachable from this block.  We also
8249    record the last statement in each block.  */
8250
8251 static void
8252 find_reachable_labels (gfc_code *block)
8253 {
8254   gfc_code *c;
8255
8256   if (!block)
8257     return;
8258
8259   cs_base->reachable_labels = bitmap_obstack_alloc (&labels_obstack);
8260
8261   /* Collect labels in this block.  We don't keep those corresponding
8262      to END {IF|SELECT}, these are checked in resolve_branch by going
8263      up through the code_stack.  */
8264   for (c = block; c; c = c->next)
8265     {
8266       if (c->here && c->op != EXEC_END_NESTED_BLOCK)
8267         bitmap_set_bit (cs_base->reachable_labels, c->here->value);
8268     }
8269
8270   /* Merge with labels from parent block.  */
8271   if (cs_base->prev)
8272     {
8273       gcc_assert (cs_base->prev->reachable_labels);
8274       bitmap_ior_into (cs_base->reachable_labels,
8275                        cs_base->prev->reachable_labels);
8276     }
8277 }
8278
8279
8280 static void
8281 resolve_lock_unlock (gfc_code *code)
8282 {
8283   if (code->expr1->ts.type != BT_DERIVED
8284       || code->expr1->expr_type != EXPR_VARIABLE
8285       || code->expr1->ts.u.derived->from_intmod != INTMOD_ISO_FORTRAN_ENV
8286       || code->expr1->ts.u.derived->intmod_sym_id != ISOFORTRAN_LOCK_TYPE
8287       || code->expr1->rank != 0
8288       || (!gfc_is_coarray (code->expr1) && !gfc_is_coindexed (code->expr1)))
8289     gfc_error ("Lock variable at %L must be a scalar of type LOCK_TYPE",
8290                &code->expr1->where);
8291
8292   /* Check STAT.  */
8293   if (code->expr2
8294       && (code->expr2->ts.type != BT_INTEGER || code->expr2->rank != 0
8295           || code->expr2->expr_type != EXPR_VARIABLE))
8296     gfc_error ("STAT= argument at %L must be a scalar INTEGER variable",
8297                &code->expr2->where);
8298
8299   if (code->expr2
8300       && gfc_check_vardef_context (code->expr2, false, false,
8301                                    _("STAT variable")) == FAILURE)
8302     return;
8303
8304   /* Check ERRMSG.  */
8305   if (code->expr3
8306       && (code->expr3->ts.type != BT_CHARACTER || code->expr3->rank != 0
8307           || code->expr3->expr_type != EXPR_VARIABLE))
8308     gfc_error ("ERRMSG= argument at %L must be a scalar CHARACTER variable",
8309                &code->expr3->where);
8310
8311   if (code->expr3
8312       && gfc_check_vardef_context (code->expr3, false, false,
8313                                    _("ERRMSG variable")) == FAILURE)
8314     return;
8315
8316   /* Check ACQUIRED_LOCK.  */
8317   if (code->expr4
8318       && (code->expr4->ts.type != BT_LOGICAL || code->expr4->rank != 0
8319           || code->expr4->expr_type != EXPR_VARIABLE))
8320     gfc_error ("ACQUIRED_LOCK= argument at %L must be a scalar LOGICAL "
8321                "variable", &code->expr4->where);
8322
8323   if (code->expr4
8324       && gfc_check_vardef_context (code->expr4, false, false,
8325                                    _("ACQUIRED_LOCK variable")) == FAILURE)
8326     return;
8327 }
8328
8329
8330 static void
8331 resolve_sync (gfc_code *code)
8332 {
8333   /* Check imageset. The * case matches expr1 == NULL.  */
8334   if (code->expr1)
8335     {
8336       if (code->expr1->ts.type != BT_INTEGER || code->expr1->rank > 1)
8337         gfc_error ("Imageset argument at %L must be a scalar or rank-1 "
8338                    "INTEGER expression", &code->expr1->where);
8339       if (code->expr1->expr_type == EXPR_CONSTANT && code->expr1->rank == 0
8340           && mpz_cmp_si (code->expr1->value.integer, 1) < 0)
8341         gfc_error ("Imageset argument at %L must between 1 and num_images()",
8342                    &code->expr1->where);
8343       else if (code->expr1->expr_type == EXPR_ARRAY
8344                && gfc_simplify_expr (code->expr1, 0) == SUCCESS)
8345         {
8346            gfc_constructor *cons;
8347            cons = gfc_constructor_first (code->expr1->value.constructor);
8348            for (; cons; cons = gfc_constructor_next (cons))
8349              if (cons->expr->expr_type == EXPR_CONSTANT
8350                  &&  mpz_cmp_si (cons->expr->value.integer, 1) < 0)
8351                gfc_error ("Imageset argument at %L must between 1 and "
8352                           "num_images()", &cons->expr->where);
8353         }
8354     }
8355
8356   /* Check STAT.  */
8357   if (code->expr2
8358       && (code->expr2->ts.type != BT_INTEGER || code->expr2->rank != 0
8359           || code->expr2->expr_type != EXPR_VARIABLE))
8360     gfc_error ("STAT= argument at %L must be a scalar INTEGER variable",
8361                &code->expr2->where);
8362
8363   /* Check ERRMSG.  */
8364   if (code->expr3
8365       && (code->expr3->ts.type != BT_CHARACTER || code->expr3->rank != 0
8366           || code->expr3->expr_type != EXPR_VARIABLE))
8367     gfc_error ("ERRMSG= argument at %L must be a scalar CHARACTER variable",
8368                &code->expr3->where);
8369 }
8370
8371
8372 /* Given a branch to a label, see if the branch is conforming.
8373    The code node describes where the branch is located.  */
8374
8375 static void
8376 resolve_branch (gfc_st_label *label, gfc_code *code)
8377 {
8378   code_stack *stack;
8379
8380   if (label == NULL)
8381     return;
8382
8383   /* Step one: is this a valid branching target?  */
8384
8385   if (label->defined == ST_LABEL_UNKNOWN)
8386     {
8387       gfc_error ("Label %d referenced at %L is never defined", label->value,
8388                  &label->where);
8389       return;
8390     }
8391
8392   if (label->defined != ST_LABEL_TARGET)
8393     {
8394       gfc_error ("Statement at %L is not a valid branch target statement "
8395                  "for the branch statement at %L", &label->where, &code->loc);
8396       return;
8397     }
8398
8399   /* Step two: make sure this branch is not a branch to itself ;-)  */
8400
8401   if (code->here == label)
8402     {
8403       gfc_warning ("Branch at %L may result in an infinite loop", &code->loc);
8404       return;
8405     }
8406
8407   /* Step three:  See if the label is in the same block as the
8408      branching statement.  The hard work has been done by setting up
8409      the bitmap reachable_labels.  */
8410
8411   if (bitmap_bit_p (cs_base->reachable_labels, label->value))
8412     {
8413       /* Check now whether there is a CRITICAL construct; if so, check
8414          whether the label is still visible outside of the CRITICAL block,
8415          which is invalid.  */
8416       for (stack = cs_base; stack; stack = stack->prev)
8417         {
8418           if (stack->current->op == EXEC_CRITICAL
8419               && bitmap_bit_p (stack->reachable_labels, label->value))
8420             gfc_error ("GOTO statement at %L leaves CRITICAL construct for "
8421                       "label at %L", &code->loc, &label->where);
8422           else if (stack->current->op == EXEC_DO_CONCURRENT
8423                    && bitmap_bit_p (stack->reachable_labels, label->value))
8424             gfc_error ("GOTO statement at %L leaves DO CONCURRENT construct "
8425                       "for label at %L", &code->loc, &label->where);
8426         }
8427
8428       return;
8429     }
8430
8431   /* Step four:  If we haven't found the label in the bitmap, it may
8432     still be the label of the END of the enclosing block, in which
8433     case we find it by going up the code_stack.  */
8434
8435   for (stack = cs_base; stack; stack = stack->prev)
8436     {
8437       if (stack->current->next && stack->current->next->here == label)
8438         break;
8439       if (stack->current->op == EXEC_CRITICAL)
8440         {
8441           /* Note: A label at END CRITICAL does not leave the CRITICAL
8442              construct as END CRITICAL is still part of it.  */
8443           gfc_error ("GOTO statement at %L leaves CRITICAL construct for label"
8444                       " at %L", &code->loc, &label->where);
8445           return;
8446         }
8447       else if (stack->current->op == EXEC_DO_CONCURRENT)
8448         {
8449           gfc_error ("GOTO statement at %L leaves DO CONCURRENT construct for "
8450                      "label at %L", &code->loc, &label->where);
8451           return;
8452         }
8453     }
8454
8455   if (stack)
8456     {
8457       gcc_assert (stack->current->next->op == EXEC_END_NESTED_BLOCK);
8458       return;
8459     }
8460
8461   /* The label is not in an enclosing block, so illegal.  This was
8462      allowed in Fortran 66, so we allow it as extension.  No
8463      further checks are necessary in this case.  */
8464   gfc_notify_std (GFC_STD_LEGACY, "Label at %L is not in the same block "
8465                   "as the GOTO statement at %L", &label->where,
8466                   &code->loc);
8467   return;
8468 }
8469
8470
8471 /* Check whether EXPR1 has the same shape as EXPR2.  */
8472
8473 static gfc_try
8474 resolve_where_shape (gfc_expr *expr1, gfc_expr *expr2)
8475 {
8476   mpz_t shape[GFC_MAX_DIMENSIONS];
8477   mpz_t shape2[GFC_MAX_DIMENSIONS];
8478   gfc_try result = FAILURE;
8479   int i;
8480
8481   /* Compare the rank.  */
8482   if (expr1->rank != expr2->rank)
8483     return result;
8484
8485   /* Compare the size of each dimension.  */
8486   for (i=0; i<expr1->rank; i++)
8487     {
8488       if (gfc_array_dimen_size (expr1, i, &shape[i]) == FAILURE)
8489         goto ignore;
8490
8491       if (gfc_array_dimen_size (expr2, i, &shape2[i]) == FAILURE)
8492         goto ignore;
8493
8494       if (mpz_cmp (shape[i], shape2[i]))
8495         goto over;
8496     }
8497
8498   /* When either of the two expression is an assumed size array, we
8499      ignore the comparison of dimension sizes.  */
8500 ignore:
8501   result = SUCCESS;
8502
8503 over:
8504   gfc_clear_shape (shape, i);
8505   gfc_clear_shape (shape2, i);
8506   return result;
8507 }
8508
8509
8510 /* Check whether a WHERE assignment target or a WHERE mask expression
8511    has the same shape as the outmost WHERE mask expression.  */
8512
8513 static void
8514 resolve_where (gfc_code *code, gfc_expr *mask)
8515 {
8516   gfc_code *cblock;
8517   gfc_code *cnext;
8518   gfc_expr *e = NULL;
8519
8520   cblock = code->block;
8521
8522   /* Store the first WHERE mask-expr of the WHERE statement or construct.
8523      In case of nested WHERE, only the outmost one is stored.  */
8524   if (mask == NULL) /* outmost WHERE */
8525     e = cblock->expr1;
8526   else /* inner WHERE */
8527     e = mask;
8528
8529   while (cblock)
8530     {
8531       if (cblock->expr1)
8532         {
8533           /* Check if the mask-expr has a consistent shape with the
8534              outmost WHERE mask-expr.  */
8535           if (resolve_where_shape (cblock->expr1, e) == FAILURE)
8536             gfc_error ("WHERE mask at %L has inconsistent shape",
8537                        &cblock->expr1->where);
8538          }
8539
8540       /* the assignment statement of a WHERE statement, or the first
8541          statement in where-body-construct of a WHERE construct */
8542       cnext = cblock->next;
8543       while (cnext)
8544         {
8545           switch (cnext->op)
8546             {
8547             /* WHERE assignment statement */
8548             case EXEC_ASSIGN:
8549
8550               /* Check shape consistent for WHERE assignment target.  */
8551               if (e && resolve_where_shape (cnext->expr1, e) == FAILURE)
8552                gfc_error ("WHERE assignment target at %L has "
8553                           "inconsistent shape", &cnext->expr1->where);
8554               break;
8555
8556
8557             case EXEC_ASSIGN_CALL:
8558               resolve_call (cnext);
8559               if (!cnext->resolved_sym->attr.elemental)
8560                 gfc_error("Non-ELEMENTAL user-defined assignment in WHERE at %L",
8561                           &cnext->ext.actual->expr->where);
8562               break;
8563
8564             /* WHERE or WHERE construct is part of a where-body-construct */
8565             case EXEC_WHERE:
8566               resolve_where (cnext, e);
8567               break;
8568
8569             default:
8570               gfc_error ("Unsupported statement inside WHERE at %L",
8571                          &cnext->loc);
8572             }
8573          /* the next statement within the same where-body-construct */
8574          cnext = cnext->next;
8575        }
8576     /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
8577     cblock = cblock->block;
8578   }
8579 }
8580
8581
8582 /* Resolve assignment in FORALL construct.
8583    NVAR is the number of FORALL index variables, and VAR_EXPR records the
8584    FORALL index variables.  */
8585
8586 static void
8587 gfc_resolve_assign_in_forall (gfc_code *code, int nvar, gfc_expr **var_expr)
8588 {
8589   int n;
8590
8591   for (n = 0; n < nvar; n++)
8592     {
8593       gfc_symbol *forall_index;
8594
8595       forall_index = var_expr[n]->symtree->n.sym;
8596
8597       /* Check whether the assignment target is one of the FORALL index
8598          variable.  */
8599       if ((code->expr1->expr_type == EXPR_VARIABLE)
8600           && (code->expr1->symtree->n.sym == forall_index))
8601         gfc_error ("Assignment to a FORALL index variable at %L",
8602                    &code->expr1->where);
8603       else
8604         {
8605           /* If one of the FORALL index variables doesn't appear in the
8606              assignment variable, then there could be a many-to-one
8607              assignment.  Emit a warning rather than an error because the
8608              mask could be resolving this problem.  */
8609           if (find_forall_index (code->expr1, forall_index, 0) == FAILURE)
8610             gfc_warning ("The FORALL with index '%s' is not used on the "
8611                          "left side of the assignment at %L and so might "
8612                          "cause multiple assignment to this object",
8613                          var_expr[n]->symtree->name, &code->expr1->where);
8614         }
8615     }
8616 }
8617
8618
8619 /* Resolve WHERE statement in FORALL construct.  */
8620
8621 static void
8622 gfc_resolve_where_code_in_forall (gfc_code *code, int nvar,
8623                                   gfc_expr **var_expr)
8624 {
8625   gfc_code *cblock;
8626   gfc_code *cnext;
8627
8628   cblock = code->block;
8629   while (cblock)
8630     {
8631       /* the assignment statement of a WHERE statement, or the first
8632          statement in where-body-construct of a WHERE construct */
8633       cnext = cblock->next;
8634       while (cnext)
8635         {
8636           switch (cnext->op)
8637             {
8638             /* WHERE assignment statement */
8639             case EXEC_ASSIGN:
8640               gfc_resolve_assign_in_forall (cnext, nvar, var_expr);
8641               break;
8642
8643             /* WHERE operator assignment statement */
8644             case EXEC_ASSIGN_CALL:
8645               resolve_call (cnext);
8646               if (!cnext->resolved_sym->attr.elemental)
8647                 gfc_error("Non-ELEMENTAL user-defined assignment in WHERE at %L",
8648                           &cnext->ext.actual->expr->where);
8649               break;
8650
8651             /* WHERE or WHERE construct is part of a where-body-construct */
8652             case EXEC_WHERE:
8653               gfc_resolve_where_code_in_forall (cnext, nvar, var_expr);
8654               break;
8655
8656             default:
8657               gfc_error ("Unsupported statement inside WHERE at %L",
8658                          &cnext->loc);
8659             }
8660           /* the next statement within the same where-body-construct */
8661           cnext = cnext->next;
8662         }
8663       /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
8664       cblock = cblock->block;
8665     }
8666 }
8667
8668
8669 /* Traverse the FORALL body to check whether the following errors exist:
8670    1. For assignment, check if a many-to-one assignment happens.
8671    2. For WHERE statement, check the WHERE body to see if there is any
8672       many-to-one assignment.  */
8673
8674 static void
8675 gfc_resolve_forall_body (gfc_code *code, int nvar, gfc_expr **var_expr)
8676 {
8677   gfc_code *c;
8678
8679   c = code->block->next;
8680   while (c)
8681     {
8682       switch (c->op)
8683         {
8684         case EXEC_ASSIGN:
8685         case EXEC_POINTER_ASSIGN:
8686           gfc_resolve_assign_in_forall (c, nvar, var_expr);
8687           break;
8688
8689         case EXEC_ASSIGN_CALL:
8690           resolve_call (c);
8691           break;
8692
8693         /* Because the gfc_resolve_blocks() will handle the nested FORALL,
8694            there is no need to handle it here.  */
8695         case EXEC_FORALL:
8696           break;
8697         case EXEC_WHERE:
8698           gfc_resolve_where_code_in_forall(c, nvar, var_expr);
8699           break;
8700         default:
8701           break;
8702         }
8703       /* The next statement in the FORALL body.  */
8704       c = c->next;
8705     }
8706 }
8707
8708
8709 /* Counts the number of iterators needed inside a forall construct, including
8710    nested forall constructs. This is used to allocate the needed memory
8711    in gfc_resolve_forall.  */
8712
8713 static int
8714 gfc_count_forall_iterators (gfc_code *code)
8715 {
8716   int max_iters, sub_iters, current_iters;
8717   gfc_forall_iterator *fa;
8718
8719   gcc_assert(code->op == EXEC_FORALL);
8720   max_iters = 0;
8721   current_iters = 0;
8722
8723   for (fa = code->ext.forall_iterator; fa; fa = fa->next)
8724     current_iters ++;
8725
8726   code = code->block->next;
8727
8728   while (code)
8729     {
8730       if (code->op == EXEC_FORALL)
8731         {
8732           sub_iters = gfc_count_forall_iterators (code);
8733           if (sub_iters > max_iters)
8734             max_iters = sub_iters;
8735         }
8736       code = code->next;
8737     }
8738
8739   return current_iters + max_iters;
8740 }
8741
8742
8743 /* Given a FORALL construct, first resolve the FORALL iterator, then call
8744    gfc_resolve_forall_body to resolve the FORALL body.  */
8745
8746 static void
8747 gfc_resolve_forall (gfc_code *code, gfc_namespace *ns, int forall_save)
8748 {
8749   static gfc_expr **var_expr;
8750   static int total_var = 0;
8751   static int nvar = 0;
8752   int old_nvar, tmp;
8753   gfc_forall_iterator *fa;
8754   int i;
8755
8756   old_nvar = nvar;
8757
8758   /* Start to resolve a FORALL construct   */
8759   if (forall_save == 0)
8760     {
8761       /* Count the total number of FORALL index in the nested FORALL
8762          construct in order to allocate the VAR_EXPR with proper size.  */
8763       total_var = gfc_count_forall_iterators (code);
8764
8765       /* Allocate VAR_EXPR with NUMBER_OF_FORALL_INDEX elements.  */
8766       var_expr = XCNEWVEC (gfc_expr *, total_var);
8767     }
8768
8769   /* The information about FORALL iterator, including FORALL index start, end
8770      and stride. The FORALL index can not appear in start, end or stride.  */
8771   for (fa = code->ext.forall_iterator; fa; fa = fa->next)
8772     {
8773       /* Check if any outer FORALL index name is the same as the current
8774          one.  */
8775       for (i = 0; i < nvar; i++)
8776         {
8777           if (fa->var->symtree->n.sym == var_expr[i]->symtree->n.sym)
8778             {
8779               gfc_error ("An outer FORALL construct already has an index "
8780                          "with this name %L", &fa->var->where);
8781             }
8782         }
8783
8784       /* Record the current FORALL index.  */
8785       var_expr[nvar] = gfc_copy_expr (fa->var);
8786
8787       nvar++;
8788
8789       /* No memory leak.  */
8790       gcc_assert (nvar <= total_var);
8791     }
8792
8793   /* Resolve the FORALL body.  */
8794   gfc_resolve_forall_body (code, nvar, var_expr);
8795
8796   /* May call gfc_resolve_forall to resolve the inner FORALL loop.  */
8797   gfc_resolve_blocks (code->block, ns);
8798
8799   tmp = nvar;
8800   nvar = old_nvar;
8801   /* Free only the VAR_EXPRs allocated in this frame.  */
8802   for (i = nvar; i < tmp; i++)
8803      gfc_free_expr (var_expr[i]);
8804
8805   if (nvar == 0)
8806     {
8807       /* We are in the outermost FORALL construct.  */
8808       gcc_assert (forall_save == 0);
8809
8810       /* VAR_EXPR is not needed any more.  */
8811       free (var_expr);
8812       total_var = 0;
8813     }
8814 }
8815
8816
8817 /* Resolve a BLOCK construct statement.  */
8818
8819 static void
8820 resolve_block_construct (gfc_code* code)
8821 {
8822   /* Resolve the BLOCK's namespace.  */
8823   gfc_resolve (code->ext.block.ns);
8824
8825   /* For an ASSOCIATE block, the associations (and their targets) are already
8826      resolved during resolve_symbol.  */
8827 }
8828
8829
8830 /* Resolve lists of blocks found in IF, SELECT CASE, WHERE, FORALL, GOTO and
8831    DO code nodes.  */
8832
8833 static void resolve_code (gfc_code *, gfc_namespace *);
8834
8835 void
8836 gfc_resolve_blocks (gfc_code *b, gfc_namespace *ns)
8837 {
8838   gfc_try t;
8839
8840   for (; b; b = b->block)
8841     {
8842       t = gfc_resolve_expr (b->expr1);
8843       if (gfc_resolve_expr (b->expr2) == FAILURE)
8844         t = FAILURE;
8845
8846       switch (b->op)
8847         {
8848         case EXEC_IF:
8849           if (t == SUCCESS && b->expr1 != NULL
8850               && (b->expr1->ts.type != BT_LOGICAL || b->expr1->rank != 0))
8851             gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
8852                        &b->expr1->where);
8853           break;
8854
8855         case EXEC_WHERE:
8856           if (t == SUCCESS
8857               && b->expr1 != NULL
8858               && (b->expr1->ts.type != BT_LOGICAL || b->expr1->rank == 0))
8859             gfc_error ("WHERE/ELSEWHERE clause at %L requires a LOGICAL array",
8860                        &b->expr1->where);
8861           break;
8862
8863         case EXEC_GOTO:
8864           resolve_branch (b->label1, b);
8865           break;
8866
8867         case EXEC_BLOCK:
8868           resolve_block_construct (b);
8869           break;
8870
8871         case EXEC_SELECT:
8872         case EXEC_SELECT_TYPE:
8873         case EXEC_FORALL:
8874         case EXEC_DO:
8875         case EXEC_DO_WHILE:
8876         case EXEC_DO_CONCURRENT:
8877         case EXEC_CRITICAL:
8878         case EXEC_READ:
8879         case EXEC_WRITE:
8880         case EXEC_IOLENGTH:
8881         case EXEC_WAIT:
8882           break;
8883
8884         case EXEC_OMP_ATOMIC:
8885         case EXEC_OMP_CRITICAL:
8886         case EXEC_OMP_DO:
8887         case EXEC_OMP_MASTER:
8888         case EXEC_OMP_ORDERED:
8889         case EXEC_OMP_PARALLEL:
8890         case EXEC_OMP_PARALLEL_DO:
8891         case EXEC_OMP_PARALLEL_SECTIONS:
8892         case EXEC_OMP_PARALLEL_WORKSHARE:
8893         case EXEC_OMP_SECTIONS:
8894         case EXEC_OMP_SINGLE:
8895         case EXEC_OMP_TASK:
8896         case EXEC_OMP_TASKWAIT:
8897         case EXEC_OMP_TASKYIELD:
8898         case EXEC_OMP_WORKSHARE:
8899           break;
8900
8901         default:
8902           gfc_internal_error ("gfc_resolve_blocks(): Bad block type");
8903         }
8904
8905       resolve_code (b->next, ns);
8906     }
8907 }
8908
8909
8910 /* Does everything to resolve an ordinary assignment.  Returns true
8911    if this is an interface assignment.  */
8912 static bool
8913 resolve_ordinary_assign (gfc_code *code, gfc_namespace *ns)
8914 {
8915   bool rval = false;
8916   gfc_expr *lhs;
8917   gfc_expr *rhs;
8918   int llen = 0;
8919   int rlen = 0;
8920   int n;
8921   gfc_ref *ref;
8922
8923   if (gfc_extend_assign (code, ns) == SUCCESS)
8924     {
8925       gfc_expr** rhsptr;
8926
8927       if (code->op == EXEC_ASSIGN_CALL)
8928         {
8929           lhs = code->ext.actual->expr;
8930           rhsptr = &code->ext.actual->next->expr;
8931         }
8932       else
8933         {
8934           gfc_actual_arglist* args;
8935           gfc_typebound_proc* tbp;
8936
8937           gcc_assert (code->op == EXEC_COMPCALL);
8938
8939           args = code->expr1->value.compcall.actual;
8940           lhs = args->expr;
8941           rhsptr = &args->next->expr;
8942
8943           tbp = code->expr1->value.compcall.tbp;
8944           gcc_assert (!tbp->is_generic);
8945         }
8946
8947       /* Make a temporary rhs when there is a default initializer
8948          and rhs is the same symbol as the lhs.  */
8949       if ((*rhsptr)->expr_type == EXPR_VARIABLE
8950             && (*rhsptr)->symtree->n.sym->ts.type == BT_DERIVED
8951             && gfc_has_default_initializer ((*rhsptr)->symtree->n.sym->ts.u.derived)
8952             && (lhs->symtree->n.sym == (*rhsptr)->symtree->n.sym))
8953         *rhsptr = gfc_get_parentheses (*rhsptr);
8954
8955       return true;
8956     }
8957
8958   lhs = code->expr1;
8959   rhs = code->expr2;
8960
8961   if (rhs->is_boz
8962       && gfc_notify_std (GFC_STD_GNU, "Extension: BOZ literal at %L outside "
8963                          "a DATA statement and outside INT/REAL/DBLE/CMPLX",
8964                          &code->loc) == FAILURE)
8965     return false;
8966
8967   /* Handle the case of a BOZ literal on the RHS.  */
8968   if (rhs->is_boz && lhs->ts.type != BT_INTEGER)
8969     {
8970       int rc;
8971       if (gfc_option.warn_surprising)
8972         gfc_warning ("BOZ literal at %L is bitwise transferred "
8973                      "non-integer symbol '%s'", &code->loc,
8974                      lhs->symtree->n.sym->name);
8975
8976       if (!gfc_convert_boz (rhs, &lhs->ts))
8977         return false;
8978       if ((rc = gfc_range_check (rhs)) != ARITH_OK)
8979         {
8980           if (rc == ARITH_UNDERFLOW)
8981             gfc_error ("Arithmetic underflow of bit-wise transferred BOZ at %L"
8982                        ". This check can be disabled with the option "
8983                        "-fno-range-check", &rhs->where);
8984           else if (rc == ARITH_OVERFLOW)
8985             gfc_error ("Arithmetic overflow of bit-wise transferred BOZ at %L"
8986                        ". This check can be disabled with the option "
8987                        "-fno-range-check", &rhs->where);
8988           else if (rc == ARITH_NAN)
8989             gfc_error ("Arithmetic NaN of bit-wise transferred BOZ at %L"
8990                        ". This check can be disabled with the option "
8991                        "-fno-range-check", &rhs->where);
8992           return false;
8993         }
8994     }
8995
8996   if (lhs->ts.type == BT_CHARACTER
8997         && gfc_option.warn_character_truncation)
8998     {
8999       if (lhs->ts.u.cl != NULL
9000             && lhs->ts.u.cl->length != NULL
9001             && lhs->ts.u.cl->length->expr_type == EXPR_CONSTANT)
9002         llen = mpz_get_si (lhs->ts.u.cl->length->value.integer);
9003
9004       if (rhs->expr_type == EXPR_CONSTANT)
9005         rlen = rhs->value.character.length;
9006
9007       else if (rhs->ts.u.cl != NULL
9008                  && rhs->ts.u.cl->length != NULL
9009                  && rhs->ts.u.cl->length->expr_type == EXPR_CONSTANT)
9010         rlen = mpz_get_si (rhs->ts.u.cl->length->value.integer);
9011
9012       if (rlen && llen && rlen > llen)
9013         gfc_warning_now ("CHARACTER expression will be truncated "
9014                          "in assignment (%d/%d) at %L",
9015                          llen, rlen, &code->loc);
9016     }
9017
9018   /* Ensure that a vector index expression for the lvalue is evaluated
9019      to a temporary if the lvalue symbol is referenced in it.  */
9020   if (lhs->rank)
9021     {
9022       for (ref = lhs->ref; ref; ref= ref->next)
9023         if (ref->type == REF_ARRAY)
9024           {
9025             for (n = 0; n < ref->u.ar.dimen; n++)
9026               if (ref->u.ar.dimen_type[n] == DIMEN_VECTOR
9027                   && gfc_find_sym_in_expr (lhs->symtree->n.sym,
9028                                            ref->u.ar.start[n]))
9029                 ref->u.ar.start[n]
9030                         = gfc_get_parentheses (ref->u.ar.start[n]);
9031           }
9032     }
9033
9034   if (gfc_pure (NULL))
9035     {
9036       if (lhs->ts.type == BT_DERIVED
9037             && lhs->expr_type == EXPR_VARIABLE
9038             && lhs->ts.u.derived->attr.pointer_comp
9039             && rhs->expr_type == EXPR_VARIABLE
9040             && (gfc_impure_variable (rhs->symtree->n.sym)
9041                 || gfc_is_coindexed (rhs)))
9042         {
9043           /* F2008, C1283.  */
9044           if (gfc_is_coindexed (rhs))
9045             gfc_error ("Coindexed expression at %L is assigned to "
9046                         "a derived type variable with a POINTER "
9047                         "component in a PURE procedure",
9048                         &rhs->where);
9049           else
9050             gfc_error ("The impure variable at %L is assigned to "
9051                         "a derived type variable with a POINTER "
9052                         "component in a PURE procedure (12.6)",
9053                         &rhs->where);
9054           return rval;
9055         }
9056
9057       /* Fortran 2008, C1283.  */
9058       if (gfc_is_coindexed (lhs))
9059         {
9060           gfc_error ("Assignment to coindexed variable at %L in a PURE "
9061                      "procedure", &rhs->where);
9062           return rval;
9063         }
9064     }
9065
9066   if (gfc_implicit_pure (NULL))
9067     {
9068       if (lhs->expr_type == EXPR_VARIABLE
9069             && lhs->symtree->n.sym != gfc_current_ns->proc_name
9070             && lhs->symtree->n.sym->ns != gfc_current_ns)
9071         gfc_current_ns->proc_name->attr.implicit_pure = 0;
9072
9073       if (lhs->ts.type == BT_DERIVED
9074             && lhs->expr_type == EXPR_VARIABLE
9075             && lhs->ts.u.derived->attr.pointer_comp
9076             && rhs->expr_type == EXPR_VARIABLE
9077             && (gfc_impure_variable (rhs->symtree->n.sym)
9078                 || gfc_is_coindexed (rhs)))
9079         gfc_current_ns->proc_name->attr.implicit_pure = 0;
9080
9081       /* Fortran 2008, C1283.  */
9082       if (gfc_is_coindexed (lhs))
9083         gfc_current_ns->proc_name->attr.implicit_pure = 0;
9084     }
9085
9086   /* F03:7.4.1.2.  */
9087   /* FIXME: Valid in Fortran 2008, unless the LHS is both polymorphic
9088      and coindexed; cf. F2008, 7.2.1.2 and PR 43366.  */
9089   if (lhs->ts.type == BT_CLASS)
9090     {
9091       gfc_error ("Variable must not be polymorphic in assignment at %L",
9092                  &lhs->where);
9093       return false;
9094     }
9095
9096   /* F2008, Section 7.2.1.2.  */
9097   if (gfc_is_coindexed (lhs) && gfc_has_ultimate_allocatable (lhs))
9098     {
9099       gfc_error ("Coindexed variable must not be have an allocatable ultimate "
9100                  "component in assignment at %L", &lhs->where);
9101       return false;
9102     }
9103
9104   gfc_check_assign (lhs, rhs, 1);
9105   return false;
9106 }
9107
9108
9109 /* Given a block of code, recursively resolve everything pointed to by this
9110    code block.  */
9111
9112 static void
9113 resolve_code (gfc_code *code, gfc_namespace *ns)
9114 {
9115   int omp_workshare_save;
9116   int forall_save, do_concurrent_save;
9117   code_stack frame;
9118   gfc_try t;
9119
9120   frame.prev = cs_base;
9121   frame.head = code;
9122   cs_base = &frame;
9123
9124   find_reachable_labels (code);
9125
9126   for (; code; code = code->next)
9127     {
9128       frame.current = code;
9129       forall_save = forall_flag;
9130       do_concurrent_save = do_concurrent_flag;
9131
9132       if (code->op == EXEC_FORALL)
9133         {
9134           forall_flag = 1;
9135           gfc_resolve_forall (code, ns, forall_save);
9136           forall_flag = 2;
9137         }
9138       else if (code->block)
9139         {
9140           omp_workshare_save = -1;
9141           switch (code->op)
9142             {
9143             case EXEC_OMP_PARALLEL_WORKSHARE:
9144               omp_workshare_save = omp_workshare_flag;
9145               omp_workshare_flag = 1;
9146               gfc_resolve_omp_parallel_blocks (code, ns);
9147               break;
9148             case EXEC_OMP_PARALLEL:
9149             case EXEC_OMP_PARALLEL_DO:
9150             case EXEC_OMP_PARALLEL_SECTIONS:
9151             case EXEC_OMP_TASK:
9152               omp_workshare_save = omp_workshare_flag;
9153               omp_workshare_flag = 0;
9154               gfc_resolve_omp_parallel_blocks (code, ns);
9155               break;
9156             case EXEC_OMP_DO:
9157               gfc_resolve_omp_do_blocks (code, ns);
9158               break;
9159             case EXEC_SELECT_TYPE:
9160               /* Blocks are handled in resolve_select_type because we have
9161                  to transform the SELECT TYPE into ASSOCIATE first.  */
9162               break;
9163             case EXEC_DO_CONCURRENT:
9164               do_concurrent_flag = 1;
9165               gfc_resolve_blocks (code->block, ns);
9166               do_concurrent_flag = 2;
9167               break;
9168             case EXEC_OMP_WORKSHARE:
9169               omp_workshare_save = omp_workshare_flag;
9170               omp_workshare_flag = 1;
9171               /* FALLTHROUGH */
9172             default:
9173               gfc_resolve_blocks (code->block, ns);
9174               break;
9175             }
9176
9177           if (omp_workshare_save != -1)
9178             omp_workshare_flag = omp_workshare_save;
9179         }
9180
9181       t = SUCCESS;
9182       if (code->op != EXEC_COMPCALL && code->op != EXEC_CALL_PPC)
9183         t = gfc_resolve_expr (code->expr1);
9184       forall_flag = forall_save;
9185       do_concurrent_flag = do_concurrent_save;
9186
9187       if (gfc_resolve_expr (code->expr2) == FAILURE)
9188         t = FAILURE;
9189
9190       if (code->op == EXEC_ALLOCATE
9191           && gfc_resolve_expr (code->expr3) == FAILURE)
9192         t = FAILURE;
9193
9194       switch (code->op)
9195         {
9196         case EXEC_NOP:
9197         case EXEC_END_BLOCK:
9198         case EXEC_END_NESTED_BLOCK:
9199         case EXEC_CYCLE:
9200         case EXEC_PAUSE:
9201         case EXEC_STOP:
9202         case EXEC_ERROR_STOP:
9203         case EXEC_EXIT:
9204         case EXEC_CONTINUE:
9205         case EXEC_DT_END:
9206         case EXEC_ASSIGN_CALL:
9207         case EXEC_CRITICAL:
9208           break;
9209
9210         case EXEC_SYNC_ALL:
9211         case EXEC_SYNC_IMAGES:
9212         case EXEC_SYNC_MEMORY:
9213           resolve_sync (code);
9214           break;
9215
9216         case EXEC_LOCK:
9217         case EXEC_UNLOCK:
9218           resolve_lock_unlock (code);
9219           break;
9220
9221         case EXEC_ENTRY:
9222           /* Keep track of which entry we are up to.  */
9223           current_entry_id = code->ext.entry->id;
9224           break;
9225
9226         case EXEC_WHERE:
9227           resolve_where (code, NULL);
9228           break;
9229
9230         case EXEC_GOTO:
9231           if (code->expr1 != NULL)
9232             {
9233               if (code->expr1->ts.type != BT_INTEGER)
9234                 gfc_error ("ASSIGNED GOTO statement at %L requires an "
9235                            "INTEGER variable", &code->expr1->where);
9236               else if (code->expr1->symtree->n.sym->attr.assign != 1)
9237                 gfc_error ("Variable '%s' has not been assigned a target "
9238                            "label at %L", code->expr1->symtree->n.sym->name,
9239                            &code->expr1->where);
9240             }
9241           else
9242             resolve_branch (code->label1, code);
9243           break;
9244
9245         case EXEC_RETURN:
9246           if (code->expr1 != NULL
9247                 && (code->expr1->ts.type != BT_INTEGER || code->expr1->rank))
9248             gfc_error ("Alternate RETURN statement at %L requires a SCALAR-"
9249                        "INTEGER return specifier", &code->expr1->where);
9250           break;
9251
9252         case EXEC_INIT_ASSIGN:
9253         case EXEC_END_PROCEDURE:
9254           break;
9255
9256         case EXEC_ASSIGN:
9257           if (t == FAILURE)
9258             break;
9259
9260           if (gfc_check_vardef_context (code->expr1, false, false,
9261                                         _("assignment")) == FAILURE)
9262             break;
9263
9264           if (resolve_ordinary_assign (code, ns))
9265             {
9266               if (code->op == EXEC_COMPCALL)
9267                 goto compcall;
9268               else
9269                 goto call;
9270             }
9271           break;
9272
9273         case EXEC_LABEL_ASSIGN:
9274           if (code->label1->defined == ST_LABEL_UNKNOWN)
9275             gfc_error ("Label %d referenced at %L is never defined",
9276                        code->label1->value, &code->label1->where);
9277           if (t == SUCCESS
9278               && (code->expr1->expr_type != EXPR_VARIABLE
9279                   || code->expr1->symtree->n.sym->ts.type != BT_INTEGER
9280                   || code->expr1->symtree->n.sym->ts.kind
9281                      != gfc_default_integer_kind
9282                   || code->expr1->symtree->n.sym->as != NULL))
9283             gfc_error ("ASSIGN statement at %L requires a scalar "
9284                        "default INTEGER variable", &code->expr1->where);
9285           break;
9286
9287         case EXEC_POINTER_ASSIGN:
9288           {
9289             gfc_expr* e;
9290
9291             if (t == FAILURE)
9292               break;
9293
9294             /* This is both a variable definition and pointer assignment
9295                context, so check both of them.  For rank remapping, a final
9296                array ref may be present on the LHS and fool gfc_expr_attr
9297                used in gfc_check_vardef_context.  Remove it.  */
9298             e = remove_last_array_ref (code->expr1);
9299             t = gfc_check_vardef_context (e, true, false,
9300                                           _("pointer assignment"));
9301             if (t == SUCCESS)
9302               t = gfc_check_vardef_context (e, false, false,
9303                                             _("pointer assignment"));
9304             gfc_free_expr (e);
9305             if (t == FAILURE)
9306               break;
9307
9308             gfc_check_pointer_assign (code->expr1, code->expr2);
9309             break;
9310           }
9311
9312         case EXEC_ARITHMETIC_IF:
9313           if (t == SUCCESS
9314               && code->expr1->ts.type != BT_INTEGER
9315               && code->expr1->ts.type != BT_REAL)
9316             gfc_error ("Arithmetic IF statement at %L requires a numeric "
9317                        "expression", &code->expr1->where);
9318
9319           resolve_branch (code->label1, code);
9320           resolve_branch (code->label2, code);
9321           resolve_branch (code->label3, code);
9322           break;
9323
9324         case EXEC_IF:
9325           if (t == SUCCESS && code->expr1 != NULL
9326               && (code->expr1->ts.type != BT_LOGICAL
9327                   || code->expr1->rank != 0))
9328             gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
9329                        &code->expr1->where);
9330           break;
9331
9332         case EXEC_CALL:
9333         call:
9334           resolve_call (code);
9335           break;
9336
9337         case EXEC_COMPCALL:
9338         compcall:
9339           resolve_typebound_subroutine (code);
9340           break;
9341
9342         case EXEC_CALL_PPC:
9343           resolve_ppc_call (code);
9344           break;
9345
9346         case EXEC_SELECT:
9347           /* Select is complicated. Also, a SELECT construct could be
9348              a transformed computed GOTO.  */
9349           resolve_select (code);
9350           break;
9351
9352         case EXEC_SELECT_TYPE:
9353           resolve_select_type (code, ns);
9354           break;
9355
9356         case EXEC_BLOCK:
9357           resolve_block_construct (code);
9358           break;
9359
9360         case EXEC_DO:
9361           if (code->ext.iterator != NULL)
9362             {
9363               gfc_iterator *iter = code->ext.iterator;
9364               if (gfc_resolve_iterator (iter, true) != FAILURE)
9365                 gfc_resolve_do_iterator (code, iter->var->symtree->n.sym);
9366             }
9367           break;
9368
9369         case EXEC_DO_WHILE:
9370           if (code->expr1 == NULL)
9371             gfc_internal_error ("resolve_code(): No expression on DO WHILE");
9372           if (t == SUCCESS
9373               && (code->expr1->rank != 0
9374                   || code->expr1->ts.type != BT_LOGICAL))
9375             gfc_error ("Exit condition of DO WHILE loop at %L must be "
9376                        "a scalar LOGICAL expression", &code->expr1->where);
9377           break;
9378
9379         case EXEC_ALLOCATE:
9380           if (t == SUCCESS)
9381             resolve_allocate_deallocate (code, "ALLOCATE");
9382
9383           break;
9384
9385         case EXEC_DEALLOCATE:
9386           if (t == SUCCESS)
9387             resolve_allocate_deallocate (code, "DEALLOCATE");
9388
9389           break;
9390
9391         case EXEC_OPEN:
9392           if (gfc_resolve_open (code->ext.open) == FAILURE)
9393             break;
9394
9395           resolve_branch (code->ext.open->err, code);
9396           break;
9397
9398         case EXEC_CLOSE:
9399           if (gfc_resolve_close (code->ext.close) == FAILURE)
9400             break;
9401
9402           resolve_branch (code->ext.close->err, code);
9403           break;
9404
9405         case EXEC_BACKSPACE:
9406         case EXEC_ENDFILE:
9407         case EXEC_REWIND:
9408         case EXEC_FLUSH:
9409           if (gfc_resolve_filepos (code->ext.filepos) == FAILURE)
9410             break;
9411
9412           resolve_branch (code->ext.filepos->err, code);
9413           break;
9414
9415         case EXEC_INQUIRE:
9416           if (gfc_resolve_inquire (code->ext.inquire) == FAILURE)
9417               break;
9418
9419           resolve_branch (code->ext.inquire->err, code);
9420           break;
9421
9422         case EXEC_IOLENGTH:
9423           gcc_assert (code->ext.inquire != NULL);
9424           if (gfc_resolve_inquire (code->ext.inquire) == FAILURE)
9425             break;
9426
9427           resolve_branch (code->ext.inquire->err, code);
9428           break;
9429
9430         case EXEC_WAIT:
9431           if (gfc_resolve_wait (code->ext.wait) == FAILURE)
9432             break;
9433
9434           resolve_branch (code->ext.wait->err, code);
9435           resolve_branch (code->ext.wait->end, code);
9436           resolve_branch (code->ext.wait->eor, code);
9437           break;
9438
9439         case EXEC_READ:
9440         case EXEC_WRITE:
9441           if (gfc_resolve_dt (code->ext.dt, &code->loc) == FAILURE)
9442             break;
9443
9444           resolve_branch (code->ext.dt->err, code);
9445           resolve_branch (code->ext.dt->end, code);
9446           resolve_branch (code->ext.dt->eor, code);
9447           break;
9448
9449         case EXEC_TRANSFER:
9450           resolve_transfer (code);
9451           break;
9452
9453         case EXEC_DO_CONCURRENT:
9454         case EXEC_FORALL:
9455           resolve_forall_iterators (code->ext.forall_iterator);
9456
9457           if (code->expr1 != NULL
9458               && (code->expr1->ts.type != BT_LOGICAL || code->expr1->rank))
9459             gfc_error ("FORALL mask clause at %L requires a scalar LOGICAL "
9460                        "expression", &code->expr1->where);
9461           break;
9462
9463         case EXEC_OMP_ATOMIC:
9464         case EXEC_OMP_BARRIER:
9465         case EXEC_OMP_CRITICAL:
9466         case EXEC_OMP_FLUSH:
9467         case EXEC_OMP_DO:
9468         case EXEC_OMP_MASTER:
9469         case EXEC_OMP_ORDERED:
9470         case EXEC_OMP_SECTIONS:
9471         case EXEC_OMP_SINGLE:
9472         case EXEC_OMP_TASKWAIT:
9473         case EXEC_OMP_TASKYIELD:
9474         case EXEC_OMP_WORKSHARE:
9475           gfc_resolve_omp_directive (code, ns);
9476           break;
9477
9478         case EXEC_OMP_PARALLEL:
9479         case EXEC_OMP_PARALLEL_DO:
9480         case EXEC_OMP_PARALLEL_SECTIONS:
9481         case EXEC_OMP_PARALLEL_WORKSHARE:
9482         case EXEC_OMP_TASK:
9483           omp_workshare_save = omp_workshare_flag;
9484           omp_workshare_flag = 0;
9485           gfc_resolve_omp_directive (code, ns);
9486           omp_workshare_flag = omp_workshare_save;
9487           break;
9488
9489         default:
9490           gfc_internal_error ("resolve_code(): Bad statement code");
9491         }
9492     }
9493
9494   cs_base = frame.prev;
9495 }
9496
9497
9498 /* Resolve initial values and make sure they are compatible with
9499    the variable.  */
9500
9501 static void
9502 resolve_values (gfc_symbol *sym)
9503 {
9504   gfc_try t;
9505
9506   if (sym->value == NULL)
9507     return;
9508
9509   if (sym->value->expr_type == EXPR_STRUCTURE)
9510     t= resolve_structure_cons (sym->value, 1);
9511   else
9512     t = gfc_resolve_expr (sym->value);
9513
9514   if (t == FAILURE)
9515     return;
9516
9517   gfc_check_assign_symbol (sym, sym->value);
9518 }
9519
9520
9521 /* Verify the binding labels for common blocks that are BIND(C).  The label
9522    for a BIND(C) common block must be identical in all scoping units in which
9523    the common block is declared.  Further, the binding label can not collide
9524    with any other global entity in the program.  */
9525
9526 static void
9527 resolve_bind_c_comms (gfc_symtree *comm_block_tree)
9528 {
9529   if (comm_block_tree->n.common->is_bind_c == 1)
9530     {
9531       gfc_gsymbol *binding_label_gsym;
9532       gfc_gsymbol *comm_name_gsym;
9533
9534       /* See if a global symbol exists by the common block's name.  It may
9535          be NULL if the common block is use-associated.  */
9536       comm_name_gsym = gfc_find_gsymbol (gfc_gsym_root,
9537                                          comm_block_tree->n.common->name);
9538       if (comm_name_gsym != NULL && comm_name_gsym->type != GSYM_COMMON)
9539         gfc_error ("Binding label '%s' for common block '%s' at %L collides "
9540                    "with the global entity '%s' at %L",
9541                    comm_block_tree->n.common->binding_label,
9542                    comm_block_tree->n.common->name,
9543                    &(comm_block_tree->n.common->where),
9544                    comm_name_gsym->name, &(comm_name_gsym->where));
9545       else if (comm_name_gsym != NULL
9546                && strcmp (comm_name_gsym->name,
9547                           comm_block_tree->n.common->name) == 0)
9548         {
9549           /* TODO: Need to make sure the fields of gfc_gsymbol are initialized
9550              as expected.  */
9551           if (comm_name_gsym->binding_label == NULL)
9552             /* No binding label for common block stored yet; save this one.  */
9553             comm_name_gsym->binding_label =
9554               comm_block_tree->n.common->binding_label;
9555           else
9556             if (strcmp (comm_name_gsym->binding_label,
9557                         comm_block_tree->n.common->binding_label) != 0)
9558               {
9559                 /* Common block names match but binding labels do not.  */
9560                 gfc_error ("Binding label '%s' for common block '%s' at %L "
9561                            "does not match the binding label '%s' for common "
9562                            "block '%s' at %L",
9563                            comm_block_tree->n.common->binding_label,
9564                            comm_block_tree->n.common->name,
9565                            &(comm_block_tree->n.common->where),
9566                            comm_name_gsym->binding_label,
9567                            comm_name_gsym->name,
9568                            &(comm_name_gsym->where));
9569                 return;
9570               }
9571         }
9572
9573       /* There is no binding label (NAME="") so we have nothing further to
9574          check and nothing to add as a global symbol for the label.  */
9575       if (comm_block_tree->n.common->binding_label[0] == '\0' )
9576         return;
9577
9578       binding_label_gsym =
9579         gfc_find_gsymbol (gfc_gsym_root,
9580                           comm_block_tree->n.common->binding_label);
9581       if (binding_label_gsym == NULL)
9582         {
9583           /* Need to make a global symbol for the binding label to prevent
9584              it from colliding with another.  */
9585           binding_label_gsym =
9586             gfc_get_gsymbol (comm_block_tree->n.common->binding_label);
9587           binding_label_gsym->sym_name = comm_block_tree->n.common->name;
9588           binding_label_gsym->type = GSYM_COMMON;
9589         }
9590       else
9591         {
9592           /* If comm_name_gsym is NULL, the name common block is use
9593              associated and the name could be colliding.  */
9594           if (binding_label_gsym->type != GSYM_COMMON)
9595             gfc_error ("Binding label '%s' for common block '%s' at %L "
9596                        "collides with the global entity '%s' at %L",
9597                        comm_block_tree->n.common->binding_label,
9598                        comm_block_tree->n.common->name,
9599                        &(comm_block_tree->n.common->where),
9600                        binding_label_gsym->name,
9601                        &(binding_label_gsym->where));
9602           else if (comm_name_gsym != NULL
9603                    && (strcmp (binding_label_gsym->name,
9604                                comm_name_gsym->binding_label) != 0)
9605                    && (strcmp (binding_label_gsym->sym_name,
9606                                comm_name_gsym->name) != 0))
9607             gfc_error ("Binding label '%s' for common block '%s' at %L "
9608                        "collides with global entity '%s' at %L",
9609                        binding_label_gsym->name, binding_label_gsym->sym_name,
9610                        &(comm_block_tree->n.common->where),
9611                        comm_name_gsym->name, &(comm_name_gsym->where));
9612         }
9613     }
9614
9615   return;
9616 }
9617
9618
9619 /* Verify any BIND(C) derived types in the namespace so we can report errors
9620    for them once, rather than for each variable declared of that type.  */
9621
9622 static void
9623 resolve_bind_c_derived_types (gfc_symbol *derived_sym)
9624 {
9625   if (derived_sym != NULL && derived_sym->attr.flavor == FL_DERIVED
9626       && derived_sym->attr.is_bind_c == 1)
9627     verify_bind_c_derived_type (derived_sym);
9628
9629   return;
9630 }
9631
9632
9633 /* Verify that any binding labels used in a given namespace do not collide
9634    with the names or binding labels of any global symbols.  */
9635
9636 static void
9637 gfc_verify_binding_labels (gfc_symbol *sym)
9638 {
9639   int has_error = 0;
9640
9641   if (sym != NULL && sym->attr.is_bind_c && sym->attr.is_iso_c == 0
9642       && sym->attr.flavor != FL_DERIVED && sym->binding_label[0] != '\0')
9643     {
9644       gfc_gsymbol *bind_c_sym;
9645
9646       bind_c_sym = gfc_find_gsymbol (gfc_gsym_root, sym->binding_label);
9647       if (bind_c_sym != NULL
9648           && strcmp (bind_c_sym->name, sym->binding_label) == 0)
9649         {
9650           if (sym->attr.if_source == IFSRC_DECL
9651               && (bind_c_sym->type != GSYM_SUBROUTINE
9652                   && bind_c_sym->type != GSYM_FUNCTION)
9653               && ((sym->attr.contained == 1
9654                    && strcmp (bind_c_sym->sym_name, sym->name) != 0)
9655                   || (sym->attr.use_assoc == 1
9656                       && (strcmp (bind_c_sym->mod_name, sym->module) != 0))))
9657             {
9658               /* Make sure global procedures don't collide with anything.  */
9659               gfc_error ("Binding label '%s' at %L collides with the global "
9660                          "entity '%s' at %L", sym->binding_label,
9661                          &(sym->declared_at), bind_c_sym->name,
9662                          &(bind_c_sym->where));
9663               has_error = 1;
9664             }
9665           else if (sym->attr.contained == 0
9666                    && (sym->attr.if_source == IFSRC_IFBODY
9667                        && sym->attr.flavor == FL_PROCEDURE)
9668                    && (bind_c_sym->sym_name != NULL
9669                        && strcmp (bind_c_sym->sym_name, sym->name) != 0))
9670             {
9671               /* Make sure procedures in interface bodies don't collide.  */
9672               gfc_error ("Binding label '%s' in interface body at %L collides "
9673                          "with the global entity '%s' at %L",
9674                          sym->binding_label,
9675                          &(sym->declared_at), bind_c_sym->name,
9676                          &(bind_c_sym->where));
9677               has_error = 1;
9678             }
9679           else if (sym->attr.contained == 0
9680                    && sym->attr.if_source == IFSRC_UNKNOWN)
9681             if ((sym->attr.use_assoc && bind_c_sym->mod_name
9682                  && strcmp (bind_c_sym->mod_name, sym->module) != 0)
9683                 || sym->attr.use_assoc == 0)
9684               {
9685                 gfc_error ("Binding label '%s' at %L collides with global "
9686                            "entity '%s' at %L", sym->binding_label,
9687                            &(sym->declared_at), bind_c_sym->name,
9688                            &(bind_c_sym->where));
9689                 has_error = 1;
9690               }
9691
9692           if (has_error != 0)
9693             /* Clear the binding label to prevent checking multiple times.  */
9694             sym->binding_label[0] = '\0';
9695         }
9696       else if (bind_c_sym == NULL)
9697         {
9698           bind_c_sym = gfc_get_gsymbol (sym->binding_label);
9699           bind_c_sym->where = sym->declared_at;
9700           bind_c_sym->sym_name = sym->name;
9701
9702           if (sym->attr.use_assoc == 1)
9703             bind_c_sym->mod_name = sym->module;
9704           else
9705             if (sym->ns->proc_name != NULL)
9706               bind_c_sym->mod_name = sym->ns->proc_name->name;
9707
9708           if (sym->attr.contained == 0)
9709             {
9710               if (sym->attr.subroutine)
9711                 bind_c_sym->type = GSYM_SUBROUTINE;
9712               else if (sym->attr.function)
9713                 bind_c_sym->type = GSYM_FUNCTION;
9714             }
9715         }
9716     }
9717   return;
9718 }
9719
9720
9721 /* Resolve an index expression.  */
9722
9723 static gfc_try
9724 resolve_index_expr (gfc_expr *e)
9725 {
9726   if (gfc_resolve_expr (e) == FAILURE)
9727     return FAILURE;
9728
9729   if (gfc_simplify_expr (e, 0) == FAILURE)
9730     return FAILURE;
9731
9732   if (gfc_specification_expr (e) == FAILURE)
9733     return FAILURE;
9734
9735   return SUCCESS;
9736 }
9737
9738
9739 /* Resolve a charlen structure.  */
9740
9741 static gfc_try
9742 resolve_charlen (gfc_charlen *cl)
9743 {
9744   int i, k;
9745
9746   if (cl->resolved)
9747     return SUCCESS;
9748
9749   cl->resolved = 1;
9750
9751   specification_expr = 1;
9752
9753   if (resolve_index_expr (cl->length) == FAILURE)
9754     {
9755       specification_expr = 0;
9756       return FAILURE;
9757     }
9758
9759   /* "If the character length parameter value evaluates to a negative
9760      value, the length of character entities declared is zero."  */
9761   if (cl->length && !gfc_extract_int (cl->length, &i) && i < 0)
9762     {
9763       if (gfc_option.warn_surprising)
9764         gfc_warning_now ("CHARACTER variable at %L has negative length %d,"
9765                          " the length has been set to zero",
9766                          &cl->length->where, i);
9767       gfc_replace_expr (cl->length,
9768                         gfc_get_int_expr (gfc_default_integer_kind, NULL, 0));
9769     }
9770
9771   /* Check that the character length is not too large.  */
9772   k = gfc_validate_kind (BT_INTEGER, gfc_charlen_int_kind, false);
9773   if (cl->length && cl->length->expr_type == EXPR_CONSTANT
9774       && cl->length->ts.type == BT_INTEGER
9775       && mpz_cmp (cl->length->value.integer, gfc_integer_kinds[k].huge) > 0)
9776     {
9777       gfc_error ("String length at %L is too large", &cl->length->where);
9778       return FAILURE;
9779     }
9780
9781   return SUCCESS;
9782 }
9783
9784
9785 /* Test for non-constant shape arrays.  */
9786
9787 static bool
9788 is_non_constant_shape_array (gfc_symbol *sym)
9789 {
9790   gfc_expr *e;
9791   int i;
9792   bool not_constant;
9793
9794   not_constant = false;
9795   if (sym->as != NULL)
9796     {
9797       /* Unfortunately, !gfc_is_compile_time_shape hits a legal case that
9798          has not been simplified; parameter array references.  Do the
9799          simplification now.  */
9800       for (i = 0; i < sym->as->rank + sym->as->corank; i++)
9801         {
9802           e = sym->as->lower[i];
9803           if (e && (resolve_index_expr (e) == FAILURE
9804                     || !gfc_is_constant_expr (e)))
9805             not_constant = true;
9806           e = sym->as->upper[i];
9807           if (e && (resolve_index_expr (e) == FAILURE
9808                     || !gfc_is_constant_expr (e)))
9809             not_constant = true;
9810         }
9811     }
9812   return not_constant;
9813 }
9814
9815 /* Given a symbol and an initialization expression, add code to initialize
9816    the symbol to the function entry.  */
9817 static void
9818 build_init_assign (gfc_symbol *sym, gfc_expr *init)
9819 {
9820   gfc_expr *lval;
9821   gfc_code *init_st;
9822   gfc_namespace *ns = sym->ns;
9823
9824   /* Search for the function namespace if this is a contained
9825      function without an explicit result.  */
9826   if (sym->attr.function && sym == sym->result
9827       && sym->name != sym->ns->proc_name->name)
9828     {
9829       ns = ns->contained;
9830       for (;ns; ns = ns->sibling)
9831         if (strcmp (ns->proc_name->name, sym->name) == 0)
9832           break;
9833     }
9834
9835   if (ns == NULL)
9836     {
9837       gfc_free_expr (init);
9838       return;
9839     }
9840
9841   /* Build an l-value expression for the result.  */
9842   lval = gfc_lval_expr_from_sym (sym);
9843
9844   /* Add the code at scope entry.  */
9845   init_st = gfc_get_code ();
9846   init_st->next = ns->code;
9847   ns->code = init_st;
9848
9849   /* Assign the default initializer to the l-value.  */
9850   init_st->loc = sym->declared_at;
9851   init_st->op = EXEC_INIT_ASSIGN;
9852   init_st->expr1 = lval;
9853   init_st->expr2 = init;
9854 }
9855
9856 /* Assign the default initializer to a derived type variable or result.  */
9857
9858 static void
9859 apply_default_init (gfc_symbol *sym)
9860 {
9861   gfc_expr *init = NULL;
9862
9863   if (sym->attr.flavor != FL_VARIABLE && !sym->attr.function)
9864     return;
9865
9866   if (sym->ts.type == BT_DERIVED && sym->ts.u.derived)
9867     init = gfc_default_initializer (&sym->ts);
9868
9869   if (init == NULL && sym->ts.type != BT_CLASS)
9870     return;
9871
9872   build_init_assign (sym, init);
9873   sym->attr.referenced = 1;
9874 }
9875
9876 /* Build an initializer for a local integer, real, complex, logical, or
9877    character variable, based on the command line flags finit-local-zero,
9878    finit-integer=, finit-real=, finit-logical=, and finit-runtime.  Returns
9879    null if the symbol should not have a default initialization.  */
9880 static gfc_expr *
9881 build_default_init_expr (gfc_symbol *sym)
9882 {
9883   int char_len;
9884   gfc_expr *init_expr;
9885   int i;
9886
9887   /* These symbols should never have a default initialization.  */
9888   if ((sym->attr.dimension && !gfc_is_compile_time_shape (sym->as))
9889       || sym->attr.external
9890       || sym->attr.dummy
9891       || sym->attr.pointer
9892       || sym->attr.in_equivalence
9893       || sym->attr.in_common
9894       || sym->attr.data
9895       || sym->module
9896       || sym->attr.cray_pointee
9897       || sym->attr.cray_pointer)
9898     return NULL;
9899
9900   /* Now we'll try to build an initializer expression.  */
9901   init_expr = gfc_get_constant_expr (sym->ts.type, sym->ts.kind,
9902                                      &sym->declared_at);
9903
9904   /* We will only initialize integers, reals, complex, logicals, and
9905      characters, and only if the corresponding command-line flags
9906      were set.  Otherwise, we free init_expr and return null.  */
9907   switch (sym->ts.type)
9908     {
9909     case BT_INTEGER:
9910       if (gfc_option.flag_init_integer != GFC_INIT_INTEGER_OFF)
9911         mpz_set_si (init_expr->value.integer,
9912                          gfc_option.flag_init_integer_value);
9913       else
9914         {
9915           gfc_free_expr (init_expr);
9916           init_expr = NULL;
9917         }
9918       break;
9919
9920     case BT_REAL:
9921       switch (gfc_option.flag_init_real)
9922         {
9923         case GFC_INIT_REAL_SNAN:
9924           init_expr->is_snan = 1;
9925           /* Fall through.  */
9926         case GFC_INIT_REAL_NAN:
9927           mpfr_set_nan (init_expr->value.real);
9928           break;
9929
9930         case GFC_INIT_REAL_INF:
9931           mpfr_set_inf (init_expr->value.real, 1);
9932           break;
9933
9934         case GFC_INIT_REAL_NEG_INF:
9935           mpfr_set_inf (init_expr->value.real, -1);
9936           break;
9937
9938         case GFC_INIT_REAL_ZERO:
9939           mpfr_set_ui (init_expr->value.real, 0.0, GFC_RND_MODE);
9940           break;
9941
9942         default:
9943           gfc_free_expr (init_expr);
9944           init_expr = NULL;
9945           break;
9946         }
9947       break;
9948
9949     case BT_COMPLEX:
9950       switch (gfc_option.flag_init_real)
9951         {
9952         case GFC_INIT_REAL_SNAN:
9953           init_expr->is_snan = 1;
9954           /* Fall through.  */
9955         case GFC_INIT_REAL_NAN:
9956           mpfr_set_nan (mpc_realref (init_expr->value.complex));
9957           mpfr_set_nan (mpc_imagref (init_expr->value.complex));
9958           break;
9959
9960         case GFC_INIT_REAL_INF:
9961           mpfr_set_inf (mpc_realref (init_expr->value.complex), 1);
9962           mpfr_set_inf (mpc_imagref (init_expr->value.complex), 1);
9963           break;
9964
9965         case GFC_INIT_REAL_NEG_INF:
9966           mpfr_set_inf (mpc_realref (init_expr->value.complex), -1);
9967           mpfr_set_inf (mpc_imagref (init_expr->value.complex), -1);
9968           break;
9969
9970         case GFC_INIT_REAL_ZERO:
9971           mpc_set_ui (init_expr->value.complex, 0, GFC_MPC_RND_MODE);
9972           break;
9973
9974         default:
9975           gfc_free_expr (init_expr);
9976           init_expr = NULL;
9977           break;
9978         }
9979       break;
9980
9981     case BT_LOGICAL:
9982       if (gfc_option.flag_init_logical == GFC_INIT_LOGICAL_FALSE)
9983         init_expr->value.logical = 0;
9984       else if (gfc_option.flag_init_logical == GFC_INIT_LOGICAL_TRUE)
9985         init_expr->value.logical = 1;
9986       else
9987         {
9988           gfc_free_expr (init_expr);
9989           init_expr = NULL;
9990         }
9991       break;
9992
9993     case BT_CHARACTER:
9994       /* For characters, the length must be constant in order to
9995          create a default initializer.  */
9996       if (gfc_option.flag_init_character == GFC_INIT_CHARACTER_ON
9997           && sym->ts.u.cl->length
9998           && sym->ts.u.cl->length->expr_type == EXPR_CONSTANT)
9999         {
10000           char_len = mpz_get_si (sym->ts.u.cl->length->value.integer);
10001           init_expr->value.character.length = char_len;
10002           init_expr->value.character.string = gfc_get_wide_string (char_len+1);
10003           for (i = 0; i < char_len; i++)
10004             init_expr->value.character.string[i]
10005               = (unsigned char) gfc_option.flag_init_character_value;
10006         }
10007       else
10008         {
10009           gfc_free_expr (init_expr);
10010           init_expr = NULL;
10011         }
10012       break;
10013
10014     default:
10015      gfc_free_expr (init_expr);
10016      init_expr = NULL;
10017     }
10018   return init_expr;
10019 }
10020
10021 /* Add an initialization expression to a local variable.  */
10022 static void
10023 apply_default_init_local (gfc_symbol *sym)
10024 {
10025   gfc_expr *init = NULL;
10026
10027   /* The symbol should be a variable or a function return value.  */
10028   if ((sym->attr.flavor != FL_VARIABLE && !sym->attr.function)
10029       || (sym->attr.function && sym->result != sym))
10030     return;
10031
10032   /* Try to build the initializer expression.  If we can't initialize
10033      this symbol, then init will be NULL.  */
10034   init = build_default_init_expr (sym);
10035   if (init == NULL)
10036     return;
10037
10038   /* For saved variables, we don't want to add an initializer at
10039      function entry, so we just add a static initializer.  */
10040   if (sym->attr.save || sym->ns->save_all
10041       || gfc_option.flag_max_stack_var_size == 0)
10042     {
10043       /* Don't clobber an existing initializer!  */
10044       gcc_assert (sym->value == NULL);
10045       sym->value = init;
10046       return;
10047     }
10048
10049   build_init_assign (sym, init);
10050 }
10051
10052
10053 /* Resolution of common features of flavors variable and procedure.  */
10054
10055 static gfc_try
10056 resolve_fl_var_and_proc (gfc_symbol *sym, int mp_flag)
10057 {
10058   /* Avoid double diagnostics for function result symbols.  */
10059   if ((sym->result || sym->attr.result) && !sym->attr.dummy
10060       && (sym->ns != gfc_current_ns))
10061     return SUCCESS;
10062
10063   /* Constraints on deferred shape variable.  */
10064   if (sym->as == NULL || sym->as->type != AS_DEFERRED)
10065     {
10066       if (sym->attr.allocatable)
10067         {
10068           if (sym->attr.dimension)
10069             {
10070               gfc_error ("Allocatable array '%s' at %L must have "
10071                          "a deferred shape", sym->name, &sym->declared_at);
10072               return FAILURE;
10073             }
10074           else if (gfc_notify_std (GFC_STD_F2003, "Scalar object '%s' at %L "
10075                                    "may not be ALLOCATABLE", sym->name,
10076                                    &sym->declared_at) == FAILURE)
10077             return FAILURE;
10078         }
10079
10080       if (sym->attr.pointer && sym->attr.dimension)
10081         {
10082           gfc_error ("Array pointer '%s' at %L must have a deferred shape",
10083                      sym->name, &sym->declared_at);
10084           return FAILURE;
10085         }
10086     }
10087   else
10088     {
10089       if (!mp_flag && !sym->attr.allocatable && !sym->attr.pointer
10090           && sym->ts.type != BT_CLASS && !sym->assoc)
10091         {
10092           gfc_error ("Array '%s' at %L cannot have a deferred shape",
10093                      sym->name, &sym->declared_at);
10094           return FAILURE;
10095          }
10096     }
10097
10098   /* Constraints on polymorphic variables.  */
10099   if (sym->ts.type == BT_CLASS && !(sym->result && sym->result != sym))
10100     {
10101       /* F03:C502.  */
10102       if (sym->attr.class_ok
10103           && !gfc_type_is_extensible (CLASS_DATA (sym)->ts.u.derived))
10104         {
10105           gfc_error ("Type '%s' of CLASS variable '%s' at %L is not extensible",
10106                      CLASS_DATA (sym)->ts.u.derived->name, sym->name,
10107                      &sym->declared_at);
10108           return FAILURE;
10109         }
10110
10111       /* F03:C509.  */
10112       /* Assume that use associated symbols were checked in the module ns.
10113          Class-variables that are associate-names are also something special
10114          and excepted from the test.  */
10115       if (!sym->attr.class_ok && !sym->attr.use_assoc && !sym->assoc)
10116         {
10117           gfc_error ("CLASS variable '%s' at %L must be dummy, allocatable "
10118                      "or pointer", sym->name, &sym->declared_at);
10119           return FAILURE;
10120         }
10121     }
10122
10123   return SUCCESS;
10124 }
10125
10126
10127 /* Additional checks for symbols with flavor variable and derived
10128    type.  To be called from resolve_fl_variable.  */
10129
10130 static gfc_try
10131 resolve_fl_variable_derived (gfc_symbol *sym, int no_init_flag)
10132 {
10133   gcc_assert (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS);
10134
10135   /* Check to see if a derived type is blocked from being host
10136      associated by the presence of another class I symbol in the same
10137      namespace.  14.6.1.3 of the standard and the discussion on
10138      comp.lang.fortran.  */
10139   if (sym->ns != sym->ts.u.derived->ns
10140       && sym->ns->proc_name->attr.if_source != IFSRC_IFBODY)
10141     {
10142       gfc_symbol *s;
10143       gfc_find_symbol (sym->ts.u.derived->name, sym->ns, 0, &s);
10144       if (s && s->attr.flavor != FL_DERIVED)
10145         {
10146           gfc_error ("The type '%s' cannot be host associated at %L "
10147                      "because it is blocked by an incompatible object "
10148                      "of the same name declared at %L",
10149                      sym->ts.u.derived->name, &sym->declared_at,
10150                      &s->declared_at);
10151           return FAILURE;
10152         }
10153     }
10154
10155   /* 4th constraint in section 11.3: "If an object of a type for which
10156      component-initialization is specified (R429) appears in the
10157      specification-part of a module and does not have the ALLOCATABLE
10158      or POINTER attribute, the object shall have the SAVE attribute."
10159
10160      The check for initializers is performed with
10161      gfc_has_default_initializer because gfc_default_initializer generates
10162      a hidden default for allocatable components.  */
10163   if (!(sym->value || no_init_flag) && sym->ns->proc_name
10164       && sym->ns->proc_name->attr.flavor == FL_MODULE
10165       && !sym->ns->save_all && !sym->attr.save
10166       && !sym->attr.pointer && !sym->attr.allocatable
10167       && gfc_has_default_initializer (sym->ts.u.derived)
10168       && gfc_notify_std (GFC_STD_F2008, "Fortran 2008: Implied SAVE for "
10169                          "module variable '%s' at %L, needed due to "
10170                          "the default initialization", sym->name,
10171                          &sym->declared_at) == FAILURE)
10172     return FAILURE;
10173
10174   /* Assign default initializer.  */
10175   if (!(sym->value || sym->attr.pointer || sym->attr.allocatable)
10176       && (!no_init_flag || sym->attr.intent == INTENT_OUT))
10177     {
10178       sym->value = gfc_default_initializer (&sym->ts);
10179     }
10180
10181   return SUCCESS;
10182 }
10183
10184
10185 /* Resolve symbols with flavor variable.  */
10186
10187 static gfc_try
10188 resolve_fl_variable (gfc_symbol *sym, int mp_flag)
10189 {
10190   int no_init_flag, automatic_flag;
10191   gfc_expr *e;
10192   const char *auto_save_msg;
10193
10194   auto_save_msg = "Automatic object '%s' at %L cannot have the "
10195                   "SAVE attribute";
10196
10197   if (resolve_fl_var_and_proc (sym, mp_flag) == FAILURE)
10198     return FAILURE;
10199
10200   /* Set this flag to check that variables are parameters of all entries.
10201      This check is effected by the call to gfc_resolve_expr through
10202      is_non_constant_shape_array.  */
10203   specification_expr = 1;
10204
10205   if (sym->ns->proc_name
10206       && (sym->ns->proc_name->attr.flavor == FL_MODULE
10207           || sym->ns->proc_name->attr.is_main_program)
10208       && !sym->attr.use_assoc
10209       && !sym->attr.allocatable
10210       && !sym->attr.pointer
10211       && is_non_constant_shape_array (sym))
10212     {
10213       /* The shape of a main program or module array needs to be
10214          constant.  */
10215       gfc_error ("The module or main program array '%s' at %L must "
10216                  "have constant shape", sym->name, &sym->declared_at);
10217       specification_expr = 0;
10218       return FAILURE;
10219     }
10220
10221   /* Constraints on deferred type parameter.  */
10222   if (sym->ts.deferred && !(sym->attr.pointer || sym->attr.allocatable))
10223     {
10224       gfc_error ("Entity '%s' at %L has a deferred type parameter and "
10225                  "requires either the pointer or allocatable attribute",
10226                      sym->name, &sym->declared_at);
10227       return FAILURE;
10228     }
10229
10230   if (sym->ts.type == BT_CHARACTER)
10231     {
10232       /* Make sure that character string variables with assumed length are
10233          dummy arguments.  */
10234       e = sym->ts.u.cl->length;
10235       if (e == NULL && !sym->attr.dummy && !sym->attr.result
10236           && !sym->ts.deferred)
10237         {
10238           gfc_error ("Entity with assumed character length at %L must be a "
10239                      "dummy argument or a PARAMETER", &sym->declared_at);
10240           return FAILURE;
10241         }
10242
10243       if (e && sym->attr.save == SAVE_EXPLICIT && !gfc_is_constant_expr (e))
10244         {
10245           gfc_error (auto_save_msg, sym->name, &sym->declared_at);
10246           return FAILURE;
10247         }
10248
10249       if (!gfc_is_constant_expr (e)
10250           && !(e->expr_type == EXPR_VARIABLE
10251                && e->symtree->n.sym->attr.flavor == FL_PARAMETER))
10252         {
10253           if (!sym->attr.use_assoc && sym->ns->proc_name
10254               && (sym->ns->proc_name->attr.flavor == FL_MODULE
10255                   || sym->ns->proc_name->attr.is_main_program))
10256             {
10257               gfc_error ("'%s' at %L must have constant character length "
10258                         "in this context", sym->name, &sym->declared_at);
10259               return FAILURE;
10260             }
10261           if (sym->attr.in_common)
10262             {
10263               gfc_error ("COMMON variable '%s' at %L must have constant "
10264                          "character length", sym->name, &sym->declared_at);
10265               return FAILURE;
10266             }
10267         }
10268     }
10269
10270   if (sym->value == NULL && sym->attr.referenced)
10271     apply_default_init_local (sym); /* Try to apply a default initialization.  */
10272
10273   /* Determine if the symbol may not have an initializer.  */
10274   no_init_flag = automatic_flag = 0;
10275   if (sym->attr.allocatable || sym->attr.external || sym->attr.dummy
10276       || sym->attr.intrinsic || sym->attr.result)
10277     no_init_flag = 1;
10278   else if ((sym->attr.dimension || sym->attr.codimension) && !sym->attr.pointer
10279            && is_non_constant_shape_array (sym))
10280     {
10281       no_init_flag = automatic_flag = 1;
10282
10283       /* Also, they must not have the SAVE attribute.
10284          SAVE_IMPLICIT is checked below.  */
10285       if (sym->as && sym->attr.codimension)
10286         {
10287           int corank = sym->as->corank;
10288           sym->as->corank = 0;
10289           no_init_flag = automatic_flag = is_non_constant_shape_array (sym);
10290           sym->as->corank = corank;
10291         }
10292       if (automatic_flag && sym->attr.save == SAVE_EXPLICIT)
10293         {
10294           gfc_error (auto_save_msg, sym->name, &sym->declared_at);
10295           return FAILURE;
10296         }
10297     }
10298
10299   /* Ensure that any initializer is simplified.  */
10300   if (sym->value)
10301     gfc_simplify_expr (sym->value, 1);
10302
10303   /* Reject illegal initializers.  */
10304   if (!sym->mark && sym->value)
10305     {
10306       if (sym->attr.allocatable || (sym->ts.type == BT_CLASS
10307                                     && CLASS_DATA (sym)->attr.allocatable))
10308         gfc_error ("Allocatable '%s' at %L cannot have an initializer",
10309                    sym->name, &sym->declared_at);
10310       else if (sym->attr.external)
10311         gfc_error ("External '%s' at %L cannot have an initializer",
10312                    sym->name, &sym->declared_at);
10313       else if (sym->attr.dummy
10314         && !(sym->ts.type == BT_DERIVED && sym->attr.intent == INTENT_OUT))
10315         gfc_error ("Dummy '%s' at %L cannot have an initializer",
10316                    sym->name, &sym->declared_at);
10317       else if (sym->attr.intrinsic)
10318         gfc_error ("Intrinsic '%s' at %L cannot have an initializer",
10319                    sym->name, &sym->declared_at);
10320       else if (sym->attr.result)
10321         gfc_error ("Function result '%s' at %L cannot have an initializer",
10322                    sym->name, &sym->declared_at);
10323       else if (automatic_flag)
10324         gfc_error ("Automatic array '%s' at %L cannot have an initializer",
10325                    sym->name, &sym->declared_at);
10326       else
10327         goto no_init_error;
10328       return FAILURE;
10329     }
10330
10331 no_init_error:
10332   if (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS)
10333     return resolve_fl_variable_derived (sym, no_init_flag);
10334
10335   return SUCCESS;
10336 }
10337
10338
10339 /* Resolve a procedure.  */
10340
10341 static gfc_try
10342 resolve_fl_procedure (gfc_symbol *sym, int mp_flag)
10343 {
10344   gfc_formal_arglist *arg;
10345
10346   if (sym->attr.function
10347       && resolve_fl_var_and_proc (sym, mp_flag) == FAILURE)
10348     return FAILURE;
10349
10350   if (sym->ts.type == BT_CHARACTER)
10351     {
10352       gfc_charlen *cl = sym->ts.u.cl;
10353
10354       if (cl && cl->length && gfc_is_constant_expr (cl->length)
10355              && resolve_charlen (cl) == FAILURE)
10356         return FAILURE;
10357
10358       if ((!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT)
10359           && sym->attr.proc == PROC_ST_FUNCTION)
10360         {
10361           gfc_error ("Character-valued statement function '%s' at %L must "
10362                      "have constant length", sym->name, &sym->declared_at);
10363           return FAILURE;
10364         }
10365     }
10366
10367   /* Ensure that derived type for are not of a private type.  Internal
10368      module procedures are excluded by 2.2.3.3 - i.e., they are not
10369      externally accessible and can access all the objects accessible in
10370      the host.  */
10371   if (!(sym->ns->parent
10372         && sym->ns->parent->proc_name->attr.flavor == FL_MODULE)
10373       && gfc_check_symbol_access (sym))
10374     {
10375       gfc_interface *iface;
10376
10377       for (arg = sym->formal; arg; arg = arg->next)
10378         {
10379           if (arg->sym
10380               && arg->sym->ts.type == BT_DERIVED
10381               && !arg->sym->ts.u.derived->attr.use_assoc
10382               && !gfc_check_symbol_access (arg->sym->ts.u.derived)
10383               && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: '%s' is of a "
10384                                  "PRIVATE type and cannot be a dummy argument"
10385                                  " of '%s', which is PUBLIC at %L",
10386                                  arg->sym->name, sym->name, &sym->declared_at)
10387                  == FAILURE)
10388             {
10389               /* Stop this message from recurring.  */
10390               arg->sym->ts.u.derived->attr.access = ACCESS_PUBLIC;
10391               return FAILURE;
10392             }
10393         }
10394
10395       /* PUBLIC interfaces may expose PRIVATE procedures that take types
10396          PRIVATE to the containing module.  */
10397       for (iface = sym->generic; iface; iface = iface->next)
10398         {
10399           for (arg = iface->sym->formal; arg; arg = arg->next)
10400             {
10401               if (arg->sym
10402                   && arg->sym->ts.type == BT_DERIVED
10403                   && !arg->sym->ts.u.derived->attr.use_assoc
10404                   && !gfc_check_symbol_access (arg->sym->ts.u.derived)
10405                   && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Procedure "
10406                                      "'%s' in PUBLIC interface '%s' at %L "
10407                                      "takes dummy arguments of '%s' which is "
10408                                      "PRIVATE", iface->sym->name, sym->name,
10409                                      &iface->sym->declared_at,
10410                                      gfc_typename (&arg->sym->ts)) == FAILURE)
10411                 {
10412                   /* Stop this message from recurring.  */
10413                   arg->sym->ts.u.derived->attr.access = ACCESS_PUBLIC;
10414                   return FAILURE;
10415                 }
10416              }
10417         }
10418
10419       /* PUBLIC interfaces may expose PRIVATE procedures that take types
10420          PRIVATE to the containing module.  */
10421       for (iface = sym->generic; iface; iface = iface->next)
10422         {
10423           for (arg = iface->sym->formal; arg; arg = arg->next)
10424             {
10425               if (arg->sym
10426                   && arg->sym->ts.type == BT_DERIVED
10427                   && !arg->sym->ts.u.derived->attr.use_assoc
10428                   && !gfc_check_symbol_access (arg->sym->ts.u.derived)
10429                   && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Procedure "
10430                                      "'%s' in PUBLIC interface '%s' at %L "
10431                                      "takes dummy arguments of '%s' which is "
10432                                      "PRIVATE", iface->sym->name, sym->name,
10433                                      &iface->sym->declared_at,
10434                                      gfc_typename (&arg->sym->ts)) == FAILURE)
10435                 {
10436                   /* Stop this message from recurring.  */
10437                   arg->sym->ts.u.derived->attr.access = ACCESS_PUBLIC;
10438                   return FAILURE;
10439                 }
10440              }
10441         }
10442     }
10443
10444   if (sym->attr.function && sym->value && sym->attr.proc != PROC_ST_FUNCTION
10445       && !sym->attr.proc_pointer)
10446     {
10447       gfc_error ("Function '%s' at %L cannot have an initializer",
10448                  sym->name, &sym->declared_at);
10449       return FAILURE;
10450     }
10451
10452   /* An external symbol may not have an initializer because it is taken to be
10453      a procedure. Exception: Procedure Pointers.  */
10454   if (sym->attr.external && sym->value && !sym->attr.proc_pointer)
10455     {
10456       gfc_error ("External object '%s' at %L may not have an initializer",
10457                  sym->name, &sym->declared_at);
10458       return FAILURE;
10459     }
10460
10461   /* An elemental function is required to return a scalar 12.7.1  */
10462   if (sym->attr.elemental && sym->attr.function && sym->as)
10463     {
10464       gfc_error ("ELEMENTAL function '%s' at %L must have a scalar "
10465                  "result", sym->name, &sym->declared_at);
10466       /* Reset so that the error only occurs once.  */
10467       sym->attr.elemental = 0;
10468       return FAILURE;
10469     }
10470
10471   if (sym->attr.proc == PROC_ST_FUNCTION
10472       && (sym->attr.allocatable || sym->attr.pointer))
10473     {
10474       gfc_error ("Statement function '%s' at %L may not have pointer or "
10475                  "allocatable attribute", sym->name, &sym->declared_at);
10476       return FAILURE;
10477     }
10478
10479   /* 5.1.1.5 of the Standard: A function name declared with an asterisk
10480      char-len-param shall not be array-valued, pointer-valued, recursive
10481      or pure.  ....snip... A character value of * may only be used in the
10482      following ways: (i) Dummy arg of procedure - dummy associates with
10483      actual length; (ii) To declare a named constant; or (iii) External
10484      function - but length must be declared in calling scoping unit.  */
10485   if (sym->attr.function
10486       && sym->ts.type == BT_CHARACTER
10487       && sym->ts.u.cl && sym->ts.u.cl->length == NULL)
10488     {
10489       if ((sym->as && sym->as->rank) || (sym->attr.pointer)
10490           || (sym->attr.recursive) || (sym->attr.pure))
10491         {
10492           if (sym->as && sym->as->rank)
10493             gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
10494                        "array-valued", sym->name, &sym->declared_at);
10495
10496           if (sym->attr.pointer)
10497             gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
10498                        "pointer-valued", sym->name, &sym->declared_at);
10499
10500           if (sym->attr.pure)
10501             gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
10502                        "pure", sym->name, &sym->declared_at);
10503
10504           if (sym->attr.recursive)
10505             gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
10506                        "recursive", sym->name, &sym->declared_at);
10507
10508           return FAILURE;
10509         }
10510
10511       /* Appendix B.2 of the standard.  Contained functions give an
10512          error anyway.  Fixed-form is likely to be F77/legacy. Deferred
10513          character length is an F2003 feature.  */
10514       if (!sym->attr.contained
10515             && gfc_current_form != FORM_FIXED
10516             && !sym->ts.deferred)
10517         gfc_notify_std (GFC_STD_F95_OBS, "Obsolescent feature: "
10518                         "CHARACTER(*) function '%s' at %L",
10519                         sym->name, &sym->declared_at);
10520     }
10521
10522   if (sym->attr.is_bind_c && sym->attr.is_c_interop != 1)
10523     {
10524       gfc_formal_arglist *curr_arg;
10525       int has_non_interop_arg = 0;
10526
10527       if (verify_bind_c_sym (sym, &(sym->ts), sym->attr.in_common,
10528                              sym->common_block) == FAILURE)
10529         {
10530           /* Clear these to prevent looking at them again if there was an
10531              error.  */
10532           sym->attr.is_bind_c = 0;
10533           sym->attr.is_c_interop = 0;
10534           sym->ts.is_c_interop = 0;
10535         }
10536       else
10537         {
10538           /* So far, no errors have been found.  */
10539           sym->attr.is_c_interop = 1;
10540           sym->ts.is_c_interop = 1;
10541         }
10542
10543       curr_arg = sym->formal;
10544       while (curr_arg != NULL)
10545         {
10546           /* Skip implicitly typed dummy args here.  */
10547           if (curr_arg->sym->attr.implicit_type == 0)
10548             if (gfc_verify_c_interop_param (curr_arg->sym) == FAILURE)
10549               /* If something is found to fail, record the fact so we
10550                  can mark the symbol for the procedure as not being
10551                  BIND(C) to try and prevent multiple errors being
10552                  reported.  */
10553               has_non_interop_arg = 1;
10554
10555           curr_arg = curr_arg->next;
10556         }
10557
10558       /* See if any of the arguments were not interoperable and if so, clear
10559          the procedure symbol to prevent duplicate error messages.  */
10560       if (has_non_interop_arg != 0)
10561         {
10562           sym->attr.is_c_interop = 0;
10563           sym->ts.is_c_interop = 0;
10564           sym->attr.is_bind_c = 0;
10565         }
10566     }
10567
10568   if (!sym->attr.proc_pointer)
10569     {
10570       if (sym->attr.save == SAVE_EXPLICIT)
10571         {
10572           gfc_error ("PROCEDURE attribute conflicts with SAVE attribute "
10573                      "in '%s' at %L", sym->name, &sym->declared_at);
10574           return FAILURE;
10575         }
10576       if (sym->attr.intent)
10577         {
10578           gfc_error ("PROCEDURE attribute conflicts with INTENT attribute "
10579                      "in '%s' at %L", sym->name, &sym->declared_at);
10580           return FAILURE;
10581         }
10582       if (sym->attr.subroutine && sym->attr.result)
10583         {
10584           gfc_error ("PROCEDURE attribute conflicts with RESULT attribute "
10585                      "in '%s' at %L", sym->name, &sym->declared_at);
10586           return FAILURE;
10587         }
10588       if (sym->attr.external && sym->attr.function
10589           && ((sym->attr.if_source == IFSRC_DECL && !sym->attr.procedure)
10590               || sym->attr.contained))
10591         {
10592           gfc_error ("EXTERNAL attribute conflicts with FUNCTION attribute "
10593                      "in '%s' at %L", sym->name, &sym->declared_at);
10594           return FAILURE;
10595         }
10596       if (strcmp ("ppr@", sym->name) == 0)
10597         {
10598           gfc_error ("Procedure pointer result '%s' at %L "
10599                      "is missing the pointer attribute",
10600                      sym->ns->proc_name->name, &sym->declared_at);
10601           return FAILURE;
10602         }
10603     }
10604
10605   return SUCCESS;
10606 }
10607
10608
10609 /* Resolve a list of finalizer procedures.  That is, after they have hopefully
10610    been defined and we now know their defined arguments, check that they fulfill
10611    the requirements of the standard for procedures used as finalizers.  */
10612
10613 static gfc_try
10614 gfc_resolve_finalizers (gfc_symbol* derived)
10615 {
10616   gfc_finalizer* list;
10617   gfc_finalizer** prev_link; /* For removing wrong entries from the list.  */
10618   gfc_try result = SUCCESS;
10619   bool seen_scalar = false;
10620
10621   if (!derived->f2k_derived || !derived->f2k_derived->finalizers)
10622     return SUCCESS;
10623
10624   /* Walk over the list of finalizer-procedures, check them, and if any one
10625      does not fit in with the standard's definition, print an error and remove
10626      it from the list.  */
10627   prev_link = &derived->f2k_derived->finalizers;
10628   for (list = derived->f2k_derived->finalizers; list; list = *prev_link)
10629     {
10630       gfc_symbol* arg;
10631       gfc_finalizer* i;
10632       int my_rank;
10633
10634       /* Skip this finalizer if we already resolved it.  */
10635       if (list->proc_tree)
10636         {
10637           prev_link = &(list->next);
10638           continue;
10639         }
10640
10641       /* Check this exists and is a SUBROUTINE.  */
10642       if (!list->proc_sym->attr.subroutine)
10643         {
10644           gfc_error ("FINAL procedure '%s' at %L is not a SUBROUTINE",
10645                      list->proc_sym->name, &list->where);
10646           goto error;
10647         }
10648
10649       /* We should have exactly one argument.  */
10650       if (!list->proc_sym->formal || list->proc_sym->formal->next)
10651         {
10652           gfc_error ("FINAL procedure at %L must have exactly one argument",
10653                      &list->where);
10654           goto error;
10655         }
10656       arg = list->proc_sym->formal->sym;
10657
10658       /* This argument must be of our type.  */
10659       if (arg->ts.type != BT_DERIVED || arg->ts.u.derived != derived)
10660         {
10661           gfc_error ("Argument of FINAL procedure at %L must be of type '%s'",
10662                      &arg->declared_at, derived->name);
10663           goto error;
10664         }
10665
10666       /* It must neither be a pointer nor allocatable nor optional.  */
10667       if (arg->attr.pointer)
10668         {
10669           gfc_error ("Argument of FINAL procedure at %L must not be a POINTER",
10670                      &arg->declared_at);
10671           goto error;
10672         }
10673       if (arg->attr.allocatable)
10674         {
10675           gfc_error ("Argument of FINAL procedure at %L must not be"
10676                      " ALLOCATABLE", &arg->declared_at);
10677           goto error;
10678         }
10679       if (arg->attr.optional)
10680         {
10681           gfc_error ("Argument of FINAL procedure at %L must not be OPTIONAL",
10682                      &arg->declared_at);
10683           goto error;
10684         }
10685
10686       /* It must not be INTENT(OUT).  */
10687       if (arg->attr.intent == INTENT_OUT)
10688         {
10689           gfc_error ("Argument of FINAL procedure at %L must not be"
10690                      " INTENT(OUT)", &arg->declared_at);
10691           goto error;
10692         }
10693
10694       /* Warn if the procedure is non-scalar and not assumed shape.  */
10695       if (gfc_option.warn_surprising && arg->as && arg->as->rank > 0
10696           && arg->as->type != AS_ASSUMED_SHAPE)
10697         gfc_warning ("Non-scalar FINAL procedure at %L should have assumed"
10698                      " shape argument", &arg->declared_at);
10699
10700       /* Check that it does not match in kind and rank with a FINAL procedure
10701          defined earlier.  To really loop over the *earlier* declarations,
10702          we need to walk the tail of the list as new ones were pushed at the
10703          front.  */
10704       /* TODO: Handle kind parameters once they are implemented.  */
10705       my_rank = (arg->as ? arg->as->rank : 0);
10706       for (i = list->next; i; i = i->next)
10707         {
10708           /* Argument list might be empty; that is an error signalled earlier,
10709              but we nevertheless continued resolving.  */
10710           if (i->proc_sym->formal)
10711             {
10712               gfc_symbol* i_arg = i->proc_sym->formal->sym;
10713               const int i_rank = (i_arg->as ? i_arg->as->rank : 0);
10714               if (i_rank == my_rank)
10715                 {
10716                   gfc_error ("FINAL procedure '%s' declared at %L has the same"
10717                              " rank (%d) as '%s'",
10718                              list->proc_sym->name, &list->where, my_rank,
10719                              i->proc_sym->name);
10720                   goto error;
10721                 }
10722             }
10723         }
10724
10725         /* Is this the/a scalar finalizer procedure?  */
10726         if (!arg->as || arg->as->rank == 0)
10727           seen_scalar = true;
10728
10729         /* Find the symtree for this procedure.  */
10730         gcc_assert (!list->proc_tree);
10731         list->proc_tree = gfc_find_sym_in_symtree (list->proc_sym);
10732
10733         prev_link = &list->next;
10734         continue;
10735
10736         /* Remove wrong nodes immediately from the list so we don't risk any
10737            troubles in the future when they might fail later expectations.  */
10738 error:
10739         result = FAILURE;
10740         i = list;
10741         *prev_link = list->next;
10742         gfc_free_finalizer (i);
10743     }
10744
10745   /* Warn if we haven't seen a scalar finalizer procedure (but we know there
10746      were nodes in the list, must have been for arrays.  It is surely a good
10747      idea to have a scalar version there if there's something to finalize.  */
10748   if (gfc_option.warn_surprising && result == SUCCESS && !seen_scalar)
10749     gfc_warning ("Only array FINAL procedures declared for derived type '%s'"
10750                  " defined at %L, suggest also scalar one",
10751                  derived->name, &derived->declared_at);
10752
10753   /* TODO:  Remove this error when finalization is finished.  */
10754   gfc_error ("Finalization at %L is not yet implemented",
10755              &derived->declared_at);
10756
10757   return result;
10758 }
10759
10760
10761 /* Check if two GENERIC targets are ambiguous and emit an error is they are.  */
10762
10763 static gfc_try
10764 check_generic_tbp_ambiguity (gfc_tbp_generic* t1, gfc_tbp_generic* t2,
10765                              const char* generic_name, locus where)
10766 {
10767   gfc_symbol* sym1;
10768   gfc_symbol* sym2;
10769
10770   gcc_assert (t1->specific && t2->specific);
10771   gcc_assert (!t1->specific->is_generic);
10772   gcc_assert (!t2->specific->is_generic);
10773
10774   sym1 = t1->specific->u.specific->n.sym;
10775   sym2 = t2->specific->u.specific->n.sym;
10776
10777   if (sym1 == sym2)
10778     return SUCCESS;
10779
10780   /* Both must be SUBROUTINEs or both must be FUNCTIONs.  */
10781   if (sym1->attr.subroutine != sym2->attr.subroutine
10782       || sym1->attr.function != sym2->attr.function)
10783     {
10784       gfc_error ("'%s' and '%s' can't be mixed FUNCTION/SUBROUTINE for"
10785                  " GENERIC '%s' at %L",
10786                  sym1->name, sym2->name, generic_name, &where);
10787       return FAILURE;
10788     }
10789
10790   /* Compare the interfaces.  */
10791   if (gfc_compare_interfaces (sym1, sym2, sym2->name, 1, 0, NULL, 0))
10792     {
10793       gfc_error ("'%s' and '%s' for GENERIC '%s' at %L are ambiguous",
10794                  sym1->name, sym2->name, generic_name, &where);
10795       return FAILURE;
10796     }
10797
10798   return SUCCESS;
10799 }
10800
10801
10802 /* Worker function for resolving a generic procedure binding; this is used to
10803    resolve GENERIC as well as user and intrinsic OPERATOR typebound procedures.
10804
10805    The difference between those cases is finding possible inherited bindings
10806    that are overridden, as one has to look for them in tb_sym_root,
10807    tb_uop_root or tb_op, respectively.  Thus the caller must already find
10808    the super-type and set p->overridden correctly.  */
10809
10810 static gfc_try
10811 resolve_tb_generic_targets (gfc_symbol* super_type,
10812                             gfc_typebound_proc* p, const char* name)
10813 {
10814   gfc_tbp_generic* target;
10815   gfc_symtree* first_target;
10816   gfc_symtree* inherited;
10817
10818   gcc_assert (p && p->is_generic);
10819
10820   /* Try to find the specific bindings for the symtrees in our target-list.  */
10821   gcc_assert (p->u.generic);
10822   for (target = p->u.generic; target; target = target->next)
10823     if (!target->specific)
10824       {
10825         gfc_typebound_proc* overridden_tbp;
10826         gfc_tbp_generic* g;
10827         const char* target_name;
10828
10829         target_name = target->specific_st->name;
10830
10831         /* Defined for this type directly.  */
10832         if (target->specific_st->n.tb && !target->specific_st->n.tb->error)
10833           {
10834             target->specific = target->specific_st->n.tb;
10835             goto specific_found;
10836           }
10837
10838         /* Look for an inherited specific binding.  */
10839         if (super_type)
10840           {
10841             inherited = gfc_find_typebound_proc (super_type, NULL, target_name,
10842                                                  true, NULL);
10843
10844             if (inherited)
10845               {
10846                 gcc_assert (inherited->n.tb);
10847                 target->specific = inherited->n.tb;
10848                 goto specific_found;
10849               }
10850           }
10851
10852         gfc_error ("Undefined specific binding '%s' as target of GENERIC '%s'"
10853                    " at %L", target_name, name, &p->where);
10854         return FAILURE;
10855
10856         /* Once we've found the specific binding, check it is not ambiguous with
10857            other specifics already found or inherited for the same GENERIC.  */
10858 specific_found:
10859         gcc_assert (target->specific);
10860
10861         /* This must really be a specific binding!  */
10862         if (target->specific->is_generic)
10863           {
10864             gfc_error ("GENERIC '%s' at %L must target a specific binding,"
10865                        " '%s' is GENERIC, too", name, &p->where, target_name);
10866             return FAILURE;
10867           }
10868
10869         /* Check those already resolved on this type directly.  */
10870         for (g = p->u.generic; g; g = g->next)
10871           if (g != target && g->specific
10872               && check_generic_tbp_ambiguity (target, g, name, p->where)
10873                   == FAILURE)
10874             return FAILURE;
10875
10876         /* Check for ambiguity with inherited specific targets.  */
10877         for (overridden_tbp = p->overridden; overridden_tbp;
10878              overridden_tbp = overridden_tbp->overridden)
10879           if (overridden_tbp->is_generic)
10880             {
10881               for (g = overridden_tbp->u.generic; g; g = g->next)
10882                 {
10883                   gcc_assert (g->specific);
10884                   if (check_generic_tbp_ambiguity (target, g,
10885                                                    name, p->where) == FAILURE)
10886                     return FAILURE;
10887                 }
10888             }
10889       }
10890
10891   /* If we attempt to "overwrite" a specific binding, this is an error.  */
10892   if (p->overridden && !p->overridden->is_generic)
10893     {
10894       gfc_error ("GENERIC '%s' at %L can't overwrite specific binding with"
10895                  " the same name", name, &p->where);
10896       return FAILURE;
10897     }
10898
10899   /* Take the SUBROUTINE/FUNCTION attributes of the first specific target, as
10900      all must have the same attributes here.  */
10901   first_target = p->u.generic->specific->u.specific;
10902   gcc_assert (first_target);
10903   p->subroutine = first_target->n.sym->attr.subroutine;
10904   p->function = first_target->n.sym->attr.function;
10905
10906   return SUCCESS;
10907 }
10908
10909
10910 /* Resolve a GENERIC procedure binding for a derived type.  */
10911
10912 static gfc_try
10913 resolve_typebound_generic (gfc_symbol* derived, gfc_symtree* st)
10914 {
10915   gfc_symbol* super_type;
10916
10917   /* Find the overridden binding if any.  */
10918   st->n.tb->overridden = NULL;
10919   super_type = gfc_get_derived_super_type (derived);
10920   if (super_type)
10921     {
10922       gfc_symtree* overridden;
10923       overridden = gfc_find_typebound_proc (super_type, NULL, st->name,
10924                                             true, NULL);
10925
10926       if (overridden && overridden->n.tb)
10927         st->n.tb->overridden = overridden->n.tb;
10928     }
10929
10930   /* Resolve using worker function.  */
10931   return resolve_tb_generic_targets (super_type, st->n.tb, st->name);
10932 }
10933
10934
10935 /* Retrieve the target-procedure of an operator binding and do some checks in
10936    common for intrinsic and user-defined type-bound operators.  */
10937
10938 static gfc_symbol*
10939 get_checked_tb_operator_target (gfc_tbp_generic* target, locus where)
10940 {
10941   gfc_symbol* target_proc;
10942
10943   gcc_assert (target->specific && !target->specific->is_generic);
10944   target_proc = target->specific->u.specific->n.sym;
10945   gcc_assert (target_proc);
10946
10947   /* All operator bindings must have a passed-object dummy argument.  */
10948   if (target->specific->nopass)
10949     {
10950       gfc_error ("Type-bound operator at %L can't be NOPASS", &where);
10951       return NULL;
10952     }
10953
10954   return target_proc;
10955 }
10956
10957
10958 /* Resolve a type-bound intrinsic operator.  */
10959
10960 static gfc_try
10961 resolve_typebound_intrinsic_op (gfc_symbol* derived, gfc_intrinsic_op op,
10962                                 gfc_typebound_proc* p)
10963 {
10964   gfc_symbol* super_type;
10965   gfc_tbp_generic* target;
10966
10967   /* If there's already an error here, do nothing (but don't fail again).  */
10968   if (p->error)
10969     return SUCCESS;
10970
10971   /* Operators should always be GENERIC bindings.  */
10972   gcc_assert (p->is_generic);
10973
10974   /* Look for an overridden binding.  */
10975   super_type = gfc_get_derived_super_type (derived);
10976   if (super_type && super_type->f2k_derived)
10977     p->overridden = gfc_find_typebound_intrinsic_op (super_type, NULL,
10978                                                      op, true, NULL);
10979   else
10980     p->overridden = NULL;
10981
10982   /* Resolve general GENERIC properties using worker function.  */
10983   if (resolve_tb_generic_targets (super_type, p, gfc_op2string (op)) == FAILURE)
10984     goto error;
10985
10986   /* Check the targets to be procedures of correct interface.  */
10987   for (target = p->u.generic; target; target = target->next)
10988     {
10989       gfc_symbol* target_proc;
10990
10991       target_proc = get_checked_tb_operator_target (target, p->where);
10992       if (!target_proc)
10993         goto error;
10994
10995       if (!gfc_check_operator_interface (target_proc, op, p->where))
10996         goto error;
10997     }
10998
10999   return SUCCESS;
11000
11001 error:
11002   p->error = 1;
11003   return FAILURE;
11004 }
11005
11006
11007 /* Resolve a type-bound user operator (tree-walker callback).  */
11008
11009 static gfc_symbol* resolve_bindings_derived;
11010 static gfc_try resolve_bindings_result;
11011
11012 static gfc_try check_uop_procedure (gfc_symbol* sym, locus where);
11013
11014 static void
11015 resolve_typebound_user_op (gfc_symtree* stree)
11016 {
11017   gfc_symbol* super_type;
11018   gfc_tbp_generic* target;
11019
11020   gcc_assert (stree && stree->n.tb);
11021
11022   if (stree->n.tb->error)
11023     return;
11024
11025   /* Operators should always be GENERIC bindings.  */
11026   gcc_assert (stree->n.tb->is_generic);
11027
11028   /* Find overridden procedure, if any.  */
11029   super_type = gfc_get_derived_super_type (resolve_bindings_derived);
11030   if (super_type && super_type->f2k_derived)
11031     {
11032       gfc_symtree* overridden;
11033       overridden = gfc_find_typebound_user_op (super_type, NULL,
11034                                                stree->name, true, NULL);
11035
11036       if (overridden && overridden->n.tb)
11037         stree->n.tb->overridden = overridden->n.tb;
11038     }
11039   else
11040     stree->n.tb->overridden = NULL;
11041
11042   /* Resolve basically using worker function.  */
11043   if (resolve_tb_generic_targets (super_type, stree->n.tb, stree->name)
11044         == FAILURE)
11045     goto error;
11046
11047   /* Check the targets to be functions of correct interface.  */
11048   for (target = stree->n.tb->u.generic; target; target = target->next)
11049     {
11050       gfc_symbol* target_proc;
11051
11052       target_proc = get_checked_tb_operator_target (target, stree->n.tb->where);
11053       if (!target_proc)
11054         goto error;
11055
11056       if (check_uop_procedure (target_proc, stree->n.tb->where) == FAILURE)
11057         goto error;
11058     }
11059
11060   return;
11061
11062 error:
11063   resolve_bindings_result = FAILURE;
11064   stree->n.tb->error = 1;
11065 }
11066
11067
11068 /* Resolve the type-bound procedures for a derived type.  */
11069
11070 static void
11071 resolve_typebound_procedure (gfc_symtree* stree)
11072 {
11073   gfc_symbol* proc;
11074   locus where;
11075   gfc_symbol* me_arg;
11076   gfc_symbol* super_type;
11077   gfc_component* comp;
11078
11079   gcc_assert (stree);
11080
11081   /* Undefined specific symbol from GENERIC target definition.  */
11082   if (!stree->n.tb)
11083     return;
11084
11085   if (stree->n.tb->error)
11086     return;
11087
11088   /* If this is a GENERIC binding, use that routine.  */
11089   if (stree->n.tb->is_generic)
11090     {
11091       if (resolve_typebound_generic (resolve_bindings_derived, stree)
11092             == FAILURE)
11093         goto error;
11094       return;
11095     }
11096
11097   /* Get the target-procedure to check it.  */
11098   gcc_assert (!stree->n.tb->is_generic);
11099   gcc_assert (stree->n.tb->u.specific);
11100   proc = stree->n.tb->u.specific->n.sym;
11101   where = stree->n.tb->where;
11102
11103   /* Default access should already be resolved from the parser.  */
11104   gcc_assert (stree->n.tb->access != ACCESS_UNKNOWN);
11105
11106   /* It should be a module procedure or an external procedure with explicit
11107      interface.  For DEFERRED bindings, abstract interfaces are ok as well.  */
11108   if ((!proc->attr.subroutine && !proc->attr.function)
11109       || (proc->attr.proc != PROC_MODULE
11110           && proc->attr.if_source != IFSRC_IFBODY)
11111       || (proc->attr.abstract && !stree->n.tb->deferred))
11112     {
11113       gfc_error ("'%s' must be a module procedure or an external procedure with"
11114                  " an explicit interface at %L", proc->name, &where);
11115       goto error;
11116     }
11117   stree->n.tb->subroutine = proc->attr.subroutine;
11118   stree->n.tb->function = proc->attr.function;
11119
11120   /* Find the super-type of the current derived type.  We could do this once and
11121      store in a global if speed is needed, but as long as not I believe this is
11122      more readable and clearer.  */
11123   super_type = gfc_get_derived_super_type (resolve_bindings_derived);
11124
11125   /* If PASS, resolve and check arguments if not already resolved / loaded
11126      from a .mod file.  */
11127   if (!stree->n.tb->nopass && stree->n.tb->pass_arg_num == 0)
11128     {
11129       if (stree->n.tb->pass_arg)
11130         {
11131           gfc_formal_arglist* i;
11132
11133           /* If an explicit passing argument name is given, walk the arg-list
11134              and look for it.  */
11135
11136           me_arg = NULL;
11137           stree->n.tb->pass_arg_num = 1;
11138           for (i = proc->formal; i; i = i->next)
11139             {
11140               if (!strcmp (i->sym->name, stree->n.tb->pass_arg))
11141                 {
11142                   me_arg = i->sym;
11143                   break;
11144                 }
11145               ++stree->n.tb->pass_arg_num;
11146             }
11147
11148           if (!me_arg)
11149             {
11150               gfc_error ("Procedure '%s' with PASS(%s) at %L has no"
11151                          " argument '%s'",
11152                          proc->name, stree->n.tb->pass_arg, &where,
11153                          stree->n.tb->pass_arg);
11154               goto error;
11155             }
11156         }
11157       else
11158         {
11159           /* Otherwise, take the first one; there should in fact be at least
11160              one.  */
11161           stree->n.tb->pass_arg_num = 1;
11162           if (!proc->formal)
11163             {
11164               gfc_error ("Procedure '%s' with PASS at %L must have at"
11165                          " least one argument", proc->name, &where);
11166               goto error;
11167             }
11168           me_arg = proc->formal->sym;
11169         }
11170
11171       /* Now check that the argument-type matches and the passed-object
11172          dummy argument is generally fine.  */
11173
11174       gcc_assert (me_arg);
11175
11176       if (me_arg->ts.type != BT_CLASS)
11177         {
11178           gfc_error ("Non-polymorphic passed-object dummy argument of '%s'"
11179                      " at %L", proc->name, &where);
11180           goto error;
11181         }
11182
11183       if (CLASS_DATA (me_arg)->ts.u.derived
11184           != resolve_bindings_derived)
11185         {
11186           gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L must be of"
11187                      " the derived-type '%s'", me_arg->name, proc->name,
11188                      me_arg->name, &where, resolve_bindings_derived->name);
11189           goto error;
11190         }
11191
11192       gcc_assert (me_arg->ts.type == BT_CLASS);
11193       if (CLASS_DATA (me_arg)->as && CLASS_DATA (me_arg)->as->rank > 0)
11194         {
11195           gfc_error ("Passed-object dummy argument of '%s' at %L must be"
11196                      " scalar", proc->name, &where);
11197           goto error;
11198         }
11199       if (CLASS_DATA (me_arg)->attr.allocatable)
11200         {
11201           gfc_error ("Passed-object dummy argument of '%s' at %L must not"
11202                      " be ALLOCATABLE", proc->name, &where);
11203           goto error;
11204         }
11205       if (CLASS_DATA (me_arg)->attr.class_pointer)
11206         {
11207           gfc_error ("Passed-object dummy argument of '%s' at %L must not"
11208                      " be POINTER", proc->name, &where);
11209           goto error;
11210         }
11211     }
11212
11213   /* If we are extending some type, check that we don't override a procedure
11214      flagged NON_OVERRIDABLE.  */
11215   stree->n.tb->overridden = NULL;
11216   if (super_type)
11217     {
11218       gfc_symtree* overridden;
11219       overridden = gfc_find_typebound_proc (super_type, NULL,
11220                                             stree->name, true, NULL);
11221
11222       if (overridden)
11223         {
11224           if (overridden->n.tb)
11225             stree->n.tb->overridden = overridden->n.tb;
11226
11227           if (gfc_check_typebound_override (stree, overridden) == FAILURE)
11228             goto error;
11229         }
11230     }
11231
11232   /* See if there's a name collision with a component directly in this type.  */
11233   for (comp = resolve_bindings_derived->components; comp; comp = comp->next)
11234     if (!strcmp (comp->name, stree->name))
11235       {
11236         gfc_error ("Procedure '%s' at %L has the same name as a component of"
11237                    " '%s'",
11238                    stree->name, &where, resolve_bindings_derived->name);
11239         goto error;
11240       }
11241
11242   /* Try to find a name collision with an inherited component.  */
11243   if (super_type && gfc_find_component (super_type, stree->name, true, true))
11244     {
11245       gfc_error ("Procedure '%s' at %L has the same name as an inherited"
11246                  " component of '%s'",
11247                  stree->name, &where, resolve_bindings_derived->name);
11248       goto error;
11249     }
11250
11251   stree->n.tb->error = 0;
11252   return;
11253
11254 error:
11255   resolve_bindings_result = FAILURE;
11256   stree->n.tb->error = 1;
11257 }
11258
11259
11260 static gfc_try
11261 resolve_typebound_procedures (gfc_symbol* derived)
11262 {
11263   int op;
11264   gfc_symbol* super_type;
11265
11266   if (!derived->f2k_derived || !derived->f2k_derived->tb_sym_root)
11267     return SUCCESS;
11268
11269   super_type = gfc_get_derived_super_type (derived);
11270   if (super_type)
11271     resolve_typebound_procedures (super_type);
11272
11273   resolve_bindings_derived = derived;
11274   resolve_bindings_result = SUCCESS;
11275
11276   /* Make sure the vtab has been generated.  */
11277   gfc_find_derived_vtab (derived);
11278
11279   if (derived->f2k_derived->tb_sym_root)
11280     gfc_traverse_symtree (derived->f2k_derived->tb_sym_root,
11281                           &resolve_typebound_procedure);
11282
11283   if (derived->f2k_derived->tb_uop_root)
11284     gfc_traverse_symtree (derived->f2k_derived->tb_uop_root,
11285                           &resolve_typebound_user_op);
11286
11287   for (op = 0; op != GFC_INTRINSIC_OPS; ++op)
11288     {
11289       gfc_typebound_proc* p = derived->f2k_derived->tb_op[op];
11290       if (p && resolve_typebound_intrinsic_op (derived, (gfc_intrinsic_op) op,
11291                                                p) == FAILURE)
11292         resolve_bindings_result = FAILURE;
11293     }
11294
11295   return resolve_bindings_result;
11296 }
11297
11298
11299 /* Add a derived type to the dt_list.  The dt_list is used in trans-types.c
11300    to give all identical derived types the same backend_decl.  */
11301 static void
11302 add_dt_to_dt_list (gfc_symbol *derived)
11303 {
11304   gfc_dt_list *dt_list;
11305
11306   for (dt_list = gfc_derived_types; dt_list; dt_list = dt_list->next)
11307     if (derived == dt_list->derived)
11308       return;
11309
11310   dt_list = gfc_get_dt_list ();
11311   dt_list->next = gfc_derived_types;
11312   dt_list->derived = derived;
11313   gfc_derived_types = dt_list;
11314 }
11315
11316
11317 /* Ensure that a derived-type is really not abstract, meaning that every
11318    inherited DEFERRED binding is overridden by a non-DEFERRED one.  */
11319
11320 static gfc_try
11321 ensure_not_abstract_walker (gfc_symbol* sub, gfc_symtree* st)
11322 {
11323   if (!st)
11324     return SUCCESS;
11325
11326   if (ensure_not_abstract_walker (sub, st->left) == FAILURE)
11327     return FAILURE;
11328   if (ensure_not_abstract_walker (sub, st->right) == FAILURE)
11329     return FAILURE;
11330
11331   if (st->n.tb && st->n.tb->deferred)
11332     {
11333       gfc_symtree* overriding;
11334       overriding = gfc_find_typebound_proc (sub, NULL, st->name, true, NULL);
11335       if (!overriding)
11336         return FAILURE;
11337       gcc_assert (overriding->n.tb);
11338       if (overriding->n.tb->deferred)
11339         {
11340           gfc_error ("Derived-type '%s' declared at %L must be ABSTRACT because"
11341                      " '%s' is DEFERRED and not overridden",
11342                      sub->name, &sub->declared_at, st->name);
11343           return FAILURE;
11344         }
11345     }
11346
11347   return SUCCESS;
11348 }
11349
11350 static gfc_try
11351 ensure_not_abstract (gfc_symbol* sub, gfc_symbol* ancestor)
11352 {
11353   /* The algorithm used here is to recursively travel up the ancestry of sub
11354      and for each ancestor-type, check all bindings.  If any of them is
11355      DEFERRED, look it up starting from sub and see if the found (overriding)
11356      binding is not DEFERRED.
11357      This is not the most efficient way to do this, but it should be ok and is
11358      clearer than something sophisticated.  */
11359
11360   gcc_assert (ancestor && !sub->attr.abstract);
11361
11362   if (!ancestor->attr.abstract)
11363     return SUCCESS;
11364
11365   /* Walk bindings of this ancestor.  */
11366   if (ancestor->f2k_derived)
11367     {
11368       gfc_try t;
11369       t = ensure_not_abstract_walker (sub, ancestor->f2k_derived->tb_sym_root);
11370       if (t == FAILURE)
11371         return FAILURE;
11372     }
11373
11374   /* Find next ancestor type and recurse on it.  */
11375   ancestor = gfc_get_derived_super_type (ancestor);
11376   if (ancestor)
11377     return ensure_not_abstract (sub, ancestor);
11378
11379   return SUCCESS;
11380 }
11381
11382
11383 /* Resolve the components of a derived type. This does not have to wait until
11384    resolution stage, but can be done as soon as the dt declaration has been
11385    parsed.  */
11386
11387 static gfc_try
11388 resolve_fl_derived0 (gfc_symbol *sym)
11389 {
11390   gfc_symbol* super_type;
11391   gfc_component *c;
11392
11393   super_type = gfc_get_derived_super_type (sym);
11394
11395   /* F2008, C432. */
11396   if (super_type && sym->attr.coarray_comp && !super_type->attr.coarray_comp)
11397     {
11398       gfc_error ("As extending type '%s' at %L has a coarray component, "
11399                  "parent type '%s' shall also have one", sym->name,
11400                  &sym->declared_at, super_type->name);
11401       return FAILURE;
11402     }
11403
11404   /* Ensure the extended type gets resolved before we do.  */
11405   if (super_type && resolve_fl_derived0 (super_type) == FAILURE)
11406     return FAILURE;
11407
11408   /* An ABSTRACT type must be extensible.  */
11409   if (sym->attr.abstract && !gfc_type_is_extensible (sym))
11410     {
11411       gfc_error ("Non-extensible derived-type '%s' at %L must not be ABSTRACT",
11412                  sym->name, &sym->declared_at);
11413       return FAILURE;
11414     }
11415
11416   for (c = sym->components; c != NULL; c = c->next)
11417     {
11418       /* F2008, C442.  */
11419       if (c->attr.codimension /* FIXME: c->as check due to PR 43412.  */
11420           && (!c->attr.allocatable || (c->as && c->as->type != AS_DEFERRED)))
11421         {
11422           gfc_error ("Coarray component '%s' at %L must be allocatable with "
11423                      "deferred shape", c->name, &c->loc);
11424           return FAILURE;
11425         }
11426
11427       /* F2008, C443.  */
11428       if (c->attr.codimension && c->ts.type == BT_DERIVED
11429           && c->ts.u.derived->ts.is_iso_c)
11430         {
11431           gfc_error ("Component '%s' at %L of TYPE(C_PTR) or TYPE(C_FUNPTR) "
11432                      "shall not be a coarray", c->name, &c->loc);
11433           return FAILURE;
11434         }
11435
11436       /* F2008, C444.  */
11437       if (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.coarray_comp
11438           && (c->attr.codimension || c->attr.pointer || c->attr.dimension
11439               || c->attr.allocatable))
11440         {
11441           gfc_error ("Component '%s' at %L with coarray component "
11442                      "shall be a nonpointer, nonallocatable scalar",
11443                      c->name, &c->loc);
11444           return FAILURE;
11445         }
11446
11447       /* F2008, C448.  */
11448       if (c->attr.contiguous && (!c->attr.dimension || !c->attr.pointer))
11449         {
11450           gfc_error ("Component '%s' at %L has the CONTIGUOUS attribute but "
11451                      "is not an array pointer", c->name, &c->loc);
11452           return FAILURE;
11453         }
11454
11455       if (c->attr.proc_pointer && c->ts.interface)
11456         {
11457           if (c->ts.interface->attr.procedure && !sym->attr.vtype)
11458             gfc_error ("Interface '%s', used by procedure pointer component "
11459                        "'%s' at %L, is declared in a later PROCEDURE statement",
11460                        c->ts.interface->name, c->name, &c->loc);
11461
11462           /* Get the attributes from the interface (now resolved).  */
11463           if (c->ts.interface->attr.if_source
11464               || c->ts.interface->attr.intrinsic)
11465             {
11466               gfc_symbol *ifc = c->ts.interface;
11467
11468               if (ifc->formal && !ifc->formal_ns)
11469                 resolve_symbol (ifc);
11470
11471               if (ifc->attr.intrinsic)
11472                 resolve_intrinsic (ifc, &ifc->declared_at);
11473
11474               if (ifc->result)
11475                 {
11476                   c->ts = ifc->result->ts;
11477                   c->attr.allocatable = ifc->result->attr.allocatable;
11478                   c->attr.pointer = ifc->result->attr.pointer;
11479                   c->attr.dimension = ifc->result->attr.dimension;
11480                   c->as = gfc_copy_array_spec (ifc->result->as);
11481                 }
11482               else
11483                 {
11484                   c->ts = ifc->ts;
11485                   c->attr.allocatable = ifc->attr.allocatable;
11486                   c->attr.pointer = ifc->attr.pointer;
11487                   c->attr.dimension = ifc->attr.dimension;
11488                   c->as = gfc_copy_array_spec (ifc->as);
11489                 }
11490               c->ts.interface = ifc;
11491               c->attr.function = ifc->attr.function;
11492               c->attr.subroutine = ifc->attr.subroutine;
11493               gfc_copy_formal_args_ppc (c, ifc);
11494
11495               c->attr.pure = ifc->attr.pure;
11496               c->attr.elemental = ifc->attr.elemental;
11497               c->attr.recursive = ifc->attr.recursive;
11498               c->attr.always_explicit = ifc->attr.always_explicit;
11499               c->attr.ext_attr |= ifc->attr.ext_attr;
11500               /* Replace symbols in array spec.  */
11501               if (c->as)
11502                 {
11503                   int i;
11504                   for (i = 0; i < c->as->rank; i++)
11505                     {
11506                       gfc_expr_replace_comp (c->as->lower[i], c);
11507                       gfc_expr_replace_comp (c->as->upper[i], c);
11508                     }
11509                 }
11510               /* Copy char length.  */
11511               if (ifc->ts.type == BT_CHARACTER && ifc->ts.u.cl)
11512                 {
11513                   gfc_charlen *cl = gfc_new_charlen (sym->ns, ifc->ts.u.cl);
11514                   gfc_expr_replace_comp (cl->length, c);
11515                   if (cl->length && !cl->resolved
11516                         && gfc_resolve_expr (cl->length) == FAILURE)
11517                     return FAILURE;
11518                   c->ts.u.cl = cl;
11519                 }
11520             }
11521           else if (!sym->attr.vtype && c->ts.interface->name[0] != '\0')
11522             {
11523               gfc_error ("Interface '%s' of procedure pointer component "
11524                          "'%s' at %L must be explicit", c->ts.interface->name,
11525                          c->name, &c->loc);
11526               return FAILURE;
11527             }
11528         }
11529       else if (c->attr.proc_pointer && c->ts.type == BT_UNKNOWN)
11530         {
11531           /* Since PPCs are not implicitly typed, a PPC without an explicit
11532              interface must be a subroutine.  */
11533           gfc_add_subroutine (&c->attr, c->name, &c->loc);
11534         }
11535
11536       /* Procedure pointer components: Check PASS arg.  */
11537       if (c->attr.proc_pointer && !c->tb->nopass && c->tb->pass_arg_num == 0
11538           && !sym->attr.vtype)
11539         {
11540           gfc_symbol* me_arg;
11541
11542           if (c->tb->pass_arg)
11543             {
11544               gfc_formal_arglist* i;
11545
11546               /* If an explicit passing argument name is given, walk the arg-list
11547                 and look for it.  */
11548
11549               me_arg = NULL;
11550               c->tb->pass_arg_num = 1;
11551               for (i = c->formal; i; i = i->next)
11552                 {
11553                   if (!strcmp (i->sym->name, c->tb->pass_arg))
11554                     {
11555                       me_arg = i->sym;
11556                       break;
11557                     }
11558                   c->tb->pass_arg_num++;
11559                 }
11560
11561               if (!me_arg)
11562                 {
11563                   gfc_error ("Procedure pointer component '%s' with PASS(%s) "
11564                              "at %L has no argument '%s'", c->name,
11565                              c->tb->pass_arg, &c->loc, c->tb->pass_arg);
11566                   c->tb->error = 1;
11567                   return FAILURE;
11568                 }
11569             }
11570           else
11571             {
11572               /* Otherwise, take the first one; there should in fact be at least
11573                 one.  */
11574               c->tb->pass_arg_num = 1;
11575               if (!c->formal)
11576                 {
11577                   gfc_error ("Procedure pointer component '%s' with PASS at %L "
11578                              "must have at least one argument",
11579                              c->name, &c->loc);
11580                   c->tb->error = 1;
11581                   return FAILURE;
11582                 }
11583               me_arg = c->formal->sym;
11584             }
11585
11586           /* Now check that the argument-type matches.  */
11587           gcc_assert (me_arg);
11588           if ((me_arg->ts.type != BT_DERIVED && me_arg->ts.type != BT_CLASS)
11589               || (me_arg->ts.type == BT_DERIVED && me_arg->ts.u.derived != sym)
11590               || (me_arg->ts.type == BT_CLASS
11591                   && CLASS_DATA (me_arg)->ts.u.derived != sym))
11592             {
11593               gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L must be of"
11594                          " the derived type '%s'", me_arg->name, c->name,
11595                          me_arg->name, &c->loc, sym->name);
11596               c->tb->error = 1;
11597               return FAILURE;
11598             }
11599
11600           /* Check for C453.  */
11601           if (me_arg->attr.dimension)
11602             {
11603               gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L "
11604                          "must be scalar", me_arg->name, c->name, me_arg->name,
11605                          &c->loc);
11606               c->tb->error = 1;
11607               return FAILURE;
11608             }
11609
11610           if (me_arg->attr.pointer)
11611             {
11612               gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L "
11613                          "may not have the POINTER attribute", me_arg->name,
11614                          c->name, me_arg->name, &c->loc);
11615               c->tb->error = 1;
11616               return FAILURE;
11617             }
11618
11619           if (me_arg->attr.allocatable)
11620             {
11621               gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L "
11622                          "may not be ALLOCATABLE", me_arg->name, c->name,
11623                          me_arg->name, &c->loc);
11624               c->tb->error = 1;
11625               return FAILURE;
11626             }
11627
11628           if (gfc_type_is_extensible (sym) && me_arg->ts.type != BT_CLASS)
11629             gfc_error ("Non-polymorphic passed-object dummy argument of '%s'"
11630                        " at %L", c->name, &c->loc);
11631
11632         }
11633
11634       /* Check type-spec if this is not the parent-type component.  */
11635       if ((!sym->attr.extension || c != sym->components) && !sym->attr.vtype
11636           && resolve_typespec_used (&c->ts, &c->loc, c->name) == FAILURE)
11637         return FAILURE;
11638
11639       /* If this type is an extension, set the accessibility of the parent
11640          component.  */
11641       if (super_type && c == sym->components
11642           && strcmp (super_type->name, c->name) == 0)
11643         c->attr.access = super_type->attr.access;
11644
11645       /* If this type is an extension, see if this component has the same name
11646          as an inherited type-bound procedure.  */
11647       if (super_type && !sym->attr.is_class
11648           && gfc_find_typebound_proc (super_type, NULL, c->name, true, NULL))
11649         {
11650           gfc_error ("Component '%s' of '%s' at %L has the same name as an"
11651                      " inherited type-bound procedure",
11652                      c->name, sym->name, &c->loc);
11653           return FAILURE;
11654         }
11655
11656       if (c->ts.type == BT_CHARACTER && !c->attr.proc_pointer
11657             && !c->ts.deferred)
11658         {
11659          if (c->ts.u.cl->length == NULL
11660              || (resolve_charlen (c->ts.u.cl) == FAILURE)
11661              || !gfc_is_constant_expr (c->ts.u.cl->length))
11662            {
11663              gfc_error ("Character length of component '%s' needs to "
11664                         "be a constant specification expression at %L",
11665                         c->name,
11666                         c->ts.u.cl->length ? &c->ts.u.cl->length->where : &c->loc);
11667              return FAILURE;
11668            }
11669         }
11670
11671       if (c->ts.type == BT_CHARACTER && c->ts.deferred
11672           && !c->attr.pointer && !c->attr.allocatable)
11673         {
11674           gfc_error ("Character component '%s' of '%s' at %L with deferred "
11675                      "length must be a POINTER or ALLOCATABLE",
11676                      c->name, sym->name, &c->loc);
11677           return FAILURE;
11678         }
11679
11680       if (c->ts.type == BT_DERIVED
11681           && sym->component_access != ACCESS_PRIVATE
11682           && gfc_check_symbol_access (sym)
11683           && !is_sym_host_assoc (c->ts.u.derived, sym->ns)
11684           && !c->ts.u.derived->attr.use_assoc
11685           && !gfc_check_symbol_access (c->ts.u.derived)
11686           && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: the component '%s' "
11687                              "is a PRIVATE type and cannot be a component of "
11688                              "'%s', which is PUBLIC at %L", c->name,
11689                              sym->name, &sym->declared_at) == FAILURE)
11690         return FAILURE;
11691
11692       if ((sym->attr.sequence || sym->attr.is_bind_c) && c->ts.type == BT_CLASS)
11693         {
11694           gfc_error ("Polymorphic component %s at %L in SEQUENCE or BIND(C) "
11695                      "type %s", c->name, &c->loc, sym->name);
11696           return FAILURE;
11697         }
11698
11699       if (sym->attr.sequence)
11700         {
11701           if (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.sequence == 0)
11702             {
11703               gfc_error ("Component %s of SEQUENCE type declared at %L does "
11704                          "not have the SEQUENCE attribute",
11705                          c->ts.u.derived->name, &sym->declared_at);
11706               return FAILURE;
11707             }
11708         }
11709
11710       if (!sym->attr.is_class && c->ts.type == BT_DERIVED && !sym->attr.vtype
11711           && c->attr.pointer && c->ts.u.derived->components == NULL
11712           && !c->ts.u.derived->attr.zero_comp)
11713         {
11714           gfc_error ("The pointer component '%s' of '%s' at %L is a type "
11715                      "that has not been declared", c->name, sym->name,
11716                      &c->loc);
11717           return FAILURE;
11718         }
11719
11720       if (c->ts.type == BT_CLASS && c->attr.class_ok
11721           && CLASS_DATA (c)->attr.class_pointer
11722           && CLASS_DATA (c)->ts.u.derived->components == NULL
11723           && !CLASS_DATA (c)->ts.u.derived->attr.zero_comp)
11724         {
11725           gfc_error ("The pointer component '%s' of '%s' at %L is a type "
11726                      "that has not been declared", c->name, sym->name,
11727                      &c->loc);
11728           return FAILURE;
11729         }
11730
11731       /* C437.  */
11732       if (c->ts.type == BT_CLASS && c->attr.flavor != FL_PROCEDURE
11733           && (!c->attr.class_ok
11734               || !(CLASS_DATA (c)->attr.class_pointer
11735                    || CLASS_DATA (c)->attr.allocatable)))
11736         {
11737           gfc_error ("Component '%s' with CLASS at %L must be allocatable "
11738                      "or pointer", c->name, &c->loc);
11739           return FAILURE;
11740         }
11741
11742       /* Ensure that all the derived type components are put on the
11743          derived type list; even in formal namespaces, where derived type
11744          pointer components might not have been declared.  */
11745       if (c->ts.type == BT_DERIVED
11746             && c->ts.u.derived
11747             && c->ts.u.derived->components
11748             && c->attr.pointer
11749             && sym != c->ts.u.derived)
11750         add_dt_to_dt_list (c->ts.u.derived);
11751
11752       if (gfc_resolve_array_spec (c->as, !(c->attr.pointer
11753                                            || c->attr.proc_pointer
11754                                            || c->attr.allocatable)) == FAILURE)
11755         return FAILURE;
11756     }
11757
11758   /* If this is a non-ABSTRACT type extending an ABSTRACT one, ensure that
11759      all DEFERRED bindings are overridden.  */
11760   if (super_type && super_type->attr.abstract && !sym->attr.abstract
11761       && !sym->attr.is_class
11762       && ensure_not_abstract (sym, super_type) == FAILURE)
11763     return FAILURE;
11764
11765   /* Add derived type to the derived type list.  */
11766   add_dt_to_dt_list (sym);
11767
11768   return SUCCESS;
11769 }
11770
11771
11772 /* The following procedure does the full resolution of a derived type,
11773    including resolution of all type-bound procedures (if present). In contrast
11774    to 'resolve_fl_derived0' this can only be done after the module has been
11775    parsed completely.  */
11776
11777 static gfc_try
11778 resolve_fl_derived (gfc_symbol *sym)
11779 {
11780   if (sym->attr.is_class && sym->ts.u.derived == NULL)
11781     {
11782       /* Fix up incomplete CLASS symbols.  */
11783       gfc_component *data = gfc_find_component (sym, "_data", true, true);
11784       gfc_component *vptr = gfc_find_component (sym, "_vptr", true, true);
11785       if (vptr->ts.u.derived == NULL)
11786         {
11787           gfc_symbol *vtab = gfc_find_derived_vtab (data->ts.u.derived);
11788           gcc_assert (vtab);
11789           vptr->ts.u.derived = vtab->ts.u.derived;
11790         }
11791     }
11792
11793   if (resolve_fl_derived0 (sym) == FAILURE)
11794     return FAILURE;
11795
11796   /* Resolve the type-bound procedures.  */
11797   if (resolve_typebound_procedures (sym) == FAILURE)
11798     return FAILURE;
11799
11800   /* Resolve the finalizer procedures.  */
11801   if (gfc_resolve_finalizers (sym) == FAILURE)
11802     return FAILURE;
11803
11804   return SUCCESS;
11805 }
11806
11807
11808 static gfc_try
11809 resolve_fl_namelist (gfc_symbol *sym)
11810 {
11811   gfc_namelist *nl;
11812   gfc_symbol *nlsym;
11813
11814   for (nl = sym->namelist; nl; nl = nl->next)
11815     {
11816       /* Check again, the check in match only works if NAMELIST comes
11817          after the decl.  */
11818       if (nl->sym->as && nl->sym->as->type == AS_ASSUMED_SIZE)
11819         {
11820           gfc_error ("Assumed size array '%s' in namelist '%s' at %L is not "
11821                      "allowed", nl->sym->name, sym->name, &sym->declared_at);
11822           return FAILURE;
11823         }
11824
11825       if (nl->sym->as && nl->sym->as->type == AS_ASSUMED_SHAPE
11826           && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: NAMELIST array "
11827                              "object '%s' with assumed shape in namelist "
11828                              "'%s' at %L", nl->sym->name, sym->name,
11829                              &sym->declared_at) == FAILURE)
11830         return FAILURE;
11831
11832       if (is_non_constant_shape_array (nl->sym)
11833           && gfc_notify_std (GFC_STD_F2003,  "Fortran 2003: NAMELIST array "
11834                              "object '%s' with nonconstant shape in namelist "
11835                              "'%s' at %L", nl->sym->name, sym->name,
11836                              &sym->declared_at) == FAILURE)
11837         return FAILURE;
11838
11839       if (nl->sym->ts.type == BT_CHARACTER
11840           && (nl->sym->ts.u.cl->length == NULL
11841               || !gfc_is_constant_expr (nl->sym->ts.u.cl->length))
11842           && gfc_notify_std (GFC_STD_F2003,  "Fortran 2003: NAMELIST object "
11843                              "'%s' with nonconstant character length in "
11844                              "namelist '%s' at %L", nl->sym->name, sym->name,
11845                              &sym->declared_at) == FAILURE)
11846         return FAILURE;
11847
11848       /* FIXME: Once UDDTIO is implemented, the following can be
11849          removed.  */
11850       if (nl->sym->ts.type == BT_CLASS)
11851         {
11852           gfc_error ("NAMELIST object '%s' in namelist '%s' at %L is "
11853                      "polymorphic and requires a defined input/output "
11854                      "procedure", nl->sym->name, sym->name, &sym->declared_at);
11855           return FAILURE;
11856         }
11857
11858       if (nl->sym->ts.type == BT_DERIVED
11859           && (nl->sym->ts.u.derived->attr.alloc_comp
11860               || nl->sym->ts.u.derived->attr.pointer_comp))
11861         {
11862           if (gfc_notify_std (GFC_STD_F2003,  "Fortran 2003: NAMELIST object "
11863                               "'%s' in namelist '%s' at %L with ALLOCATABLE "
11864                               "or POINTER components", nl->sym->name,
11865                               sym->name, &sym->declared_at) == FAILURE)
11866             return FAILURE;
11867
11868          /* FIXME: Once UDDTIO is implemented, the following can be
11869             removed.  */
11870           gfc_error ("NAMELIST object '%s' in namelist '%s' at %L has "
11871                      "ALLOCATABLE or POINTER components and thus requires "
11872                      "a defined input/output procedure", nl->sym->name,
11873                      sym->name, &sym->declared_at);
11874           return FAILURE;
11875         }
11876     }
11877
11878   /* Reject PRIVATE objects in a PUBLIC namelist.  */
11879   if (gfc_check_symbol_access (sym))
11880     {
11881       for (nl = sym->namelist; nl; nl = nl->next)
11882         {
11883           if (!nl->sym->attr.use_assoc
11884               && !is_sym_host_assoc (nl->sym, sym->ns)
11885               && !gfc_check_symbol_access (nl->sym))
11886             {
11887               gfc_error ("NAMELIST object '%s' was declared PRIVATE and "
11888                          "cannot be member of PUBLIC namelist '%s' at %L",
11889                          nl->sym->name, sym->name, &sym->declared_at);
11890               return FAILURE;
11891             }
11892
11893           /* Types with private components that came here by USE-association.  */
11894           if (nl->sym->ts.type == BT_DERIVED
11895               && derived_inaccessible (nl->sym->ts.u.derived))
11896             {
11897               gfc_error ("NAMELIST object '%s' has use-associated PRIVATE "
11898                          "components and cannot be member of namelist '%s' at %L",
11899                          nl->sym->name, sym->name, &sym->declared_at);
11900               return FAILURE;
11901             }
11902
11903           /* Types with private components that are defined in the same module.  */
11904           if (nl->sym->ts.type == BT_DERIVED
11905               && !is_sym_host_assoc (nl->sym->ts.u.derived, sym->ns)
11906               && nl->sym->ts.u.derived->attr.private_comp)
11907             {
11908               gfc_error ("NAMELIST object '%s' has PRIVATE components and "
11909                          "cannot be a member of PUBLIC namelist '%s' at %L",
11910                          nl->sym->name, sym->name, &sym->declared_at);
11911               return FAILURE;
11912             }
11913         }
11914     }
11915
11916
11917   /* 14.1.2 A module or internal procedure represent local entities
11918      of the same type as a namelist member and so are not allowed.  */
11919   for (nl = sym->namelist; nl; nl = nl->next)
11920     {
11921       if (nl->sym->ts.kind != 0 && nl->sym->attr.flavor == FL_VARIABLE)
11922         continue;
11923
11924       if (nl->sym->attr.function && nl->sym == nl->sym->result)
11925         if ((nl->sym == sym->ns->proc_name)
11926                ||
11927             (sym->ns->parent && nl->sym == sym->ns->parent->proc_name))
11928           continue;
11929
11930       nlsym = NULL;
11931       if (nl->sym && nl->sym->name)
11932         gfc_find_symbol (nl->sym->name, sym->ns, 1, &nlsym);
11933       if (nlsym && nlsym->attr.flavor == FL_PROCEDURE)
11934         {
11935           gfc_error ("PROCEDURE attribute conflicts with NAMELIST "
11936                      "attribute in '%s' at %L", nlsym->name,
11937                      &sym->declared_at);
11938           return FAILURE;
11939         }
11940     }
11941
11942   return SUCCESS;
11943 }
11944
11945
11946 static gfc_try
11947 resolve_fl_parameter (gfc_symbol *sym)
11948 {
11949   /* A parameter array's shape needs to be constant.  */
11950   if (sym->as != NULL
11951       && (sym->as->type == AS_DEFERRED
11952           || is_non_constant_shape_array (sym)))
11953     {
11954       gfc_error ("Parameter array '%s' at %L cannot be automatic "
11955                  "or of deferred shape", sym->name, &sym->declared_at);
11956       return FAILURE;
11957     }
11958
11959   /* Make sure a parameter that has been implicitly typed still
11960      matches the implicit type, since PARAMETER statements can precede
11961      IMPLICIT statements.  */
11962   if (sym->attr.implicit_type
11963       && !gfc_compare_types (&sym->ts, gfc_get_default_type (sym->name,
11964                                                              sym->ns)))
11965     {
11966       gfc_error ("Implicitly typed PARAMETER '%s' at %L doesn't match a "
11967                  "later IMPLICIT type", sym->name, &sym->declared_at);
11968       return FAILURE;
11969     }
11970
11971   /* Make sure the types of derived parameters are consistent.  This
11972      type checking is deferred until resolution because the type may
11973      refer to a derived type from the host.  */
11974   if (sym->ts.type == BT_DERIVED
11975       && !gfc_compare_types (&sym->ts, &sym->value->ts))
11976     {
11977       gfc_error ("Incompatible derived type in PARAMETER at %L",
11978                  &sym->value->where);
11979       return FAILURE;
11980     }
11981   return SUCCESS;
11982 }
11983
11984
11985 /* Do anything necessary to resolve a symbol.  Right now, we just
11986    assume that an otherwise unknown symbol is a variable.  This sort
11987    of thing commonly happens for symbols in module.  */
11988
11989 static void
11990 resolve_symbol (gfc_symbol *sym)
11991 {
11992   int check_constant, mp_flag;
11993   gfc_symtree *symtree;
11994   gfc_symtree *this_symtree;
11995   gfc_namespace *ns;
11996   gfc_component *c;
11997
11998   if (sym->attr.flavor == FL_UNKNOWN)
11999     {
12000
12001     /* If we find that a flavorless symbol is an interface in one of the
12002        parent namespaces, find its symtree in this namespace, free the
12003        symbol and set the symtree to point to the interface symbol.  */
12004       for (ns = gfc_current_ns->parent; ns; ns = ns->parent)
12005         {
12006           symtree = gfc_find_symtree (ns->sym_root, sym->name);
12007           if (symtree && (symtree->n.sym->generic ||
12008                           (symtree->n.sym->attr.flavor == FL_PROCEDURE
12009                            && sym->ns->construct_entities)))
12010             {
12011               this_symtree = gfc_find_symtree (gfc_current_ns->sym_root,
12012                                                sym->name);
12013               gfc_release_symbol (sym);
12014               symtree->n.sym->refs++;
12015               this_symtree->n.sym = symtree->n.sym;
12016               return;
12017             }
12018         }
12019
12020       /* Otherwise give it a flavor according to such attributes as
12021          it has.  */
12022       if (sym->attr.external == 0 && sym->attr.intrinsic == 0)
12023         sym->attr.flavor = FL_VARIABLE;
12024       else
12025         {
12026           sym->attr.flavor = FL_PROCEDURE;
12027           if (sym->attr.dimension)
12028             sym->attr.function = 1;
12029         }
12030     }
12031
12032   if (sym->attr.external && sym->ts.type != BT_UNKNOWN && !sym->attr.function)
12033     gfc_add_function (&sym->attr, sym->name, &sym->declared_at);
12034
12035   if (sym->attr.procedure && sym->ts.interface
12036       && sym->attr.if_source != IFSRC_DECL
12037       && resolve_procedure_interface (sym) == FAILURE)
12038     return;
12039
12040   if (sym->attr.is_protected && !sym->attr.proc_pointer
12041       && (sym->attr.procedure || sym->attr.external))
12042     {
12043       if (sym->attr.external)
12044         gfc_error ("PROTECTED attribute conflicts with EXTERNAL attribute "
12045                    "at %L", &sym->declared_at);
12046       else
12047         gfc_error ("PROCEDURE attribute conflicts with PROTECTED attribute "
12048                    "at %L", &sym->declared_at);
12049
12050       return;
12051     }
12052
12053
12054   /* F2008, C530. */
12055   if (sym->attr.contiguous
12056       && (!sym->attr.dimension || (sym->as->type != AS_ASSUMED_SHAPE
12057                                    && !sym->attr.pointer)))
12058     {
12059       gfc_error ("'%s' at %L has the CONTIGUOUS attribute but is not an "
12060                   "array pointer or an assumed-shape array", sym->name,
12061                   &sym->declared_at);
12062       return;
12063     }
12064
12065   if (sym->attr.flavor == FL_DERIVED && resolve_fl_derived (sym) == FAILURE)
12066     return;
12067
12068   /* Symbols that are module procedures with results (functions) have
12069      the types and array specification copied for type checking in
12070      procedures that call them, as well as for saving to a module
12071      file.  These symbols can't stand the scrutiny that their results
12072      can.  */
12073   mp_flag = (sym->result != NULL && sym->result != sym);
12074
12075   /* Make sure that the intrinsic is consistent with its internal
12076      representation. This needs to be done before assigning a default
12077      type to avoid spurious warnings.  */
12078   if (sym->attr.flavor != FL_MODULE && sym->attr.intrinsic
12079       && resolve_intrinsic (sym, &sym->declared_at) == FAILURE)
12080     return;
12081
12082   /* Resolve associate names.  */
12083   if (sym->assoc)
12084     resolve_assoc_var (sym, true);
12085
12086   /* Assign default type to symbols that need one and don't have one.  */
12087   if (sym->ts.type == BT_UNKNOWN)
12088     {
12089       if (sym->attr.flavor == FL_VARIABLE || sym->attr.flavor == FL_PARAMETER)
12090         gfc_set_default_type (sym, 1, NULL);
12091
12092       if (sym->attr.flavor == FL_PROCEDURE && sym->attr.external
12093           && !sym->attr.function && !sym->attr.subroutine
12094           && gfc_get_default_type (sym->name, sym->ns)->type == BT_UNKNOWN)
12095         gfc_add_subroutine (&sym->attr, sym->name, &sym->declared_at);
12096
12097       if (sym->attr.flavor == FL_PROCEDURE && sym->attr.function)
12098         {
12099           /* The specific case of an external procedure should emit an error
12100              in the case that there is no implicit type.  */
12101           if (!mp_flag)
12102             gfc_set_default_type (sym, sym->attr.external, NULL);
12103           else
12104             {
12105               /* Result may be in another namespace.  */
12106               resolve_symbol (sym->result);
12107
12108               if (!sym->result->attr.proc_pointer)
12109                 {
12110                   sym->ts = sym->result->ts;
12111                   sym->as = gfc_copy_array_spec (sym->result->as);
12112                   sym->attr.dimension = sym->result->attr.dimension;
12113                   sym->attr.pointer = sym->result->attr.pointer;
12114                   sym->attr.allocatable = sym->result->attr.allocatable;
12115                   sym->attr.contiguous = sym->result->attr.contiguous;
12116                 }
12117             }
12118         }
12119     }
12120   else if (mp_flag && sym->attr.flavor == FL_PROCEDURE && sym->attr.function)
12121     gfc_resolve_array_spec (sym->result->as, false);
12122
12123   /* Assumed size arrays and assumed shape arrays must be dummy
12124      arguments.  Array-spec's of implied-shape should have been resolved to
12125      AS_EXPLICIT already.  */
12126
12127   if (sym->as)
12128     {
12129       gcc_assert (sym->as->type != AS_IMPLIED_SHAPE);
12130       if (((sym->as->type == AS_ASSUMED_SIZE && !sym->as->cp_was_assumed)
12131            || sym->as->type == AS_ASSUMED_SHAPE)
12132           && sym->attr.dummy == 0)
12133         {
12134           if (sym->as->type == AS_ASSUMED_SIZE)
12135             gfc_error ("Assumed size array at %L must be a dummy argument",
12136                        &sym->declared_at);
12137           else
12138             gfc_error ("Assumed shape array at %L must be a dummy argument",
12139                        &sym->declared_at);
12140           return;
12141         }
12142     }
12143
12144   /* Make sure symbols with known intent or optional are really dummy
12145      variable.  Because of ENTRY statement, this has to be deferred
12146      until resolution time.  */
12147
12148   if (!sym->attr.dummy
12149       && (sym->attr.optional || sym->attr.intent != INTENT_UNKNOWN))
12150     {
12151       gfc_error ("Symbol at %L is not a DUMMY variable", &sym->declared_at);
12152       return;
12153     }
12154
12155   if (sym->attr.value && !sym->attr.dummy)
12156     {
12157       gfc_error ("'%s' at %L cannot have the VALUE attribute because "
12158                  "it is not a dummy argument", sym->name, &sym->declared_at);
12159       return;
12160     }
12161
12162   if (sym->attr.value && sym->ts.type == BT_CHARACTER)
12163     {
12164       gfc_charlen *cl = sym->ts.u.cl;
12165       if (!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT)
12166         {
12167           gfc_error ("Character dummy variable '%s' at %L with VALUE "
12168                      "attribute must have constant length",
12169                      sym->name, &sym->declared_at);
12170           return;
12171         }
12172
12173       if (sym->ts.is_c_interop
12174           && mpz_cmp_si (cl->length->value.integer, 1) != 0)
12175         {
12176           gfc_error ("C interoperable character dummy variable '%s' at %L "
12177                      "with VALUE attribute must have length one",
12178                      sym->name, &sym->declared_at);
12179           return;
12180         }
12181     }
12182
12183   /* If the symbol is marked as bind(c), verify it's type and kind.  Do not
12184      do this for something that was implicitly typed because that is handled
12185      in gfc_set_default_type.  Handle dummy arguments and procedure
12186      definitions separately.  Also, anything that is use associated is not
12187      handled here but instead is handled in the module it is declared in.
12188      Finally, derived type definitions are allowed to be BIND(C) since that
12189      only implies that they're interoperable, and they are checked fully for
12190      interoperability when a variable is declared of that type.  */
12191   if (sym->attr.is_bind_c && sym->attr.implicit_type == 0 &&
12192       sym->attr.use_assoc == 0 && sym->attr.dummy == 0 &&
12193       sym->attr.flavor != FL_PROCEDURE && sym->attr.flavor != FL_DERIVED)
12194     {
12195       gfc_try t = SUCCESS;
12196
12197       /* First, make sure the variable is declared at the
12198          module-level scope (J3/04-007, Section 15.3).  */
12199       if (sym->ns->proc_name->attr.flavor != FL_MODULE &&
12200           sym->attr.in_common == 0)
12201         {
12202           gfc_error ("Variable '%s' at %L cannot be BIND(C) because it "
12203                      "is neither a COMMON block nor declared at the "
12204                      "module level scope", sym->name, &(sym->declared_at));
12205           t = FAILURE;
12206         }
12207       else if (sym->common_head != NULL)
12208         {
12209           t = verify_com_block_vars_c_interop (sym->common_head);
12210         }
12211       else
12212         {
12213           /* If type() declaration, we need to verify that the components
12214              of the given type are all C interoperable, etc.  */
12215           if (sym->ts.type == BT_DERIVED &&
12216               sym->ts.u.derived->attr.is_c_interop != 1)
12217             {
12218               /* Make sure the user marked the derived type as BIND(C).  If
12219                  not, call the verify routine.  This could print an error
12220                  for the derived type more than once if multiple variables
12221                  of that type are declared.  */
12222               if (sym->ts.u.derived->attr.is_bind_c != 1)
12223                 verify_bind_c_derived_type (sym->ts.u.derived);
12224               t = FAILURE;
12225             }
12226
12227           /* Verify the variable itself as C interoperable if it
12228              is BIND(C).  It is not possible for this to succeed if
12229              the verify_bind_c_derived_type failed, so don't have to handle
12230              any error returned by verify_bind_c_derived_type.  */
12231           t = verify_bind_c_sym (sym, &(sym->ts), sym->attr.in_common,
12232                                  sym->common_block);
12233         }
12234
12235       if (t == FAILURE)
12236         {
12237           /* clear the is_bind_c flag to prevent reporting errors more than
12238              once if something failed.  */
12239           sym->attr.is_bind_c = 0;
12240           return;
12241         }
12242     }
12243
12244   /* If a derived type symbol has reached this point, without its
12245      type being declared, we have an error.  Notice that most
12246      conditions that produce undefined derived types have already
12247      been dealt with.  However, the likes of:
12248      implicit type(t) (t) ..... call foo (t) will get us here if
12249      the type is not declared in the scope of the implicit
12250      statement. Change the type to BT_UNKNOWN, both because it is so
12251      and to prevent an ICE.  */
12252   if (sym->ts.type == BT_DERIVED && sym->ts.u.derived->components == NULL
12253       && !sym->ts.u.derived->attr.zero_comp)
12254     {
12255       gfc_error ("The derived type '%s' at %L is of type '%s', "
12256                  "which has not been defined", sym->name,
12257                   &sym->declared_at, sym->ts.u.derived->name);
12258       sym->ts.type = BT_UNKNOWN;
12259       return;
12260     }
12261
12262   /* Make sure that the derived type has been resolved and that the
12263      derived type is visible in the symbol's namespace, if it is a
12264      module function and is not PRIVATE.  */
12265   if (sym->ts.type == BT_DERIVED
12266         && sym->ts.u.derived->attr.use_assoc
12267         && sym->ns->proc_name
12268         && sym->ns->proc_name->attr.flavor == FL_MODULE)
12269     {
12270       gfc_symbol *ds;
12271
12272       if (resolve_fl_derived (sym->ts.u.derived) == FAILURE)
12273         return;
12274
12275       gfc_find_symbol (sym->ts.u.derived->name, sym->ns, 1, &ds);
12276       if (!ds && sym->attr.function && gfc_check_symbol_access (sym))
12277         {
12278           symtree = gfc_new_symtree (&sym->ns->sym_root,
12279                                      sym->ts.u.derived->name);
12280           symtree->n.sym = sym->ts.u.derived;
12281           sym->ts.u.derived->refs++;
12282         }
12283     }
12284
12285   /* Unless the derived-type declaration is use associated, Fortran 95
12286      does not allow public entries of private derived types.
12287      See 4.4.1 (F95) and 4.5.1.1 (F2003); and related interpretation
12288      161 in 95-006r3.  */
12289   if (sym->ts.type == BT_DERIVED
12290       && sym->ns->proc_name && sym->ns->proc_name->attr.flavor == FL_MODULE
12291       && !sym->ts.u.derived->attr.use_assoc
12292       && gfc_check_symbol_access (sym)
12293       && !gfc_check_symbol_access (sym->ts.u.derived)
12294       && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: PUBLIC %s '%s' at %L "
12295                          "of PRIVATE derived type '%s'",
12296                          (sym->attr.flavor == FL_PARAMETER) ? "parameter"
12297                          : "variable", sym->name, &sym->declared_at,
12298                          sym->ts.u.derived->name) == FAILURE)
12299     return;
12300
12301   /* F2008, C1302.  */
12302   if (sym->ts.type == BT_DERIVED
12303       && ((sym->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
12304            && sym->ts.u.derived->intmod_sym_id == ISOFORTRAN_LOCK_TYPE)
12305           || sym->ts.u.derived->attr.lock_comp)
12306       && !sym->attr.codimension && !sym->ts.u.derived->attr.coarray_comp)
12307     {
12308       gfc_error ("Variable %s at %L of type LOCK_TYPE or with subcomponent of "
12309                  "type LOCK_TYPE must be a coarray", sym->name,
12310                  &sym->declared_at);
12311       return;
12312     }
12313
12314   /* An assumed-size array with INTENT(OUT) shall not be of a type for which
12315      default initialization is defined (5.1.2.4.4).  */
12316   if (sym->ts.type == BT_DERIVED
12317       && sym->attr.dummy
12318       && sym->attr.intent == INTENT_OUT
12319       && sym->as
12320       && sym->as->type == AS_ASSUMED_SIZE)
12321     {
12322       for (c = sym->ts.u.derived->components; c; c = c->next)
12323         {
12324           if (c->initializer)
12325             {
12326               gfc_error ("The INTENT(OUT) dummy argument '%s' at %L is "
12327                          "ASSUMED SIZE and so cannot have a default initializer",
12328                          sym->name, &sym->declared_at);
12329               return;
12330             }
12331         }
12332     }
12333
12334   /* F2008, C542.  */
12335   if (sym->ts.type == BT_DERIVED && sym->attr.dummy
12336       && sym->attr.intent == INTENT_OUT && sym->attr.lock_comp)
12337     {
12338       gfc_error ("Dummy argument '%s' at %L of LOCK_TYPE shall not be "
12339                  "INTENT(OUT)", sym->name, &sym->declared_at);
12340       return;
12341     }
12342
12343   /* F2008, C525.  */
12344   if (((sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.coarray_comp)
12345        || sym->attr.codimension)
12346       && (sym->attr.result || sym->result == sym))
12347     {
12348       gfc_error ("Function result '%s' at %L shall not be a coarray or have "
12349                  "a coarray component", sym->name, &sym->declared_at);
12350       return;
12351     }
12352
12353   /* F2008, C524.  */
12354   if (sym->attr.codimension && sym->ts.type == BT_DERIVED
12355       && sym->ts.u.derived->ts.is_iso_c)
12356     {
12357       gfc_error ("Variable '%s' at %L of TYPE(C_PTR) or TYPE(C_FUNPTR) "
12358                  "shall not be a coarray", sym->name, &sym->declared_at);
12359       return;
12360     }
12361
12362   /* F2008, C525.  */
12363   if (sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.coarray_comp
12364       && (sym->attr.codimension || sym->attr.pointer || sym->attr.dimension
12365           || sym->attr.allocatable))
12366     {
12367       gfc_error ("Variable '%s' at %L with coarray component "
12368                  "shall be a nonpointer, nonallocatable scalar",
12369                  sym->name, &sym->declared_at);
12370       return;
12371     }
12372
12373   /* F2008, C526.  The function-result case was handled above.  */
12374   if (sym->attr.codimension
12375       && !(sym->attr.allocatable || sym->attr.dummy || sym->attr.save
12376            || sym->ns->save_all
12377            || sym->ns->proc_name->attr.flavor == FL_MODULE
12378            || sym->ns->proc_name->attr.is_main_program
12379            || sym->attr.function || sym->attr.result || sym->attr.use_assoc))
12380     {
12381       gfc_error ("Variable '%s' at %L is a coarray and is not ALLOCATABLE, SAVE "
12382                  "nor a dummy argument", sym->name, &sym->declared_at);
12383       return;
12384     }
12385   /* F2008, C528.  */  /* FIXME: sym->as check due to PR 43412.  */
12386   else if (sym->attr.codimension && !sym->attr.allocatable
12387       && sym->as && sym->as->cotype == AS_DEFERRED)
12388     {
12389       gfc_error ("Coarray variable '%s' at %L shall not have codimensions with "
12390                  "deferred shape", sym->name, &sym->declared_at);
12391       return;
12392     }
12393   else if (sym->attr.codimension && sym->attr.allocatable
12394       && (sym->as->type != AS_DEFERRED || sym->as->cotype != AS_DEFERRED))
12395     {
12396       gfc_error ("Allocatable coarray variable '%s' at %L must have "
12397                  "deferred shape", sym->name, &sym->declared_at);
12398       return;
12399     }
12400
12401   /* F2008, C541.  */
12402   if (((sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.coarray_comp)
12403        || (sym->attr.codimension && sym->attr.allocatable))
12404       && sym->attr.dummy && sym->attr.intent == INTENT_OUT)
12405     {
12406       gfc_error ("Variable '%s' at %L is INTENT(OUT) and can thus not be an "
12407                  "allocatable coarray or have coarray components",
12408                  sym->name, &sym->declared_at);
12409       return;
12410     }
12411
12412   if (sym->attr.codimension && sym->attr.dummy
12413       && sym->ns->proc_name && sym->ns->proc_name->attr.is_bind_c)
12414     {
12415       gfc_error ("Coarray dummy variable '%s' at %L not allowed in BIND(C) "
12416                  "procedure '%s'", sym->name, &sym->declared_at,
12417                  sym->ns->proc_name->name);
12418       return;
12419     }
12420
12421   switch (sym->attr.flavor)
12422     {
12423     case FL_VARIABLE:
12424       if (resolve_fl_variable (sym, mp_flag) == FAILURE)
12425         return;
12426       break;
12427
12428     case FL_PROCEDURE:
12429       if (resolve_fl_procedure (sym, mp_flag) == FAILURE)
12430         return;
12431       break;
12432
12433     case FL_NAMELIST:
12434       if (resolve_fl_namelist (sym) == FAILURE)
12435         return;
12436       break;
12437
12438     case FL_PARAMETER:
12439       if (resolve_fl_parameter (sym) == FAILURE)
12440         return;
12441       break;
12442
12443     default:
12444       break;
12445     }
12446
12447   /* Resolve array specifier. Check as well some constraints
12448      on COMMON blocks.  */
12449
12450   check_constant = sym->attr.in_common && !sym->attr.pointer;
12451
12452   /* Set the formal_arg_flag so that check_conflict will not throw
12453      an error for host associated variables in the specification
12454      expression for an array_valued function.  */
12455   if (sym->attr.function && sym->as)
12456     formal_arg_flag = 1;
12457
12458   gfc_resolve_array_spec (sym->as, check_constant);
12459
12460   formal_arg_flag = 0;
12461
12462   /* Resolve formal namespaces.  */
12463   if (sym->formal_ns && sym->formal_ns != gfc_current_ns
12464       && !sym->attr.contained && !sym->attr.intrinsic)
12465     gfc_resolve (sym->formal_ns);
12466
12467   /* Make sure the formal namespace is present.  */
12468   if (sym->formal && !sym->formal_ns)
12469     {
12470       gfc_formal_arglist *formal = sym->formal;
12471       while (formal && !formal->sym)
12472         formal = formal->next;
12473
12474       if (formal)
12475         {
12476           sym->formal_ns = formal->sym->ns;
12477           sym->formal_ns->refs++;
12478         }
12479     }
12480
12481   /* Check threadprivate restrictions.  */
12482   if (sym->attr.threadprivate && !sym->attr.save && !sym->ns->save_all
12483       && (!sym->attr.in_common
12484           && sym->module == NULL
12485           && (sym->ns->proc_name == NULL
12486               || sym->ns->proc_name->attr.flavor != FL_MODULE)))
12487     gfc_error ("Threadprivate at %L isn't SAVEd", &sym->declared_at);
12488
12489   /* If we have come this far we can apply default-initializers, as
12490      described in 14.7.5, to those variables that have not already
12491      been assigned one.  */
12492   if (sym->ts.type == BT_DERIVED
12493       && sym->ns == gfc_current_ns
12494       && !sym->value
12495       && !sym->attr.allocatable
12496       && !sym->attr.alloc_comp)
12497     {
12498       symbol_attribute *a = &sym->attr;
12499
12500       if ((!a->save && !a->dummy && !a->pointer
12501            && !a->in_common && !a->use_assoc
12502            && (a->referenced || a->result)
12503            && !(a->function && sym != sym->result))
12504           || (a->dummy && a->intent == INTENT_OUT && !a->pointer))
12505         apply_default_init (sym);
12506     }
12507
12508   if (sym->ts.type == BT_CLASS && sym->ns == gfc_current_ns
12509       && sym->attr.dummy && sym->attr.intent == INTENT_OUT
12510       && !CLASS_DATA (sym)->attr.class_pointer
12511       && !CLASS_DATA (sym)->attr.allocatable)
12512     apply_default_init (sym);
12513
12514   /* If this symbol has a type-spec, check it.  */
12515   if (sym->attr.flavor == FL_VARIABLE || sym->attr.flavor == FL_PARAMETER
12516       || (sym->attr.flavor == FL_PROCEDURE && sym->attr.function))
12517     if (resolve_typespec_used (&sym->ts, &sym->declared_at, sym->name)
12518           == FAILURE)
12519       return;
12520 }
12521
12522
12523 /************* Resolve DATA statements *************/
12524
12525 static struct
12526 {
12527   gfc_data_value *vnode;
12528   mpz_t left;
12529 }
12530 values;
12531
12532
12533 /* Advance the values structure to point to the next value in the data list.  */
12534
12535 static gfc_try
12536 next_data_value (void)
12537 {
12538   while (mpz_cmp_ui (values.left, 0) == 0)
12539     {
12540
12541       if (values.vnode->next == NULL)
12542         return FAILURE;
12543
12544       values.vnode = values.vnode->next;
12545       mpz_set (values.left, values.vnode->repeat);
12546     }
12547
12548   return SUCCESS;
12549 }
12550
12551
12552 static gfc_try
12553 check_data_variable (gfc_data_variable *var, locus *where)
12554 {
12555   gfc_expr *e;
12556   mpz_t size;
12557   mpz_t offset;
12558   gfc_try t;
12559   ar_type mark = AR_UNKNOWN;
12560   int i;
12561   mpz_t section_index[GFC_MAX_DIMENSIONS];
12562   gfc_ref *ref;
12563   gfc_array_ref *ar;
12564   gfc_symbol *sym;
12565   int has_pointer;
12566
12567   if (gfc_resolve_expr (var->expr) == FAILURE)
12568     return FAILURE;
12569
12570   ar = NULL;
12571   mpz_init_set_si (offset, 0);
12572   e = var->expr;
12573
12574   if (e->expr_type != EXPR_VARIABLE)
12575     gfc_internal_error ("check_data_variable(): Bad expression");
12576
12577   sym = e->symtree->n.sym;
12578
12579   if (sym->ns->is_block_data && !sym->attr.in_common)
12580     {
12581       gfc_error ("BLOCK DATA element '%s' at %L must be in COMMON",
12582                  sym->name, &sym->declared_at);
12583     }
12584
12585   if (e->ref == NULL && sym->as)
12586     {
12587       gfc_error ("DATA array '%s' at %L must be specified in a previous"
12588                  " declaration", sym->name, where);
12589       return FAILURE;
12590     }
12591
12592   has_pointer = sym->attr.pointer;
12593
12594   if (gfc_is_coindexed (e))
12595     {
12596       gfc_error ("DATA element '%s' at %L cannot have a coindex", sym->name,
12597                  where);
12598       return FAILURE;
12599     }
12600
12601   for (ref = e->ref; ref; ref = ref->next)
12602     {
12603       if (ref->type == REF_COMPONENT && ref->u.c.component->attr.pointer)
12604         has_pointer = 1;
12605
12606       if (has_pointer
12607             && ref->type == REF_ARRAY
12608             && ref->u.ar.type != AR_FULL)
12609           {
12610             gfc_error ("DATA element '%s' at %L is a pointer and so must "
12611                         "be a full array", sym->name, where);
12612             return FAILURE;
12613           }
12614     }
12615
12616   if (e->rank == 0 || has_pointer)
12617     {
12618       mpz_init_set_ui (size, 1);
12619       ref = NULL;
12620     }
12621   else
12622     {
12623       ref = e->ref;
12624
12625       /* Find the array section reference.  */
12626       for (ref = e->ref; ref; ref = ref->next)
12627         {
12628           if (ref->type != REF_ARRAY)
12629             continue;
12630           if (ref->u.ar.type == AR_ELEMENT)
12631             continue;
12632           break;
12633         }
12634       gcc_assert (ref);
12635
12636       /* Set marks according to the reference pattern.  */
12637       switch (ref->u.ar.type)
12638         {
12639         case AR_FULL:
12640           mark = AR_FULL;
12641           break;
12642
12643         case AR_SECTION:
12644           ar = &ref->u.ar;
12645           /* Get the start position of array section.  */
12646           gfc_get_section_index (ar, section_index, &offset);
12647           mark = AR_SECTION;
12648           break;
12649
12650         default:
12651           gcc_unreachable ();
12652         }
12653
12654       if (gfc_array_size (e, &size) == FAILURE)
12655         {
12656           gfc_error ("Nonconstant array section at %L in DATA statement",
12657                      &e->where);
12658           mpz_clear (offset);
12659           return FAILURE;
12660         }
12661     }
12662
12663   t = SUCCESS;
12664
12665   while (mpz_cmp_ui (size, 0) > 0)
12666     {
12667       if (next_data_value () == FAILURE)
12668         {
12669           gfc_error ("DATA statement at %L has more variables than values",
12670                      where);
12671           t = FAILURE;
12672           break;
12673         }
12674
12675       t = gfc_check_assign (var->expr, values.vnode->expr, 0);
12676       if (t == FAILURE)
12677         break;
12678
12679       /* If we have more than one element left in the repeat count,
12680          and we have more than one element left in the target variable,
12681          then create a range assignment.  */
12682       /* FIXME: Only done for full arrays for now, since array sections
12683          seem tricky.  */
12684       if (mark == AR_FULL && ref && ref->next == NULL
12685           && mpz_cmp_ui (values.left, 1) > 0 && mpz_cmp_ui (size, 1) > 0)
12686         {
12687           mpz_t range;
12688
12689           if (mpz_cmp (size, values.left) >= 0)
12690             {
12691               mpz_init_set (range, values.left);
12692               mpz_sub (size, size, values.left);
12693               mpz_set_ui (values.left, 0);
12694             }
12695           else
12696             {
12697               mpz_init_set (range, size);
12698               mpz_sub (values.left, values.left, size);
12699               mpz_set_ui (size, 0);
12700             }
12701
12702           t = gfc_assign_data_value (var->expr, values.vnode->expr,
12703                                      offset, &range);
12704
12705           mpz_add (offset, offset, range);
12706           mpz_clear (range);
12707
12708           if (t == FAILURE)
12709             break;
12710         }
12711
12712       /* Assign initial value to symbol.  */
12713       else
12714         {
12715           mpz_sub_ui (values.left, values.left, 1);
12716           mpz_sub_ui (size, size, 1);
12717
12718           t = gfc_assign_data_value (var->expr, values.vnode->expr,
12719                                      offset, NULL);
12720           if (t == FAILURE)
12721             break;
12722
12723           if (mark == AR_FULL)
12724             mpz_add_ui (offset, offset, 1);
12725
12726           /* Modify the array section indexes and recalculate the offset
12727              for next element.  */
12728           else if (mark == AR_SECTION)
12729             gfc_advance_section (section_index, ar, &offset);
12730         }
12731     }
12732
12733   if (mark == AR_SECTION)
12734     {
12735       for (i = 0; i < ar->dimen; i++)
12736         mpz_clear (section_index[i]);
12737     }
12738
12739   mpz_clear (size);
12740   mpz_clear (offset);
12741
12742   return t;
12743 }
12744
12745
12746 static gfc_try traverse_data_var (gfc_data_variable *, locus *);
12747
12748 /* Iterate over a list of elements in a DATA statement.  */
12749
12750 static gfc_try
12751 traverse_data_list (gfc_data_variable *var, locus *where)
12752 {
12753   mpz_t trip;
12754   iterator_stack frame;
12755   gfc_expr *e, *start, *end, *step;
12756   gfc_try retval = SUCCESS;
12757
12758   mpz_init (frame.value);
12759   mpz_init (trip);
12760
12761   start = gfc_copy_expr (var->iter.start);
12762   end = gfc_copy_expr (var->iter.end);
12763   step = gfc_copy_expr (var->iter.step);
12764
12765   if (gfc_simplify_expr (start, 1) == FAILURE
12766       || start->expr_type != EXPR_CONSTANT)
12767     {
12768       gfc_error ("start of implied-do loop at %L could not be "
12769                  "simplified to a constant value", &start->where);
12770       retval = FAILURE;
12771       goto cleanup;
12772     }
12773   if (gfc_simplify_expr (end, 1) == FAILURE
12774       || end->expr_type != EXPR_CONSTANT)
12775     {
12776       gfc_error ("end of implied-do loop at %L could not be "
12777                  "simplified to a constant value", &start->where);
12778       retval = FAILURE;
12779       goto cleanup;
12780     }
12781   if (gfc_simplify_expr (step, 1) == FAILURE
12782       || step->expr_type != EXPR_CONSTANT)
12783     {
12784       gfc_error ("step of implied-do loop at %L could not be "
12785                  "simplified to a constant value", &start->where);
12786       retval = FAILURE;
12787       goto cleanup;
12788     }
12789
12790   mpz_set (trip, end->value.integer);
12791   mpz_sub (trip, trip, start->value.integer);
12792   mpz_add (trip, trip, step->value.integer);
12793
12794   mpz_div (trip, trip, step->value.integer);
12795
12796   mpz_set (frame.value, start->value.integer);
12797
12798   frame.prev = iter_stack;
12799   frame.variable = var->iter.var->symtree;
12800   iter_stack = &frame;
12801
12802   while (mpz_cmp_ui (trip, 0) > 0)
12803     {
12804       if (traverse_data_var (var->list, where) == FAILURE)
12805         {
12806           retval = FAILURE;
12807           goto cleanup;
12808         }
12809
12810       e = gfc_copy_expr (var->expr);
12811       if (gfc_simplify_expr (e, 1) == FAILURE)
12812         {
12813           gfc_free_expr (e);
12814           retval = FAILURE;
12815           goto cleanup;
12816         }
12817
12818       mpz_add (frame.value, frame.value, step->value.integer);
12819
12820       mpz_sub_ui (trip, trip, 1);
12821     }
12822
12823 cleanup:
12824   mpz_clear (frame.value);
12825   mpz_clear (trip);
12826
12827   gfc_free_expr (start);
12828   gfc_free_expr (end);
12829   gfc_free_expr (step);
12830
12831   iter_stack = frame.prev;
12832   return retval;
12833 }
12834
12835
12836 /* Type resolve variables in the variable list of a DATA statement.  */
12837
12838 static gfc_try
12839 traverse_data_var (gfc_data_variable *var, locus *where)
12840 {
12841   gfc_try t;
12842
12843   for (; var; var = var->next)
12844     {
12845       if (var->expr == NULL)
12846         t = traverse_data_list (var, where);
12847       else
12848         t = check_data_variable (var, where);
12849
12850       if (t == FAILURE)
12851         return FAILURE;
12852     }
12853
12854   return SUCCESS;
12855 }
12856
12857
12858 /* Resolve the expressions and iterators associated with a data statement.
12859    This is separate from the assignment checking because data lists should
12860    only be resolved once.  */
12861
12862 static gfc_try
12863 resolve_data_variables (gfc_data_variable *d)
12864 {
12865   for (; d; d = d->next)
12866     {
12867       if (d->list == NULL)
12868         {
12869           if (gfc_resolve_expr (d->expr) == FAILURE)
12870             return FAILURE;
12871         }
12872       else
12873         {
12874           if (gfc_resolve_iterator (&d->iter, false) == FAILURE)
12875             return FAILURE;
12876
12877           if (resolve_data_variables (d->list) == FAILURE)
12878             return FAILURE;
12879         }
12880     }
12881
12882   return SUCCESS;
12883 }
12884
12885
12886 /* Resolve a single DATA statement.  We implement this by storing a pointer to
12887    the value list into static variables, and then recursively traversing the
12888    variables list, expanding iterators and such.  */
12889
12890 static void
12891 resolve_data (gfc_data *d)
12892 {
12893
12894   if (resolve_data_variables (d->var) == FAILURE)
12895     return;
12896
12897   values.vnode = d->value;
12898   if (d->value == NULL)
12899     mpz_set_ui (values.left, 0);
12900   else
12901     mpz_set (values.left, d->value->repeat);
12902
12903   if (traverse_data_var (d->var, &d->where) == FAILURE)
12904     return;
12905
12906   /* At this point, we better not have any values left.  */
12907
12908   if (next_data_value () == SUCCESS)
12909     gfc_error ("DATA statement at %L has more values than variables",
12910                &d->where);
12911 }
12912
12913
12914 /* 12.6 Constraint: In a pure subprogram any variable which is in common or
12915    accessed by host or use association, is a dummy argument to a pure function,
12916    is a dummy argument with INTENT (IN) to a pure subroutine, or an object that
12917    is storage associated with any such variable, shall not be used in the
12918    following contexts: (clients of this function).  */
12919
12920 /* Determines if a variable is not 'pure', i.e., not assignable within a pure
12921    procedure.  Returns zero if assignment is OK, nonzero if there is a
12922    problem.  */
12923 int
12924 gfc_impure_variable (gfc_symbol *sym)
12925 {
12926   gfc_symbol *proc;
12927   gfc_namespace *ns;
12928
12929   if (sym->attr.use_assoc || sym->attr.in_common)
12930     return 1;
12931
12932   /* Check if the symbol's ns is inside the pure procedure.  */
12933   for (ns = gfc_current_ns; ns; ns = ns->parent)
12934     {
12935       if (ns == sym->ns)
12936         break;
12937       if (ns->proc_name->attr.flavor == FL_PROCEDURE && !sym->attr.function)
12938         return 1;
12939     }
12940
12941   proc = sym->ns->proc_name;
12942   if (sym->attr.dummy && gfc_pure (proc)
12943         && ((proc->attr.subroutine && sym->attr.intent == INTENT_IN)
12944                 ||
12945              proc->attr.function))
12946     return 1;
12947
12948   /* TODO: Sort out what can be storage associated, if anything, and include
12949      it here.  In principle equivalences should be scanned but it does not
12950      seem to be possible to storage associate an impure variable this way.  */
12951   return 0;
12952 }
12953
12954
12955 /* Test whether a symbol is pure or not.  For a NULL pointer, checks if the
12956    current namespace is inside a pure procedure.  */
12957
12958 int
12959 gfc_pure (gfc_symbol *sym)
12960 {
12961   symbol_attribute attr;
12962   gfc_namespace *ns;
12963
12964   if (sym == NULL)
12965     {
12966       /* Check if the current namespace or one of its parents
12967         belongs to a pure procedure.  */
12968       for (ns = gfc_current_ns; ns; ns = ns->parent)
12969         {
12970           sym = ns->proc_name;
12971           if (sym == NULL)
12972             return 0;
12973           attr = sym->attr;
12974           if (attr.flavor == FL_PROCEDURE && attr.pure)
12975             return 1;
12976         }
12977       return 0;
12978     }
12979
12980   attr = sym->attr;
12981
12982   return attr.flavor == FL_PROCEDURE && attr.pure;
12983 }
12984
12985
12986 /* Test whether a symbol is implicitly pure or not.  For a NULL pointer,
12987    checks if the current namespace is implicitly pure.  Note that this
12988    function returns false for a PURE procedure.  */
12989
12990 int
12991 gfc_implicit_pure (gfc_symbol *sym)
12992 {
12993   symbol_attribute attr;
12994
12995   if (sym == NULL)
12996     {
12997       /* Check if the current namespace is implicit_pure.  */
12998       sym = gfc_current_ns->proc_name;
12999       if (sym == NULL)
13000         return 0;
13001       attr = sym->attr;
13002       if (attr.flavor == FL_PROCEDURE
13003             && attr.implicit_pure && !attr.pure)
13004         return 1;
13005       return 0;
13006     }
13007
13008   attr = sym->attr;
13009
13010   return attr.flavor == FL_PROCEDURE && attr.implicit_pure && !attr.pure;
13011 }
13012
13013
13014 /* Test whether the current procedure is elemental or not.  */
13015
13016 int
13017 gfc_elemental (gfc_symbol *sym)
13018 {
13019   symbol_attribute attr;
13020
13021   if (sym == NULL)
13022     sym = gfc_current_ns->proc_name;
13023   if (sym == NULL)
13024     return 0;
13025   attr = sym->attr;
13026
13027   return attr.flavor == FL_PROCEDURE && attr.elemental;
13028 }
13029
13030
13031 /* Warn about unused labels.  */
13032
13033 static void
13034 warn_unused_fortran_label (gfc_st_label *label)
13035 {
13036   if (label == NULL)
13037     return;
13038
13039   warn_unused_fortran_label (label->left);
13040
13041   if (label->defined == ST_LABEL_UNKNOWN)
13042     return;
13043
13044   switch (label->referenced)
13045     {
13046     case ST_LABEL_UNKNOWN:
13047       gfc_warning ("Label %d at %L defined but not used", label->value,
13048                    &label->where);
13049       break;
13050
13051     case ST_LABEL_BAD_TARGET:
13052       gfc_warning ("Label %d at %L defined but cannot be used",
13053                    label->value, &label->where);
13054       break;
13055
13056     default:
13057       break;
13058     }
13059
13060   warn_unused_fortran_label (label->right);
13061 }
13062
13063
13064 /* Returns the sequence type of a symbol or sequence.  */
13065
13066 static seq_type
13067 sequence_type (gfc_typespec ts)
13068 {
13069   seq_type result;
13070   gfc_component *c;
13071
13072   switch (ts.type)
13073   {
13074     case BT_DERIVED:
13075
13076       if (ts.u.derived->components == NULL)
13077         return SEQ_NONDEFAULT;
13078
13079       result = sequence_type (ts.u.derived->components->ts);
13080       for (c = ts.u.derived->components->next; c; c = c->next)
13081         if (sequence_type (c->ts) != result)
13082           return SEQ_MIXED;
13083
13084       return result;
13085
13086     case BT_CHARACTER:
13087       if (ts.kind != gfc_default_character_kind)
13088           return SEQ_NONDEFAULT;
13089
13090       return SEQ_CHARACTER;
13091
13092     case BT_INTEGER:
13093       if (ts.kind != gfc_default_integer_kind)
13094           return SEQ_NONDEFAULT;
13095
13096       return SEQ_NUMERIC;
13097
13098     case BT_REAL:
13099       if (!(ts.kind == gfc_default_real_kind
13100             || ts.kind == gfc_default_double_kind))
13101           return SEQ_NONDEFAULT;
13102
13103       return SEQ_NUMERIC;
13104
13105     case BT_COMPLEX:
13106       if (ts.kind != gfc_default_complex_kind)
13107           return SEQ_NONDEFAULT;
13108
13109       return SEQ_NUMERIC;
13110
13111     case BT_LOGICAL:
13112       if (ts.kind != gfc_default_logical_kind)
13113           return SEQ_NONDEFAULT;
13114
13115       return SEQ_NUMERIC;
13116
13117     default:
13118       return SEQ_NONDEFAULT;
13119   }
13120 }
13121
13122
13123 /* Resolve derived type EQUIVALENCE object.  */
13124
13125 static gfc_try
13126 resolve_equivalence_derived (gfc_symbol *derived, gfc_symbol *sym, gfc_expr *e)
13127 {
13128   gfc_component *c = derived->components;
13129
13130   if (!derived)
13131     return SUCCESS;
13132
13133   /* Shall not be an object of nonsequence derived type.  */
13134   if (!derived->attr.sequence)
13135     {
13136       gfc_error ("Derived type variable '%s' at %L must have SEQUENCE "
13137                  "attribute to be an EQUIVALENCE object", sym->name,
13138                  &e->where);
13139       return FAILURE;
13140     }
13141
13142   /* Shall not have allocatable components.  */
13143   if (derived->attr.alloc_comp)
13144     {
13145       gfc_error ("Derived type variable '%s' at %L cannot have ALLOCATABLE "
13146                  "components to be an EQUIVALENCE object",sym->name,
13147                  &e->where);
13148       return FAILURE;
13149     }
13150
13151   if (sym->attr.in_common && gfc_has_default_initializer (sym->ts.u.derived))
13152     {
13153       gfc_error ("Derived type variable '%s' at %L with default "
13154                  "initialization cannot be in EQUIVALENCE with a variable "
13155                  "in COMMON", sym->name, &e->where);
13156       return FAILURE;
13157     }
13158
13159   for (; c ; c = c->next)
13160     {
13161       if (c->ts.type == BT_DERIVED
13162           && (resolve_equivalence_derived (c->ts.u.derived, sym, e) == FAILURE))
13163         return FAILURE;
13164
13165       /* Shall not be an object of sequence derived type containing a pointer
13166          in the structure.  */
13167       if (c->attr.pointer)
13168         {
13169           gfc_error ("Derived type variable '%s' at %L with pointer "
13170                      "component(s) cannot be an EQUIVALENCE object",
13171                      sym->name, &e->where);
13172           return FAILURE;
13173         }
13174     }
13175   return SUCCESS;
13176 }
13177
13178
13179 /* Resolve equivalence object.
13180    An EQUIVALENCE object shall not be a dummy argument, a pointer, a target,
13181    an allocatable array, an object of nonsequence derived type, an object of
13182    sequence derived type containing a pointer at any level of component
13183    selection, an automatic object, a function name, an entry name, a result
13184    name, a named constant, a structure component, or a subobject of any of
13185    the preceding objects.  A substring shall not have length zero.  A
13186    derived type shall not have components with default initialization nor
13187    shall two objects of an equivalence group be initialized.
13188    Either all or none of the objects shall have an protected attribute.
13189    The simple constraints are done in symbol.c(check_conflict) and the rest
13190    are implemented here.  */
13191
13192 static void
13193 resolve_equivalence (gfc_equiv *eq)
13194 {
13195   gfc_symbol *sym;
13196   gfc_symbol *first_sym;
13197   gfc_expr *e;
13198   gfc_ref *r;
13199   locus *last_where = NULL;
13200   seq_type eq_type, last_eq_type;
13201   gfc_typespec *last_ts;
13202   int object, cnt_protected;
13203   const char *msg;
13204
13205   last_ts = &eq->expr->symtree->n.sym->ts;
13206
13207   first_sym = eq->expr->symtree->n.sym;
13208
13209   cnt_protected = 0;
13210
13211   for (object = 1; eq; eq = eq->eq, object++)
13212     {
13213       e = eq->expr;
13214
13215       e->ts = e->symtree->n.sym->ts;
13216       /* match_varspec might not know yet if it is seeing
13217          array reference or substring reference, as it doesn't
13218          know the types.  */
13219       if (e->ref && e->ref->type == REF_ARRAY)
13220         {
13221           gfc_ref *ref = e->ref;
13222           sym = e->symtree->n.sym;
13223
13224           if (sym->attr.dimension)
13225             {
13226               ref->u.ar.as = sym->as;
13227               ref = ref->next;
13228             }
13229
13230           /* For substrings, convert REF_ARRAY into REF_SUBSTRING.  */
13231           if (e->ts.type == BT_CHARACTER
13232               && ref
13233               && ref->type == REF_ARRAY
13234               && ref->u.ar.dimen == 1
13235               && ref->u.ar.dimen_type[0] == DIMEN_RANGE
13236               && ref->u.ar.stride[0] == NULL)
13237             {
13238               gfc_expr *start = ref->u.ar.start[0];
13239               gfc_expr *end = ref->u.ar.end[0];
13240               void *mem = NULL;
13241
13242               /* Optimize away the (:) reference.  */
13243               if (start == NULL && end == NULL)
13244                 {
13245                   if (e->ref == ref)
13246                     e->ref = ref->next;
13247                   else
13248                     e->ref->next = ref->next;
13249                   mem = ref;
13250                 }
13251               else
13252                 {
13253                   ref->type = REF_SUBSTRING;
13254                   if (start == NULL)
13255                     start = gfc_get_int_expr (gfc_default_integer_kind,
13256                                               NULL, 1);
13257                   ref->u.ss.start = start;
13258                   if (end == NULL && e->ts.u.cl)
13259                     end = gfc_copy_expr (e->ts.u.cl->length);
13260                   ref->u.ss.end = end;
13261                   ref->u.ss.length = e->ts.u.cl;
13262                   e->ts.u.cl = NULL;
13263                 }
13264               ref = ref->next;
13265               free (mem);
13266             }
13267
13268           /* Any further ref is an error.  */
13269           if (ref)
13270             {
13271               gcc_assert (ref->type == REF_ARRAY);
13272               gfc_error ("Syntax error in EQUIVALENCE statement at %L",
13273                          &ref->u.ar.where);
13274               continue;
13275             }
13276         }
13277
13278       if (gfc_resolve_expr (e) == FAILURE)
13279         continue;
13280
13281       sym = e->symtree->n.sym;
13282
13283       if (sym->attr.is_protected)
13284         cnt_protected++;
13285       if (cnt_protected > 0 && cnt_protected != object)
13286         {
13287               gfc_error ("Either all or none of the objects in the "
13288                          "EQUIVALENCE set at %L shall have the "
13289                          "PROTECTED attribute",
13290                          &e->where);
13291               break;
13292         }
13293
13294       /* Shall not equivalence common block variables in a PURE procedure.  */
13295       if (sym->ns->proc_name
13296           && sym->ns->proc_name->attr.pure
13297           && sym->attr.in_common)
13298         {
13299           gfc_error ("Common block member '%s' at %L cannot be an EQUIVALENCE "
13300                      "object in the pure procedure '%s'",
13301                      sym->name, &e->where, sym->ns->proc_name->name);
13302           break;
13303         }
13304
13305       /* Shall not be a named constant.  */
13306       if (e->expr_type == EXPR_CONSTANT)
13307         {
13308           gfc_error ("Named constant '%s' at %L cannot be an EQUIVALENCE "
13309                      "object", sym->name, &e->where);
13310           continue;
13311         }
13312
13313       if (e->ts.type == BT_DERIVED
13314           && resolve_equivalence_derived (e->ts.u.derived, sym, e) == FAILURE)
13315         continue;
13316
13317       /* Check that the types correspond correctly:
13318          Note 5.28:
13319          A numeric sequence structure may be equivalenced to another sequence
13320          structure, an object of default integer type, default real type, double
13321          precision real type, default logical type such that components of the
13322          structure ultimately only become associated to objects of the same
13323          kind. A character sequence structure may be equivalenced to an object
13324          of default character kind or another character sequence structure.
13325          Other objects may be equivalenced only to objects of the same type and
13326          kind parameters.  */
13327
13328       /* Identical types are unconditionally OK.  */
13329       if (object == 1 || gfc_compare_types (last_ts, &sym->ts))
13330         goto identical_types;
13331
13332       last_eq_type = sequence_type (*last_ts);
13333       eq_type = sequence_type (sym->ts);
13334
13335       /* Since the pair of objects is not of the same type, mixed or
13336          non-default sequences can be rejected.  */
13337
13338       msg = "Sequence %s with mixed components in EQUIVALENCE "
13339             "statement at %L with different type objects";
13340       if ((object ==2
13341            && last_eq_type == SEQ_MIXED
13342            && gfc_notify_std (GFC_STD_GNU, msg, first_sym->name, last_where)
13343               == FAILURE)
13344           || (eq_type == SEQ_MIXED
13345               && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
13346                                  &e->where) == FAILURE))
13347         continue;
13348
13349       msg = "Non-default type object or sequence %s in EQUIVALENCE "
13350             "statement at %L with objects of different type";
13351       if ((object ==2
13352            && last_eq_type == SEQ_NONDEFAULT
13353            && gfc_notify_std (GFC_STD_GNU, msg, first_sym->name,
13354                               last_where) == FAILURE)
13355           || (eq_type == SEQ_NONDEFAULT
13356               && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
13357                                  &e->where) == FAILURE))
13358         continue;
13359
13360       msg ="Non-CHARACTER object '%s' in default CHARACTER "
13361            "EQUIVALENCE statement at %L";
13362       if (last_eq_type == SEQ_CHARACTER
13363           && eq_type != SEQ_CHARACTER
13364           && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
13365                              &e->where) == FAILURE)
13366                 continue;
13367
13368       msg ="Non-NUMERIC object '%s' in default NUMERIC "
13369            "EQUIVALENCE statement at %L";
13370       if (last_eq_type == SEQ_NUMERIC
13371           && eq_type != SEQ_NUMERIC
13372           && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
13373                              &e->where) == FAILURE)
13374                 continue;
13375
13376   identical_types:
13377       last_ts =&sym->ts;
13378       last_where = &e->where;
13379
13380       if (!e->ref)
13381         continue;
13382
13383       /* Shall not be an automatic array.  */
13384       if (e->ref->type == REF_ARRAY
13385           && gfc_resolve_array_spec (e->ref->u.ar.as, 1) == FAILURE)
13386         {
13387           gfc_error ("Array '%s' at %L with non-constant bounds cannot be "
13388                      "an EQUIVALENCE object", sym->name, &e->where);
13389           continue;
13390         }
13391
13392       r = e->ref;
13393       while (r)
13394         {
13395           /* Shall not be a structure component.  */
13396           if (r->type == REF_COMPONENT)
13397             {
13398               gfc_error ("Structure component '%s' at %L cannot be an "
13399                          "EQUIVALENCE object",
13400                          r->u.c.component->name, &e->where);
13401               break;
13402             }
13403
13404           /* A substring shall not have length zero.  */
13405           if (r->type == REF_SUBSTRING)
13406             {
13407               if (compare_bound (r->u.ss.start, r->u.ss.end) == CMP_GT)
13408                 {
13409                   gfc_error ("Substring at %L has length zero",
13410                              &r->u.ss.start->where);
13411                   break;
13412                 }
13413             }
13414           r = r->next;
13415         }
13416     }
13417 }
13418
13419
13420 /* Resolve function and ENTRY types, issue diagnostics if needed.  */
13421
13422 static void
13423 resolve_fntype (gfc_namespace *ns)
13424 {
13425   gfc_entry_list *el;
13426   gfc_symbol *sym;
13427
13428   if (ns->proc_name == NULL || !ns->proc_name->attr.function)
13429     return;
13430
13431   /* If there are any entries, ns->proc_name is the entry master
13432      synthetic symbol and ns->entries->sym actual FUNCTION symbol.  */
13433   if (ns->entries)
13434     sym = ns->entries->sym;
13435   else
13436     sym = ns->proc_name;
13437   if (sym->result == sym
13438       && sym->ts.type == BT_UNKNOWN
13439       && gfc_set_default_type (sym, 0, NULL) == FAILURE
13440       && !sym->attr.untyped)
13441     {
13442       gfc_error ("Function '%s' at %L has no IMPLICIT type",
13443                  sym->name, &sym->declared_at);
13444       sym->attr.untyped = 1;
13445     }
13446
13447   if (sym->ts.type == BT_DERIVED && !sym->ts.u.derived->attr.use_assoc
13448       && !sym->attr.contained
13449       && !gfc_check_symbol_access (sym->ts.u.derived)
13450       && gfc_check_symbol_access (sym))
13451     {
13452       gfc_notify_std (GFC_STD_F2003, "Fortran 2003: PUBLIC function '%s' at "
13453                       "%L of PRIVATE type '%s'", sym->name,
13454                       &sym->declared_at, sym->ts.u.derived->name);
13455     }
13456
13457     if (ns->entries)
13458     for (el = ns->entries->next; el; el = el->next)
13459       {
13460         if (el->sym->result == el->sym
13461             && el->sym->ts.type == BT_UNKNOWN
13462             && gfc_set_default_type (el->sym, 0, NULL) == FAILURE
13463             && !el->sym->attr.untyped)
13464           {
13465             gfc_error ("ENTRY '%s' at %L has no IMPLICIT type",
13466                        el->sym->name, &el->sym->declared_at);
13467             el->sym->attr.untyped = 1;
13468           }
13469       }
13470 }
13471
13472
13473 /* 12.3.2.1.1 Defined operators.  */
13474
13475 static gfc_try
13476 check_uop_procedure (gfc_symbol *sym, locus where)
13477 {
13478   gfc_formal_arglist *formal;
13479
13480   if (!sym->attr.function)
13481     {
13482       gfc_error ("User operator procedure '%s' at %L must be a FUNCTION",
13483                  sym->name, &where);
13484       return FAILURE;
13485     }
13486
13487   if (sym->ts.type == BT_CHARACTER
13488       && !(sym->ts.u.cl && sym->ts.u.cl->length)
13489       && !(sym->result && sym->result->ts.u.cl
13490            && sym->result->ts.u.cl->length))
13491     {
13492       gfc_error ("User operator procedure '%s' at %L cannot be assumed "
13493                  "character length", sym->name, &where);
13494       return FAILURE;
13495     }
13496
13497   formal = sym->formal;
13498   if (!formal || !formal->sym)
13499     {
13500       gfc_error ("User operator procedure '%s' at %L must have at least "
13501                  "one argument", sym->name, &where);
13502       return FAILURE;
13503     }
13504
13505   if (formal->sym->attr.intent != INTENT_IN)
13506     {
13507       gfc_error ("First argument of operator interface at %L must be "
13508                  "INTENT(IN)", &where);
13509       return FAILURE;
13510     }
13511
13512   if (formal->sym->attr.optional)
13513     {
13514       gfc_error ("First argument of operator interface at %L cannot be "
13515                  "optional", &where);
13516       return FAILURE;
13517     }
13518
13519   formal = formal->next;
13520   if (!formal || !formal->sym)
13521     return SUCCESS;
13522
13523   if (formal->sym->attr.intent != INTENT_IN)
13524     {
13525       gfc_error ("Second argument of operator interface at %L must be "
13526                  "INTENT(IN)", &where);
13527       return FAILURE;
13528     }
13529
13530   if (formal->sym->attr.optional)
13531     {
13532       gfc_error ("Second argument of operator interface at %L cannot be "
13533                  "optional", &where);
13534       return FAILURE;
13535     }
13536
13537   if (formal->next)
13538     {
13539       gfc_error ("Operator interface at %L must have, at most, two "
13540                  "arguments", &where);
13541       return FAILURE;
13542     }
13543
13544   return SUCCESS;
13545 }
13546
13547 static void
13548 gfc_resolve_uops (gfc_symtree *symtree)
13549 {
13550   gfc_interface *itr;
13551
13552   if (symtree == NULL)
13553     return;
13554
13555   gfc_resolve_uops (symtree->left);
13556   gfc_resolve_uops (symtree->right);
13557
13558   for (itr = symtree->n.uop->op; itr; itr = itr->next)
13559     check_uop_procedure (itr->sym, itr->sym->declared_at);
13560 }
13561
13562
13563 /* Examine all of the expressions associated with a program unit,
13564    assign types to all intermediate expressions, make sure that all
13565    assignments are to compatible types and figure out which names
13566    refer to which functions or subroutines.  It doesn't check code
13567    block, which is handled by resolve_code.  */
13568
13569 static void
13570 resolve_types (gfc_namespace *ns)
13571 {
13572   gfc_namespace *n;
13573   gfc_charlen *cl;
13574   gfc_data *d;
13575   gfc_equiv *eq;
13576   gfc_namespace* old_ns = gfc_current_ns;
13577
13578   /* Check that all IMPLICIT types are ok.  */
13579   if (!ns->seen_implicit_none)
13580     {
13581       unsigned letter;
13582       for (letter = 0; letter != GFC_LETTERS; ++letter)
13583         if (ns->set_flag[letter]
13584             && resolve_typespec_used (&ns->default_type[letter],
13585                                       &ns->implicit_loc[letter],
13586                                       NULL) == FAILURE)
13587           return;
13588     }
13589
13590   gfc_current_ns = ns;
13591
13592   resolve_entries (ns);
13593
13594   resolve_common_vars (ns->blank_common.head, false);
13595   resolve_common_blocks (ns->common_root);
13596
13597   resolve_contained_functions (ns);
13598
13599   if (ns->proc_name && ns->proc_name->attr.flavor == FL_PROCEDURE
13600       && ns->proc_name->attr.if_source == IFSRC_IFBODY)
13601     resolve_formal_arglist (ns->proc_name);
13602
13603   gfc_traverse_ns (ns, resolve_bind_c_derived_types);
13604
13605   for (cl = ns->cl_list; cl; cl = cl->next)
13606     resolve_charlen (cl);
13607
13608   gfc_traverse_ns (ns, resolve_symbol);
13609
13610   resolve_fntype (ns);
13611
13612   for (n = ns->contained; n; n = n->sibling)
13613     {
13614       if (gfc_pure (ns->proc_name) && !gfc_pure (n->proc_name))
13615         gfc_error ("Contained procedure '%s' at %L of a PURE procedure must "
13616                    "also be PURE", n->proc_name->name,
13617                    &n->proc_name->declared_at);
13618
13619       resolve_types (n);
13620     }
13621
13622   forall_flag = 0;
13623   do_concurrent_flag = 0;
13624   gfc_check_interfaces (ns);
13625
13626   gfc_traverse_ns (ns, resolve_values);
13627
13628   if (ns->save_all)
13629     gfc_save_all (ns);
13630
13631   iter_stack = NULL;
13632   for (d = ns->data; d; d = d->next)
13633     resolve_data (d);
13634
13635   iter_stack = NULL;
13636   gfc_traverse_ns (ns, gfc_formalize_init_value);
13637
13638   gfc_traverse_ns (ns, gfc_verify_binding_labels);
13639
13640   if (ns->common_root != NULL)
13641     gfc_traverse_symtree (ns->common_root, resolve_bind_c_comms);
13642
13643   for (eq = ns->equiv; eq; eq = eq->next)
13644     resolve_equivalence (eq);
13645
13646   /* Warn about unused labels.  */
13647   if (warn_unused_label)
13648     warn_unused_fortran_label (ns->st_labels);
13649
13650   gfc_resolve_uops (ns->uop_root);
13651
13652   gfc_current_ns = old_ns;
13653 }
13654
13655
13656 /* Call resolve_code recursively.  */
13657
13658 static void
13659 resolve_codes (gfc_namespace *ns)
13660 {
13661   gfc_namespace *n;
13662   bitmap_obstack old_obstack;
13663
13664   if (ns->resolved == 1)
13665     return;
13666
13667   for (n = ns->contained; n; n = n->sibling)
13668     resolve_codes (n);
13669
13670   gfc_current_ns = ns;
13671
13672   /* Don't clear 'cs_base' if this is the namespace of a BLOCK construct.  */
13673   if (!(ns->proc_name && ns->proc_name->attr.flavor == FL_LABEL))
13674     cs_base = NULL;
13675
13676   /* Set to an out of range value.  */
13677   current_entry_id = -1;
13678
13679   old_obstack = labels_obstack;
13680   bitmap_obstack_initialize (&labels_obstack);
13681
13682   resolve_code (ns->code, ns);
13683
13684   bitmap_obstack_release (&labels_obstack);
13685   labels_obstack = old_obstack;
13686 }
13687
13688
13689 /* This function is called after a complete program unit has been compiled.
13690    Its purpose is to examine all of the expressions associated with a program
13691    unit, assign types to all intermediate expressions, make sure that all
13692    assignments are to compatible types and figure out which names refer to
13693    which functions or subroutines.  */
13694
13695 void
13696 gfc_resolve (gfc_namespace *ns)
13697 {
13698   gfc_namespace *old_ns;
13699   code_stack *old_cs_base;
13700
13701   if (ns->resolved)
13702     return;
13703
13704   ns->resolved = -1;
13705   old_ns = gfc_current_ns;
13706   old_cs_base = cs_base;
13707
13708   resolve_types (ns);
13709   resolve_codes (ns);
13710
13711   gfc_current_ns = old_ns;
13712   cs_base = old_cs_base;
13713   ns->resolved = 1;
13714
13715   gfc_run_passes (ns);
13716 }