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