gcc/fortran/resolve.c

   1 /* Perform type resolution on the various stuctures.
   2    Copyright (C) 2001, 2002, 2003, 2004, 2005, 2006 Free Software Foundation,
   3    Inc.
   4    Contributed by Andy Vaught
   5
   6 This file is part of GCC.
   7
   8 GCC is free software; you can redistribute it and/or modify it under
   9 the terms of the GNU General Public License as published by the Free
  10 Software Foundation; either version 2, or (at your option) any later
  11 version.
  12
  13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
  14 WARRANTY; without even the implied warranty of MERCHANTABILITY or
  15 FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
  16 for more details.
  17
  18 You should have received a copy of the GNU General Public License
  19 along with GCC; see the file COPYING.  If not, write to the Free
  20 Software Foundation, 51 Franklin Street, Fifth Floor,Boston, MA
  21 02110-1301, USA.  */
  22
  23
  24 #include "config.h"
  25 #include "system.h"
  26 #include "gfortran.h"
  27 #include "arith.h"  /* For gfc_compare_expr().  */
  28 #include "dependency.h"
  29
  30 /* Types used in equivalence statements.  */
  31
  32 typedef enum seq_type
  33 {
  34   SEQ_NONDEFAULT, SEQ_NUMERIC, SEQ_CHARACTER, SEQ_MIXED
  35 }
  36 seq_type;
  37
  38 /* Stack to push the current if we descend into a block during
  39    resolution.  See resolve_branch() and resolve_code().  */
  40
  41 typedef struct code_stack
  42 {
  43   struct gfc_code *head, *current;
  44   struct code_stack *prev;
  45 }
  46 code_stack;
  47
  48 static code_stack *cs_base = NULL;
  49
  50
  51 /* Nonzero if we're inside a FORALL block */
  52
  53 static int forall_flag;
  54
  55 /* Nonzero if we are processing a formal arglist. The corresponding function
  56    resets the flag each time that it is read.  */
  57 static int formal_arg_flag = 0;
  58
  59 int
  60 gfc_is_formal_arg (void)
  61 {
  62   return formal_arg_flag;
  63 }
  64
  65 /* Resolve types of formal argument lists.  These have to be done early so that
  66    the formal argument lists of module procedures can be copied to the
  67    containing module before the individual procedures are resolved
  68    individually.  We also resolve argument lists of procedures in interface
  69    blocks because they are self-contained scoping units.
  70
  71    Since a dummy argument cannot be a non-dummy procedure, the only
  72    resort left for untyped names are the IMPLICIT types.  */
  73
  74 static void
  75 resolve_formal_arglist (gfc_symbol * proc)
  76 {
  77   gfc_formal_arglist *f;
  78   gfc_symbol *sym;
  79   int i;
  80
  81   /* TODO: Procedures whose return character length parameter is not constant
  82      or assumed must also have explicit interfaces.  */
  83   if (proc->result != NULL)
  84     sym = proc->result;
  85   else
  86     sym = proc;
  87
  88   if (gfc_elemental (proc)
  89       || sym->attr.pointer || sym->attr.allocatable
  90       || (sym->as && sym->as->rank > 0))
  91     proc->attr.always_explicit = 1;
  92
  93   formal_arg_flag = 1;
  94
  95   for (f = proc->formal; f; f = f->next)
  96     {
  97       sym = f->sym;
  98
  99       if (sym == NULL)
 100         {
 101           /* Alternate return placeholder.  */
 102           if (gfc_elemental (proc))
 103             gfc_error ("Alternate return specifier in elemental subroutine "
 104                        "'%s' at %L is not allowed", proc->name,
 105                        &proc->declared_at);
 106           if (proc->attr.function)
 107             gfc_error ("Alternate return specifier in function "
 108                        "'%s' at %L is not allowed", proc->name,
 109                        &proc->declared_at);
 110           continue;
 111         }
 112
 113       if (sym->attr.if_source != IFSRC_UNKNOWN)
 114         resolve_formal_arglist (sym);
 115
 116       if (sym->attr.subroutine || sym->attr.external || sym->attr.intrinsic)
 117         {
 118           if (gfc_pure (proc) && !gfc_pure (sym))
 119             {
 120               gfc_error
 121                 ("Dummy procedure '%s' of PURE procedure at %L must also "
 122                  "be PURE", sym->name, &sym->declared_at);
 123               continue;
 124             }
 125
 126           if (gfc_elemental (proc))
 127             {
 128               gfc_error
 129                 ("Dummy procedure at %L not allowed in ELEMENTAL procedure",
 130                  &sym->declared_at);
 131               continue;
 132             }
 133
 134           continue;
 135         }
 136
 137       if (sym->ts.type == BT_UNKNOWN)
 138         {
 139           if (!sym->attr.function || sym->result == sym)
 140             gfc_set_default_type (sym, 1, sym->ns);
 141         }
 142
 143       gfc_resolve_array_spec (sym->as, 0);
 144
 145       /* We can't tell if an array with dimension (:) is assumed or deferred
 146          shape until we know if it has the pointer or allocatable attributes.
 147       */
 148       if (sym->as && sym->as->rank > 0 && sym->as->type == AS_DEFERRED
 149           && !(sym->attr.pointer || sym->attr.allocatable))
 150         {
 151           sym->as->type = AS_ASSUMED_SHAPE;
 152           for (i = 0; i < sym->as->rank; i++)
 153             sym->as->lower[i] = gfc_int_expr (1);
 154         }
 155
 156       if ((sym->as && sym->as->rank > 0 && sym->as->type == AS_ASSUMED_SHAPE)
 157           || sym->attr.pointer || sym->attr.allocatable || sym->attr.target
 158           || sym->attr.optional)
 159         proc->attr.always_explicit = 1;
 160
 161       /* If the flavor is unknown at this point, it has to be a variable.
 162          A procedure specification would have already set the type.  */
 163
 164       if (sym->attr.flavor == FL_UNKNOWN)
 165         gfc_add_flavor (&sym->attr, FL_VARIABLE, sym->name, &sym->declared_at);
 166
 167       if (gfc_pure (proc))
 168         {
 169           if (proc->attr.function && !sym->attr.pointer
 170               && sym->attr.flavor != FL_PROCEDURE
 171               && sym->attr.intent != INTENT_IN)
 172
 173             gfc_error ("Argument '%s' of pure function '%s' at %L must be "
 174                        "INTENT(IN)", sym->name, proc->name,
 175                        &sym->declared_at);
 176
 177           if (proc->attr.subroutine && !sym->attr.pointer
 178               && sym->attr.intent == INTENT_UNKNOWN)
 179
 180             gfc_error
 181               ("Argument '%s' of pure subroutine '%s' at %L must have "
 182                "its INTENT specified", sym->name, proc->name,
 183                &sym->declared_at);
 184         }
 185
 186
 187       if (gfc_elemental (proc))
 188         {
 189           if (sym->as != NULL)
 190             {
 191               gfc_error
 192                 ("Argument '%s' of elemental procedure at %L must be scalar",
 193                  sym->name, &sym->declared_at);
 194               continue;
 195             }
 196
 197           if (sym->attr.pointer)
 198             {
 199               gfc_error
 200                 ("Argument '%s' of elemental procedure at %L cannot have "
 201                  "the POINTER attribute", sym->name, &sym->declared_at);
 202               continue;
 203             }
 204         }
 205
 206       /* Each dummy shall be specified to be scalar.  */
 207       if (proc->attr.proc == PROC_ST_FUNCTION)
 208         {
 209           if (sym->as != NULL)
 210             {
 211               gfc_error
 212                 ("Argument '%s' of statement function at %L must be scalar",
 213                  sym->name, &sym->declared_at);
 214               continue;
 215             }
 216
 217           if (sym->ts.type == BT_CHARACTER)
 218             {
 219               gfc_charlen *cl = sym->ts.cl;
 220               if (!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT)
 221                 {
 222                   gfc_error
 223                     ("Character-valued argument '%s' of statement function at "
 224                      "%L must has constant length",
 225                      sym->name, &sym->declared_at);
 226                   continue;
 227                 }
 228             }
 229         }
 230     }
 231   formal_arg_flag = 0;
 232 }
 233
 234
 235 /* Work function called when searching for symbols that have argument lists
 236    associated with them.  */
 237
 238 static void
 239 find_arglists (gfc_symbol * sym)
 240 {
 241
 242   if (sym->attr.if_source == IFSRC_UNKNOWN || sym->ns != gfc_current_ns)
 243     return;
 244
 245   resolve_formal_arglist (sym);
 246 }
 247
 248
 249 /* Given a namespace, resolve all formal argument lists within the namespace.
 250  */
 251
 252 static void
 253 resolve_formal_arglists (gfc_namespace * ns)
 254 {
 255
 256   if (ns == NULL)
 257     return;
 258
 259   gfc_traverse_ns (ns, find_arglists);
 260 }
 261
 262
 263 static void
 264 resolve_contained_fntype (gfc_symbol * sym, gfc_namespace * ns)
 265 {
 266   try t;
 267
 268   /* If this namespace is not a function, ignore it.  */
 269   if (! sym
 270       || !(sym->attr.function
 271            || sym->attr.flavor == FL_VARIABLE))
 272     return;
 273
 274   /* Try to find out of what the return type is.  */
 275   if (sym->result != NULL)
 276     sym = sym->result;
 277
 278   if (sym->ts.type == BT_UNKNOWN)
 279     {
 280       t = gfc_set_default_type (sym, 0, ns);
 281
 282       if (t == FAILURE && !sym->attr.untyped)
 283         {
 284           gfc_error ("Contained function '%s' at %L has no IMPLICIT type",
 285                      sym->name, &sym->declared_at); /* FIXME */
 286           sym->attr.untyped = 1;
 287         }
 288     }
 289
 290   /*Fortran 95 Draft Standard, page 51, Section 5.1.1.5, on the Character type,
 291     lists the only ways a character length value of * can be used: dummy arguments
 292     of procedures, named constants, and function results in external functions.
 293     Internal function results are not on that list; ergo, not permitted.  */
 294
 295   if (sym->ts.type == BT_CHARACTER)
 296     {
 297       gfc_charlen *cl = sym->ts.cl;
 298       if (!cl || !cl->length)
 299         gfc_error ("Character-valued internal function '%s' at %L must "
 300                    "not be assumed length", sym->name, &sym->declared_at);
 301     }
 302 }
 303
 304
 305 /* Add NEW_ARGS to the formal argument list of PROC, taking care not to
 306    introduce duplicates.  */
 307
 308 static void
 309 merge_argument_lists (gfc_symbol *proc, gfc_formal_arglist *new_args)
 310 {
 311   gfc_formal_arglist *f, *new_arglist;
 312   gfc_symbol *new_sym;
 313
 314   for (; new_args != NULL; new_args = new_args->next)
 315     {
 316       new_sym = new_args->sym;
 317       /* See if ths arg is already in the formal argument list.  */
 318       for (f = proc->formal; f; f = f->next)
 319         {
 320           if (new_sym == f->sym)
 321             break;
 322         }
 323
 324       if (f)
 325         continue;
 326
 327       /* Add a new argument.  Argument order is not important.  */
 328       new_arglist = gfc_get_formal_arglist ();
 329       new_arglist->sym = new_sym;
 330       new_arglist->next = proc->formal;
 331       proc->formal  = new_arglist;
 332     }
 333 }
 334
 335
 336 /* Resolve alternate entry points.  If a symbol has multiple entry points we
 337    create a new master symbol for the main routine, and turn the existing
 338    symbol into an entry point.  */
 339
 340 static void
 341 resolve_entries (gfc_namespace * ns)
 342 {
 343   gfc_namespace *old_ns;
 344   gfc_code *c;
 345   gfc_symbol *proc;
 346   gfc_entry_list *el;
 347   char name[GFC_MAX_SYMBOL_LEN + 1];
 348   static int master_count = 0;
 349
 350   if (ns->proc_name == NULL)
 351     return;
 352
 353   /* No need to do anything if this procedure doesn't have alternate entry
 354      points.  */
 355   if (!ns->entries)
 356     return;
 357
 358   /* We may already have resolved alternate entry points.  */
 359   if (ns->proc_name->attr.entry_master)
 360     return;
 361
 362   /* If this isn't a procedure something has gone horribly wrong.  */
 363   gcc_assert (ns->proc_name->attr.flavor == FL_PROCEDURE);
 364
 365   /* Remember the current namespace.  */
 366   old_ns = gfc_current_ns;
 367
 368   gfc_current_ns = ns;
 369
 370   /* Add the main entry point to the list of entry points.  */
 371   el = gfc_get_entry_list ();
 372   el->sym = ns->proc_name;
 373   el->id = 0;
 374   el->next = ns->entries;
 375   ns->entries = el;
 376   ns->proc_name->attr.entry = 1;
 377
 378   /* Add an entry statement for it.  */
 379   c = gfc_get_code ();
 380   c->op = EXEC_ENTRY;
 381   c->ext.entry = el;
 382   c->next = ns->code;
 383   ns->code = c;
 384
 385   /* Create a new symbol for the master function.  */
 386   /* Give the internal function a unique name (within this file).
 387      Also include the function name so the user has some hope of figuring
 388      out what is going on.  */
 389   snprintf (name, GFC_MAX_SYMBOL_LEN, "master.%d.%s",
 390             master_count++, ns->proc_name->name);
 391   gfc_get_ha_symbol (name, &proc);
 392   gcc_assert (proc != NULL);
 393
 394   gfc_add_procedure (&proc->attr, PROC_INTERNAL, proc->name, NULL);
 395   if (ns->proc_name->attr.subroutine)
 396     gfc_add_subroutine (&proc->attr, proc->name, NULL);
 397   else
 398     {
 399       gfc_symbol *sym;
 400       gfc_typespec *ts, *fts;
 401
 402       gfc_add_function (&proc->attr, proc->name, NULL);
 403       proc->result = proc;
 404       fts = &ns->entries->sym->result->ts;
 405       if (fts->type == BT_UNKNOWN)
 406         fts = gfc_get_default_type (ns->entries->sym->result, NULL);
 407       for (el = ns->entries->next; el; el = el->next)
 408         {
 409           ts = &el->sym->result->ts;
 410           if (ts->type == BT_UNKNOWN)
 411             ts = gfc_get_default_type (el->sym->result, NULL);
 412           if (! gfc_compare_types (ts, fts)
 413               || (el->sym->result->attr.dimension
 414                   != ns->entries->sym->result->attr.dimension)
 415               || (el->sym->result->attr.pointer
 416                   != ns->entries->sym->result->attr.pointer))
 417             break;
 418         }
 419
 420       if (el == NULL)
 421         {
 422           sym = ns->entries->sym->result;
 423           /* All result types the same.  */
 424           proc->ts = *fts;
 425           if (sym->attr.dimension)
 426             gfc_set_array_spec (proc, gfc_copy_array_spec (sym->as), NULL);
 427           if (sym->attr.pointer)
 428             gfc_add_pointer (&proc->attr, NULL);
 429         }
 430       else
 431         {
 432           /* Otherwise the result will be passed through a union by
 433              reference.  */
 434           proc->attr.mixed_entry_master = 1;
 435           for (el = ns->entries; el; el = el->next)
 436             {
 437               sym = el->sym->result;
 438               if (sym->attr.dimension)
 439               {
 440                 if (el == ns->entries)
 441                   gfc_error
 442                   ("FUNCTION result %s can't be an array in FUNCTION %s at %L",
 443                    sym->name, ns->entries->sym->name, &sym->declared_at);
 444                 else
 445                   gfc_error
 446                     ("ENTRY result %s can't be an array in FUNCTION %s at %L",
 447                      sym->name, ns->entries->sym->name, &sym->declared_at);
 448               }
 449               else if (sym->attr.pointer)
 450               {
 451                 if (el == ns->entries)
 452                   gfc_error
 453                   ("FUNCTION result %s can't be a POINTER in FUNCTION %s at %L",
 454                    sym->name, ns->entries->sym->name, &sym->declared_at);
 455                 else
 456                   gfc_error
 457                     ("ENTRY result %s can't be a POINTER in FUNCTION %s at %L",
 458                      sym->name, ns->entries->sym->name, &sym->declared_at);
 459               }
 460               else
 461                 {
 462                   ts = &sym->ts;
 463                   if (ts->type == BT_UNKNOWN)
 464                     ts = gfc_get_default_type (sym, NULL);
 465                   switch (ts->type)
 466                     {
 467                     case BT_INTEGER:
 468                       if (ts->kind == gfc_default_integer_kind)
 469                         sym = NULL;
 470                       break;
 471                     case BT_REAL:
 472                       if (ts->kind == gfc_default_real_kind
 473                           || ts->kind == gfc_default_double_kind)
 474                         sym = NULL;
 475                       break;
 476                     case BT_COMPLEX:
 477                       if (ts->kind == gfc_default_complex_kind)
 478                         sym = NULL;
 479                       break;
 480                     case BT_LOGICAL:
 481                       if (ts->kind == gfc_default_logical_kind)
 482                         sym = NULL;
 483                       break;
 484                     case BT_UNKNOWN:
 485                       /* We will issue error elsewhere.  */
 486                       sym = NULL;
 487                       break;
 488                     default:
 489                       break;
 490                     }
 491                   if (sym)
 492                   {
 493                     if (el == ns->entries)
 494                       gfc_error
 495                         ("FUNCTION result %s can't be of type %s in FUNCTION %s at %L",
 496                          sym->name, gfc_typename (ts), ns->entries->sym->name,
 497                          &sym->declared_at);
 498                     else
 499                       gfc_error
 500                         ("ENTRY result %s can't be of type %s in FUNCTION %s at %L",
 501                          sym->name, gfc_typename (ts), ns->entries->sym->name,
 502                          &sym->declared_at);
 503                   }
 504                 }
 505             }
 506         }
 507     }
 508   proc->attr.access = ACCESS_PRIVATE;
 509   proc->attr.entry_master = 1;
 510
 511   /* Merge all the entry point arguments.  */
 512   for (el = ns->entries; el; el = el->next)
 513     merge_argument_lists (proc, el->sym->formal);
 514
 515   /* Use the master function for the function body.  */
 516   ns->proc_name = proc;
 517
 518   /* Finalize the new symbols.  */
 519   gfc_commit_symbols ();
 520
 521   /* Restore the original namespace.  */
 522   gfc_current_ns = old_ns;
 523 }
 524
 525
 526 /* Resolve contained function types.  Because contained functions can call one
 527    another, they have to be worked out before any of the contained procedures
 528    can be resolved.
 529
 530    The good news is that if a function doesn't already have a type, the only
 531    way it can get one is through an IMPLICIT type or a RESULT variable, because
 532    by definition contained functions are contained namespace they're contained
 533    in, not in a sibling or parent namespace.  */
 534
 535 static void
 536 resolve_contained_functions (gfc_namespace * ns)
 537 {
 538   gfc_namespace *child;
 539   gfc_entry_list *el;
 540
 541   resolve_formal_arglists (ns);
 542
 543   for (child = ns->contained; child; child = child->sibling)
 544     {
 545       /* Resolve alternate entry points first.  */
 546       resolve_entries (child);
 547
 548       /* Then check function return types.  */
 549       resolve_contained_fntype (child->proc_name, child);
 550       for (el = child->entries; el; el = el->next)
 551         resolve_contained_fntype (el->sym, child);
 552     }
 553 }
 554
 555
 556 /* Resolve all of the elements of a structure constructor and make sure that
 557    the types are correct.  */
 558
 559 static try
 560 resolve_structure_cons (gfc_expr * expr)
 561 {
 562   gfc_constructor *cons;
 563   gfc_component *comp;
 564   try t;
 565
 566   t = SUCCESS;
 567   cons = expr->value.constructor;
 568   /* A constructor may have references if it is the result of substituting a
 569      parameter variable.  In this case we just pull out the component we
 570      want.  */
 571   if (expr->ref)
 572     comp = expr->ref->u.c.sym->components;
 573   else
 574     comp = expr->ts.derived->components;
 575
 576   for (; comp; comp = comp->next, cons = cons->next)
 577     {
 578       if (! cons->expr)
 579         {
 580           t = FAILURE;
 581           continue;
 582         }
 583
 584       if (gfc_resolve_expr (cons->expr) == FAILURE)
 585         {
 586           t = FAILURE;
 587           continue;
 588         }
 589
 590       /* If we don't have the right type, try to convert it.  */
 591
 592       if (!gfc_compare_types (&cons->expr->ts, &comp->ts))
 593         {
 594           t = FAILURE;
 595           if (comp->pointer && cons->expr->ts.type != BT_UNKNOWN)
 596             gfc_error ("The element in the derived type constructor at %L, "
 597                        "for pointer component '%s', is %s but should be %s",
 598                        &cons->expr->where, comp->name,
 599                        gfc_basic_typename (cons->expr->ts.type),
 600                        gfc_basic_typename (comp->ts.type));
 601           else
 602             t = gfc_convert_type (cons->expr, &comp->ts, 1);
 603         }
 604     }
 605
 606   return t;
 607 }
 608
 609
 610
 611 /****************** Expression name resolution ******************/
 612
 613 /* Returns 0 if a symbol was not declared with a type or
 614    attribute declaration statement, nonzero otherwise.  */
 615
 616 static int
 617 was_declared (gfc_symbol * sym)
 618 {
 619   symbol_attribute a;
 620
 621   a = sym->attr;
 622
 623   if (!a.implicit_type && sym->ts.type != BT_UNKNOWN)
 624     return 1;
 625
 626   if (a.allocatable || a.dimension || a.dummy || a.external || a.intrinsic
 627       || a.optional || a.pointer || a.save || a.target
 628       || a.access != ACCESS_UNKNOWN || a.intent != INTENT_UNKNOWN)
 629     return 1;
 630
 631   return 0;
 632 }
 633
 634
 635 /* Determine if a symbol is generic or not.  */
 636
 637 static int
 638 generic_sym (gfc_symbol * sym)
 639 {
 640   gfc_symbol *s;
 641
 642   if (sym->attr.generic ||
 643       (sym->attr.intrinsic && gfc_generic_intrinsic (sym->name)))
 644     return 1;
 645
 646   if (was_declared (sym) || sym->ns->parent == NULL)
 647     return 0;
 648
 649   gfc_find_symbol (sym->name, sym->ns->parent, 1, &s);
 650
 651   return (s == NULL) ? 0 : generic_sym (s);
 652 }
 653
 654
 655 /* Determine if a symbol is specific or not.  */
 656
 657 static int
 658 specific_sym (gfc_symbol * sym)
 659 {
 660   gfc_symbol *s;
 661
 662   if (sym->attr.if_source == IFSRC_IFBODY
 663       || sym->attr.proc == PROC_MODULE
 664       || sym->attr.proc == PROC_INTERNAL
 665       || sym->attr.proc == PROC_ST_FUNCTION
 666       || (sym->attr.intrinsic &&
 667           gfc_specific_intrinsic (sym->name))
 668       || sym->attr.external)
 669     return 1;
 670
 671   if (was_declared (sym) || sym->ns->parent == NULL)
 672     return 0;
 673
 674   gfc_find_symbol (sym->name, sym->ns->parent, 1, &s);
 675
 676   return (s == NULL) ? 0 : specific_sym (s);
 677 }
 678
 679
 680 /* Figure out if the procedure is specific, generic or unknown.  */
 681
 682 typedef enum
 683 { PTYPE_GENERIC = 1, PTYPE_SPECIFIC, PTYPE_UNKNOWN }
 684 proc_type;
 685
 686 static proc_type
 687 procedure_kind (gfc_symbol * sym)
 688 {
 689
 690   if (generic_sym (sym))
 691     return PTYPE_GENERIC;
 692
 693   if (specific_sym (sym))
 694     return PTYPE_SPECIFIC;
 695
 696   return PTYPE_UNKNOWN;
 697 }
 698
 699 /* Check references to assumed size arrays.  The flag need_full_assumed_size
 700    is non-zero when matching actual arguments.  */
 701
 702 static int need_full_assumed_size = 0;
 703
 704 static bool
 705 check_assumed_size_reference (gfc_symbol * sym, gfc_expr * e)
 706 {
 707   gfc_ref * ref;
 708   int dim;
 709   int last = 1;
 710
 711   if (need_full_assumed_size
 712         || !(sym->as && sym->as->type == AS_ASSUMED_SIZE))
 713       return false;
 714
 715   for (ref = e->ref; ref; ref = ref->next)
 716     if (ref->type == REF_ARRAY)
 717       for (dim = 0; dim < ref->u.ar.as->rank; dim++)
 718         last = (ref->u.ar.end[dim] == NULL) && (ref->u.ar.type == DIMEN_ELEMENT);
 719
 720   if (last)
 721     {
 722       gfc_error ("The upper bound in the last dimension must "
 723                  "appear in the reference to the assumed size "
 724                  "array '%s' at %L.", sym->name, &e->where);
 725       return true;
 726     }
 727   return false;
 728 }
 729
 730
 731 /* Look for bad assumed size array references in argument expressions
 732   of elemental and array valued intrinsic procedures.  Since this is
 733   called from procedure resolution functions, it only recurses at
 734   operators.  */
 735
 736 static bool
 737 resolve_assumed_size_actual (gfc_expr *e)
 738 {
 739   if (e == NULL)
 740    return false;
 741
 742   switch (e->expr_type)
 743     {
 744     case EXPR_VARIABLE:
 745       if (e->symtree
 746             && check_assumed_size_reference (e->symtree->n.sym, e))
 747         return true;
 748       break;
 749
 750     case EXPR_OP:
 751       if (resolve_assumed_size_actual (e->value.op.op1)
 752             || resolve_assumed_size_actual (e->value.op.op2))
 753         return true;
 754       break;
 755
 756     default:
 757       break;
 758     }
 759   return false;
 760 }
 761
 762
 763 /* Resolve an actual argument list.  Most of the time, this is just
 764    resolving the expressions in the list.
 765    The exception is that we sometimes have to decide whether arguments
 766    that look like procedure arguments are really simple variable
 767    references.  */
 768
 769 static try
 770 resolve_actual_arglist (gfc_actual_arglist * arg)
 771 {
 772   gfc_symbol *sym;
 773   gfc_symtree *parent_st;
 774   gfc_expr *e;
 775
 776   for (; arg; arg = arg->next)
 777     {
 778
 779       e = arg->expr;
 780       if (e == NULL)
 781         {
 782           /* Check the label is a valid branching target.  */
 783           if (arg->label)
 784             {
 785               if (arg->label->defined == ST_LABEL_UNKNOWN)
 786                 {
 787                   gfc_error ("Label %d referenced at %L is never defined",
 788                              arg->label->value, &arg->label->where);
 789                   return FAILURE;
 790                 }
 791             }
 792           continue;
 793         }
 794
 795       if (e->ts.type != BT_PROCEDURE)
 796         {
 797           if (gfc_resolve_expr (e) != SUCCESS)
 798             return FAILURE;
 799           continue;
 800         }
 801
 802       /* See if the expression node should really be a variable
 803          reference.  */
 804
 805       sym = e->symtree->n.sym;
 806
 807       if (sym->attr.flavor == FL_PROCEDURE
 808           || sym->attr.intrinsic
 809           || sym->attr.external)
 810         {
 811
 812           if (sym->attr.proc == PROC_ST_FUNCTION)
 813             {
 814               gfc_error ("Statement function '%s' at %L is not allowed as an "
 815                          "actual argument", sym->name, &e->where);
 816             }
 817
 818           /* If the symbol is the function that names the current (or
 819              parent) scope, then we really have a variable reference.  */
 820
 821           if (sym->attr.function && sym->result == sym
 822               && (sym->ns->proc_name == sym
 823                   || (sym->ns->parent != NULL
 824                       && sym->ns->parent->proc_name == sym)))
 825             goto got_variable;
 826
 827           continue;
 828         }
 829
 830       /* See if the name is a module procedure in a parent unit.  */
 831
 832       if (was_declared (sym) || sym->ns->parent == NULL)
 833         goto got_variable;
 834
 835       if (gfc_find_sym_tree (sym->name, sym->ns->parent, 1, &parent_st))
 836         {
 837           gfc_error ("Symbol '%s' at %L is ambiguous", sym->name, &e->where);
 838           return FAILURE;
 839         }
 840
 841       if (parent_st == NULL)
 842         goto got_variable;
 843
 844       sym = parent_st->n.sym;
 845       e->symtree = parent_st;           /* Point to the right thing.  */
 846
 847       if (sym->attr.flavor == FL_PROCEDURE
 848           || sym->attr.intrinsic
 849           || sym->attr.external)
 850         {
 851           continue;
 852         }
 853
 854     got_variable:
 855       e->expr_type = EXPR_VARIABLE;
 856       e->ts = sym->ts;
 857       if (sym->as != NULL)
 858         {
 859           e->rank = sym->as->rank;
 860           e->ref = gfc_get_ref ();
 861           e->ref->type = REF_ARRAY;
 862           e->ref->u.ar.type = AR_FULL;
 863           e->ref->u.ar.as = sym->as;
 864         }
 865     }
 866
 867   return SUCCESS;
 868 }
 869
 870
 871 /* Go through each actual argument in ACTUAL and see if it can be
 872    implemented as an inlined, non-copying intrinsic.  FNSYM is the
 873    function being called, or NULL if not known.  */
 874
 875 static void
 876 find_noncopying_intrinsics (gfc_symbol * fnsym, gfc_actual_arglist * actual)
 877 {
 878   gfc_actual_arglist *ap;
 879   gfc_expr *expr;
 880
 881   for (ap = actual; ap; ap = ap->next)
 882     if (ap->expr
 883         && (expr = gfc_get_noncopying_intrinsic_argument (ap->expr))
 884         && !gfc_check_fncall_dependency (expr, INTENT_IN, fnsym, actual))
 885       ap->expr->inline_noncopying_intrinsic = 1;
 886 }
 887
 888
 889 /************* Function resolution *************/
 890
 891 /* Resolve a function call known to be generic.
 892    Section 14.1.2.4.1.  */
 893
 894 static match
 895 resolve_generic_f0 (gfc_expr * expr, gfc_symbol * sym)
 896 {
 897   gfc_symbol *s;
 898
 899   if (sym->attr.generic)
 900     {
 901       s =
 902         gfc_search_interface (sym->generic, 0, &expr->value.function.actual);
 903       if (s != NULL)
 904         {
 905           expr->value.function.name = s->name;
 906           expr->value.function.esym = s;
 907           expr->ts = s->ts;
 908           if (s->as != NULL)
 909             expr->rank = s->as->rank;
 910           return MATCH_YES;
 911         }
 912
 913       /* TODO: Need to search for elemental references in generic interface */
 914     }
 915
 916   if (sym->attr.intrinsic)
 917     return gfc_intrinsic_func_interface (expr, 0);
 918
 919   return MATCH_NO;
 920 }
 921
 922
 923 static try
 924 resolve_generic_f (gfc_expr * expr)
 925 {
 926   gfc_symbol *sym;
 927   match m;
 928
 929   sym = expr->symtree->n.sym;
 930
 931   for (;;)
 932     {
 933       m = resolve_generic_f0 (expr, sym);
 934       if (m == MATCH_YES)
 935         return SUCCESS;
 936       else if (m == MATCH_ERROR)
 937         return FAILURE;
 938
 939 generic:
 940       if (sym->ns->parent == NULL)
 941         break;
 942       gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
 943
 944       if (sym == NULL)
 945         break;
 946       if (!generic_sym (sym))
 947         goto generic;
 948     }
 949
 950   /* Last ditch attempt.  */
 951
 952   if (!gfc_generic_intrinsic (expr->symtree->n.sym->name))
 953     {
 954       gfc_error ("Generic function '%s' at %L is not an intrinsic function",
 955                  expr->symtree->n.sym->name, &expr->where);
 956       return FAILURE;
 957     }
 958
 959   m = gfc_intrinsic_func_interface (expr, 0);
 960   if (m == MATCH_YES)
 961     return SUCCESS;
 962   if (m == MATCH_NO)
 963     gfc_error
 964       ("Generic function '%s' at %L is not consistent with a specific "
 965        "intrinsic interface", expr->symtree->n.sym->name, &expr->where);
 966
 967   return FAILURE;
 968 }
 969
 970
 971 /* Resolve a function call known to be specific.  */
 972
 973 static match
 974 resolve_specific_f0 (gfc_symbol * sym, gfc_expr * expr)
 975 {
 976   match m;
 977
 978   if (sym->attr.external || sym->attr.if_source == IFSRC_IFBODY)
 979     {
 980       if (sym->attr.dummy)
 981         {
 982           sym->attr.proc = PROC_DUMMY;
 983           goto found;
 984         }
 985
 986       sym->attr.proc = PROC_EXTERNAL;
 987       goto found;
 988     }
 989
 990   if (sym->attr.proc == PROC_MODULE
 991       || sym->attr.proc == PROC_ST_FUNCTION
 992       || sym->attr.proc == PROC_INTERNAL)
 993     goto found;
 994
 995   if (sym->attr.intrinsic)
 996     {
 997       m = gfc_intrinsic_func_interface (expr, 1);
 998       if (m == MATCH_YES)
 999         return MATCH_YES;
1000       if (m == MATCH_NO)
1001         gfc_error
1002           ("Function '%s' at %L is INTRINSIC but is not compatible with "
1003            "an intrinsic", sym->name, &expr->where);
1004
1005       return MATCH_ERROR;
1006     }
1007
1008   return MATCH_NO;
1009
1010 found:
1011   gfc_procedure_use (sym, &expr->value.function.actual, &expr->where);
1012
1013   expr->ts = sym->ts;
1014   expr->value.function.name = sym->name;
1015   expr->value.function.esym = sym;
1016   if (sym->as != NULL)
1017     expr->rank = sym->as->rank;
1018
1019   return MATCH_YES;
1020 }
1021
1022
1023 static try
1024 resolve_specific_f (gfc_expr * expr)
1025 {
1026   gfc_symbol *sym;
1027   match m;
1028
1029   sym = expr->symtree->n.sym;
1030
1031   for (;;)
1032     {
1033       m = resolve_specific_f0 (sym, expr);
1034       if (m == MATCH_YES)
1035         return SUCCESS;
1036       if (m == MATCH_ERROR)
1037         return FAILURE;
1038
1039       if (sym->ns->parent == NULL)
1040         break;
1041
1042       gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
1043
1044       if (sym == NULL)
1045         break;
1046     }
1047
1048   gfc_error ("Unable to resolve the specific function '%s' at %L",
1049              expr->symtree->n.sym->name, &expr->where);
1050
1051   return SUCCESS;
1052 }
1053
1054
1055 /* Resolve a procedure call not known to be generic nor specific.  */
1056
1057 static try
1058 resolve_unknown_f (gfc_expr * expr)
1059 {
1060   gfc_symbol *sym;
1061   gfc_typespec *ts;
1062
1063   sym = expr->symtree->n.sym;
1064
1065   if (sym->attr.dummy)
1066     {
1067       sym->attr.proc = PROC_DUMMY;
1068       expr->value.function.name = sym->name;
1069       goto set_type;
1070     }
1071
1072   /* See if we have an intrinsic function reference.  */
1073
1074   if (gfc_intrinsic_name (sym->name, 0))
1075     {
1076       if (gfc_intrinsic_func_interface (expr, 1) == MATCH_YES)
1077         return SUCCESS;
1078       return FAILURE;
1079     }
1080
1081   /* The reference is to an external name.  */
1082
1083   sym->attr.proc = PROC_EXTERNAL;
1084   expr->value.function.name = sym->name;
1085   expr->value.function.esym = expr->symtree->n.sym;
1086
1087   if (sym->as != NULL)
1088     expr->rank = sym->as->rank;
1089
1090   /* Type of the expression is either the type of the symbol or the
1091      default type of the symbol.  */
1092
1093 set_type:
1094   gfc_procedure_use (sym, &expr->value.function.actual, &expr->where);
1095
1096   if (sym->ts.type != BT_UNKNOWN)
1097     expr->ts = sym->ts;
1098   else
1099     {
1100       ts = gfc_get_default_type (sym, sym->ns);
1101
1102       if (ts->type == BT_UNKNOWN)
1103         {
1104           gfc_error ("Function '%s' at %L has no IMPLICIT type",
1105                      sym->name, &expr->where);
1106           return FAILURE;
1107         }
1108       else
1109         expr->ts = *ts;
1110     }
1111
1112   return SUCCESS;
1113 }
1114
1115
1116 /* Figure out if a function reference is pure or not.  Also set the name
1117    of the function for a potential error message.  Return nonzero if the
1118    function is PURE, zero if not.  */
1119
1120 static int
1121 pure_function (gfc_expr * e, const char **name)
1122 {
1123   int pure;
1124
1125   if (e->value.function.esym)
1126     {
1127       pure = gfc_pure (e->value.function.esym);
1128       *name = e->value.function.esym->name;
1129     }
1130   else if (e->value.function.isym)
1131     {
1132       pure = e->value.function.isym->pure
1133         || e->value.function.isym->elemental;
1134       *name = e->value.function.isym->name;
1135     }
1136   else
1137     {
1138       /* Implicit functions are not pure.  */
1139       pure = 0;
1140       *name = e->value.function.name;
1141     }
1142
1143   return pure;
1144 }
1145
1146
1147 /* Resolve a function call, which means resolving the arguments, then figuring
1148    out which entity the name refers to.  */
1149 /* TODO: Check procedure arguments so that an INTENT(IN) isn't passed
1150    to INTENT(OUT) or INTENT(INOUT).  */
1151
1152 static try
1153 resolve_function (gfc_expr * expr)
1154 {
1155   gfc_actual_arglist *arg;
1156   const char *name;
1157   try t;
1158   int temp;
1159
1160   /* Switch off assumed size checking and do this again for certain kinds
1161      of procedure, once the procedure itself is resolved.  */
1162   need_full_assumed_size++;
1163
1164   if (resolve_actual_arglist (expr->value.function.actual) == FAILURE)
1165     return FAILURE;
1166
1167   /* Resume assumed_size checking. */
1168   need_full_assumed_size--;
1169
1170 /* See if function is already resolved.  */
1171
1172   if (expr->value.function.name != NULL)
1173     {
1174       if (expr->ts.type == BT_UNKNOWN)
1175         expr->ts = expr->symtree->n.sym->ts;
1176       t = SUCCESS;
1177     }
1178   else
1179     {
1180       /* Apply the rules of section 14.1.2.  */
1181
1182       switch (procedure_kind (expr->symtree->n.sym))
1183         {
1184         case PTYPE_GENERIC:
1185           t = resolve_generic_f (expr);
1186           break;
1187
1188         case PTYPE_SPECIFIC:
1189           t = resolve_specific_f (expr);
1190           break;
1191
1192         case PTYPE_UNKNOWN:
1193           t = resolve_unknown_f (expr);
1194           break;
1195
1196         default:
1197           gfc_internal_error ("resolve_function(): bad function type");
1198         }
1199     }
1200
1201   /* If the expression is still a function (it might have simplified),
1202      then we check to see if we are calling an elemental function.  */
1203
1204   if (expr->expr_type != EXPR_FUNCTION)
1205     return t;
1206
1207   temp = need_full_assumed_size;
1208   need_full_assumed_size = 0;
1209
1210   if (expr->value.function.actual != NULL
1211       && ((expr->value.function.esym != NULL
1212            && expr->value.function.esym->attr.elemental)
1213           || (expr->value.function.isym != NULL
1214               && expr->value.function.isym->elemental)))
1215     {
1216       /* The rank of an elemental is the rank of its array argument(s).  */
1217       for (arg = expr->value.function.actual; arg; arg = arg->next)
1218         {
1219           if (arg->expr != NULL && arg->expr->rank > 0)
1220             {
1221               expr->rank = arg->expr->rank;
1222               break;
1223             }
1224         }
1225
1226       /* Being elemental, the last upper bound of an assumed size array
1227          argument must be present.  */
1228       for (arg = expr->value.function.actual; arg; arg = arg->next)
1229         {
1230           if (arg->expr != NULL
1231                 && arg->expr->rank > 0
1232                 && resolve_assumed_size_actual (arg->expr))
1233             return FAILURE;
1234         }
1235     }
1236
1237   else if (expr->value.function.actual != NULL
1238       && expr->value.function.isym != NULL
1239       && strcmp (expr->value.function.isym->name, "lbound"))
1240     {
1241       /* Array instrinsics must also have the last upper bound of an
1242          asumed size array argument.  UBOUND and SIZE have to be
1243          excluded from the check if the second argument is anything
1244          than a constant.  */
1245       int inquiry;
1246       inquiry = strcmp (expr->value.function.isym->name, "ubound") == 0
1247                   || strcmp (expr->value.function.isym->name, "size") == 0;
1248
1249       for (arg = expr->value.function.actual; arg; arg = arg->next)
1250         {
1251           if (inquiry && arg->next != NULL && arg->next->expr
1252                 && arg->next->expr->expr_type != EXPR_CONSTANT)
1253             break;
1254
1255           if (arg->expr != NULL
1256                 && arg->expr->rank > 0
1257                 && resolve_assumed_size_actual (arg->expr))
1258             return FAILURE;
1259         }
1260     }
1261
1262   need_full_assumed_size = temp;
1263
1264   if (!pure_function (expr, &name))
1265     {
1266       if (forall_flag)
1267         {
1268           gfc_error
1269             ("Function reference to '%s' at %L is inside a FORALL block",
1270              name, &expr->where);
1271           t = FAILURE;
1272         }
1273       else if (gfc_pure (NULL))
1274         {
1275           gfc_error ("Function reference to '%s' at %L is to a non-PURE "
1276                      "procedure within a PURE procedure", name, &expr->where);
1277           t = FAILURE;
1278         }
1279     }
1280
1281   /* Character lengths of use associated functions may contains references to
1282      symbols not referenced from the current program unit otherwise.  Make sure
1283      those symbols are marked as referenced.  */
1284
1285   if (expr->ts.type == BT_CHARACTER && expr->value.function.esym
1286       && expr->value.function.esym->attr.use_assoc)
1287     {
1288       gfc_expr_set_symbols_referenced (expr->ts.cl->length);
1289     }
1290
1291   if (t == SUCCESS)
1292     find_noncopying_intrinsics (expr->value.function.esym,
1293                                 expr->value.function.actual);
1294   return t;
1295 }
1296
1297
1298 /************* Subroutine resolution *************/
1299
1300 static void
1301 pure_subroutine (gfc_code * c, gfc_symbol * sym)
1302 {
1303
1304   if (gfc_pure (sym))
1305     return;
1306
1307   if (forall_flag)
1308     gfc_error ("Subroutine call to '%s' in FORALL block at %L is not PURE",
1309                sym->name, &c->loc);
1310   else if (gfc_pure (NULL))
1311     gfc_error ("Subroutine call to '%s' at %L is not PURE", sym->name,
1312                &c->loc);
1313 }
1314
1315
1316 static match
1317 resolve_generic_s0 (gfc_code * c, gfc_symbol * sym)
1318 {
1319   gfc_symbol *s;
1320
1321   if (sym->attr.generic)
1322     {
1323       s = gfc_search_interface (sym->generic, 1, &c->ext.actual);
1324       if (s != NULL)
1325         {
1326           c->resolved_sym = s;
1327           pure_subroutine (c, s);
1328           return MATCH_YES;
1329         }
1330
1331       /* TODO: Need to search for elemental references in generic interface.  */
1332     }
1333
1334   if (sym->attr.intrinsic)
1335     return gfc_intrinsic_sub_interface (c, 0);
1336
1337   return MATCH_NO;
1338 }
1339
1340
1341 static try
1342 resolve_generic_s (gfc_code * c)
1343 {
1344   gfc_symbol *sym;
1345   match m;
1346
1347   sym = c->symtree->n.sym;
1348
1349   m = resolve_generic_s0 (c, sym);
1350   if (m == MATCH_YES)
1351     return SUCCESS;
1352   if (m == MATCH_ERROR)
1353     return FAILURE;
1354
1355   if (sym->ns->parent != NULL)
1356     {
1357       gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
1358       if (sym != NULL)
1359         {
1360           m = resolve_generic_s0 (c, sym);
1361           if (m == MATCH_YES)
1362             return SUCCESS;
1363           if (m == MATCH_ERROR)
1364             return FAILURE;
1365         }
1366     }
1367
1368   /* Last ditch attempt.  */
1369
1370   if (!gfc_generic_intrinsic (sym->name))
1371     {
1372       gfc_error
1373         ("Generic subroutine '%s' at %L is not an intrinsic subroutine",
1374          sym->name, &c->loc);
1375       return FAILURE;
1376     }
1377
1378   m = gfc_intrinsic_sub_interface (c, 0);
1379   if (m == MATCH_YES)
1380     return SUCCESS;
1381   if (m == MATCH_NO)
1382     gfc_error ("Generic subroutine '%s' at %L is not consistent with an "
1383                "intrinsic subroutine interface", sym->name, &c->loc);
1384
1385   return FAILURE;
1386 }
1387
1388
1389 /* Resolve a subroutine call known to be specific.  */
1390
1391 static match
1392 resolve_specific_s0 (gfc_code * c, gfc_symbol * sym)
1393 {
1394   match m;
1395
1396   if (sym->attr.external || sym->attr.if_source == IFSRC_IFBODY)
1397     {
1398       if (sym->attr.dummy)
1399         {
1400           sym->attr.proc = PROC_DUMMY;
1401           goto found;
1402         }
1403
1404       sym->attr.proc = PROC_EXTERNAL;
1405       goto found;
1406     }
1407
1408   if (sym->attr.proc == PROC_MODULE || sym->attr.proc == PROC_INTERNAL)
1409     goto found;
1410
1411   if (sym->attr.intrinsic)
1412     {
1413       m = gfc_intrinsic_sub_interface (c, 1);
1414       if (m == MATCH_YES)
1415         return MATCH_YES;
1416       if (m == MATCH_NO)
1417         gfc_error ("Subroutine '%s' at %L is INTRINSIC but is not compatible "
1418                    "with an intrinsic", sym->name, &c->loc);
1419
1420       return MATCH_ERROR;
1421     }
1422
1423   return MATCH_NO;
1424
1425 found:
1426   gfc_procedure_use (sym, &c->ext.actual, &c->loc);
1427
1428   c->resolved_sym = sym;
1429   pure_subroutine (c, sym);
1430
1431   return MATCH_YES;
1432 }
1433
1434
1435 static try
1436 resolve_specific_s (gfc_code * c)
1437 {
1438   gfc_symbol *sym;
1439   match m;
1440
1441   sym = c->symtree->n.sym;
1442
1443   m = resolve_specific_s0 (c, sym);
1444   if (m == MATCH_YES)
1445     return SUCCESS;
1446   if (m == MATCH_ERROR)
1447     return FAILURE;
1448
1449   gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
1450
1451   if (sym != NULL)
1452     {
1453       m = resolve_specific_s0 (c, sym);
1454       if (m == MATCH_YES)
1455         return SUCCESS;
1456       if (m == MATCH_ERROR)
1457         return FAILURE;
1458     }
1459
1460   gfc_error ("Unable to resolve the specific subroutine '%s' at %L",
1461              sym->name, &c->loc);
1462
1463   return FAILURE;
1464 }
1465
1466
1467 /* Resolve a subroutine call not known to be generic nor specific.  */
1468
1469 static try
1470 resolve_unknown_s (gfc_code * c)
1471 {
1472   gfc_symbol *sym;
1473
1474   sym = c->symtree->n.sym;
1475
1476   if (sym->attr.dummy)
1477     {
1478       sym->attr.proc = PROC_DUMMY;
1479       goto found;
1480     }
1481
1482   /* See if we have an intrinsic function reference.  */
1483
1484   if (gfc_intrinsic_name (sym->name, 1))
1485     {
1486       if (gfc_intrinsic_sub_interface (c, 1) == MATCH_YES)
1487         return SUCCESS;
1488       return FAILURE;
1489     }
1490
1491   /* The reference is to an external name.  */
1492
1493 found:
1494   gfc_procedure_use (sym, &c->ext.actual, &c->loc);
1495
1496   c->resolved_sym = sym;
1497
1498   pure_subroutine (c, sym);
1499
1500   return SUCCESS;
1501 }
1502
1503
1504 /* Resolve a subroutine call.  Although it was tempting to use the same code
1505    for functions, subroutines and functions are stored differently and this
1506    makes things awkward.  */
1507
1508 static try
1509 resolve_call (gfc_code * c)
1510 {
1511   try t;
1512
1513   /* Switch off assumed size checking and do this again for certain kinds
1514      of procedure, once the procedure itself is resolved.  */
1515   need_full_assumed_size++;
1516
1517   if (resolve_actual_arglist (c->ext.actual) == FAILURE)
1518     return FAILURE;
1519
1520   /* Resume assumed_size checking. */
1521   need_full_assumed_size--;
1522
1523
1524   t = SUCCESS;
1525   if (c->resolved_sym == NULL)
1526     switch (procedure_kind (c->symtree->n.sym))
1527       {
1528       case PTYPE_GENERIC:
1529         t = resolve_generic_s (c);
1530         break;
1531
1532       case PTYPE_SPECIFIC:
1533         t = resolve_specific_s (c);
1534         break;
1535
1536       case PTYPE_UNKNOWN:
1537         t = resolve_unknown_s (c);
1538         break;
1539
1540       default:
1541         gfc_internal_error ("resolve_subroutine(): bad function type");
1542       }
1543
1544   if (c->ext.actual != NULL
1545       && c->symtree->n.sym->attr.elemental)
1546     {
1547       gfc_actual_arglist * a;
1548       /* Being elemental, the last upper bound of an assumed size array
1549          argument must be present.  */
1550       for (a = c->ext.actual; a; a = a->next)
1551         {
1552           if (a->expr != NULL
1553                 && a->expr->rank > 0
1554                 && resolve_assumed_size_actual (a->expr))
1555             return FAILURE;
1556         }
1557     }
1558
1559   if (t == SUCCESS)
1560     find_noncopying_intrinsics (c->resolved_sym, c->ext.actual);
1561   return t;
1562 }
1563
1564 /* Compare the shapes of two arrays that have non-NULL shapes.  If both
1565    op1->shape and op2->shape are non-NULL return SUCCESS if their shapes
1566    match.  If both op1->shape and op2->shape are non-NULL return FAILURE
1567    if their shapes do not match.  If either op1->shape or op2->shape is
1568    NULL, return SUCCESS.  */
1569
1570 static try
1571 compare_shapes (gfc_expr * op1, gfc_expr * op2)
1572 {
1573   try t;
1574   int i;
1575
1576   t = SUCCESS;
1577
1578   if (op1->shape != NULL && op2->shape != NULL)
1579     {
1580       for (i = 0; i < op1->rank; i++)
1581         {
1582           if (mpz_cmp (op1->shape[i], op2->shape[i]) != 0)
1583            {
1584              gfc_error ("Shapes for operands at %L and %L are not conformable",
1585                          &op1->where, &op2->where);
1586              t = FAILURE;
1587              break;
1588            }
1589         }
1590     }
1591
1592   return t;
1593 }
1594
1595 /* Resolve an operator expression node.  This can involve replacing the
1596    operation with a user defined function call.  */
1597
1598 static try
1599 resolve_operator (gfc_expr * e)
1600 {
1601   gfc_expr *op1, *op2;
1602   char msg[200];
1603   try t;
1604
1605   /* Resolve all subnodes-- give them types.  */
1606
1607   switch (e->value.op.operator)
1608     {
1609     default:
1610       if (gfc_resolve_expr (e->value.op.op2) == FAILURE)
1611         return FAILURE;
1612
1613     /* Fall through...  */
1614
1615     case INTRINSIC_NOT:
1616     case INTRINSIC_UPLUS:
1617     case INTRINSIC_UMINUS:
1618       if (gfc_resolve_expr (e->value.op.op1) == FAILURE)
1619         return FAILURE;
1620       break;
1621     }
1622
1623   /* Typecheck the new node.  */
1624
1625   op1 = e->value.op.op1;
1626   op2 = e->value.op.op2;
1627
1628   switch (e->value.op.operator)
1629     {
1630     case INTRINSIC_UPLUS:
1631     case INTRINSIC_UMINUS:
1632       if (op1->ts.type == BT_INTEGER
1633           || op1->ts.type == BT_REAL
1634           || op1->ts.type == BT_COMPLEX)
1635         {
1636           e->ts = op1->ts;
1637           break;
1638         }
1639
1640       sprintf (msg, _("Operand of unary numeric operator '%s' at %%L is %s"),
1641                gfc_op2string (e->value.op.operator), gfc_typename (&e->ts));
1642       goto bad_op;
1643
1644     case INTRINSIC_PLUS:
1645     case INTRINSIC_MINUS:
1646     case INTRINSIC_TIMES:
1647     case INTRINSIC_DIVIDE:
1648     case INTRINSIC_POWER:
1649       if (gfc_numeric_ts (&op1->ts) && gfc_numeric_ts (&op2->ts))
1650         {
1651           gfc_type_convert_binary (e);
1652           break;
1653         }
1654
1655       sprintf (msg,
1656                _("Operands of binary numeric operator '%s' at %%L are %s/%s"),
1657                gfc_op2string (e->value.op.operator), gfc_typename (&op1->ts),
1658                gfc_typename (&op2->ts));
1659       goto bad_op;
1660
1661     case INTRINSIC_CONCAT:
1662       if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER)
1663         {
1664           e->ts.type = BT_CHARACTER;
1665           e->ts.kind = op1->ts.kind;
1666           break;
1667         }
1668
1669       sprintf (msg,
1670                _("Operands of string concatenation operator at %%L are %s/%s"),
1671                gfc_typename (&op1->ts), gfc_typename (&op2->ts));
1672       goto bad_op;
1673
1674     case INTRINSIC_AND:
1675     case INTRINSIC_OR:
1676     case INTRINSIC_EQV:
1677     case INTRINSIC_NEQV:
1678       if (op1->ts.type == BT_LOGICAL && op2->ts.type == BT_LOGICAL)
1679         {
1680           e->ts.type = BT_LOGICAL;
1681           e->ts.kind = gfc_kind_max (op1, op2);
1682           if (op1->ts.kind < e->ts.kind)
1683             gfc_convert_type (op1, &e->ts, 2);
1684           else if (op2->ts.kind < e->ts.kind)
1685             gfc_convert_type (op2, &e->ts, 2);
1686           break;
1687         }
1688
1689       sprintf (msg, _("Operands of logical operator '%s' at %%L are %s/%s"),
1690                gfc_op2string (e->value.op.operator), gfc_typename (&op1->ts),
1691                gfc_typename (&op2->ts));
1692
1693       goto bad_op;
1694
1695     case INTRINSIC_NOT:
1696       if (op1->ts.type == BT_LOGICAL)
1697         {
1698           e->ts.type = BT_LOGICAL;
1699           e->ts.kind = op1->ts.kind;
1700           break;
1701         }
1702
1703       sprintf (msg, _("Operand of .NOT. operator at %%L is %s"),
1704                gfc_typename (&op1->ts));
1705       goto bad_op;
1706
1707     case INTRINSIC_GT:
1708     case INTRINSIC_GE:
1709     case INTRINSIC_LT:
1710     case INTRINSIC_LE:
1711       if (op1->ts.type == BT_COMPLEX || op2->ts.type == BT_COMPLEX)
1712         {
1713           strcpy (msg, _("COMPLEX quantities cannot be compared at %L"));
1714           goto bad_op;
1715         }
1716
1717       /* Fall through...  */
1718
1719     case INTRINSIC_EQ:
1720     case INTRINSIC_NE:
1721       if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER)
1722         {
1723           e->ts.type = BT_LOGICAL;
1724           e->ts.kind = gfc_default_logical_kind;
1725           break;
1726         }
1727
1728       if (gfc_numeric_ts (&op1->ts) && gfc_numeric_ts (&op2->ts))
1729         {
1730           gfc_type_convert_binary (e);
1731
1732           e->ts.type = BT_LOGICAL;
1733           e->ts.kind = gfc_default_logical_kind;
1734           break;
1735         }
1736
1737       if (op1->ts.type == BT_LOGICAL && op2->ts.type == BT_LOGICAL)
1738         sprintf (msg,
1739                  _("Logicals at %%L must be compared with %s instead of %s"),
1740                  e->value.op.operator == INTRINSIC_EQ ? ".EQV." : ".NEQV.",
1741                  gfc_op2string (e->value.op.operator));
1742       else
1743         sprintf (msg,
1744                  _("Operands of comparison operator '%s' at %%L are %s/%s"),
1745                  gfc_op2string (e->value.op.operator), gfc_typename (&op1->ts),
1746                  gfc_typename (&op2->ts));
1747
1748       goto bad_op;
1749
1750     case INTRINSIC_USER:
1751       if (op2 == NULL)
1752         sprintf (msg, _("Operand of user operator '%s' at %%L is %s"),
1753                  e->value.op.uop->name, gfc_typename (&op1->ts));
1754       else
1755         sprintf (msg, _("Operands of user operator '%s' at %%L are %s/%s"),
1756                  e->value.op.uop->name, gfc_typename (&op1->ts),
1757                  gfc_typename (&op2->ts));
1758
1759       goto bad_op;
1760
1761     default:
1762       gfc_internal_error ("resolve_operator(): Bad intrinsic");
1763     }
1764
1765   /* Deal with arrayness of an operand through an operator.  */
1766
1767   t = SUCCESS;
1768
1769   switch (e->value.op.operator)
1770     {
1771     case INTRINSIC_PLUS:
1772     case INTRINSIC_MINUS:
1773     case INTRINSIC_TIMES:
1774     case INTRINSIC_DIVIDE:
1775     case INTRINSIC_POWER:
1776     case INTRINSIC_CONCAT:
1777     case INTRINSIC_AND:
1778     case INTRINSIC_OR:
1779     case INTRINSIC_EQV:
1780     case INTRINSIC_NEQV:
1781     case INTRINSIC_EQ:
1782     case INTRINSIC_NE:
1783     case INTRINSIC_GT:
1784     case INTRINSIC_GE:
1785     case INTRINSIC_LT:
1786     case INTRINSIC_LE:
1787
1788       if (op1->rank == 0 && op2->rank == 0)
1789         e->rank = 0;
1790
1791       if (op1->rank == 0 && op2->rank != 0)
1792         {
1793           e->rank = op2->rank;
1794
1795           if (e->shape == NULL)
1796             e->shape = gfc_copy_shape (op2->shape, op2->rank);
1797         }
1798
1799       if (op1->rank != 0 && op2->rank == 0)
1800         {
1801           e->rank = op1->rank;
1802
1803           if (e->shape == NULL)
1804             e->shape = gfc_copy_shape (op1->shape, op1->rank);
1805         }
1806
1807       if (op1->rank != 0 && op2->rank != 0)
1808         {
1809           if (op1->rank == op2->rank)
1810             {
1811               e->rank = op1->rank;
1812               if (e->shape == NULL)
1813                 {
1814                   t = compare_shapes(op1, op2);
1815                   if (t == FAILURE)
1816                     e->shape = NULL;
1817                   else
1818                 e->shape = gfc_copy_shape (op1->shape, op1->rank);
1819                 }
1820             }
1821           else
1822             {
1823               gfc_error ("Inconsistent ranks for operator at %L and %L",
1824                          &op1->where, &op2->where);
1825               t = FAILURE;
1826
1827               /* Allow higher level expressions to work.  */
1828               e->rank = 0;
1829             }
1830         }
1831
1832       break;
1833
1834     case INTRINSIC_NOT:
1835     case INTRINSIC_UPLUS:
1836     case INTRINSIC_UMINUS:
1837       e->rank = op1->rank;
1838
1839       if (e->shape == NULL)
1840         e->shape = gfc_copy_shape (op1->shape, op1->rank);
1841
1842       /* Simply copy arrayness attribute */
1843       break;
1844
1845     default:
1846       break;
1847     }
1848
1849   /* Attempt to simplify the expression.  */
1850   if (t == SUCCESS)
1851     t = gfc_simplify_expr (e, 0);
1852   return t;
1853
1854 bad_op:
1855
1856   if (gfc_extend_expr (e) == SUCCESS)
1857     return SUCCESS;
1858
1859   gfc_error (msg, &e->where);
1860
1861   return FAILURE;
1862 }
1863
1864
1865 /************** Array resolution subroutines **************/
1866
1867
1868 typedef enum
1869 { CMP_LT, CMP_EQ, CMP_GT, CMP_UNKNOWN }
1870 comparison;
1871
1872 /* Compare two integer expressions.  */
1873
1874 static comparison
1875 compare_bound (gfc_expr * a, gfc_expr * b)
1876 {
1877   int i;
1878
1879   if (a == NULL || a->expr_type != EXPR_CONSTANT
1880       || b == NULL || b->expr_type != EXPR_CONSTANT)
1881     return CMP_UNKNOWN;
1882
1883   if (a->ts.type != BT_INTEGER || b->ts.type != BT_INTEGER)
1884     gfc_internal_error ("compare_bound(): Bad expression");
1885
1886   i = mpz_cmp (a->value.integer, b->value.integer);
1887
1888   if (i < 0)
1889     return CMP_LT;
1890   if (i > 0)
1891     return CMP_GT;
1892   return CMP_EQ;
1893 }
1894
1895
1896 /* Compare an integer expression with an integer.  */
1897
1898 static comparison
1899 compare_bound_int (gfc_expr * a, int b)
1900 {
1901   int i;
1902
1903   if (a == NULL || a->expr_type != EXPR_CONSTANT)
1904     return CMP_UNKNOWN;
1905
1906   if (a->ts.type != BT_INTEGER)
1907     gfc_internal_error ("compare_bound_int(): Bad expression");
1908
1909   i = mpz_cmp_si (a->value.integer, b);
1910
1911   if (i < 0)
1912     return CMP_LT;
1913   if (i > 0)
1914     return CMP_GT;
1915   return CMP_EQ;
1916 }
1917
1918
1919 /* Compare a single dimension of an array reference to the array
1920    specification.  */
1921
1922 static try
1923 check_dimension (int i, gfc_array_ref * ar, gfc_array_spec * as)
1924 {
1925
1926 /* Given start, end and stride values, calculate the minimum and
1927    maximum referenced indexes.  */
1928
1929   switch (ar->type)
1930     {
1931     case AR_FULL:
1932       break;
1933
1934     case AR_ELEMENT:
1935       if (compare_bound (ar->start[i], as->lower[i]) == CMP_LT)
1936         goto bound;
1937       if (compare_bound (ar->start[i], as->upper[i]) == CMP_GT)
1938         goto bound;
1939
1940       break;
1941
1942     case AR_SECTION:
1943       if (compare_bound_int (ar->stride[i], 0) == CMP_EQ)
1944         {
1945           gfc_error ("Illegal stride of zero at %L", &ar->c_where[i]);
1946           return FAILURE;
1947         }
1948
1949       if (compare_bound (ar->start[i], as->lower[i]) == CMP_LT)
1950         goto bound;
1951       if (compare_bound (ar->start[i], as->upper[i]) == CMP_GT)
1952         goto bound;
1953
1954       /* TODO: Possibly, we could warn about end[i] being out-of-bound although
1955          it is legal (see 6.2.2.3.1).  */
1956
1957       break;
1958
1959     default:
1960       gfc_internal_error ("check_dimension(): Bad array reference");
1961     }
1962
1963   return SUCCESS;
1964
1965 bound:
1966   gfc_warning ("Array reference at %L is out of bounds", &ar->c_where[i]);
1967   return SUCCESS;
1968 }
1969
1970
1971 /* Compare an array reference with an array specification.  */
1972
1973 static try
1974 compare_spec_to_ref (gfc_array_ref * ar)
1975 {
1976   gfc_array_spec *as;
1977   int i;
1978
1979   as = ar->as;
1980   i = as->rank - 1;
1981   /* TODO: Full array sections are only allowed as actual parameters.  */
1982   if (as->type == AS_ASSUMED_SIZE
1983       && (/*ar->type == AR_FULL
1984           ||*/ (ar->type == AR_SECTION
1985               && ar->dimen_type[i] == DIMEN_RANGE && ar->end[i] == NULL)))
1986     {
1987       gfc_error ("Rightmost upper bound of assumed size array section"
1988                  " not specified at %L", &ar->where);
1989       return FAILURE;
1990     }
1991
1992   if (ar->type == AR_FULL)
1993     return SUCCESS;
1994
1995   if (as->rank != ar->dimen)
1996     {
1997       gfc_error ("Rank mismatch in array reference at %L (%d/%d)",
1998                  &ar->where, ar->dimen, as->rank);
1999       return FAILURE;
2000     }
2001
2002   for (i = 0; i < as->rank; i++)
2003     if (check_dimension (i, ar, as) == FAILURE)
2004       return FAILURE;
2005
2006   return SUCCESS;
2007 }
2008
2009
2010 /* Resolve one part of an array index.  */
2011
2012 try
2013 gfc_resolve_index (gfc_expr * index, int check_scalar)
2014 {
2015   gfc_typespec ts;
2016
2017   if (index == NULL)
2018     return SUCCESS;
2019
2020   if (gfc_resolve_expr (index) == FAILURE)
2021     return FAILURE;
2022
2023   if (check_scalar && index->rank != 0)
2024     {
2025       gfc_error ("Array index at %L must be scalar", &index->where);
2026       return FAILURE;
2027     }
2028
2029   if (index->ts.type != BT_INTEGER && index->ts.type != BT_REAL)
2030     {
2031       gfc_error ("Array index at %L must be of INTEGER type",
2032                  &index->where);
2033       return FAILURE;
2034     }
2035
2036   if (index->ts.type == BT_REAL)
2037     if (gfc_notify_std (GFC_STD_GNU, "Extension: REAL array index at %L",
2038                         &index->where) == FAILURE)
2039       return FAILURE;
2040
2041   if (index->ts.kind != gfc_index_integer_kind
2042       || index->ts.type != BT_INTEGER)
2043     {
2044       ts.type = BT_INTEGER;
2045       ts.kind = gfc_index_integer_kind;
2046
2047       gfc_convert_type_warn (index, &ts, 2, 0);
2048     }
2049
2050   return SUCCESS;
2051 }
2052
2053 /* Resolve a dim argument to an intrinsic function.  */
2054
2055 try
2056 gfc_resolve_dim_arg (gfc_expr *dim)
2057 {
2058   if (dim == NULL)
2059     return SUCCESS;
2060
2061   if (gfc_resolve_expr (dim) == FAILURE)
2062     return FAILURE;
2063
2064   if (dim->rank != 0)
2065     {
2066       gfc_error ("Argument dim at %L must be scalar", &dim->where);
2067       return FAILURE;
2068
2069     }
2070   if (dim->ts.type != BT_INTEGER)
2071     {
2072       gfc_error ("Argument dim at %L must be of INTEGER type", &dim->where);
2073       return FAILURE;
2074     }
2075   if (dim->ts.kind != gfc_index_integer_kind)
2076     {
2077       gfc_typespec ts;
2078
2079       ts.type = BT_INTEGER;
2080       ts.kind = gfc_index_integer_kind;
2081
2082       gfc_convert_type_warn (dim, &ts, 2, 0);
2083     }
2084
2085   return SUCCESS;
2086 }
2087
2088 /* Given an expression that contains array references, update those array
2089    references to point to the right array specifications.  While this is
2090    filled in during matching, this information is difficult to save and load
2091    in a module, so we take care of it here.
2092
2093    The idea here is that the original array reference comes from the
2094    base symbol.  We traverse the list of reference structures, setting
2095    the stored reference to references.  Component references can
2096    provide an additional array specification.  */
2097
2098 static void
2099 find_array_spec (gfc_expr * e)
2100 {
2101   gfc_array_spec *as;
2102   gfc_component *c;
2103   gfc_ref *ref;
2104
2105   as = e->symtree->n.sym->as;
2106
2107   for (ref = e->ref; ref; ref = ref->next)
2108     switch (ref->type)
2109       {
2110       case REF_ARRAY:
2111         if (as == NULL)
2112           gfc_internal_error ("find_array_spec(): Missing spec");
2113
2114         ref->u.ar.as = as;
2115         as = NULL;
2116         break;
2117
2118       case REF_COMPONENT:
2119         for (c = e->symtree->n.sym->ts.derived->components; c; c = c->next)
2120           if (c == ref->u.c.component)
2121             break;
2122
2123         if (c == NULL)
2124           gfc_internal_error ("find_array_spec(): Component not found");
2125
2126         if (c->dimension)
2127           {
2128             if (as != NULL)
2129               gfc_internal_error ("find_array_spec(): unused as(1)");
2130             as = c->as;
2131           }
2132
2133         break;
2134
2135       case REF_SUBSTRING:
2136         break;
2137       }
2138
2139   if (as != NULL)
2140     gfc_internal_error ("find_array_spec(): unused as(2)");
2141 }
2142
2143
2144 /* Resolve an array reference.  */
2145
2146 static try
2147 resolve_array_ref (gfc_array_ref * ar)
2148 {
2149   int i, check_scalar;
2150
2151   for (i = 0; i < ar->dimen; i++)
2152     {
2153       check_scalar = ar->dimen_type[i] == DIMEN_RANGE;
2154
2155       if (gfc_resolve_index (ar->start[i], check_scalar) == FAILURE)
2156         return FAILURE;
2157       if (gfc_resolve_index (ar->end[i], check_scalar) == FAILURE)
2158         return FAILURE;
2159       if (gfc_resolve_index (ar->stride[i], check_scalar) == FAILURE)
2160         return FAILURE;
2161
2162       if (ar->dimen_type[i] == DIMEN_UNKNOWN)
2163         switch (ar->start[i]->rank)
2164           {
2165           case 0:
2166             ar->dimen_type[i] = DIMEN_ELEMENT;
2167             break;
2168
2169           case 1:
2170             ar->dimen_type[i] = DIMEN_VECTOR;
2171             break;
2172
2173           default:
2174             gfc_error ("Array index at %L is an array of rank %d",
2175                        &ar->c_where[i], ar->start[i]->rank);
2176             return FAILURE;
2177           }
2178     }
2179
2180   /* If the reference type is unknown, figure out what kind it is.  */
2181
2182   if (ar->type == AR_UNKNOWN)
2183     {
2184       ar->type = AR_ELEMENT;
2185       for (i = 0; i < ar->dimen; i++)
2186         if (ar->dimen_type[i] == DIMEN_RANGE
2187             || ar->dimen_type[i] == DIMEN_VECTOR)
2188           {
2189             ar->type = AR_SECTION;
2190             break;
2191           }
2192     }
2193
2194   if (!ar->as->cray_pointee && compare_spec_to_ref (ar) == FAILURE)
2195     return FAILURE;
2196
2197   return SUCCESS;
2198 }
2199
2200
2201 static try
2202 resolve_substring (gfc_ref * ref)
2203 {
2204
2205   if (ref->u.ss.start != NULL)
2206     {
2207       if (gfc_resolve_expr (ref->u.ss.start) == FAILURE)
2208         return FAILURE;
2209
2210       if (ref->u.ss.start->ts.type != BT_INTEGER)
2211         {
2212           gfc_error ("Substring start index at %L must be of type INTEGER",
2213                      &ref->u.ss.start->where);
2214           return FAILURE;
2215         }
2216
2217       if (ref->u.ss.start->rank != 0)
2218         {
2219           gfc_error ("Substring start index at %L must be scalar",
2220                      &ref->u.ss.start->where);
2221           return FAILURE;
2222         }
2223
2224       if (compare_bound_int (ref->u.ss.start, 1) == CMP_LT)
2225         {
2226           gfc_error ("Substring start index at %L is less than one",
2227                      &ref->u.ss.start->where);
2228           return FAILURE;
2229         }
2230     }
2231
2232   if (ref->u.ss.end != NULL)
2233     {
2234       if (gfc_resolve_expr (ref->u.ss.end) == FAILURE)
2235         return FAILURE;
2236
2237       if (ref->u.ss.end->ts.type != BT_INTEGER)
2238         {
2239           gfc_error ("Substring end index at %L must be of type INTEGER",
2240                      &ref->u.ss.end->where);
2241           return FAILURE;
2242         }
2243
2244       if (ref->u.ss.end->rank != 0)
2245         {
2246           gfc_error ("Substring end index at %L must be scalar",
2247                      &ref->u.ss.end->where);
2248           return FAILURE;
2249         }
2250
2251       if (ref->u.ss.length != NULL
2252           && compare_bound (ref->u.ss.end, ref->u.ss.length->length) == CMP_GT)
2253         {
2254           gfc_error ("Substring end index at %L is out of bounds",
2255                      &ref->u.ss.start->where);
2256           return FAILURE;
2257         }
2258     }
2259
2260   return SUCCESS;
2261 }
2262
2263
2264 /* Resolve subtype references.  */
2265
2266 static try
2267 resolve_ref (gfc_expr * expr)
2268 {
2269   int current_part_dimension, n_components, seen_part_dimension;
2270   gfc_ref *ref;
2271
2272   for (ref = expr->ref; ref; ref = ref->next)
2273     if (ref->type == REF_ARRAY && ref->u.ar.as == NULL)
2274       {
2275         find_array_spec (expr);
2276         break;
2277       }
2278
2279   for (ref = expr->ref; ref; ref = ref->next)
2280     switch (ref->type)
2281       {
2282       case REF_ARRAY:
2283         if (resolve_array_ref (&ref->u.ar) == FAILURE)
2284           return FAILURE;
2285         break;
2286
2287       case REF_COMPONENT:
2288         break;
2289
2290       case REF_SUBSTRING:
2291         resolve_substring (ref);
2292         break;
2293       }
2294
2295   /* Check constraints on part references.  */
2296
2297   current_part_dimension = 0;
2298   seen_part_dimension = 0;
2299   n_components = 0;
2300
2301   for (ref = expr->ref; ref; ref = ref->next)
2302     {
2303       switch (ref->type)
2304         {
2305         case REF_ARRAY:
2306           switch (ref->u.ar.type)
2307             {
2308             case AR_FULL:
2309             case AR_SECTION:
2310               current_part_dimension = 1;
2311               break;
2312
2313             case AR_ELEMENT:
2314               current_part_dimension = 0;
2315               break;
2316
2317             case AR_UNKNOWN:
2318               gfc_internal_error ("resolve_ref(): Bad array reference");
2319             }
2320
2321           break;
2322
2323         case REF_COMPONENT:
2324           if ((current_part_dimension || seen_part_dimension)
2325               && ref->u.c.component->pointer)
2326             {
2327               gfc_error
2328                 ("Component to the right of a part reference with nonzero "
2329                  "rank must not have the POINTER attribute at %L",
2330                  &expr->where);
2331               return FAILURE;
2332             }
2333
2334           n_components++;
2335           break;
2336
2337         case REF_SUBSTRING:
2338           break;
2339         }
2340
2341       if (((ref->type == REF_COMPONENT && n_components > 1)
2342            || ref->next == NULL)
2343           && current_part_dimension
2344           && seen_part_dimension)
2345         {
2346
2347           gfc_error ("Two or more part references with nonzero rank must "
2348                      "not be specified at %L", &expr->where);
2349           return FAILURE;
2350         }
2351
2352       if (ref->type == REF_COMPONENT)
2353         {
2354           if (current_part_dimension)
2355             seen_part_dimension = 1;
2356
2357           /* reset to make sure */
2358           current_part_dimension = 0;
2359         }
2360     }
2361
2362   return SUCCESS;
2363 }
2364
2365
2366 /* Given an expression, determine its shape.  This is easier than it sounds.
2367    Leaves the shape array NULL if it is not possible to determine the shape.  */
2368
2369 static void
2370 expression_shape (gfc_expr * e)
2371 {
2372   mpz_t array[GFC_MAX_DIMENSIONS];
2373   int i;
2374
2375   if (e->rank == 0 || e->shape != NULL)
2376     return;
2377
2378   for (i = 0; i < e->rank; i++)
2379     if (gfc_array_dimen_size (e, i, &array[i]) == FAILURE)
2380       goto fail;
2381
2382   e->shape = gfc_get_shape (e->rank);
2383
2384   memcpy (e->shape, array, e->rank * sizeof (mpz_t));
2385
2386   return;
2387
2388 fail:
2389   for (i--; i >= 0; i--)
2390     mpz_clear (array[i]);
2391 }
2392
2393
2394 /* Given a variable expression node, compute the rank of the expression by
2395    examining the base symbol and any reference structures it may have.  */
2396
2397 static void
2398 expression_rank (gfc_expr * e)
2399 {
2400   gfc_ref *ref;
2401   int i, rank;
2402
2403   if (e->ref == NULL)
2404     {
2405       if (e->expr_type == EXPR_ARRAY)
2406         goto done;
2407       /* Constructors can have a rank different from one via RESHAPE().  */
2408
2409       if (e->symtree == NULL)
2410         {
2411           e->rank = 0;
2412           goto done;
2413         }
2414
2415       e->rank = (e->symtree->n.sym->as == NULL)
2416                   ? 0 : e->symtree->n.sym->as->rank;
2417       goto done;
2418     }
2419
2420   rank = 0;
2421
2422   for (ref = e->ref; ref; ref = ref->next)
2423     {
2424       if (ref->type != REF_ARRAY)
2425         continue;
2426
2427       if (ref->u.ar.type == AR_FULL)
2428         {
2429           rank = ref->u.ar.as->rank;
2430           break;
2431         }
2432
2433       if (ref->u.ar.type == AR_SECTION)
2434         {
2435           /* Figure out the rank of the section.  */
2436           if (rank != 0)
2437             gfc_internal_error ("expression_rank(): Two array specs");
2438
2439           for (i = 0; i < ref->u.ar.dimen; i++)
2440             if (ref->u.ar.dimen_type[i] == DIMEN_RANGE
2441                 || ref->u.ar.dimen_type[i] == DIMEN_VECTOR)
2442               rank++;
2443
2444           break;
2445         }
2446     }
2447
2448   e->rank = rank;
2449
2450 done:
2451   expression_shape (e);
2452 }
2453
2454
2455 /* Resolve a variable expression.  */
2456
2457 static try
2458 resolve_variable (gfc_expr * e)
2459 {
2460   gfc_symbol *sym;
2461
2462   if (e->ref && resolve_ref (e) == FAILURE)
2463     return FAILURE;
2464
2465   if (e->symtree == NULL)
2466     return FAILURE;
2467
2468   sym = e->symtree->n.sym;
2469   if (sym->attr.flavor == FL_PROCEDURE && !sym->attr.function)
2470     {
2471       e->ts.type = BT_PROCEDURE;
2472       return SUCCESS;
2473     }
2474
2475   if (sym->ts.type != BT_UNKNOWN)
2476     gfc_variable_attr (e, &e->ts);
2477   else
2478     {
2479       /* Must be a simple variable reference.  */
2480       if (gfc_set_default_type (sym, 1, NULL) == FAILURE)
2481         return FAILURE;
2482       e->ts = sym->ts;
2483     }
2484
2485   if (check_assumed_size_reference (sym, e))
2486     return FAILURE;
2487
2488   return SUCCESS;
2489 }
2490
2491
2492 /* Resolve an expression.  That is, make sure that types of operands agree
2493    with their operators, intrinsic operators are converted to function calls
2494    for overloaded types and unresolved function references are resolved.  */
2495
2496 try
2497 gfc_resolve_expr (gfc_expr * e)
2498 {
2499   try t;
2500
2501   if (e == NULL)
2502     return SUCCESS;
2503
2504   switch (e->expr_type)
2505     {
2506     case EXPR_OP:
2507       t = resolve_operator (e);
2508       break;
2509
2510     case EXPR_FUNCTION:
2511       t = resolve_function (e);
2512       break;
2513
2514     case EXPR_VARIABLE:
2515       t = resolve_variable (e);
2516       if (t == SUCCESS)
2517         expression_rank (e);
2518       break;
2519
2520     case EXPR_SUBSTRING:
2521       t = resolve_ref (e);
2522       break;
2523
2524     case EXPR_CONSTANT:
2525     case EXPR_NULL:
2526       t = SUCCESS;
2527       break;
2528
2529     case EXPR_ARRAY:
2530       t = FAILURE;
2531       if (resolve_ref (e) == FAILURE)
2532         break;
2533
2534       t = gfc_resolve_array_constructor (e);
2535       /* Also try to expand a constructor.  */
2536       if (t == SUCCESS)
2537         {
2538           expression_rank (e);
2539           gfc_expand_constructor (e);
2540         }
2541
2542       break;
2543
2544     case EXPR_STRUCTURE:
2545       t = resolve_ref (e);
2546       if (t == FAILURE)
2547         break;
2548
2549       t = resolve_structure_cons (e);
2550       if (t == FAILURE)
2551         break;
2552
2553       t = gfc_simplify_expr (e, 0);
2554       break;
2555
2556     default:
2557       gfc_internal_error ("gfc_resolve_expr(): Bad expression type");
2558     }
2559
2560   return t;
2561 }
2562
2563
2564 /* Resolve an expression from an iterator.  They must be scalar and have
2565    INTEGER or (optionally) REAL type.  */
2566
2567 static try
2568 gfc_resolve_iterator_expr (gfc_expr * expr, bool real_ok,
2569                            const char * name_msgid)
2570 {
2571   if (gfc_resolve_expr (expr) == FAILURE)
2572     return FAILURE;
2573
2574   if (expr->rank != 0)
2575     {
2576       gfc_error ("%s at %L must be a scalar", _(name_msgid), &expr->where);
2577       return FAILURE;
2578     }
2579
2580   if (!(expr->ts.type == BT_INTEGER
2581         || (expr->ts.type == BT_REAL && real_ok)))
2582     {
2583       if (real_ok)
2584         gfc_error ("%s at %L must be INTEGER or REAL", _(name_msgid),
2585                    &expr->where);
2586       else
2587         gfc_error ("%s at %L must be INTEGER", _(name_msgid), &expr->where);
2588       return FAILURE;
2589     }
2590   return SUCCESS;
2591 }
2592
2593
2594 /* Resolve the expressions in an iterator structure.  If REAL_OK is
2595    false allow only INTEGER type iterators, otherwise allow REAL types.  */
2596
2597 try
2598 gfc_resolve_iterator (gfc_iterator * iter, bool real_ok)
2599 {
2600
2601   if (iter->var->ts.type == BT_REAL)
2602     gfc_notify_std (GFC_STD_F95_DEL,
2603                     "Obsolete: REAL DO loop iterator at %L",
2604                     &iter->var->where);
2605
2606   if (gfc_resolve_iterator_expr (iter->var, real_ok, "Loop variable")
2607       == FAILURE)
2608     return FAILURE;
2609
2610   if (gfc_pure (NULL) && gfc_impure_variable (iter->var->symtree->n.sym))
2611     {
2612       gfc_error ("Cannot assign to loop variable in PURE procedure at %L",
2613                  &iter->var->where);
2614       return FAILURE;
2615     }
2616
2617   if (gfc_resolve_iterator_expr (iter->start, real_ok,
2618                                  "Start expression in DO loop") == FAILURE)
2619     return FAILURE;
2620
2621   if (gfc_resolve_iterator_expr (iter->end, real_ok,
2622                                  "End expression in DO loop") == FAILURE)
2623     return FAILURE;
2624
2625   if (gfc_resolve_iterator_expr (iter->step, real_ok,
2626                                  "Step expression in DO loop") == FAILURE)
2627     return FAILURE;
2628
2629   if (iter->step->expr_type == EXPR_CONSTANT)
2630     {
2631       if ((iter->step->ts.type == BT_INTEGER
2632            && mpz_cmp_ui (iter->step->value.integer, 0) == 0)
2633           || (iter->step->ts.type == BT_REAL
2634               && mpfr_sgn (iter->step->value.real) == 0))
2635         {
2636           gfc_error ("Step expression in DO loop at %L cannot be zero",
2637                      &iter->step->where);
2638           return FAILURE;
2639         }
2640     }
2641
2642   /* Convert start, end, and step to the same type as var.  */
2643   if (iter->start->ts.kind != iter->var->ts.kind
2644       || iter->start->ts.type != iter->var->ts.type)
2645     gfc_convert_type (iter->start, &iter->var->ts, 2);
2646
2647   if (iter->end->ts.kind != iter->var->ts.kind
2648       || iter->end->ts.type != iter->var->ts.type)
2649     gfc_convert_type (iter->end, &iter->var->ts, 2);
2650
2651   if (iter->step->ts.kind != iter->var->ts.kind
2652       || iter->step->ts.type != iter->var->ts.type)
2653     gfc_convert_type (iter->step, &iter->var->ts, 2);
2654
2655   return SUCCESS;
2656 }
2657
2658
2659 /* Resolve a list of FORALL iterators.  The FORALL index-name is constrained
2660    to be a scalar INTEGER variable.  The subscripts and stride are scalar
2661    INTEGERs, and if stride is a constant it must be nonzero.  */
2662
2663 static void
2664 resolve_forall_iterators (gfc_forall_iterator * iter)
2665 {
2666
2667   while (iter)
2668     {
2669       if (gfc_resolve_expr (iter->var) == SUCCESS
2670           && (iter->var->ts.type != BT_INTEGER || iter->var->rank != 0))
2671         gfc_error ("FORALL index-name at %L must be a scalar INTEGER",
2672                    &iter->var->where);
2673
2674       if (gfc_resolve_expr (iter->start) == SUCCESS
2675           && (iter->start->ts.type != BT_INTEGER || iter->start->rank != 0))
2676         gfc_error ("FORALL start expression at %L must be a scalar INTEGER",
2677                    &iter->start->where);
2678       if (iter->var->ts.kind != iter->start->ts.kind)
2679         gfc_convert_type (iter->start, &iter->var->ts, 2);
2680
2681       if (gfc_resolve_expr (iter->end) == SUCCESS
2682           && (iter->end->ts.type != BT_INTEGER || iter->end->rank != 0))
2683         gfc_error ("FORALL end expression at %L must be a scalar INTEGER",
2684                    &iter->end->where);
2685       if (iter->var->ts.kind != iter->end->ts.kind)
2686         gfc_convert_type (iter->end, &iter->var->ts, 2);
2687
2688       if (gfc_resolve_expr (iter->stride) == SUCCESS)
2689         {
2690           if (iter->stride->ts.type != BT_INTEGER || iter->stride->rank != 0)
2691             gfc_error ("FORALL stride expression at %L must be a scalar %s",
2692                         &iter->stride->where, "INTEGER");
2693
2694           if (iter->stride->expr_type == EXPR_CONSTANT
2695               && mpz_cmp_ui(iter->stride->value.integer, 0) == 0)
2696             gfc_error ("FORALL stride expression at %L cannot be zero",
2697                        &iter->stride->where);
2698         }
2699       if (iter->var->ts.kind != iter->stride->ts.kind)
2700         gfc_convert_type (iter->stride, &iter->var->ts, 2);
2701
2702       iter = iter->next;
2703     }
2704 }
2705
2706
2707 /* Given a pointer to a symbol that is a derived type, see if any components
2708    have the POINTER attribute.  The search is recursive if necessary.
2709    Returns zero if no pointer components are found, nonzero otherwise.  */
2710
2711 static int
2712 derived_pointer (gfc_symbol * sym)
2713 {
2714   gfc_component *c;
2715
2716   for (c = sym->components; c; c = c->next)
2717     {
2718       if (c->pointer)
2719         return 1;
2720
2721       if (c->ts.type == BT_DERIVED && derived_pointer (c->ts.derived))
2722         return 1;
2723     }
2724
2725   return 0;
2726 }
2727
2728
2729 /* Given a pointer to a symbol that is a derived type, see if it's
2730    inaccessible, i.e. if it's defined in another module and the components are
2731    PRIVATE.  The search is recursive if necessary.  Returns zero if no
2732    inaccessible components are found, nonzero otherwise.  */
2733
2734 static int
2735 derived_inaccessible (gfc_symbol *sym)
2736 {
2737   gfc_component *c;
2738
2739   if (sym->attr.use_assoc && sym->component_access == ACCESS_PRIVATE)
2740     return 1;
2741
2742   for (c = sym->components; c; c = c->next)
2743     {
2744         if (c->ts.type == BT_DERIVED && derived_inaccessible (c->ts.derived))
2745           return 1;
2746     }
2747
2748   return 0;
2749 }
2750
2751
2752 /* Resolve the argument of a deallocate expression.  The expression must be
2753    a pointer or a full array.  */
2754
2755 static try
2756 resolve_deallocate_expr (gfc_expr * e)
2757 {
2758   symbol_attribute attr;
2759   int allocatable;
2760   gfc_ref *ref;
2761
2762   if (gfc_resolve_expr (e) == FAILURE)
2763     return FAILURE;
2764
2765   attr = gfc_expr_attr (e);
2766   if (attr.pointer)
2767     return SUCCESS;
2768
2769   if (e->expr_type != EXPR_VARIABLE)
2770     goto bad;
2771
2772   allocatable = e->symtree->n.sym->attr.allocatable;
2773   for (ref = e->ref; ref; ref = ref->next)
2774     switch (ref->type)
2775       {
2776       case REF_ARRAY:
2777         if (ref->u.ar.type != AR_FULL)
2778           allocatable = 0;
2779         break;
2780
2781       case REF_COMPONENT:
2782         allocatable = (ref->u.c.component->as != NULL
2783                        && ref->u.c.component->as->type == AS_DEFERRED);
2784         break;
2785
2786       case REF_SUBSTRING:
2787         allocatable = 0;
2788         break;
2789       }
2790
2791   if (allocatable == 0)
2792     {
2793     bad:
2794       gfc_error ("Expression in DEALLOCATE statement at %L must be "
2795                  "ALLOCATABLE or a POINTER", &e->where);
2796     }
2797
2798   return SUCCESS;
2799 }
2800
2801
2802 /* Given the expression node e for an allocatable/pointer of derived type to be
2803    allocated, get the expression node to be initialized afterwards (needed for
2804    derived types with default initializers).  */
2805
2806 static gfc_expr *
2807 expr_to_initialize (gfc_expr * e)
2808 {
2809   gfc_expr *result;
2810   gfc_ref *ref;
2811   int i;
2812
2813   result = gfc_copy_expr (e);
2814
2815   /* Change the last array reference from AR_ELEMENT to AR_FULL.  */
2816   for (ref = result->ref; ref; ref = ref->next)
2817     if (ref->type == REF_ARRAY && ref->next == NULL)
2818       {
2819         ref->u.ar.type = AR_FULL;
2820
2821         for (i = 0; i < ref->u.ar.dimen; i++)
2822           ref->u.ar.start[i] = ref->u.ar.end[i] = ref->u.ar.stride[i] = NULL;
2823
2824         result->rank = ref->u.ar.dimen;
2825         break;
2826       }
2827
2828   return result;
2829 }
2830
2831
2832 /* Resolve the expression in an ALLOCATE statement, doing the additional
2833    checks to see whether the expression is OK or not.  The expression must
2834    have a trailing array reference that gives the size of the array.  */
2835
2836 static try
2837 resolve_allocate_expr (gfc_expr * e, gfc_code * code)
2838 {
2839   int i, pointer, allocatable, dimension;
2840   symbol_attribute attr;
2841   gfc_ref *ref, *ref2;
2842   gfc_array_ref *ar;
2843   gfc_code *init_st;
2844   gfc_expr *init_e;
2845
2846   if (gfc_resolve_expr (e) == FAILURE)
2847     return FAILURE;
2848
2849   /* Make sure the expression is allocatable or a pointer.  If it is
2850      pointer, the next-to-last reference must be a pointer.  */
2851
2852   ref2 = NULL;
2853
2854   if (e->expr_type != EXPR_VARIABLE)
2855     {
2856       allocatable = 0;
2857
2858       attr = gfc_expr_attr (e);
2859       pointer = attr.pointer;
2860       dimension = attr.dimension;
2861
2862     }
2863   else
2864     {
2865       allocatable = e->symtree->n.sym->attr.allocatable;
2866       pointer = e->symtree->n.sym->attr.pointer;
2867       dimension = e->symtree->n.sym->attr.dimension;
2868
2869       for (ref = e->ref; ref; ref2 = ref, ref = ref->next)
2870         switch (ref->type)
2871           {
2872           case REF_ARRAY:
2873             if (ref->next != NULL)
2874               pointer = 0;
2875             break;
2876
2877           case REF_COMPONENT:
2878             allocatable = (ref->u.c.component->as != NULL
2879                            && ref->u.c.component->as->type == AS_DEFERRED);
2880
2881             pointer = ref->u.c.component->pointer;
2882             dimension = ref->u.c.component->dimension;
2883             break;
2884
2885           case REF_SUBSTRING:
2886             allocatable = 0;
2887             pointer = 0;
2888             break;
2889           }
2890     }
2891
2892   if (allocatable == 0 && pointer == 0)
2893     {
2894       gfc_error ("Expression in ALLOCATE statement at %L must be "
2895                  "ALLOCATABLE or a POINTER", &e->where);
2896       return FAILURE;
2897     }
2898
2899   /* Add default initializer for those derived types that need them.  */
2900   if (e->ts.type == BT_DERIVED && (init_e = gfc_default_initializer (&e->ts)))
2901     {
2902         init_st = gfc_get_code ();
2903         init_st->loc = code->loc;
2904         init_st->op = EXEC_ASSIGN;
2905         init_st->expr = expr_to_initialize (e);
2906         init_st->expr2 = init_e;
2907
2908         init_st->next = code->next;
2909         code->next = init_st;
2910     }
2911
2912   if (pointer && dimension == 0)
2913     return SUCCESS;
2914
2915   /* Make sure the next-to-last reference node is an array specification.  */
2916
2917   if (ref2 == NULL || ref2->type != REF_ARRAY || ref2->u.ar.type == AR_FULL)
2918     {
2919       gfc_error ("Array specification required in ALLOCATE statement "
2920                  "at %L", &e->where);
2921       return FAILURE;
2922     }
2923
2924   if (ref2->u.ar.type == AR_ELEMENT)
2925     return SUCCESS;
2926
2927   /* Make sure that the array section reference makes sense in the
2928     context of an ALLOCATE specification.  */
2929
2930   ar = &ref2->u.ar;
2931
2932   for (i = 0; i < ar->dimen; i++)
2933     switch (ar->dimen_type[i])
2934       {
2935       case DIMEN_ELEMENT:
2936         break;
2937
2938       case DIMEN_RANGE:
2939         if (ar->start[i] != NULL
2940             && ar->end[i] != NULL
2941             && ar->stride[i] == NULL)
2942           break;
2943
2944         /* Fall Through...  */
2945
2946       case DIMEN_UNKNOWN:
2947       case DIMEN_VECTOR:
2948         gfc_error ("Bad array specification in ALLOCATE statement at %L",
2949                    &e->where);
2950         return FAILURE;
2951       }
2952
2953   return SUCCESS;
2954 }
2955
2956
2957 /************ SELECT CASE resolution subroutines ************/
2958
2959 /* Callback function for our mergesort variant.  Determines interval
2960    overlaps for CASEs. Return <0 if op1 < op2, 0 for overlap, >0 for
2961    op1 > op2.  Assumes we're not dealing with the default case.
2962    We have op1 = (:L), (K:L) or (K:) and op2 = (:N), (M:N) or (M:).
2963    There are nine situations to check.  */
2964
2965 static int
2966 compare_cases (const gfc_case * op1, const gfc_case * op2)
2967 {
2968   int retval;
2969
2970   if (op1->low == NULL) /* op1 = (:L)  */
2971     {
2972       /* op2 = (:N), so overlap.  */
2973       retval = 0;
2974       /* op2 = (M:) or (M:N),  L < M  */
2975       if (op2->low != NULL
2976           && gfc_compare_expr (op1->high, op2->low) < 0)
2977         retval = -1;
2978     }
2979   else if (op1->high == NULL) /* op1 = (K:)  */
2980     {
2981       /* op2 = (M:), so overlap.  */
2982       retval = 0;
2983       /* op2 = (:N) or (M:N), K > N  */
2984       if (op2->high != NULL
2985           && gfc_compare_expr (op1->low, op2->high) > 0)
2986         retval = 1;
2987     }
2988   else /* op1 = (K:L)  */
2989     {
2990       if (op2->low == NULL)       /* op2 = (:N), K > N  */
2991         retval = (gfc_compare_expr (op1->low, op2->high) > 0) ? 1 : 0;
2992       else if (op2->high == NULL) /* op2 = (M:), L < M  */
2993         retval = (gfc_compare_expr (op1->high, op2->low) < 0) ? -1 : 0;
2994       else                        /* op2 = (M:N)  */
2995         {
2996           retval =  0;
2997           /* L < M  */
2998           if (gfc_compare_expr (op1->high, op2->low) < 0)
2999             retval =  -1;
3000           /* K > N  */
3001           else if (gfc_compare_expr (op1->low, op2->high) > 0)
3002             retval =  1;
3003         }
3004     }
3005
3006   return retval;
3007 }
3008
3009
3010 /* Merge-sort a double linked case list, detecting overlap in the
3011    process.  LIST is the head of the double linked case list before it
3012    is sorted.  Returns the head of the sorted list if we don't see any
3013    overlap, or NULL otherwise.  */
3014
3015 static gfc_case *
3016 check_case_overlap (gfc_case * list)
3017 {
3018   gfc_case *p, *q, *e, *tail;
3019   int insize, nmerges, psize, qsize, cmp, overlap_seen;
3020
3021   /* If the passed list was empty, return immediately.  */
3022   if (!list)
3023     return NULL;
3024
3025   overlap_seen = 0;
3026   insize = 1;
3027
3028   /* Loop unconditionally.  The only exit from this loop is a return
3029      statement, when we've finished sorting the case list.  */
3030   for (;;)
3031     {
3032       p = list;
3033       list = NULL;
3034       tail = NULL;
3035
3036       /* Count the number of merges we do in this pass.  */
3037       nmerges = 0;
3038
3039       /* Loop while there exists a merge to be done.  */
3040       while (p)
3041         {
3042           int i;
3043
3044           /* Count this merge.  */
3045           nmerges++;
3046
3047           /* Cut the list in two pieces by stepping INSIZE places
3048              forward in the list, starting from P.  */
3049           psize = 0;
3050           q = p;
3051           for (i = 0; i < insize; i++)
3052             {
3053               psize++;
3054               q = q->right;
3055               if (!q)
3056                 break;
3057             }
3058           qsize = insize;
3059
3060           /* Now we have two lists.  Merge them!  */
3061           while (psize > 0 || (qsize > 0 && q != NULL))
3062             {
3063
3064               /* See from which the next case to merge comes from.  */
3065               if (psize == 0)
3066                 {
3067                   /* P is empty so the next case must come from Q.  */
3068                   e = q;
3069                   q = q->right;
3070                   qsize--;
3071                 }
3072               else if (qsize == 0 || q == NULL)
3073                 {
3074                   /* Q is empty.  */
3075                   e = p;
3076                   p = p->right;
3077                   psize--;
3078                 }
3079               else
3080                 {
3081                   cmp = compare_cases (p, q);
3082                   if (cmp < 0)
3083                     {
3084                       /* The whole case range for P is less than the
3085                          one for Q.  */
3086                       e = p;
3087                       p = p->right;
3088                       psize--;
3089                     }
3090                   else if (cmp > 0)
3091                     {
3092                       /* The whole case range for Q is greater than
3093                          the case range for P.  */
3094                       e = q;
3095                       q = q->right;
3096                       qsize--;
3097                     }
3098                   else
3099                     {
3100                       /* The cases overlap, or they are the same
3101                          element in the list.  Either way, we must
3102                          issue an error and get the next case from P.  */
3103                       /* FIXME: Sort P and Q by line number.  */
3104                       gfc_error ("CASE label at %L overlaps with CASE "
3105                                  "label at %L", &p->where, &q->where);
3106                       overlap_seen = 1;
3107                       e = p;
3108                       p = p->right;
3109                       psize--;
3110                     }
3111                 }
3112
3113                 /* Add the next element to the merged list.  */
3114               if (tail)
3115                 tail->right = e;
3116               else
3117                 list = e;
3118               e->left = tail;
3119               tail = e;
3120             }
3121
3122           /* P has now stepped INSIZE places along, and so has Q.  So
3123              they're the same.  */
3124           p = q;
3125         }
3126       tail->right = NULL;
3127
3128       /* If we have done only one merge or none at all, we've
3129          finished sorting the cases.  */
3130       if (nmerges <= 1)
3131         {
3132           if (!overlap_seen)
3133             return list;
3134           else
3135             return NULL;
3136         }
3137
3138       /* Otherwise repeat, merging lists twice the size.  */
3139       insize *= 2;
3140     }
3141 }
3142
3143
3144 /* Check to see if an expression is suitable for use in a CASE statement.
3145    Makes sure that all case expressions are scalar constants of the same
3146    type.  Return FAILURE if anything is wrong.  */
3147
3148 static try
3149 validate_case_label_expr (gfc_expr * e, gfc_expr * case_expr)
3150 {
3151   if (e == NULL) return SUCCESS;
3152
3153   if (e->ts.type != case_expr->ts.type)
3154     {
3155       gfc_error ("Expression in CASE statement at %L must be of type %s",
3156                  &e->where, gfc_basic_typename (case_expr->ts.type));
3157       return FAILURE;
3158     }
3159
3160   /* C805 (R808) For a given case-construct, each case-value shall be of
3161      the same type as case-expr.  For character type, length differences
3162      are allowed, but the kind type parameters shall be the same.  */
3163
3164   if (case_expr->ts.type == BT_CHARACTER && e->ts.kind != case_expr->ts.kind)
3165     {
3166       gfc_error("Expression in CASE statement at %L must be kind %d",
3167                 &e->where, case_expr->ts.kind);
3168       return FAILURE;
3169     }
3170
3171   /* Convert the case value kind to that of case expression kind, if needed.
3172      FIXME:  Should a warning be issued?  */
3173   if (e->ts.kind != case_expr->ts.kind)
3174     gfc_convert_type_warn (e, &case_expr->ts, 2, 0);
3175
3176   if (e->rank != 0)
3177     {
3178       gfc_error ("Expression in CASE statement at %L must be scalar",
3179                  &e->where);
3180       return FAILURE;
3181     }
3182
3183   return SUCCESS;
3184 }
3185
3186
3187 /* Given a completely parsed select statement, we:
3188
3189      - Validate all expressions and code within the SELECT.
3190      - Make sure that the selection expression is not of the wrong type.
3191      - Make sure that no case ranges overlap.
3192      - Eliminate unreachable cases and unreachable code resulting from
3193        removing case labels.
3194
3195    The standard does allow unreachable cases, e.g. CASE (5:3).  But
3196    they are a hassle for code generation, and to prevent that, we just
3197    cut them out here.  This is not necessary for overlapping cases
3198    because they are illegal and we never even try to generate code.
3199
3200    We have the additional caveat that a SELECT construct could have
3201    been a computed GOTO in the source code. Fortunately we can fairly
3202    easily work around that here: The case_expr for a "real" SELECT CASE
3203    is in code->expr1, but for a computed GOTO it is in code->expr2. All
3204    we have to do is make sure that the case_expr is a scalar integer
3205    expression.  */
3206
3207 static void
3208 resolve_select (gfc_code * code)
3209 {
3210   gfc_code *body;
3211   gfc_expr *case_expr;
3212   gfc_case *cp, *default_case, *tail, *head;
3213   int seen_unreachable;
3214   int ncases;
3215   bt type;
3216   try t;
3217
3218   if (code->expr == NULL)
3219     {
3220       /* This was actually a computed GOTO statement.  */
3221       case_expr = code->expr2;
3222       if (case_expr->ts.type != BT_INTEGER
3223           || case_expr->rank != 0)
3224         gfc_error ("Selection expression in computed GOTO statement "
3225                    "at %L must be a scalar integer expression",
3226                    &case_expr->where);
3227
3228       /* Further checking is not necessary because this SELECT was built
3229          by the compiler, so it should always be OK.  Just move the
3230          case_expr from expr2 to expr so that we can handle computed
3231          GOTOs as normal SELECTs from here on.  */
3232       code->expr = code->expr2;
3233       code->expr2 = NULL;
3234       return;
3235     }
3236
3237   case_expr = code->expr;
3238
3239   type = case_expr->ts.type;
3240   if (type != BT_LOGICAL && type != BT_INTEGER && type != BT_CHARACTER)
3241     {
3242       gfc_error ("Argument of SELECT statement at %L cannot be %s",
3243                  &case_expr->where, gfc_typename (&case_expr->ts));
3244
3245       /* Punt. Going on here just produce more garbage error messages.  */
3246       return;
3247     }
3248
3249   if (case_expr->rank != 0)
3250     {
3251       gfc_error ("Argument of SELECT statement at %L must be a scalar "
3252                  "expression", &case_expr->where);
3253
3254       /* Punt.  */
3255       return;
3256     }
3257
3258   /* PR 19168 has a long discussion concerning a mismatch of the kinds
3259      of the SELECT CASE expression and its CASE values.  Walk the lists
3260      of case values, and if we find a mismatch, promote case_expr to
3261      the appropriate kind.  */
3262
3263   if (type == BT_LOGICAL || type == BT_INTEGER)
3264     {
3265       for (body = code->block; body; body = body->block)
3266         {
3267           /* Walk the case label list.  */
3268           for (cp = body->ext.case_list; cp; cp = cp->next)
3269             {
3270               /* Intercept the DEFAULT case.  It does not have a kind.  */
3271               if (cp->low == NULL && cp->high == NULL)
3272                 continue;
3273
3274               /* Unreachable case ranges are discarded, so ignore.  */
3275               if (cp->low != NULL && cp->high != NULL
3276                   && cp->low != cp->high
3277                   && gfc_compare_expr (cp->low, cp->high) > 0)
3278                 continue;
3279
3280               /* FIXME: Should a warning be issued?  */
3281               if (cp->low != NULL
3282                   && case_expr->ts.kind != gfc_kind_max(case_expr, cp->low))
3283                 gfc_convert_type_warn (case_expr, &cp->low->ts, 2, 0);
3284
3285               if (cp->high != NULL
3286                   && case_expr->ts.kind != gfc_kind_max(case_expr, cp->high))
3287                 gfc_convert_type_warn (case_expr, &cp->high->ts, 2, 0);
3288             }
3289          }
3290     }
3291
3292   /* Assume there is no DEFAULT case.  */
3293   default_case = NULL;
3294   head = tail = NULL;
3295   ncases = 0;
3296
3297   for (body = code->block; body; body = body->block)
3298     {
3299       /* Assume the CASE list is OK, and all CASE labels can be matched.  */
3300       t = SUCCESS;
3301       seen_unreachable = 0;
3302
3303       /* Walk the case label list, making sure that all case labels
3304          are legal.  */
3305       for (cp = body->ext.case_list; cp; cp = cp->next)
3306         {
3307           /* Count the number of cases in the whole construct.  */
3308           ncases++;
3309
3310           /* Intercept the DEFAULT case.  */
3311           if (cp->low == NULL && cp->high == NULL)
3312             {
3313               if (default_case != NULL)
3314                 {
3315                   gfc_error ("The DEFAULT CASE at %L cannot be followed "
3316                              "by a second DEFAULT CASE at %L",
3317                              &default_case->where, &cp->where);
3318                   t = FAILURE;
3319                   break;
3320                 }
3321               else
3322                 {
3323                   default_case = cp;
3324                   continue;
3325                 }
3326             }
3327
3328           /* Deal with single value cases and case ranges.  Errors are
3329              issued from the validation function.  */
3330           if(validate_case_label_expr (cp->low, case_expr) != SUCCESS
3331              || validate_case_label_expr (cp->high, case_expr) != SUCCESS)
3332             {
3333               t = FAILURE;
3334               break;
3335             }
3336
3337           if (type == BT_LOGICAL
3338               && ((cp->low == NULL || cp->high == NULL)
3339                   || cp->low != cp->high))
3340             {
3341               gfc_error
3342                 ("Logical range in CASE statement at %L is not allowed",
3343                  &cp->low->where);
3344               t = FAILURE;
3345               break;
3346             }
3347
3348           if (cp->low != NULL && cp->high != NULL
3349               && cp->low != cp->high
3350               && gfc_compare_expr (cp->low, cp->high) > 0)
3351             {
3352               if (gfc_option.warn_surprising)
3353                 gfc_warning ("Range specification at %L can never "
3354                              "be matched", &cp->where);
3355
3356               cp->unreachable = 1;
3357               seen_unreachable = 1;
3358             }
3359           else
3360             {
3361               /* If the case range can be matched, it can also overlap with
3362                  other cases.  To make sure it does not, we put it in a
3363                  double linked list here.  We sort that with a merge sort
3364                  later on to detect any overlapping cases.  */
3365               if (!head)
3366                 {
3367                   head = tail = cp;
3368                   head->right = head->left = NULL;
3369                 }
3370               else
3371                 {
3372                   tail->right = cp;
3373                   tail->right->left = tail;
3374                   tail = tail->right;
3375                   tail->right = NULL;
3376                 }
3377             }
3378         }
3379
3380       /* It there was a failure in the previous case label, give up
3381          for this case label list.  Continue with the next block.  */
3382       if (t == FAILURE)
3383         continue;
3384
3385       /* See if any case labels that are unreachable have been seen.
3386          If so, we eliminate them.  This is a bit of a kludge because
3387          the case lists for a single case statement (label) is a
3388          single forward linked lists.  */
3389       if (seen_unreachable)
3390       {
3391         /* Advance until the first case in the list is reachable.  */
3392         while (body->ext.case_list != NULL
3393                && body->ext.case_list->unreachable)
3394           {
3395             gfc_case *n = body->ext.case_list;
3396             body->ext.case_list = body->ext.case_list->next;
3397             n->next = NULL;
3398             gfc_free_case_list (n);
3399           }
3400
3401         /* Strip all other unreachable cases.  */
3402         if (body->ext.case_list)
3403           {
3404             for (cp = body->ext.case_list; cp->next; cp = cp->next)
3405               {
3406                 if (cp->next->unreachable)
3407                   {
3408                     gfc_case *n = cp->next;
3409                     cp->next = cp->next->next;
3410                     n->next = NULL;
3411                     gfc_free_case_list (n);
3412                   }
3413               }
3414           }
3415       }
3416     }
3417
3418   /* See if there were overlapping cases.  If the check returns NULL,
3419      there was overlap.  In that case we don't do anything.  If head
3420      is non-NULL, we prepend the DEFAULT case.  The sorted list can
3421      then used during code generation for SELECT CASE constructs with
3422      a case expression of a CHARACTER type.  */
3423   if (head)
3424     {
3425       head = check_case_overlap (head);
3426
3427       /* Prepend the default_case if it is there.  */
3428       if (head != NULL && default_case)
3429         {
3430           default_case->left = NULL;
3431           default_case->right = head;
3432           head->left = default_case;
3433         }
3434     }
3435
3436   /* Eliminate dead blocks that may be the result if we've seen
3437      unreachable case labels for a block.  */
3438   for (body = code; body && body->block; body = body->block)
3439     {
3440       if (body->block->ext.case_list == NULL)
3441         {
3442           /* Cut the unreachable block from the code chain.  */
3443           gfc_code *c = body->block;
3444           body->block = c->block;
3445
3446           /* Kill the dead block, but not the blocks below it.  */
3447           c->block = NULL;
3448           gfc_free_statements (c);
3449         }
3450     }
3451
3452   /* More than two cases is legal but insane for logical selects.
3453      Issue a warning for it.  */
3454   if (gfc_option.warn_surprising && type == BT_LOGICAL
3455       && ncases > 2)
3456     gfc_warning ("Logical SELECT CASE block at %L has more that two cases",
3457                  &code->loc);
3458 }
3459
3460
3461 /* Resolve a transfer statement. This is making sure that:
3462    -- a derived type being transferred has only non-pointer components
3463    -- a derived type being transferred doesn't have private components, unless
3464       it's being transferred from the module where the type was defined
3465    -- we're not trying to transfer a whole assumed size array.  */
3466
3467 static void
3468 resolve_transfer (gfc_code * code)
3469 {
3470   gfc_typespec *ts;
3471   gfc_symbol *sym;
3472   gfc_ref *ref;
3473   gfc_expr *exp;
3474
3475   exp = code->expr;
3476
3477   if (exp->expr_type != EXPR_VARIABLE)
3478     return;
3479
3480   sym = exp->symtree->n.sym;
3481   ts = &sym->ts;
3482
3483   /* Go to actual component transferred.  */
3484   for (ref = code->expr->ref; ref; ref = ref->next)
3485     if (ref->type == REF_COMPONENT)
3486       ts = &ref->u.c.component->ts;
3487
3488   if (ts->type == BT_DERIVED)
3489     {
3490       /* Check that transferred derived type doesn't contain POINTER
3491          components.  */
3492       if (derived_pointer (ts->derived))
3493         {
3494           gfc_error ("Data transfer element at %L cannot have "
3495                      "POINTER components", &code->loc);
3496           return;
3497         }
3498
3499       if (derived_inaccessible (ts->derived))
3500         {
3501           gfc_error ("Data transfer element at %L cannot have "
3502                      "PRIVATE components",&code->loc);
3503           return;
3504         }
3505     }
3506
3507   if (sym->as != NULL && sym->as->type == AS_ASSUMED_SIZE
3508       && exp->ref->type == REF_ARRAY && exp->ref->u.ar.type == AR_FULL)
3509     {
3510       gfc_error ("Data transfer element at %L cannot be a full reference to "
3511                  "an assumed-size array", &code->loc);
3512       return;
3513     }
3514 }
3515
3516
3517 /*********** Toplevel code resolution subroutines ***********/
3518
3519 /* Given a branch to a label and a namespace, if the branch is conforming.
3520    The code node described where the branch is located.  */
3521
3522 static void
3523 resolve_branch (gfc_st_label * label, gfc_code * code)
3524 {
3525   gfc_code *block, *found;
3526   code_stack *stack;
3527   gfc_st_label *lp;
3528
3529   if (label == NULL)
3530     return;
3531   lp = label;
3532
3533   /* Step one: is this a valid branching target?  */
3534
3535   if (lp->defined == ST_LABEL_UNKNOWN)
3536     {
3537       gfc_error ("Label %d referenced at %L is never defined", lp->value,
3538                  &lp->where);
3539       return;
3540     }
3541
3542   if (lp->defined != ST_LABEL_TARGET)
3543     {
3544       gfc_error ("Statement at %L is not a valid branch target statement "
3545                  "for the branch statement at %L", &lp->where, &code->loc);
3546       return;
3547     }
3548
3549   /* Step two: make sure this branch is not a branch to itself ;-)  */
3550
3551   if (code->here == label)
3552     {
3553       gfc_warning ("Branch at %L causes an infinite loop", &code->loc);
3554       return;
3555     }
3556
3557   /* Step three: Try to find the label in the parse tree. To do this,
3558      we traverse the tree block-by-block: first the block that
3559      contains this GOTO, then the block that it is nested in, etc.  We
3560      can ignore other blocks because branching into another block is
3561      not allowed.  */
3562
3563   found = NULL;
3564
3565   for (stack = cs_base; stack; stack = stack->prev)
3566     {
3567       for (block = stack->head; block; block = block->next)
3568         {
3569           if (block->here == label)
3570             {
3571               found = block;
3572               break;
3573             }
3574         }
3575
3576       if (found)
3577         break;
3578     }
3579
3580   if (found == NULL)
3581     {
3582       /* still nothing, so illegal.  */
3583       gfc_error_now ("Label at %L is not in the same block as the "
3584                      "GOTO statement at %L", &lp->where, &code->loc);
3585       return;
3586     }
3587
3588   /* Step four: Make sure that the branching target is legal if
3589      the statement is an END {SELECT,DO,IF}.  */
3590
3591   if (found->op == EXEC_NOP)
3592     {
3593       for (stack = cs_base; stack; stack = stack->prev)
3594         if (stack->current->next == found)
3595           break;
3596
3597       if (stack == NULL)
3598         gfc_notify_std (GFC_STD_F95_DEL,
3599                         "Obsolete: GOTO at %L jumps to END of construct at %L",
3600                         &code->loc, &found->loc);
3601     }
3602 }
3603
3604
3605 /* Check whether EXPR1 has the same shape as EXPR2.  */
3606
3607 static try
3608 resolve_where_shape (gfc_expr *expr1, gfc_expr *expr2)
3609 {
3610   mpz_t shape[GFC_MAX_DIMENSIONS];
3611   mpz_t shape2[GFC_MAX_DIMENSIONS];
3612   try result = FAILURE;
3613   int i;
3614
3615   /* Compare the rank.  */
3616   if (expr1->rank != expr2->rank)
3617     return result;
3618
3619   /* Compare the size of each dimension.  */
3620   for (i=0; i<expr1->rank; i++)
3621     {
3622       if (gfc_array_dimen_size (expr1, i, &shape[i]) == FAILURE)
3623         goto ignore;
3624
3625       if (gfc_array_dimen_size (expr2, i, &shape2[i]) == FAILURE)
3626         goto ignore;
3627
3628       if (mpz_cmp (shape[i], shape2[i]))
3629         goto over;
3630     }
3631
3632   /* When either of the two expression is an assumed size array, we
3633      ignore the comparison of dimension sizes.  */
3634 ignore:
3635   result = SUCCESS;
3636
3637 over:
3638   for (i--; i>=0; i--)
3639     {
3640       mpz_clear (shape[i]);
3641       mpz_clear (shape2[i]);
3642     }
3643   return result;
3644 }
3645
3646
3647 /* Check whether a WHERE assignment target or a WHERE mask expression
3648    has the same shape as the outmost WHERE mask expression.  */
3649
3650 static void
3651 resolve_where (gfc_code *code, gfc_expr *mask)
3652 {
3653   gfc_code *cblock;
3654   gfc_code *cnext;
3655   gfc_expr *e = NULL;
3656
3657   cblock = code->block;
3658
3659   /* Store the first WHERE mask-expr of the WHERE statement or construct.
3660      In case of nested WHERE, only the outmost one is stored.  */
3661   if (mask == NULL) /* outmost WHERE */
3662     e = cblock->expr;
3663   else /* inner WHERE */
3664     e = mask;
3665
3666   while (cblock)
3667     {
3668       if (cblock->expr)
3669         {
3670           /* Check if the mask-expr has a consistent shape with the
3671              outmost WHERE mask-expr.  */
3672           if (resolve_where_shape (cblock->expr, e) == FAILURE)
3673             gfc_error ("WHERE mask at %L has inconsistent shape",
3674                        &cblock->expr->where);
3675          }
3676
3677       /* the assignment statement of a WHERE statement, or the first
3678          statement in where-body-construct of a WHERE construct */
3679       cnext = cblock->next;
3680       while (cnext)
3681         {
3682           switch (cnext->op)
3683             {
3684             /* WHERE assignment statement */
3685             case EXEC_ASSIGN:
3686
3687               /* Check shape consistent for WHERE assignment target.  */
3688               if (e && resolve_where_shape (cnext->expr, e) == FAILURE)
3689                gfc_error ("WHERE assignment target at %L has "
3690                           "inconsistent shape", &cnext->expr->where);
3691               break;
3692
3693             /* WHERE or WHERE construct is part of a where-body-construct */
3694             case EXEC_WHERE:
3695               resolve_where (cnext, e);
3696               break;
3697
3698             default:
3699               gfc_error ("Unsupported statement inside WHERE at %L",
3700                          &cnext->loc);
3701             }
3702          /* the next statement within the same where-body-construct */
3703          cnext = cnext->next;
3704        }
3705     /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
3706     cblock = cblock->block;
3707   }
3708 }
3709
3710
3711 /* Check whether the FORALL index appears in the expression or not.  */
3712
3713 static try
3714 gfc_find_forall_index (gfc_expr *expr, gfc_symbol *symbol)
3715 {
3716   gfc_array_ref ar;
3717   gfc_ref *tmp;
3718   gfc_actual_arglist *args;
3719   int i;
3720
3721   switch (expr->expr_type)
3722     {
3723     case EXPR_VARIABLE:
3724       gcc_assert (expr->symtree->n.sym);
3725
3726       /* A scalar assignment  */
3727       if (!expr->ref)
3728         {
3729           if (expr->symtree->n.sym == symbol)
3730             return SUCCESS;
3731           else
3732             return FAILURE;
3733         }
3734
3735       /* the expr is array ref, substring or struct component.  */
3736       tmp = expr->ref;
3737       while (tmp != NULL)
3738         {
3739           switch (tmp->type)
3740             {
3741             case  REF_ARRAY:
3742               /* Check if the symbol appears in the array subscript.  */
3743               ar = tmp->u.ar;
3744               for (i = 0; i < GFC_MAX_DIMENSIONS; i++)
3745                 {
3746                   if (ar.start[i])
3747                     if (gfc_find_forall_index (ar.start[i], symbol) == SUCCESS)
3748                       return SUCCESS;
3749
3750                   if (ar.end[i])
3751                     if (gfc_find_forall_index (ar.end[i], symbol) == SUCCESS)
3752                       return SUCCESS;
3753
3754                   if (ar.stride[i])
3755                     if (gfc_find_forall_index (ar.stride[i], symbol) == SUCCESS)
3756                       return SUCCESS;
3757                 }  /* end for  */
3758               break;
3759
3760             case REF_SUBSTRING:
3761               if (expr->symtree->n.sym == symbol)
3762                 return SUCCESS;
3763               tmp = expr->ref;
3764               /* Check if the symbol appears in the substring section.  */
3765               if (gfc_find_forall_index (tmp->u.ss.start, symbol) == SUCCESS)
3766                 return SUCCESS;
3767               if (gfc_find_forall_index (tmp->u.ss.end, symbol) == SUCCESS)
3768                 return SUCCESS;
3769               break;
3770
3771             case REF_COMPONENT:
3772               break;
3773
3774             default:
3775               gfc_error("expresion reference type error at %L", &expr->where);
3776             }
3777           tmp = tmp->next;
3778         }
3779       break;
3780
3781     /* If the expression is a function call, then check if the symbol
3782        appears in the actual arglist of the function.  */
3783     case EXPR_FUNCTION:
3784       for (args = expr->value.function.actual; args; args = args->next)
3785         {
3786           if (gfc_find_forall_index(args->expr,symbol) == SUCCESS)
3787             return SUCCESS;
3788         }
3789       break;
3790
3791     /* It seems not to happen.  */
3792     case EXPR_SUBSTRING:
3793       if (expr->ref)
3794         {
3795           tmp = expr->ref;
3796           gcc_assert (expr->ref->type == REF_SUBSTRING);
3797           if (gfc_find_forall_index (tmp->u.ss.start, symbol) == SUCCESS)
3798             return SUCCESS;
3799           if (gfc_find_forall_index (tmp->u.ss.end, symbol) == SUCCESS)
3800             return SUCCESS;
3801         }
3802       break;
3803
3804     /* It seems not to happen.  */
3805     case EXPR_STRUCTURE:
3806     case EXPR_ARRAY:
3807       gfc_error ("Unsupported statement while finding forall index in "
3808                  "expression");
3809       break;
3810
3811     case EXPR_OP:
3812       /* Find the FORALL index in the first operand.  */
3813       if (expr->value.op.op1)
3814         {
3815           if (gfc_find_forall_index (expr->value.op.op1, symbol) == SUCCESS)
3816             return SUCCESS;
3817         }
3818
3819       /* Find the FORALL index in the second operand.  */
3820       if (expr->value.op.op2)
3821         {
3822           if (gfc_find_forall_index (expr->value.op.op2, symbol) == SUCCESS)
3823             return SUCCESS;
3824         }
3825       break;
3826
3827     default:
3828       break;
3829     }
3830
3831   return FAILURE;
3832 }
3833
3834
3835 /* Resolve assignment in FORALL construct.
3836    NVAR is the number of FORALL index variables, and VAR_EXPR records the
3837    FORALL index variables.  */
3838
3839 static void
3840 gfc_resolve_assign_in_forall (gfc_code *code, int nvar, gfc_expr **var_expr)
3841 {
3842   int n;
3843
3844   for (n = 0; n < nvar; n++)
3845     {
3846       gfc_symbol *forall_index;
3847
3848       forall_index = var_expr[n]->symtree->n.sym;
3849
3850       /* Check whether the assignment target is one of the FORALL index
3851          variable.  */
3852       if ((code->expr->expr_type == EXPR_VARIABLE)
3853           && (code->expr->symtree->n.sym == forall_index))
3854         gfc_error ("Assignment to a FORALL index variable at %L",
3855                    &code->expr->where);
3856       else
3857         {
3858           /* If one of the FORALL index variables doesn't appear in the
3859              assignment target, then there will be a many-to-one
3860              assignment.  */
3861           if (gfc_find_forall_index (code->expr, forall_index) == FAILURE)
3862             gfc_error ("The FORALL with index '%s' cause more than one "
3863                        "assignment to this object at %L",
3864                        var_expr[n]->symtree->name, &code->expr->where);
3865         }
3866     }
3867 }
3868
3869
3870 /* Resolve WHERE statement in FORALL construct.  */
3871
3872 static void
3873 gfc_resolve_where_code_in_forall (gfc_code *code, int nvar, gfc_expr **var_expr){
3874   gfc_code *cblock;
3875   gfc_code *cnext;
3876
3877   cblock = code->block;
3878   while (cblock)
3879     {
3880       /* the assignment statement of a WHERE statement, or the first
3881          statement in where-body-construct of a WHERE construct */
3882       cnext = cblock->next;
3883       while (cnext)
3884         {
3885           switch (cnext->op)
3886             {
3887             /* WHERE assignment statement */
3888             case EXEC_ASSIGN:
3889               gfc_resolve_assign_in_forall (cnext, nvar, var_expr);
3890               break;
3891
3892             /* WHERE or WHERE construct is part of a where-body-construct */
3893             case EXEC_WHERE:
3894               gfc_resolve_where_code_in_forall (cnext, nvar, var_expr);
3895               break;
3896
3897             default:
3898               gfc_error ("Unsupported statement inside WHERE at %L",
3899                          &cnext->loc);
3900             }
3901           /* the next statement within the same where-body-construct */
3902           cnext = cnext->next;
3903         }
3904       /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
3905       cblock = cblock->block;
3906     }
3907 }
3908
3909
3910 /* Traverse the FORALL body to check whether the following errors exist:
3911    1. For assignment, check if a many-to-one assignment happens.
3912    2. For WHERE statement, check the WHERE body to see if there is any
3913       many-to-one assignment.  */
3914
3915 static void
3916 gfc_resolve_forall_body (gfc_code *code, int nvar, gfc_expr **var_expr)
3917 {
3918   gfc_code *c;
3919
3920   c = code->block->next;
3921   while (c)
3922     {
3923       switch (c->op)
3924         {
3925         case EXEC_ASSIGN:
3926         case EXEC_POINTER_ASSIGN:
3927           gfc_resolve_assign_in_forall (c, nvar, var_expr);
3928           break;
3929
3930         /* Because the resolve_blocks() will handle the nested FORALL,
3931            there is no need to handle it here.  */
3932         case EXEC_FORALL:
3933           break;
3934         case EXEC_WHERE:
3935           gfc_resolve_where_code_in_forall(c, nvar, var_expr);
3936           break;
3937         default:
3938           break;
3939         }
3940       /* The next statement in the FORALL body.  */
3941       c = c->next;
3942     }
3943 }
3944
3945
3946 /* Given a FORALL construct, first resolve the FORALL iterator, then call
3947    gfc_resolve_forall_body to resolve the FORALL body.  */
3948
3949 static void resolve_blocks (gfc_code *, gfc_namespace *);
3950
3951 static void
3952 gfc_resolve_forall (gfc_code *code, gfc_namespace *ns, int forall_save)
3953 {
3954   static gfc_expr **var_expr;
3955   static int total_var = 0;
3956   static int nvar = 0;
3957   gfc_forall_iterator *fa;
3958   gfc_symbol *forall_index;
3959   gfc_code *next;
3960   int i;
3961
3962   /* Start to resolve a FORALL construct   */
3963   if (forall_save == 0)
3964     {
3965       /* Count the total number of FORALL index in the nested FORALL
3966          construct in order to allocate the VAR_EXPR with proper size.  */
3967       next = code;
3968       while ((next != NULL) && (next->op == EXEC_FORALL))
3969         {
3970           for (fa = next->ext.forall_iterator; fa; fa = fa->next)
3971             total_var ++;
3972           next = next->block->next;
3973         }
3974
3975       /* Allocate VAR_EXPR with NUMBER_OF_FORALL_INDEX elements.  */
3976       var_expr = (gfc_expr **) gfc_getmem (total_var * sizeof (gfc_expr *));
3977     }
3978
3979   /* The information about FORALL iterator, including FORALL index start, end
3980      and stride. The FORALL index can not appear in start, end or stride.  */
3981   for (fa = code->ext.forall_iterator; fa; fa = fa->next)
3982     {
3983       /* Check if any outer FORALL index name is the same as the current
3984          one.  */
3985       for (i = 0; i < nvar; i++)
3986         {
3987           if (fa->var->symtree->n.sym == var_expr[i]->symtree->n.sym)
3988             {
3989               gfc_error ("An outer FORALL construct already has an index "
3990                          "with this name %L", &fa->var->where);
3991             }
3992         }
3993
3994       /* Record the current FORALL index.  */
3995       var_expr[nvar] = gfc_copy_expr (fa->var);
3996
3997       forall_index = fa->var->symtree->n.sym;
3998
3999       /* Check if the FORALL index appears in start, end or stride.  */
4000       if (gfc_find_forall_index (fa->start, forall_index) == SUCCESS)
4001         gfc_error ("A FORALL index must not appear in a limit or stride "
4002                    "expression in the same FORALL at %L", &fa->start->where);
4003       if (gfc_find_forall_index (fa->end, forall_index) == SUCCESS)
4004         gfc_error ("A FORALL index must not appear in a limit or stride "
4005                    "expression in the same FORALL at %L", &fa->end->where);
4006       if (gfc_find_forall_index (fa->stride, forall_index) == SUCCESS)
4007         gfc_error ("A FORALL index must not appear in a limit or stride "
4008                    "expression in the same FORALL at %L", &fa->stride->where);
4009       nvar++;
4010     }
4011
4012   /* Resolve the FORALL body.  */
4013   gfc_resolve_forall_body (code, nvar, var_expr);
4014
4015   /* May call gfc_resolve_forall to resolve the inner FORALL loop.  */
4016   resolve_blocks (code->block, ns);
4017
4018   /* Free VAR_EXPR after the whole FORALL construct resolved.  */
4019   for (i = 0; i < total_var; i++)
4020     gfc_free_expr (var_expr[i]);
4021
4022   /* Reset the counters.  */
4023   total_var = 0;
4024   nvar = 0;
4025 }
4026
4027
4028 /* Resolve lists of blocks found in IF, SELECT CASE, WHERE, FORALL ,GOTO and
4029    DO code nodes.  */
4030
4031 static void resolve_code (gfc_code *, gfc_namespace *);
4032
4033 static void
4034 resolve_blocks (gfc_code * b, gfc_namespace * ns)
4035 {
4036   try t;
4037
4038   for (; b; b = b->block)
4039     {
4040       t = gfc_resolve_expr (b->expr);
4041       if (gfc_resolve_expr (b->expr2) == FAILURE)
4042         t = FAILURE;
4043
4044       switch (b->op)
4045         {
4046         case EXEC_IF:
4047           if (t == SUCCESS && b->expr != NULL
4048               && (b->expr->ts.type != BT_LOGICAL || b->expr->rank != 0))
4049             gfc_error
4050               ("ELSE IF clause at %L requires a scalar LOGICAL expression",
4051                &b->expr->where);
4052           break;
4053
4054         case EXEC_WHERE:
4055           if (t == SUCCESS
4056               && b->expr != NULL
4057               && (b->expr->ts.type != BT_LOGICAL
4058                   || b->expr->rank == 0))
4059             gfc_error
4060               ("WHERE/ELSEWHERE clause at %L requires a LOGICAL array",
4061                &b->expr->where);
4062           break;
4063
4064         case EXEC_GOTO:
4065           resolve_branch (b->label, b);
4066           break;
4067
4068         case EXEC_SELECT:
4069         case EXEC_FORALL:
4070         case EXEC_DO:
4071         case EXEC_DO_WHILE:
4072         case EXEC_READ:
4073         case EXEC_WRITE:
4074         case EXEC_IOLENGTH:
4075           break;
4076
4077         default:
4078           gfc_internal_error ("resolve_block(): Bad block type");
4079         }
4080
4081       resolve_code (b->next, ns);
4082     }
4083 }
4084
4085
4086 /* Given a block of code, recursively resolve everything pointed to by this
4087    code block.  */
4088
4089 static void
4090 resolve_code (gfc_code * code, gfc_namespace * ns)
4091 {
4092   int forall_save = 0;
4093   code_stack frame;
4094   gfc_alloc *a;
4095   try t;
4096
4097   frame.prev = cs_base;
4098   frame.head = code;
4099   cs_base = &frame;
4100
4101   for (; code; code = code->next)
4102     {
4103       frame.current = code;
4104
4105       if (code->op == EXEC_FORALL)
4106         {
4107           forall_save = forall_flag;
4108           forall_flag = 1;
4109           gfc_resolve_forall (code, ns, forall_save);
4110         }
4111       else
4112         resolve_blocks (code->block, ns);
4113
4114       if (code->op == EXEC_FORALL)
4115         forall_flag = forall_save;
4116
4117       t = gfc_resolve_expr (code->expr);
4118       if (gfc_resolve_expr (code->expr2) == FAILURE)
4119         t = FAILURE;
4120
4121       switch (code->op)
4122         {
4123         case EXEC_NOP:
4124         case EXEC_CYCLE:
4125         case EXEC_PAUSE:
4126         case EXEC_STOP:
4127         case EXEC_EXIT:
4128         case EXEC_CONTINUE:
4129         case EXEC_DT_END:
4130         case EXEC_ENTRY:
4131           break;
4132
4133         case EXEC_WHERE:
4134           resolve_where (code, NULL);
4135           break;
4136
4137         case EXEC_GOTO:
4138           if (code->expr != NULL)
4139             {
4140               if (code->expr->ts.type != BT_INTEGER)
4141                 gfc_error ("ASSIGNED GOTO statement at %L requires an INTEGER "
4142                        "variable", &code->expr->where);
4143               else if (code->expr->symtree->n.sym->attr.assign != 1)
4144                 gfc_error ("Variable '%s' has not been assigned a target label "
4145                         "at %L", code->expr->symtree->n.sym->name,
4146                         &code->expr->where);
4147             }
4148           else
4149             resolve_branch (code->label, code);
4150           break;
4151
4152         case EXEC_RETURN:
4153           if (code->expr != NULL && code->expr->ts.type != BT_INTEGER)
4154             gfc_error ("Alternate RETURN statement at %L requires an INTEGER "
4155                        "return specifier", &code->expr->where);
4156           break;
4157
4158         case EXEC_ASSIGN:
4159           if (t == FAILURE)
4160             break;
4161
4162           if (gfc_extend_assign (code, ns) == SUCCESS)
4163             goto call;
4164
4165           if (gfc_pure (NULL))
4166             {
4167               if (gfc_impure_variable (code->expr->symtree->n.sym))
4168                 {
4169                   gfc_error
4170                     ("Cannot assign to variable '%s' in PURE procedure at %L",
4171                      code->expr->symtree->n.sym->name, &code->expr->where);
4172                   break;
4173                 }
4174
4175               if (code->expr2->ts.type == BT_DERIVED
4176                   && derived_pointer (code->expr2->ts.derived))
4177                 {
4178                   gfc_error
4179                     ("Right side of assignment at %L is a derived type "
4180                      "containing a POINTER in a PURE procedure",
4181                      &code->expr2->where);
4182                   break;
4183                 }
4184             }
4185
4186           gfc_check_assign (code->expr, code->expr2, 1);
4187           break;
4188
4189         case EXEC_LABEL_ASSIGN:
4190           if (code->label->defined == ST_LABEL_UNKNOWN)
4191             gfc_error ("Label %d referenced at %L is never defined",
4192                        code->label->value, &code->label->where);
4193           if (t == SUCCESS
4194               && (code->expr->expr_type != EXPR_VARIABLE
4195                   || code->expr->symtree->n.sym->ts.type != BT_INTEGER
4196                   || code->expr->symtree->n.sym->ts.kind
4197                         != gfc_default_integer_kind
4198                   || code->expr->symtree->n.sym->as != NULL))
4199             gfc_error ("ASSIGN statement at %L requires a scalar "
4200                        "default INTEGER variable", &code->expr->where);
4201           break;
4202
4203         case EXEC_POINTER_ASSIGN:
4204           if (t == FAILURE)
4205             break;
4206
4207           gfc_check_pointer_assign (code->expr, code->expr2);
4208           break;
4209
4210         case EXEC_ARITHMETIC_IF:
4211           if (t == SUCCESS
4212               && code->expr->ts.type != BT_INTEGER
4213               && code->expr->ts.type != BT_REAL)
4214             gfc_error ("Arithmetic IF statement at %L requires a numeric "
4215                        "expression", &code->expr->where);
4216
4217           resolve_branch (code->label, code);
4218           resolve_branch (code->label2, code);
4219           resolve_branch (code->label3, code);
4220           break;
4221
4222         case EXEC_IF:
4223           if (t == SUCCESS && code->expr != NULL
4224               && (code->expr->ts.type != BT_LOGICAL
4225                   || code->expr->rank != 0))
4226             gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
4227                        &code->expr->where);
4228           break;
4229
4230         case EXEC_CALL:
4231         call:
4232           resolve_call (code);
4233           break;
4234
4235         case EXEC_SELECT:
4236           /* Select is complicated. Also, a SELECT construct could be
4237              a transformed computed GOTO.  */
4238           resolve_select (code);
4239           break;
4240
4241         case EXEC_DO:
4242           if (code->ext.iterator != NULL)
4243             gfc_resolve_iterator (code->ext.iterator, true);
4244           break;
4245
4246         case EXEC_DO_WHILE:
4247           if (code->expr == NULL)
4248             gfc_internal_error ("resolve_code(): No expression on DO WHILE");
4249           if (t == SUCCESS
4250               && (code->expr->rank != 0
4251                   || code->expr->ts.type != BT_LOGICAL))
4252             gfc_error ("Exit condition of DO WHILE loop at %L must be "
4253                        "a scalar LOGICAL expression", &code->expr->where);
4254           break;
4255
4256         case EXEC_ALLOCATE:
4257           if (t == SUCCESS && code->expr != NULL
4258               && code->expr->ts.type != BT_INTEGER)
4259             gfc_error ("STAT tag in ALLOCATE statement at %L must be "
4260                        "of type INTEGER", &code->expr->where);
4261
4262           for (a = code->ext.alloc_list; a; a = a->next)
4263             resolve_allocate_expr (a->expr, code);
4264
4265           break;
4266
4267         case EXEC_DEALLOCATE:
4268           if (t == SUCCESS && code->expr != NULL
4269               && code->expr->ts.type != BT_INTEGER)
4270             gfc_error
4271               ("STAT tag in DEALLOCATE statement at %L must be of type "
4272                "INTEGER", &code->expr->where);
4273
4274           for (a = code->ext.alloc_list; a; a = a->next)
4275             resolve_deallocate_expr (a->expr);
4276
4277           break;
4278
4279         case EXEC_OPEN:
4280           if (gfc_resolve_open (code->ext.open) == FAILURE)
4281             break;
4282
4283           resolve_branch (code->ext.open->err, code);
4284           break;
4285
4286         case EXEC_CLOSE:
4287           if (gfc_resolve_close (code->ext.close) == FAILURE)
4288             break;
4289
4290           resolve_branch (code->ext.close->err, code);
4291           break;
4292
4293         case EXEC_BACKSPACE:
4294         case EXEC_ENDFILE:
4295         case EXEC_REWIND:
4296         case EXEC_FLUSH:
4297           if (gfc_resolve_filepos (code->ext.filepos) == FAILURE)
4298             break;
4299
4300           resolve_branch (code->ext.filepos->err, code);
4301           break;
4302
4303         case EXEC_INQUIRE:
4304           if (gfc_resolve_inquire (code->ext.inquire) == FAILURE)
4305               break;
4306
4307           resolve_branch (code->ext.inquire->err, code);
4308           break;
4309
4310         case EXEC_IOLENGTH:
4311           gcc_assert (code->ext.inquire != NULL);
4312           if (gfc_resolve_inquire (code->ext.inquire) == FAILURE)
4313             break;
4314
4315           resolve_branch (code->ext.inquire->err, code);
4316           break;
4317
4318         case EXEC_READ:
4319         case EXEC_WRITE:
4320           if (gfc_resolve_dt (code->ext.dt) == FAILURE)
4321             break;
4322
4323           resolve_branch (code->ext.dt->err, code);
4324           resolve_branch (code->ext.dt->end, code);
4325           resolve_branch (code->ext.dt->eor, code);
4326           break;
4327
4328         case EXEC_TRANSFER:
4329           resolve_transfer (code);
4330           break;
4331
4332         case EXEC_FORALL:
4333           resolve_forall_iterators (code->ext.forall_iterator);
4334
4335           if (code->expr != NULL && code->expr->ts.type != BT_LOGICAL)
4336             gfc_error
4337               ("FORALL mask clause at %L requires a LOGICAL expression",
4338                &code->expr->where);
4339           break;
4340
4341         default:
4342           gfc_internal_error ("resolve_code(): Bad statement code");
4343         }
4344     }
4345
4346   cs_base = frame.prev;
4347 }
4348
4349
4350 /* Resolve initial values and make sure they are compatible with
4351    the variable.  */
4352
4353 static void
4354 resolve_values (gfc_symbol * sym)
4355 {
4356
4357   if (sym->value == NULL)
4358     return;
4359
4360   if (gfc_resolve_expr (sym->value) == FAILURE)
4361     return;
4362
4363   gfc_check_assign_symbol (sym, sym->value);
4364 }
4365
4366
4367 /* Resolve a charlen structure.  */
4368
4369 static try
4370 resolve_charlen (gfc_charlen *cl)
4371 {
4372   if (cl->resolved)
4373     return SUCCESS;
4374
4375   cl->resolved = 1;
4376
4377   if (gfc_resolve_expr (cl->length) == FAILURE)
4378     return FAILURE;
4379
4380   if (gfc_simplify_expr (cl->length, 0) == FAILURE)
4381     return FAILURE;
4382
4383   if (gfc_specification_expr (cl->length) == FAILURE)
4384     return FAILURE;
4385
4386   return SUCCESS;
4387 }
4388
4389
4390 /* Resolve the components of a derived type.  */
4391
4392 static try
4393 resolve_derived (gfc_symbol *sym)
4394 {
4395   gfc_component *c;
4396
4397   for (c = sym->components; c != NULL; c = c->next)
4398     {
4399       if (c->ts.type == BT_CHARACTER)
4400         {
4401          if (resolve_charlen (c->ts.cl) == FAILURE)
4402            return FAILURE;
4403
4404          if (c->ts.cl->length == NULL
4405              || !gfc_is_constant_expr (c->ts.cl->length))
4406            {
4407              gfc_error ("Character length of component '%s' needs to "
4408                         "be a constant specification expression at %L.",
4409                         c->name,
4410                         c->ts.cl->length ? &c->ts.cl->length->where : &c->loc);
4411              return FAILURE;
4412            }
4413         }
4414
4415       /* TODO: Anything else that should be done here?  */
4416     }
4417
4418   return SUCCESS;
4419 }
4420
4421 /* Do anything necessary to resolve a symbol.  Right now, we just
4422    assume that an otherwise unknown symbol is a variable.  This sort
4423    of thing commonly happens for symbols in module.  */
4424
4425 static void
4426 resolve_symbol (gfc_symbol * sym)
4427 {
4428   /* Zero if we are checking a formal namespace.  */
4429   static int formal_ns_flag = 1;
4430   int formal_ns_save, check_constant, mp_flag;
4431   int i, flag;
4432   gfc_namelist *nl;
4433   gfc_symtree * symtree;
4434   gfc_symtree * this_symtree;
4435   gfc_namespace * ns;
4436   gfc_component * c;
4437   gfc_formal_arglist * arg;
4438
4439   if (sym->attr.flavor == FL_UNKNOWN)
4440     {
4441
4442     /* If we find that a flavorless symbol is an interface in one of the
4443        parent namespaces, find its symtree in this namespace, free the
4444        symbol and set the symtree to point to the interface symbol.  */
4445       for (ns = gfc_current_ns->parent; ns; ns = ns->parent)
4446         {
4447           symtree = gfc_find_symtree (ns->sym_root, sym->name);
4448           if (symtree && symtree->n.sym->generic)
4449             {
4450               this_symtree = gfc_find_symtree (gfc_current_ns->sym_root,
4451                                                sym->name);
4452               sym->refs--;
4453               if (!sym->refs)
4454                 gfc_free_symbol (sym);
4455               symtree->n.sym->refs++;
4456               this_symtree->n.sym = symtree->n.sym;
4457               return;
4458             }
4459         }
4460
4461       /* Otherwise give it a flavor according to such attributes as
4462          it has.  */
4463       if (sym->attr.external == 0 && sym->attr.intrinsic == 0)
4464         sym->attr.flavor = FL_VARIABLE;
4465       else
4466         {
4467           sym->attr.flavor = FL_PROCEDURE;
4468           if (sym->attr.dimension)
4469             sym->attr.function = 1;
4470         }
4471     }
4472
4473   if (sym->attr.flavor == FL_DERIVED && resolve_derived (sym) == FAILURE)
4474     return;
4475
4476   /* Symbols that are module procedures with results (functions) have
4477      the types and array specification copied for type checking in
4478      procedures that call them, as well as for saving to a module
4479      file.  These symbols can't stand the scrutiny that their results
4480      can.  */
4481   mp_flag = (sym->result != NULL && sym->result != sym);
4482
4483   /* Assign default type to symbols that need one and don't have one.  */
4484   if (sym->ts.type == BT_UNKNOWN)
4485     {
4486       if (sym->attr.flavor == FL_VARIABLE || sym->attr.flavor == FL_PARAMETER)
4487         gfc_set_default_type (sym, 1, NULL);
4488
4489       if (sym->attr.flavor == FL_PROCEDURE && sym->attr.function)
4490         {
4491           /* The specific case of an external procedure should emit an error
4492              in the case that there is no implicit type.  */
4493           if (!mp_flag)
4494             gfc_set_default_type (sym, sym->attr.external, NULL);
4495           else
4496             {
4497               /* Result may be in another namespace.  */
4498               resolve_symbol (sym->result);
4499
4500               sym->ts = sym->result->ts;
4501               sym->as = gfc_copy_array_spec (sym->result->as);
4502               sym->attr.dimension = sym->result->attr.dimension;
4503               sym->attr.pointer = sym->result->attr.pointer;
4504             }
4505         }
4506     }
4507
4508   /* Assumed size arrays and assumed shape arrays must be dummy
4509      arguments.  */
4510
4511   if (sym->as != NULL
4512       && (sym->as->type == AS_ASSUMED_SIZE
4513           || sym->as->type == AS_ASSUMED_SHAPE)
4514       && sym->attr.dummy == 0)
4515     {
4516       if (sym->as->type == AS_ASSUMED_SIZE)
4517         gfc_error ("Assumed size array at %L must be a dummy argument",
4518                    &sym->declared_at);
4519       else
4520         gfc_error ("Assumed shape array at %L must be a dummy argument",
4521                    &sym->declared_at);
4522       return;
4523     }
4524
4525   /* A parameter array's shape needs to be constant.  */
4526
4527   if (sym->attr.flavor == FL_PARAMETER && sym->as != NULL
4528       && !gfc_is_compile_time_shape (sym->as))
4529     {
4530       gfc_error ("Parameter array '%s' at %L cannot be automatic "
4531                  "or assumed shape", sym->name, &sym->declared_at);
4532           return;
4533     }
4534
4535   /* A module array's shape needs to be constant.  */
4536
4537   if (sym->ns->proc_name
4538       && sym->attr.flavor == FL_VARIABLE
4539       && sym->ns->proc_name->attr.flavor == FL_MODULE
4540       && !sym->attr.use_assoc
4541       && !sym->attr.allocatable
4542       && !sym->attr.pointer
4543       && sym->as != NULL
4544       && !gfc_is_compile_time_shape (sym->as))
4545     {
4546       gfc_error ("Module array '%s' at %L cannot be automatic "
4547          "or assumed shape", sym->name, &sym->declared_at);
4548       return;
4549     }
4550
4551   /* Make sure that character string variables with assumed length are
4552      dummy arguments.  */
4553
4554   if (sym->attr.flavor == FL_VARIABLE && !sym->attr.result
4555       && sym->ts.type == BT_CHARACTER
4556       && sym->ts.cl->length == NULL && sym->attr.dummy == 0)
4557     {
4558       gfc_error ("Entity with assumed character length at %L must be a "
4559                  "dummy argument or a PARAMETER", &sym->declared_at);
4560       return;
4561     }
4562
4563   /* Make sure a parameter that has been implicitly typed still
4564      matches the implicit type, since PARAMETER statements can precede
4565      IMPLICIT statements.  */
4566
4567   if (sym->attr.flavor == FL_PARAMETER
4568       && sym->attr.implicit_type
4569       && !gfc_compare_types (&sym->ts, gfc_get_default_type (sym, sym->ns)))
4570     gfc_error ("Implicitly typed PARAMETER '%s' at %L doesn't match a "
4571                "later IMPLICIT type", sym->name, &sym->declared_at);
4572
4573   /* Make sure the types of derived parameters are consistent.  This
4574      type checking is deferred until resolution because the type may
4575      refer to a derived type from the host.  */
4576
4577   if (sym->attr.flavor == FL_PARAMETER
4578       && sym->ts.type == BT_DERIVED
4579       && !gfc_compare_types (&sym->ts, &sym->value->ts))
4580     gfc_error ("Incompatible derived type in PARAMETER at %L",
4581                &sym->value->where);
4582
4583   /* Make sure symbols with known intent or optional are really dummy
4584      variable.  Because of ENTRY statement, this has to be deferred
4585      until resolution time.  */
4586
4587   if (! sym->attr.dummy
4588       && (sym->attr.optional
4589           || sym->attr.intent != INTENT_UNKNOWN))
4590     {
4591       gfc_error ("Symbol at %L is not a DUMMY variable", &sym->declared_at);
4592       return;
4593     }
4594
4595   if (sym->attr.proc == PROC_ST_FUNCTION)
4596     {
4597       if (sym->ts.type == BT_CHARACTER)
4598         {
4599           gfc_charlen *cl = sym->ts.cl;
4600           if (!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT)
4601             {
4602               gfc_error ("Character-valued statement function '%s' at %L must "
4603                          "have constant length", sym->name, &sym->declared_at);
4604               return;
4605             }
4606         }
4607     }
4608
4609   /* If a derived type symbol has reached this point, without its
4610      type being declared, we have an error.  Notice that most
4611      conditions that produce undefined derived types have already
4612      been dealt with.  However, the likes of:
4613      implicit type(t) (t) ..... call foo (t) will get us here if
4614      the type is not declared in the scope of the implicit
4615      statement. Change the type to BT_UNKNOWN, both because it is so
4616      and to prevent an ICE.  */
4617   if (sym->ts.type == BT_DERIVED
4618         && sym->ts.derived->components == NULL)
4619     {
4620       gfc_error ("The derived type '%s' at %L is of type '%s', "
4621                  "which has not been defined.", sym->name,
4622                   &sym->declared_at, sym->ts.derived->name);
4623       sym->ts.type = BT_UNKNOWN;
4624       return;
4625     }
4626
4627   /* If a component of a derived type is of a type declared to be private,
4628      either the derived type definition must contain the PRIVATE statement,
4629      or the derived type must be private.  (4.4.1 just after R427) */
4630   if (sym->attr.flavor == FL_DERIVED
4631         && sym->component_access != ACCESS_PRIVATE
4632         && gfc_check_access(sym->attr.access, sym->ns->default_access))
4633     {
4634       for (c = sym->components; c; c = c->next)
4635         {
4636           if (c->ts.type == BT_DERIVED
4637                 && !c->ts.derived->attr.use_assoc
4638                 && !gfc_check_access(c->ts.derived->attr.access,
4639                                      c->ts.derived->ns->default_access))
4640             {
4641               gfc_error ("The component '%s' is a PRIVATE type and cannot be "
4642                          "a component of '%s', which is PUBLIC at %L",
4643                          c->name, sym->name, &sym->declared_at);
4644               return;
4645             }
4646         }
4647     }
4648
4649   /* An assumed-size array with INTENT(OUT) shall not be of a type for which
4650      default initialization is defined (5.1.2.4.4).  */
4651   if (sym->ts.type == BT_DERIVED
4652         && sym->attr.dummy
4653         && sym->attr.intent == INTENT_OUT
4654         && sym->as
4655         && sym->as->type == AS_ASSUMED_SIZE)
4656     {
4657       for (c = sym->ts.derived->components; c; c = c->next)
4658         {
4659           if (c->initializer)
4660             {
4661               gfc_error ("The INTENT(OUT) dummy argument '%s' at %L is "
4662                          "ASSUMED SIZE and so cannot have a default initializer",
4663                          sym->name, &sym->declared_at);
4664               return;
4665             }
4666         }
4667     }
4668
4669
4670   /* Ensure that derived type formal arguments of a public procedure
4671      are not of a private type.  */
4672   if (sym->attr.flavor == FL_PROCEDURE
4673         && gfc_check_access(sym->attr.access, sym->ns->default_access))
4674     {
4675       for (arg = sym->formal; arg; arg = arg->next)
4676         {
4677           if (arg->sym
4678                 && arg->sym->ts.type == BT_DERIVED
4679                 && !arg->sym->ts.derived->attr.use_assoc
4680                 && !gfc_check_access(arg->sym->ts.derived->attr.access,
4681                                      arg->sym->ts.derived->ns->default_access))
4682             {
4683               gfc_error_now ("'%s' is a PRIVATE type and cannot be "
4684                              "a dummy argument of '%s', which is PUBLIC at %L",
4685                              arg->sym->name, sym->name, &sym->declared_at);
4686               /* Stop this message from recurring.  */
4687               arg->sym->ts.derived->attr.access = ACCESS_PUBLIC;
4688               return;
4689             }
4690         }
4691     }
4692
4693   /* Constraints on deferred shape variable.  */
4694   if (sym->attr.flavor == FL_VARIABLE
4695       || (sym->attr.flavor == FL_PROCEDURE
4696           && sym->attr.function))
4697     {
4698       if (sym->as == NULL || sym->as->type != AS_DEFERRED)
4699         {
4700           if (sym->attr.allocatable)
4701             {
4702               if (sym->attr.dimension)
4703                 gfc_error ("Allocatable array '%s' at %L must have "
4704                            "a deferred shape", sym->name, &sym->declared_at);
4705               else
4706                 gfc_error ("Scalar object '%s' at %L may not be ALLOCATABLE",
4707                            sym->name, &sym->declared_at);
4708               return;
4709             }
4710
4711           if (sym->attr.pointer && sym->attr.dimension)
4712             {
4713               gfc_error ("Array pointer '%s' at %L must have a deferred shape",
4714                          sym->name, &sym->declared_at);
4715               return;
4716             }
4717
4718         }
4719       else
4720         {
4721           if (!mp_flag && !sym->attr.allocatable
4722               && !sym->attr.pointer && !sym->attr.dummy)
4723             {
4724               gfc_error ("Array '%s' at %L cannot have a deferred shape",
4725                          sym->name, &sym->declared_at);
4726               return;
4727             }
4728         }
4729     }
4730
4731   switch (sym->attr.flavor)
4732     {
4733     case FL_VARIABLE:
4734       /* Can the symbol have an initializer?  */
4735       flag = 0;
4736       if (sym->attr.allocatable || sym->attr.external || sym->attr.dummy
4737           || sym->attr.intrinsic || sym->attr.result)
4738         flag = 1;
4739       else if (sym->attr.dimension && !sym->attr.pointer)
4740         {
4741           /* Don't allow initialization of automatic arrays.  */
4742           for (i = 0; i < sym->as->rank; i++)
4743             {
4744               if (sym->as->lower[i] == NULL
4745                   || sym->as->lower[i]->expr_type != EXPR_CONSTANT
4746                   || sym->as->upper[i] == NULL
4747                   || sym->as->upper[i]->expr_type != EXPR_CONSTANT)
4748                 {
4749                   flag = 1;
4750                   break;
4751                 }
4752             }
4753         }
4754
4755       /* Reject illegal initializers.  */
4756       if (sym->value && flag)
4757         {
4758           if (sym->attr.allocatable)
4759             gfc_error ("Allocatable '%s' at %L cannot have an initializer",
4760                        sym->name, &sym->declared_at);
4761           else if (sym->attr.external)
4762             gfc_error ("External '%s' at %L cannot have an initializer",
4763                        sym->name, &sym->declared_at);
4764           else if (sym->attr.dummy)
4765             gfc_error ("Dummy '%s' at %L cannot have an initializer",
4766                        sym->name, &sym->declared_at);
4767           else if (sym->attr.intrinsic)
4768             gfc_error ("Intrinsic '%s' at %L cannot have an initializer",
4769                        sym->name, &sym->declared_at);
4770           else if (sym->attr.result)
4771             gfc_error ("Function result '%s' at %L cannot have an initializer",
4772                        sym->name, &sym->declared_at);
4773           else
4774             gfc_error ("Automatic array '%s' at %L cannot have an initializer",
4775                        sym->name, &sym->declared_at);
4776           return;
4777         }
4778
4779       /* Assign default initializer.  */
4780       if (sym->ts.type == BT_DERIVED && !(sym->value || flag)
4781           && !sym->attr.pointer)
4782         sym->value = gfc_default_initializer (&sym->ts);
4783       break;
4784
4785     case FL_NAMELIST:
4786       /* Reject PRIVATE objects in a PUBLIC namelist.  */
4787       if (gfc_check_access(sym->attr.access, sym->ns->default_access))
4788         {
4789           for (nl = sym->namelist; nl; nl = nl->next)
4790             {
4791               if (!nl->sym->attr.use_assoc
4792                     &&
4793                   !(sym->ns->parent == nl->sym->ns)
4794                     &&
4795                   !gfc_check_access(nl->sym->attr.access,
4796                                     nl->sym->ns->default_access))
4797                 gfc_error ("PRIVATE symbol '%s' cannot be member of "
4798                            "PUBLIC namelist at %L", nl->sym->name,
4799                            &sym->declared_at);
4800             }
4801         }
4802       break;
4803
4804     case FL_DERIVED:
4805       /* Add derived type to the derived type list.  */
4806       {
4807         gfc_dt_list * dt_list;
4808         dt_list = gfc_get_dt_list ();
4809         dt_list->next = sym->ns->derived_types;
4810         dt_list->derived = sym;
4811         sym->ns->derived_types = dt_list;
4812       }
4813       break;
4814
4815     default:
4816
4817       /* An external symbol falls through to here if it is not referenced.  */
4818       if (sym->attr.external && sym->value)
4819         {
4820           gfc_error ("External object '%s' at %L may not have an initializer",
4821                      sym->name, &sym->declared_at);
4822           return;
4823         }
4824
4825       break;
4826     }
4827
4828
4829   /* Make sure that intrinsic exist */
4830   if (sym->attr.intrinsic
4831       && ! gfc_intrinsic_name(sym->name, 0)
4832       && ! gfc_intrinsic_name(sym->name, 1))
4833     gfc_error("Intrinsic at %L does not exist", &sym->declared_at);
4834
4835   /* Resolve array specifier. Check as well some constraints
4836      on COMMON blocks.  */
4837
4838   check_constant = sym->attr.in_common && !sym->attr.pointer;
4839   gfc_resolve_array_spec (sym->as, check_constant);
4840
4841   /* Resolve formal namespaces.  */
4842
4843   if (formal_ns_flag && sym != NULL && sym->formal_ns != NULL)
4844     {
4845       formal_ns_save = formal_ns_flag;
4846       formal_ns_flag = 0;
4847       gfc_resolve (sym->formal_ns);
4848       formal_ns_flag = formal_ns_save;
4849     }
4850 }
4851
4852
4853
4854 /************* Resolve DATA statements *************/
4855
4856 static struct
4857 {
4858   gfc_data_value *vnode;
4859   unsigned int left;
4860 }
4861 values;
4862
4863
4864 /* Advance the values structure to point to the next value in the data list.  */
4865
4866 static try
4867 next_data_value (void)
4868 {
4869   while (values.left == 0)
4870     {
4871       if (values.vnode->next == NULL)
4872         return FAILURE;
4873
4874       values.vnode = values.vnode->next;
4875       values.left = values.vnode->repeat;
4876     }
4877
4878   return SUCCESS;
4879 }
4880
4881
4882 static try
4883 check_data_variable (gfc_data_variable * var, locus * where)
4884 {
4885   gfc_expr *e;
4886   mpz_t size;
4887   mpz_t offset;
4888   try t;
4889   ar_type mark = AR_UNKNOWN;
4890   int i;
4891   mpz_t section_index[GFC_MAX_DIMENSIONS];
4892   gfc_ref *ref;
4893   gfc_array_ref *ar;
4894
4895   if (gfc_resolve_expr (var->expr) == FAILURE)
4896     return FAILURE;
4897
4898   ar = NULL;
4899   mpz_init_set_si (offset, 0);
4900   e = var->expr;
4901
4902   if (e->expr_type != EXPR_VARIABLE)
4903     gfc_internal_error ("check_data_variable(): Bad expression");
4904
4905   if (e->rank == 0)
4906     {
4907       mpz_init_set_ui (size, 1);
4908       ref = NULL;
4909     }
4910   else
4911     {
4912       ref = e->ref;
4913
4914       /* Find the array section reference.  */
4915       for (ref = e->ref; ref; ref = ref->next)
4916         {
4917           if (ref->type != REF_ARRAY)
4918             continue;
4919           if (ref->u.ar.type == AR_ELEMENT)
4920             continue;
4921           break;
4922         }
4923       gcc_assert (ref);
4924
4925       /* Set marks according to the reference pattern.  */
4926       switch (ref->u.ar.type)
4927         {
4928         case AR_FULL:
4929           mark = AR_FULL;
4930           break;
4931
4932         case AR_SECTION:
4933           ar = &ref->u.ar;
4934           /* Get the start position of array section.  */
4935           gfc_get_section_index (ar, section_index, &offset);
4936           mark = AR_SECTION;
4937           break;
4938
4939         default:
4940           gcc_unreachable ();
4941         }
4942
4943       if (gfc_array_size (e, &size) == FAILURE)
4944         {
4945           gfc_error ("Nonconstant array section at %L in DATA statement",
4946                      &e->where);
4947           mpz_clear (offset);
4948           return FAILURE;
4949         }
4950     }
4951
4952   t = SUCCESS;
4953
4954   while (mpz_cmp_ui (size, 0) > 0)
4955     {
4956       if (next_data_value () == FAILURE)
4957         {
4958           gfc_error ("DATA statement at %L has more variables than values",
4959                      where);
4960           t = FAILURE;
4961           break;
4962         }
4963
4964       t = gfc_check_assign (var->expr, values.vnode->expr, 0);
4965       if (t == FAILURE)
4966         break;
4967
4968       /* If we have more than one element left in the repeat count,
4969          and we have more than one element left in the target variable,
4970          then create a range assignment.  */
4971       /* ??? Only done for full arrays for now, since array sections
4972          seem tricky.  */
4973       if (mark == AR_FULL && ref && ref->next == NULL
4974           && values.left > 1 && mpz_cmp_ui (size, 1) > 0)
4975         {
4976           mpz_t range;
4977
4978           if (mpz_cmp_ui (size, values.left) >= 0)
4979             {
4980               mpz_init_set_ui (range, values.left);
4981               mpz_sub_ui (size, size, values.left);
4982               values.left = 0;
4983             }
4984           else
4985             {
4986               mpz_init_set (range, size);
4987               values.left -= mpz_get_ui (size);
4988               mpz_set_ui (size, 0);
4989             }
4990
4991           gfc_assign_data_value_range (var->expr, values.vnode->expr,
4992                                        offset, range);
4993
4994           mpz_add (offset, offset, range);
4995           mpz_clear (range);
4996         }
4997
4998       /* Assign initial value to symbol.  */
4999       else
5000         {
5001           values.left -= 1;
5002           mpz_sub_ui (size, size, 1);
5003
5004           gfc_assign_data_value (var->expr, values.vnode->expr, offset);
5005
5006           if (mark == AR_FULL)
5007             mpz_add_ui (offset, offset, 1);
5008
5009           /* Modify the array section indexes and recalculate the offset
5010              for next element.  */
5011           else if (mark == AR_SECTION)
5012             gfc_advance_section (section_index, ar, &offset);
5013         }
5014     }
5015
5016   if (mark == AR_SECTION)
5017     {
5018       for (i = 0; i < ar->dimen; i++)
5019         mpz_clear (section_index[i]);
5020     }
5021
5022   mpz_clear (size);
5023   mpz_clear (offset);
5024
5025   return t;
5026 }
5027
5028
5029 static try traverse_data_var (gfc_data_variable *, locus *);
5030
5031 /* Iterate over a list of elements in a DATA statement.  */
5032
5033 static try
5034 traverse_data_list (gfc_data_variable * var, locus * where)
5035 {
5036   mpz_t trip;
5037   iterator_stack frame;
5038   gfc_expr *e;
5039
5040   mpz_init (frame.value);
5041
5042   mpz_init_set (trip, var->iter.end->value.integer);
5043   mpz_sub (trip, trip, var->iter.start->value.integer);
5044   mpz_add (trip, trip, var->iter.step->value.integer);
5045
5046   mpz_div (trip, trip, var->iter.step->value.integer);
5047
5048   mpz_set (frame.value, var->iter.start->value.integer);
5049
5050   frame.prev = iter_stack;
5051   frame.variable = var->iter.var->symtree;
5052   iter_stack = &frame;
5053
5054   while (mpz_cmp_ui (trip, 0) > 0)
5055     {
5056       if (traverse_data_var (var->list, where) == FAILURE)
5057         {
5058           mpz_clear (trip);
5059           return FAILURE;
5060         }
5061
5062       e = gfc_copy_expr (var->expr);
5063       if (gfc_simplify_expr (e, 1) == FAILURE)
5064         {
5065           gfc_free_expr (e);
5066           return FAILURE;
5067         }
5068
5069       mpz_add (frame.value, frame.value, var->iter.step->value.integer);
5070
5071       mpz_sub_ui (trip, trip, 1);
5072     }
5073
5074   mpz_clear (trip);
5075   mpz_clear (frame.value);
5076
5077   iter_stack = frame.prev;
5078   return SUCCESS;
5079 }
5080
5081
5082 /* Type resolve variables in the variable list of a DATA statement.  */
5083
5084 static try
5085 traverse_data_var (gfc_data_variable * var, locus * where)
5086 {
5087   try t;
5088
5089   for (; var; var = var->next)
5090     {
5091       if (var->expr == NULL)
5092         t = traverse_data_list (var, where);
5093       else
5094         t = check_data_variable (var, where);
5095
5096       if (t == FAILURE)
5097         return FAILURE;
5098     }
5099
5100   return SUCCESS;
5101 }
5102
5103
5104 /* Resolve the expressions and iterators associated with a data statement.
5105    This is separate from the assignment checking because data lists should
5106    only be resolved once.  */
5107
5108 static try
5109 resolve_data_variables (gfc_data_variable * d)
5110 {
5111   for (; d; d = d->next)
5112     {
5113       if (d->list == NULL)
5114         {
5115           if (gfc_resolve_expr (d->expr) == FAILURE)
5116             return FAILURE;
5117         }
5118       else
5119         {
5120           if (gfc_resolve_iterator (&d->iter, false) == FAILURE)
5121             return FAILURE;
5122
5123           if (d->iter.start->expr_type != EXPR_CONSTANT
5124               || d->iter.end->expr_type != EXPR_CONSTANT
5125               || d->iter.step->expr_type != EXPR_CONSTANT)
5126             gfc_internal_error ("resolve_data_variables(): Bad iterator");
5127
5128           if (resolve_data_variables (d->list) == FAILURE)
5129             return FAILURE;
5130         }
5131     }
5132
5133   return SUCCESS;
5134 }
5135
5136
5137 /* Resolve a single DATA statement.  We implement this by storing a pointer to
5138    the value list into static variables, and then recursively traversing the
5139    variables list, expanding iterators and such.  */
5140
5141 static void
5142 resolve_data (gfc_data * d)
5143 {
5144   if (resolve_data_variables (d->var) == FAILURE)
5145     return;
5146
5147   values.vnode = d->value;
5148   values.left = (d->value == NULL) ? 0 : d->value->repeat;
5149
5150   if (traverse_data_var (d->var, &d->where) == FAILURE)
5151     return;
5152
5153   /* At this point, we better not have any values left.  */
5154
5155   if (next_data_value () == SUCCESS)
5156     gfc_error ("DATA statement at %L has more values than variables",
5157                &d->where);
5158 }
5159
5160
5161 /* Determines if a variable is not 'pure', ie not assignable within a pure
5162    procedure.  Returns zero if assignment is OK, nonzero if there is a problem.
5163  */
5164
5165 int
5166 gfc_impure_variable (gfc_symbol * sym)
5167 {
5168   if (sym->attr.use_assoc || sym->attr.in_common)
5169     return 1;
5170
5171   if (sym->ns != gfc_current_ns)
5172     return !sym->attr.function;
5173
5174   /* TODO: Check storage association through EQUIVALENCE statements */
5175
5176   return 0;
5177 }
5178
5179
5180 /* Test whether a symbol is pure or not.  For a NULL pointer, checks the
5181    symbol of the current procedure.  */
5182
5183 int
5184 gfc_pure (gfc_symbol * sym)
5185 {
5186   symbol_attribute attr;
5187
5188   if (sym == NULL)
5189     sym = gfc_current_ns->proc_name;
5190   if (sym == NULL)
5191     return 0;
5192
5193   attr = sym->attr;
5194
5195   return attr.flavor == FL_PROCEDURE && (attr.pure || attr.elemental);
5196 }
5197
5198
5199 /* Test whether the current procedure is elemental or not.  */
5200
5201 int
5202 gfc_elemental (gfc_symbol * sym)
5203 {
5204   symbol_attribute attr;
5205
5206   if (sym == NULL)
5207     sym = gfc_current_ns->proc_name;
5208   if (sym == NULL)
5209     return 0;
5210   attr = sym->attr;
5211
5212   return attr.flavor == FL_PROCEDURE && attr.elemental;
5213 }
5214
5215
5216 /* Warn about unused labels.  */
5217
5218 static void
5219 warn_unused_label (gfc_namespace * ns)
5220 {
5221   gfc_st_label *l;
5222
5223   l = ns->st_labels;
5224   if (l == NULL)
5225     return;
5226
5227   while (l->next)
5228     l = l->next;
5229
5230   for (; l; l = l->prev)
5231     {
5232       if (l->defined == ST_LABEL_UNKNOWN)
5233         continue;
5234
5235       switch (l->referenced)
5236         {
5237         case ST_LABEL_UNKNOWN:
5238           gfc_warning ("Label %d at %L defined but not used", l->value,
5239                        &l->where);
5240           break;
5241
5242         case ST_LABEL_BAD_TARGET:
5243           gfc_warning ("Label %d at %L defined but cannot be used", l->value,
5244                        &l->where);
5245           break;
5246
5247         default:
5248           break;
5249         }
5250     }
5251 }
5252
5253
5254 /* Returns the sequence type of a symbol or sequence.  */
5255
5256 static seq_type
5257 sequence_type (gfc_typespec ts)
5258 {
5259   seq_type result;
5260   gfc_component *c;
5261
5262   switch (ts.type)
5263   {
5264     case BT_DERIVED:
5265
5266       if (ts.derived->components == NULL)
5267         return SEQ_NONDEFAULT;
5268
5269       result = sequence_type (ts.derived->components->ts);
5270       for (c = ts.derived->components->next; c; c = c->next)
5271         if (sequence_type (c->ts) != result)
5272           return SEQ_MIXED;
5273
5274       return result;
5275
5276     case BT_CHARACTER:
5277       if (ts.kind != gfc_default_character_kind)
5278           return SEQ_NONDEFAULT;
5279
5280       return SEQ_CHARACTER;
5281
5282     case BT_INTEGER:
5283       if (ts.kind != gfc_default_integer_kind)
5284           return SEQ_NONDEFAULT;
5285
5286       return SEQ_NUMERIC;
5287
5288     case BT_REAL:
5289       if (!(ts.kind == gfc_default_real_kind
5290              || ts.kind == gfc_default_double_kind))
5291           return SEQ_NONDEFAULT;
5292
5293       return SEQ_NUMERIC;
5294
5295     case BT_COMPLEX:
5296       if (ts.kind != gfc_default_complex_kind)
5297           return SEQ_NONDEFAULT;
5298
5299       return SEQ_NUMERIC;
5300
5301     case BT_LOGICAL:
5302       if (ts.kind != gfc_default_logical_kind)
5303           return SEQ_NONDEFAULT;
5304
5305       return SEQ_NUMERIC;
5306
5307     default:
5308       return SEQ_NONDEFAULT;
5309   }
5310 }
5311
5312
5313 /* Resolve derived type EQUIVALENCE object.  */
5314
5315 static try
5316 resolve_equivalence_derived (gfc_symbol *derived, gfc_symbol *sym, gfc_expr *e)
5317 {
5318   gfc_symbol *d;
5319   gfc_component *c = derived->components;
5320
5321   if (!derived)
5322     return SUCCESS;
5323
5324   /* Shall not be an object of nonsequence derived type.  */
5325   if (!derived->attr.sequence)
5326     {
5327       gfc_error ("Derived type variable '%s' at %L must have SEQUENCE "
5328                  "attribute to be an EQUIVALENCE object", sym->name, &e->where);
5329       return FAILURE;
5330     }
5331
5332   for (; c ; c = c->next)
5333     {
5334       d = c->ts.derived;
5335       if (d && (resolve_equivalence_derived (c->ts.derived, sym, e) == FAILURE))
5336         return FAILURE;
5337
5338       /* Shall not be an object of sequence derived type containing a pointer
5339          in the structure.  */
5340       if (c->pointer)
5341         {
5342           gfc_error ("Derived type variable '%s' at %L with pointer component(s) "
5343                      "cannot be an EQUIVALENCE object", sym->name, &e->where);
5344           return FAILURE;
5345         }
5346
5347       if (c->initializer)
5348         {
5349           gfc_error ("Derived type variable '%s' at %L with default initializer "
5350                      "cannot be an EQUIVALENCE object", sym->name, &e->where);
5351           return FAILURE;
5352         }
5353     }
5354   return SUCCESS;
5355 }
5356
5357
5358 /* Resolve equivalence object.
5359    An EQUIVALENCE object shall not be a dummy argument, a pointer, a target,
5360    an allocatable array, an object of nonsequence derived type, an object of
5361    sequence derived type containing a pointer at any level of component
5362    selection, an automatic object, a function name, an entry name, a result
5363    name, a named constant, a structure component, or a subobject of any of
5364    the preceding objects.  A substring shall not have length zero.  A
5365    derived type shall not have components with default initialization nor
5366    shall two objects of an equivalence group be initialized.
5367    The simple constraints are done in symbol.c(check_conflict) and the rest
5368    are implemented here.  */
5369
5370 static void
5371 resolve_equivalence (gfc_equiv *eq)
5372 {
5373   gfc_symbol *sym;
5374   gfc_symbol *derived;
5375   gfc_symbol *first_sym;
5376   gfc_expr *e;
5377   gfc_ref *r;
5378   locus *last_where = NULL;
5379   seq_type eq_type, last_eq_type;
5380   gfc_typespec *last_ts;
5381   int object;
5382   const char *value_name;
5383   const char *msg;
5384
5385   value_name = NULL;
5386   last_ts = &eq->expr->symtree->n.sym->ts;
5387
5388   first_sym = eq->expr->symtree->n.sym;
5389
5390   for (object = 1; eq; eq = eq->eq, object++)
5391     {
5392       e = eq->expr;
5393
5394       e->ts = e->symtree->n.sym->ts;
5395       /* match_varspec might not know yet if it is seeing
5396          array reference or substring reference, as it doesn't
5397          know the types.  */
5398       if (e->ref && e->ref->type == REF_ARRAY)
5399         {
5400           gfc_ref *ref = e->ref;
5401           sym = e->symtree->n.sym;
5402
5403           if (sym->attr.dimension)
5404             {
5405               ref->u.ar.as = sym->as;
5406               ref = ref->next;
5407             }
5408
5409           /* For substrings, convert REF_ARRAY into REF_SUBSTRING.  */
5410           if (e->ts.type == BT_CHARACTER
5411               && ref
5412               && ref->type == REF_ARRAY
5413               && ref->u.ar.dimen == 1
5414               && ref->u.ar.dimen_type[0] == DIMEN_RANGE
5415               && ref->u.ar.stride[0] == NULL)
5416             {
5417               gfc_expr *start = ref->u.ar.start[0];
5418               gfc_expr *end = ref->u.ar.end[0];
5419               void *mem = NULL;
5420
5421               /* Optimize away the (:) reference.  */
5422               if (start == NULL && end == NULL)
5423                 {
5424                   if (e->ref == ref)
5425                     e->ref = ref->next;
5426                   else
5427                     e->ref->next = ref->next;
5428                   mem = ref;
5429                 }
5430               else
5431                 {
5432                   ref->type = REF_SUBSTRING;
5433                   if (start == NULL)
5434                     start = gfc_int_expr (1);
5435                   ref->u.ss.start = start;
5436                   if (end == NULL && e->ts.cl)
5437                     end = gfc_copy_expr (e->ts.cl->length);
5438                   ref->u.ss.end = end;
5439                   ref->u.ss.length = e->ts.cl;
5440                   e->ts.cl = NULL;
5441                 }
5442               ref = ref->next;
5443               gfc_free (mem);
5444             }
5445
5446           /* Any further ref is an error.  */
5447           if (ref)
5448             {
5449               gcc_assert (ref->type == REF_ARRAY);
5450               gfc_error ("Syntax error in EQUIVALENCE statement at %L",
5451                          &ref->u.ar.where);
5452               continue;
5453             }
5454         }
5455
5456       if (gfc_resolve_expr (e) == FAILURE)
5457         continue;
5458
5459       sym = e->symtree->n.sym;
5460
5461       /* An equivalence statement cannot have more than one initialized
5462          object.  */
5463       if (sym->value)
5464         {
5465           if (value_name != NULL)
5466             {
5467               gfc_error ("Initialized objects '%s' and '%s'  cannot both "
5468                          "be in the EQUIVALENCE statement at %L",
5469                          value_name, sym->name, &e->where);
5470               continue;
5471             }
5472           else
5473             value_name = sym->name;
5474         }
5475
5476       /* Shall not equivalence common block variables in a PURE procedure.  */
5477       if (sym->ns->proc_name
5478             && sym->ns->proc_name->attr.pure
5479             && sym->attr.in_common)
5480         {
5481           gfc_error ("Common block member '%s' at %L cannot be an EQUIVALENCE "
5482                      "object in the pure procedure '%s'",
5483                      sym->name, &e->where, sym->ns->proc_name->name);
5484           break;
5485         }
5486
5487       /* Shall not be a named constant.  */
5488       if (e->expr_type == EXPR_CONSTANT)
5489         {
5490           gfc_error ("Named constant '%s' at %L cannot be an EQUIVALENCE "
5491                      "object", sym->name, &e->where);
5492           continue;
5493         }
5494
5495       derived = e->ts.derived;
5496       if (derived && resolve_equivalence_derived (derived, sym, e) == FAILURE)
5497         continue;
5498
5499       /* Check that the types correspond correctly:
5500          Note 5.28:
5501          A numeric sequence structure may be equivalenced to another sequence
5502          structure, an object of default integer type, default real type, double
5503          precision real type, default logical type such that components of the
5504          structure ultimately only become associated to objects of the same
5505          kind. A character sequence structure may be equivalenced to an object
5506          of default character kind or another character sequence structure.
5507          Other objects may be equivalenced only to objects of the same type and
5508          kind parameters.  */
5509
5510       /* Identical types are unconditionally OK.  */
5511       if (object == 1 || gfc_compare_types (last_ts, &sym->ts))
5512         goto identical_types;
5513
5514       last_eq_type = sequence_type (*last_ts);
5515       eq_type = sequence_type (sym->ts);
5516
5517       /* Since the pair of objects is not of the same type, mixed or
5518          non-default sequences can be rejected.  */
5519
5520       msg = "Sequence %s with mixed components in EQUIVALENCE "
5521             "statement at %L with different type objects";
5522       if ((object ==2
5523                && last_eq_type == SEQ_MIXED
5524                && gfc_notify_std (GFC_STD_GNU, msg, first_sym->name,
5525                                   last_where) == FAILURE)
5526            ||  (eq_type == SEQ_MIXED
5527                && gfc_notify_std (GFC_STD_GNU, msg,sym->name,
5528                                   &e->where) == FAILURE))
5529         continue;
5530
5531       msg = "Non-default type object or sequence %s in EQUIVALENCE "
5532             "statement at %L with objects of different type";
5533       if ((object ==2
5534                && last_eq_type == SEQ_NONDEFAULT
5535                && gfc_notify_std (GFC_STD_GNU, msg, first_sym->name,
5536                                   last_where) == FAILURE)
5537            ||  (eq_type == SEQ_NONDEFAULT
5538                && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
5539                                   &e->where) == FAILURE))
5540         continue;
5541
5542       msg ="Non-CHARACTER object '%s' in default CHARACTER "
5543            "EQUIVALENCE statement at %L";
5544       if (last_eq_type == SEQ_CHARACTER
5545             && eq_type != SEQ_CHARACTER
5546             && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
5547                                   &e->where) == FAILURE)
5548                 continue;
5549
5550       msg ="Non-NUMERIC object '%s' in default NUMERIC "
5551            "EQUIVALENCE statement at %L";
5552       if (last_eq_type == SEQ_NUMERIC
5553             && eq_type != SEQ_NUMERIC
5554             && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
5555                                   &e->where) == FAILURE)
5556                 continue;
5557
5558   identical_types:
5559       last_ts =&sym->ts;
5560       last_where = &e->where;
5561
5562       if (!e->ref)
5563         continue;
5564
5565       /* Shall not be an automatic array.  */
5566       if (e->ref->type == REF_ARRAY
5567           && gfc_resolve_array_spec (e->ref->u.ar.as, 1) == FAILURE)
5568         {
5569           gfc_error ("Array '%s' at %L with non-constant bounds cannot be "
5570                      "an EQUIVALENCE object", sym->name, &e->where);
5571           continue;
5572         }
5573
5574       r = e->ref;
5575       while (r)
5576         {
5577           /* Shall not be a structure component.  */
5578           if (r->type == REF_COMPONENT)
5579             {
5580               gfc_error ("Structure component '%s' at %L cannot be an "
5581                          "EQUIVALENCE object",
5582                          r->u.c.component->name, &e->where);
5583               break;
5584             }
5585
5586           /* A substring shall not have length zero.  */
5587           if (r->type == REF_SUBSTRING)
5588             {
5589               if (compare_bound (r->u.ss.start, r->u.ss.end) == CMP_GT)
5590                 {
5591                   gfc_error ("Substring at %L has length zero",
5592                              &r->u.ss.start->where);
5593                   break;
5594                 }
5595             }
5596           r = r->next;
5597         }
5598     }
5599 }
5600
5601
5602 /* Resolve function and ENTRY types, issue diagnostics if needed. */
5603
5604 static void
5605 resolve_fntype (gfc_namespace * ns)
5606 {
5607   gfc_entry_list *el;
5608   gfc_symbol *sym;
5609
5610   if (ns->proc_name == NULL || !ns->proc_name->attr.function)
5611     return;
5612
5613   /* If there are any entries, ns->proc_name is the entry master
5614      synthetic symbol and ns->entries->sym actual FUNCTION symbol.  */
5615   if (ns->entries)
5616     sym = ns->entries->sym;
5617   else
5618     sym = ns->proc_name;
5619   if (sym->result == sym
5620       && sym->ts.type == BT_UNKNOWN
5621       && gfc_set_default_type (sym, 0, NULL) == FAILURE
5622       && !sym->attr.untyped)
5623     {
5624       gfc_error ("Function '%s' at %L has no IMPLICIT type",
5625                  sym->name, &sym->declared_at);
5626       sym->attr.untyped = 1;
5627     }
5628
5629   if (ns->entries)
5630     for (el = ns->entries->next; el; el = el->next)
5631       {
5632         if (el->sym->result == el->sym
5633             && el->sym->ts.type == BT_UNKNOWN
5634             && gfc_set_default_type (el->sym, 0, NULL) == FAILURE
5635             && !el->sym->attr.untyped)
5636           {
5637             gfc_error ("ENTRY '%s' at %L has no IMPLICIT type",
5638                        el->sym->name, &el->sym->declared_at);
5639             el->sym->attr.untyped = 1;
5640           }
5641       }
5642 }
5643
5644
5645 /* This function is called after a complete program unit has been compiled.
5646    Its purpose is to examine all of the expressions associated with a program
5647    unit, assign types to all intermediate expressions, make sure that all
5648    assignments are to compatible types and figure out which names refer to
5649    which functions or subroutines.  */
5650
5651 void
5652 gfc_resolve (gfc_namespace * ns)
5653 {
5654   gfc_namespace *old_ns, *n;
5655   gfc_charlen *cl;
5656   gfc_data *d;
5657   gfc_equiv *eq;
5658
5659   old_ns = gfc_current_ns;
5660   gfc_current_ns = ns;
5661
5662   resolve_entries (ns);
5663
5664   resolve_contained_functions (ns);
5665
5666   gfc_traverse_ns (ns, resolve_symbol);
5667
5668   resolve_fntype (ns);
5669
5670   for (n = ns->contained; n; n = n->sibling)
5671     {
5672       if (gfc_pure (ns->proc_name) && !gfc_pure (n->proc_name))
5673         gfc_error ("Contained procedure '%s' at %L of a PURE procedure must "
5674                    "also be PURE", n->proc_name->name,
5675                    &n->proc_name->declared_at);
5676
5677       gfc_resolve (n);
5678     }
5679
5680   forall_flag = 0;
5681   gfc_check_interfaces (ns);
5682
5683   for (cl = ns->cl_list; cl; cl = cl->next)
5684     resolve_charlen (cl);
5685
5686   gfc_traverse_ns (ns, resolve_values);
5687
5688   if (ns->save_all)
5689     gfc_save_all (ns);
5690
5691   iter_stack = NULL;
5692   for (d = ns->data; d; d = d->next)
5693     resolve_data (d);
5694
5695   iter_stack = NULL;
5696   gfc_traverse_ns (ns, gfc_formalize_init_value);
5697
5698   for (eq = ns->equiv; eq; eq = eq->next)
5699     resolve_equivalence (eq);
5700
5701   cs_base = NULL;
5702   resolve_code (ns->code, ns);
5703
5704   /* Warn about unused labels.  */
5705   if (gfc_option.warn_unused_labels)
5706     warn_unused_label (ns);
5707
5708   gfc_current_ns = old_ns;
5709 }