gcc/fortran/resolve.c

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