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 a 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               {
 415                 if (el == ns->entries)
 416                   gfc_error
 417                   ("FUNCTION result %s can't be an array in FUNCTION %s at %L",
 418                    sym->name, ns->entries->sym->name, &sym->declared_at);
 419                 else
 420                   gfc_error
 421                     ("ENTRY result %s can't be an array in FUNCTION %s at %L",
 422                      sym->name, ns->entries->sym->name, &sym->declared_at);
 423               }
 424               else if (sym->attr.pointer)
 425               {
 426                 if (el == ns->entries)
 427                   gfc_error
 428                   ("FUNCTION result %s can't be a POINTER in FUNCTION %s at %L",
 429                    sym->name, ns->entries->sym->name, &sym->declared_at);
 430                 else
 431                   gfc_error
 432                     ("ENTRY result %s can't be a POINTER in FUNCTION %s at %L",
 433                      sym->name, ns->entries->sym->name, &sym->declared_at);
 434               }
 435               else
 436                 {
 437                   ts = &sym->ts;
 438                   if (ts->type == BT_UNKNOWN)
 439                     ts = gfc_get_default_type (sym, NULL);
 440                   switch (ts->type)
 441                     {
 442                     case BT_INTEGER:
 443                       if (ts->kind == gfc_default_integer_kind)
 444                         sym = NULL;
 445                       break;
 446                     case BT_REAL:
 447                       if (ts->kind == gfc_default_real_kind
 448                           || ts->kind == gfc_default_double_kind)
 449                         sym = NULL;
 450                       break;
 451                     case BT_COMPLEX:
 452                       if (ts->kind == gfc_default_complex_kind)
 453                         sym = NULL;
 454                       break;
 455                     case BT_LOGICAL:
 456                       if (ts->kind == gfc_default_logical_kind)
 457                         sym = NULL;
 458                       break;
 459                     case BT_UNKNOWN:
 460                       /* We will issue error elsewhere.  */
 461                       sym = NULL;
 462                       break;
 463                     default:
 464                       break;
 465                     }
 466                   if (sym)
 467                   {
 468                     if (el == ns->entries)
 469                       gfc_error
 470                         ("FUNCTION result %s can't be of type %s in FUNCTION %s at %L",
 471                          sym->name, gfc_typename (ts), ns->entries->sym->name,
 472                          &sym->declared_at);
 473                     else
 474                       gfc_error
 475                         ("ENTRY result %s can't be of type %s in FUNCTION %s at %L",
 476                          sym->name, gfc_typename (ts), ns->entries->sym->name,
 477                          &sym->declared_at);
 478                   }
 479                 }
 480             }
 481         }
 482     }
 483   proc->attr.access = ACCESS_PRIVATE;
 484   proc->attr.entry_master = 1;
 485
 486   /* Merge all the entry point arguments.  */
 487   for (el = ns->entries; el; el = el->next)
 488     merge_argument_lists (proc, el->sym->formal);
 489
 490   /* Use the master function for the function body.  */
 491   ns->proc_name = proc;
 492
 493   /* Finalize the new symbols.  */
 494   gfc_commit_symbols ();
 495
 496   /* Restore the original namespace.  */
 497   gfc_current_ns = old_ns;
 498 }
 499
 500
 501 /* Resolve contained function types.  Because contained functions can call one
 502    another, they have to be worked out before any of the contained procedures
 503    can be resolved.
 504
 505    The good news is that if a function doesn't already have a type, the only
 506    way it can get one is through an IMPLICIT type or a RESULT variable, because
 507    by definition contained functions are contained namespace they're contained
 508    in, not in a sibling or parent namespace.  */
 509
 510 static void
 511 resolve_contained_functions (gfc_namespace * ns)
 512 {
 513   gfc_namespace *child;
 514   gfc_entry_list *el;
 515
 516   resolve_formal_arglists (ns);
 517
 518   for (child = ns->contained; child; child = child->sibling)
 519     {
 520       /* Resolve alternate entry points first.  */
 521       resolve_entries (child);
 522
 523       /* Then check function return types.  */
 524       resolve_contained_fntype (child->proc_name, child);
 525       for (el = child->entries; el; el = el->next)
 526         resolve_contained_fntype (el->sym, child);
 527     }
 528 }
 529
 530
 531 /* Resolve all of the elements of a structure constructor and make sure that
 532    the types are correct.  */
 533
 534 static try
 535 resolve_structure_cons (gfc_expr * expr)
 536 {
 537   gfc_constructor *cons;
 538   gfc_component *comp;
 539   try t;
 540
 541   t = SUCCESS;
 542   cons = expr->value.constructor;
 543   /* A constructor may have references if it is the result of substituting a
 544      parameter variable.  In this case we just pull out the component we
 545      want.  */
 546   if (expr->ref)
 547     comp = expr->ref->u.c.sym->components;
 548   else
 549     comp = expr->ts.derived->components;
 550
 551   for (; comp; comp = comp->next, cons = cons->next)
 552     {
 553       if (! cons->expr)
 554         {
 555           t = FAILURE;
 556           continue;
 557         }
 558
 559       if (gfc_resolve_expr (cons->expr) == FAILURE)
 560         {
 561           t = FAILURE;
 562           continue;
 563         }
 564
 565       /* If we don't have the right type, try to convert it.  */
 566
 567       if (!gfc_compare_types (&cons->expr->ts, &comp->ts)
 568           && gfc_convert_type (cons->expr, &comp->ts, 1) == FAILURE)
 569         t = FAILURE;
 570     }
 571
 572   return t;
 573 }
 574
 575
 576
 577 /****************** Expression name resolution ******************/
 578
 579 /* Returns 0 if a symbol was not declared with a type or
 580    attribute declaration statement, nonzero otherwise.  */
 581
 582 static int
 583 was_declared (gfc_symbol * sym)
 584 {
 585   symbol_attribute a;
 586
 587   a = sym->attr;
 588
 589   if (!a.implicit_type && sym->ts.type != BT_UNKNOWN)
 590     return 1;
 591
 592   if (a.allocatable || a.dimension || a.dummy || a.external || a.intrinsic
 593       || a.optional || a.pointer || a.save || a.target
 594       || a.access != ACCESS_UNKNOWN || a.intent != INTENT_UNKNOWN)
 595     return 1;
 596
 597   return 0;
 598 }
 599
 600
 601 /* Determine if a symbol is generic or not.  */
 602
 603 static int
 604 generic_sym (gfc_symbol * sym)
 605 {
 606   gfc_symbol *s;
 607
 608   if (sym->attr.generic ||
 609       (sym->attr.intrinsic && gfc_generic_intrinsic (sym->name)))
 610     return 1;
 611
 612   if (was_declared (sym) || sym->ns->parent == NULL)
 613     return 0;
 614
 615   gfc_find_symbol (sym->name, sym->ns->parent, 1, &s);
 616
 617   return (s == NULL) ? 0 : generic_sym (s);
 618 }
 619
 620
 621 /* Determine if a symbol is specific or not.  */
 622
 623 static int
 624 specific_sym (gfc_symbol * sym)
 625 {
 626   gfc_symbol *s;
 627
 628   if (sym->attr.if_source == IFSRC_IFBODY
 629       || sym->attr.proc == PROC_MODULE
 630       || sym->attr.proc == PROC_INTERNAL
 631       || sym->attr.proc == PROC_ST_FUNCTION
 632       || (sym->attr.intrinsic &&
 633           gfc_specific_intrinsic (sym->name))
 634       || sym->attr.external)
 635     return 1;
 636
 637   if (was_declared (sym) || sym->ns->parent == NULL)
 638     return 0;
 639
 640   gfc_find_symbol (sym->name, sym->ns->parent, 1, &s);
 641
 642   return (s == NULL) ? 0 : specific_sym (s);
 643 }
 644
 645
 646 /* Figure out if the procedure is specific, generic or unknown.  */
 647
 648 typedef enum
 649 { PTYPE_GENERIC = 1, PTYPE_SPECIFIC, PTYPE_UNKNOWN }
 650 proc_type;
 651
 652 static proc_type
 653 procedure_kind (gfc_symbol * sym)
 654 {
 655
 656   if (generic_sym (sym))
 657     return PTYPE_GENERIC;
 658
 659   if (specific_sym (sym))
 660     return PTYPE_SPECIFIC;
 661
 662   return PTYPE_UNKNOWN;
 663 }
 664
 665
 666 /* Resolve an actual argument list.  Most of the time, this is just
 667    resolving the expressions in the list.
 668    The exception is that we sometimes have to decide whether arguments
 669    that look like procedure arguments are really simple variable
 670    references.  */
 671
 672 static try
 673 resolve_actual_arglist (gfc_actual_arglist * arg)
 674 {
 675   gfc_symbol *sym;
 676   gfc_symtree *parent_st;
 677   gfc_expr *e;
 678
 679   for (; arg; arg = arg->next)
 680     {
 681
 682       e = arg->expr;
 683       if (e == NULL)
 684         {
 685           /* Check the label is a valid branching target.  */
 686           if (arg->label)
 687             {
 688               if (arg->label->defined == ST_LABEL_UNKNOWN)
 689                 {
 690                   gfc_error ("Label %d referenced at %L is never defined",
 691                              arg->label->value, &arg->label->where);
 692                   return FAILURE;
 693                 }
 694             }
 695           continue;
 696         }
 697
 698       if (e->ts.type != BT_PROCEDURE)
 699         {
 700           if (gfc_resolve_expr (e) != SUCCESS)
 701             return FAILURE;
 702           continue;
 703         }
 704
 705       /* See if the expression node should really be a variable
 706          reference.  */
 707
 708       sym = e->symtree->n.sym;
 709
 710       if (sym->attr.flavor == FL_PROCEDURE
 711           || sym->attr.intrinsic
 712           || sym->attr.external)
 713         {
 714
 715           if (sym->attr.proc == PROC_ST_FUNCTION)
 716             {
 717               gfc_error ("Statement function '%s' at %L is not allowed as an "
 718                          "actual argument", sym->name, &e->where);
 719             }
 720
 721           /* If the symbol is the function that names the current (or
 722              parent) scope, then we really have a variable reference.  */
 723
 724           if (sym->attr.function && sym->result == sym
 725               && (sym->ns->proc_name == sym
 726                   || (sym->ns->parent != NULL
 727                       && sym->ns->parent->proc_name == sym)))
 728             goto got_variable;
 729
 730           continue;
 731         }
 732
 733       /* See if the name is a module procedure in a parent unit.  */
 734
 735       if (was_declared (sym) || sym->ns->parent == NULL)
 736         goto got_variable;
 737
 738       if (gfc_find_sym_tree (sym->name, sym->ns->parent, 1, &parent_st))
 739         {
 740           gfc_error ("Symbol '%s' at %L is ambiguous", sym->name, &e->where);
 741           return FAILURE;
 742         }
 743
 744       if (parent_st == NULL)
 745         goto got_variable;
 746
 747       sym = parent_st->n.sym;
 748       e->symtree = parent_st;           /* Point to the right thing.  */
 749
 750       if (sym->attr.flavor == FL_PROCEDURE
 751           || sym->attr.intrinsic
 752           || sym->attr.external)
 753         {
 754           continue;
 755         }
 756
 757     got_variable:
 758       e->expr_type = EXPR_VARIABLE;
 759       e->ts = sym->ts;
 760       if (sym->as != NULL)
 761         {
 762           e->rank = sym->as->rank;
 763           e->ref = gfc_get_ref ();
 764           e->ref->type = REF_ARRAY;
 765           e->ref->u.ar.type = AR_FULL;
 766           e->ref->u.ar.as = sym->as;
 767         }
 768     }
 769
 770   return SUCCESS;
 771 }
 772
 773
 774 /************* Function resolution *************/
 775
 776 /* Resolve a function call known to be generic.
 777    Section 14.1.2.4.1.  */
 778
 779 static match
 780 resolve_generic_f0 (gfc_expr * expr, gfc_symbol * sym)
 781 {
 782   gfc_symbol *s;
 783
 784   if (sym->attr.generic)
 785     {
 786       s =
 787         gfc_search_interface (sym->generic, 0, &expr->value.function.actual);
 788       if (s != NULL)
 789         {
 790           expr->value.function.name = s->name;
 791           expr->value.function.esym = s;
 792           expr->ts = s->ts;
 793           if (s->as != NULL)
 794             expr->rank = s->as->rank;
 795           return MATCH_YES;
 796         }
 797
 798       /* TODO: Need to search for elemental references in generic interface */
 799     }
 800
 801   if (sym->attr.intrinsic)
 802     return gfc_intrinsic_func_interface (expr, 0);
 803
 804   return MATCH_NO;
 805 }
 806
 807
 808 static try
 809 resolve_generic_f (gfc_expr * expr)
 810 {
 811   gfc_symbol *sym;
 812   match m;
 813
 814   sym = expr->symtree->n.sym;
 815
 816   for (;;)
 817     {
 818       m = resolve_generic_f0 (expr, sym);
 819       if (m == MATCH_YES)
 820         return SUCCESS;
 821       else if (m == MATCH_ERROR)
 822         return FAILURE;
 823
 824 generic:
 825       if (sym->ns->parent == NULL)
 826         break;
 827       gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
 828
 829       if (sym == NULL)
 830         break;
 831       if (!generic_sym (sym))
 832         goto generic;
 833     }
 834
 835   /* Last ditch attempt.  */
 836
 837   if (!gfc_generic_intrinsic (expr->symtree->n.sym->name))
 838     {
 839       gfc_error ("Generic function '%s' at %L is not an intrinsic function",
 840                  expr->symtree->n.sym->name, &expr->where);
 841       return FAILURE;
 842     }
 843
 844   m = gfc_intrinsic_func_interface (expr, 0);
 845   if (m == MATCH_YES)
 846     return SUCCESS;
 847   if (m == MATCH_NO)
 848     gfc_error
 849       ("Generic function '%s' at %L is not consistent with a specific "
 850        "intrinsic interface", expr->symtree->n.sym->name, &expr->where);
 851
 852   return FAILURE;
 853 }
 854
 855
 856 /* Resolve a function call known to be specific.  */
 857
 858 static match
 859 resolve_specific_f0 (gfc_symbol * sym, gfc_expr * expr)
 860 {
 861   match m;
 862
 863   if (sym->attr.external || sym->attr.if_source == IFSRC_IFBODY)
 864     {
 865       if (sym->attr.dummy)
 866         {
 867           sym->attr.proc = PROC_DUMMY;
 868           goto found;
 869         }
 870
 871       sym->attr.proc = PROC_EXTERNAL;
 872       goto found;
 873     }
 874
 875   if (sym->attr.proc == PROC_MODULE
 876       || sym->attr.proc == PROC_ST_FUNCTION
 877       || sym->attr.proc == PROC_INTERNAL)
 878     goto found;
 879
 880   if (sym->attr.intrinsic)
 881     {
 882       m = gfc_intrinsic_func_interface (expr, 1);
 883       if (m == MATCH_YES)
 884         return MATCH_YES;
 885       if (m == MATCH_NO)
 886         gfc_error
 887           ("Function '%s' at %L is INTRINSIC but is not compatible with "
 888            "an intrinsic", sym->name, &expr->where);
 889
 890       return MATCH_ERROR;
 891     }
 892
 893   return MATCH_NO;
 894
 895 found:
 896   gfc_procedure_use (sym, &expr->value.function.actual, &expr->where);
 897
 898   expr->ts = sym->ts;
 899   expr->value.function.name = sym->name;
 900   expr->value.function.esym = sym;
 901   if (sym->as != NULL)
 902     expr->rank = sym->as->rank;
 903
 904   return MATCH_YES;
 905 }
 906
 907
 908 static try
 909 resolve_specific_f (gfc_expr * expr)
 910 {
 911   gfc_symbol *sym;
 912   match m;
 913
 914   sym = expr->symtree->n.sym;
 915
 916   for (;;)
 917     {
 918       m = resolve_specific_f0 (sym, expr);
 919       if (m == MATCH_YES)
 920         return SUCCESS;
 921       if (m == MATCH_ERROR)
 922         return FAILURE;
 923
 924       if (sym->ns->parent == NULL)
 925         break;
 926
 927       gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
 928
 929       if (sym == NULL)
 930         break;
 931     }
 932
 933   gfc_error ("Unable to resolve the specific function '%s' at %L",
 934              expr->symtree->n.sym->name, &expr->where);
 935
 936   return SUCCESS;
 937 }
 938
 939
 940 /* Resolve a procedure call not known to be generic nor specific.  */
 941
 942 static try
 943 resolve_unknown_f (gfc_expr * expr)
 944 {
 945   gfc_symbol *sym;
 946   gfc_typespec *ts;
 947
 948   sym = expr->symtree->n.sym;
 949
 950   if (sym->attr.dummy)
 951     {
 952       sym->attr.proc = PROC_DUMMY;
 953       expr->value.function.name = sym->name;
 954       goto set_type;
 955     }
 956
 957   /* See if we have an intrinsic function reference.  */
 958
 959   if (gfc_intrinsic_name (sym->name, 0))
 960     {
 961       if (gfc_intrinsic_func_interface (expr, 1) == MATCH_YES)
 962         return SUCCESS;
 963       return FAILURE;
 964     }
 965
 966   /* The reference is to an external name.  */
 967
 968   sym->attr.proc = PROC_EXTERNAL;
 969   expr->value.function.name = sym->name;
 970   expr->value.function.esym = expr->symtree->n.sym;
 971
 972   if (sym->as != NULL)
 973     expr->rank = sym->as->rank;
 974
 975   /* Type of the expression is either the type of the symbol or the
 976      default type of the symbol.  */
 977
 978 set_type:
 979   gfc_procedure_use (sym, &expr->value.function.actual, &expr->where);
 980
 981   if (sym->ts.type != BT_UNKNOWN)
 982     expr->ts = sym->ts;
 983   else
 984     {
 985       ts = gfc_get_default_type (sym, sym->ns);
 986
 987       if (ts->type == BT_UNKNOWN)
 988         {
 989           gfc_error ("Function '%s' at %L has no IMPLICIT type",
 990                      sym->name, &expr->where);
 991           return FAILURE;
 992         }
 993       else
 994         expr->ts = *ts;
 995     }
 996
 997   return SUCCESS;
 998 }
 999
1000
1001 /* Figure out if a function reference is pure or not.  Also set the name
1002    of the function for a potential error message.  Return nonzero if the
1003    function is PURE, zero if not.  */
1004
1005 static int
1006 pure_function (gfc_expr * e, const char **name)
1007 {
1008   int pure;
1009
1010   if (e->value.function.esym)
1011     {
1012       pure = gfc_pure (e->value.function.esym);
1013       *name = e->value.function.esym->name;
1014     }
1015   else if (e->value.function.isym)
1016     {
1017       pure = e->value.function.isym->pure
1018         || e->value.function.isym->elemental;
1019       *name = e->value.function.isym->name;
1020     }
1021   else
1022     {
1023       /* Implicit functions are not pure.  */
1024       pure = 0;
1025       *name = e->value.function.name;
1026     }
1027
1028   return pure;
1029 }
1030
1031
1032 /* Resolve a function call, which means resolving the arguments, then figuring
1033    out which entity the name refers to.  */
1034 /* TODO: Check procedure arguments so that an INTENT(IN) isn't passed
1035    to INTENT(OUT) or INTENT(INOUT).  */
1036
1037 static try
1038 resolve_function (gfc_expr * expr)
1039 {
1040   gfc_actual_arglist *arg;
1041   const char *name;
1042   try t;
1043
1044   if (resolve_actual_arglist (expr->value.function.actual) == FAILURE)
1045     return FAILURE;
1046
1047 /* See if function is already resolved.  */
1048
1049   if (expr->value.function.name != NULL)
1050     {
1051       if (expr->ts.type == BT_UNKNOWN)
1052         expr->ts = expr->symtree->n.sym->ts;
1053       t = SUCCESS;
1054     }
1055   else
1056     {
1057       /* Apply the rules of section 14.1.2.  */
1058
1059       switch (procedure_kind (expr->symtree->n.sym))
1060         {
1061         case PTYPE_GENERIC:
1062           t = resolve_generic_f (expr);
1063           break;
1064
1065         case PTYPE_SPECIFIC:
1066           t = resolve_specific_f (expr);
1067           break;
1068
1069         case PTYPE_UNKNOWN:
1070           t = resolve_unknown_f (expr);
1071           break;
1072
1073         default:
1074           gfc_internal_error ("resolve_function(): bad function type");
1075         }
1076     }
1077
1078   /* If the expression is still a function (it might have simplified),
1079      then we check to see if we are calling an elemental function.  */
1080
1081   if (expr->expr_type != EXPR_FUNCTION)
1082     return t;
1083
1084   if (expr->value.function.actual != NULL
1085       && ((expr->value.function.esym != NULL
1086            && expr->value.function.esym->attr.elemental)
1087           || (expr->value.function.isym != NULL
1088               && expr->value.function.isym->elemental)))
1089     {
1090
1091       /* The rank of an elemental is the rank of its array argument(s).  */
1092
1093       for (arg = expr->value.function.actual; arg; arg = arg->next)
1094         {
1095           if (arg->expr != NULL && arg->expr->rank > 0)
1096             {
1097               expr->rank = arg->expr->rank;
1098               break;
1099             }
1100         }
1101     }
1102
1103   if (!pure_function (expr, &name))
1104     {
1105       if (forall_flag)
1106         {
1107           gfc_error
1108             ("Function reference to '%s' at %L is inside a FORALL block",
1109              name, &expr->where);
1110           t = FAILURE;
1111         }
1112       else if (gfc_pure (NULL))
1113         {
1114           gfc_error ("Function reference to '%s' at %L is to a non-PURE "
1115                      "procedure within a PURE procedure", name, &expr->where);
1116           t = FAILURE;
1117         }
1118     }
1119
1120   return t;
1121 }
1122
1123
1124 /************* Subroutine resolution *************/
1125
1126 static void
1127 pure_subroutine (gfc_code * c, gfc_symbol * sym)
1128 {
1129
1130   if (gfc_pure (sym))
1131     return;
1132
1133   if (forall_flag)
1134     gfc_error ("Subroutine call to '%s' in FORALL block at %L is not PURE",
1135                sym->name, &c->loc);
1136   else if (gfc_pure (NULL))
1137     gfc_error ("Subroutine call to '%s' at %L is not PURE", sym->name,
1138                &c->loc);
1139 }
1140
1141
1142 static match
1143 resolve_generic_s0 (gfc_code * c, gfc_symbol * sym)
1144 {
1145   gfc_symbol *s;
1146
1147   if (sym->attr.generic)
1148     {
1149       s = gfc_search_interface (sym->generic, 1, &c->ext.actual);
1150       if (s != NULL)
1151         {
1152           c->resolved_sym = s;
1153           pure_subroutine (c, s);
1154           return MATCH_YES;
1155         }
1156
1157       /* TODO: Need to search for elemental references in generic interface.  */
1158     }
1159
1160   if (sym->attr.intrinsic)
1161     return gfc_intrinsic_sub_interface (c, 0);
1162
1163   return MATCH_NO;
1164 }
1165
1166
1167 static try
1168 resolve_generic_s (gfc_code * c)
1169 {
1170   gfc_symbol *sym;
1171   match m;
1172
1173   sym = c->symtree->n.sym;
1174
1175   m = resolve_generic_s0 (c, sym);
1176   if (m == MATCH_YES)
1177     return SUCCESS;
1178   if (m == MATCH_ERROR)
1179     return FAILURE;
1180
1181   if (sym->ns->parent != NULL)
1182     {
1183       gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
1184       if (sym != NULL)
1185         {
1186           m = resolve_generic_s0 (c, sym);
1187           if (m == MATCH_YES)
1188             return SUCCESS;
1189           if (m == MATCH_ERROR)
1190             return FAILURE;
1191         }
1192     }
1193
1194   /* Last ditch attempt.  */
1195
1196   if (!gfc_generic_intrinsic (sym->name))
1197     {
1198       gfc_error
1199         ("Generic subroutine '%s' at %L is not an intrinsic subroutine",
1200          sym->name, &c->loc);
1201       return FAILURE;
1202     }
1203
1204   m = gfc_intrinsic_sub_interface (c, 0);
1205   if (m == MATCH_YES)
1206     return SUCCESS;
1207   if (m == MATCH_NO)
1208     gfc_error ("Generic subroutine '%s' at %L is not consistent with an "
1209                "intrinsic subroutine interface", sym->name, &c->loc);
1210
1211   return FAILURE;
1212 }
1213
1214
1215 /* Resolve a subroutine call known to be specific.  */
1216
1217 static match
1218 resolve_specific_s0 (gfc_code * c, gfc_symbol * sym)
1219 {
1220   match m;
1221
1222   if (sym->attr.external || sym->attr.if_source == IFSRC_IFBODY)
1223     {
1224       if (sym->attr.dummy)
1225         {
1226           sym->attr.proc = PROC_DUMMY;
1227           goto found;
1228         }
1229
1230       sym->attr.proc = PROC_EXTERNAL;
1231       goto found;
1232     }
1233
1234   if (sym->attr.proc == PROC_MODULE || sym->attr.proc == PROC_INTERNAL)
1235     goto found;
1236
1237   if (sym->attr.intrinsic)
1238     {
1239       m = gfc_intrinsic_sub_interface (c, 1);
1240       if (m == MATCH_YES)
1241         return MATCH_YES;
1242       if (m == MATCH_NO)
1243         gfc_error ("Subroutine '%s' at %L is INTRINSIC but is not compatible "
1244                    "with an intrinsic", sym->name, &c->loc);
1245
1246       return MATCH_ERROR;
1247     }
1248
1249   return MATCH_NO;
1250
1251 found:
1252   gfc_procedure_use (sym, &c->ext.actual, &c->loc);
1253
1254   c->resolved_sym = sym;
1255   pure_subroutine (c, sym);
1256
1257   return MATCH_YES;
1258 }
1259
1260
1261 static try
1262 resolve_specific_s (gfc_code * c)
1263 {
1264   gfc_symbol *sym;
1265   match m;
1266
1267   sym = c->symtree->n.sym;
1268
1269   m = resolve_specific_s0 (c, sym);
1270   if (m == MATCH_YES)
1271     return SUCCESS;
1272   if (m == MATCH_ERROR)
1273     return FAILURE;
1274
1275   gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
1276
1277   if (sym != NULL)
1278     {
1279       m = resolve_specific_s0 (c, sym);
1280       if (m == MATCH_YES)
1281         return SUCCESS;
1282       if (m == MATCH_ERROR)
1283         return FAILURE;
1284     }
1285
1286   gfc_error ("Unable to resolve the specific subroutine '%s' at %L",
1287              sym->name, &c->loc);
1288
1289   return FAILURE;
1290 }
1291
1292
1293 /* Resolve a subroutine call not known to be generic nor specific.  */
1294
1295 static try
1296 resolve_unknown_s (gfc_code * c)
1297 {
1298   gfc_symbol *sym;
1299
1300   sym = c->symtree->n.sym;
1301
1302   if (sym->attr.dummy)
1303     {
1304       sym->attr.proc = PROC_DUMMY;
1305       goto found;
1306     }
1307
1308   /* See if we have an intrinsic function reference.  */
1309
1310   if (gfc_intrinsic_name (sym->name, 1))
1311     {
1312       if (gfc_intrinsic_sub_interface (c, 1) == MATCH_YES)
1313         return SUCCESS;
1314       return FAILURE;
1315     }
1316
1317   /* The reference is to an external name.  */
1318
1319 found:
1320   gfc_procedure_use (sym, &c->ext.actual, &c->loc);
1321
1322   c->resolved_sym = sym;
1323
1324   pure_subroutine (c, sym);
1325
1326   return SUCCESS;
1327 }
1328
1329
1330 /* Resolve a subroutine call.  Although it was tempting to use the same code
1331    for functions, subroutines and functions are stored differently and this
1332    makes things awkward.  */
1333
1334 static try
1335 resolve_call (gfc_code * c)
1336 {
1337   try t;
1338
1339   if (resolve_actual_arglist (c->ext.actual) == FAILURE)
1340     return FAILURE;
1341
1342   if (c->resolved_sym != NULL)
1343     return SUCCESS;
1344
1345   switch (procedure_kind (c->symtree->n.sym))
1346     {
1347     case PTYPE_GENERIC:
1348       t = resolve_generic_s (c);
1349       break;
1350
1351     case PTYPE_SPECIFIC:
1352       t = resolve_specific_s (c);
1353       break;
1354
1355     case PTYPE_UNKNOWN:
1356       t = resolve_unknown_s (c);
1357       break;
1358
1359     default:
1360       gfc_internal_error ("resolve_subroutine(): bad function type");
1361     }
1362
1363   return t;
1364 }
1365
1366 /* Compare the shapes of two arrays that have non-NULL shapes.  If both
1367    op1->shape and op2->shape are non-NULL return SUCCESS if their shapes
1368    match.  If both op1->shape and op2->shape are non-NULL return FAILURE
1369    if their shapes do not match.  If either op1->shape or op2->shape is
1370    NULL, return SUCCESS.  */
1371
1372 static try
1373 compare_shapes (gfc_expr * op1, gfc_expr * op2)
1374 {
1375   try t;
1376   int i;
1377
1378   t = SUCCESS;
1379
1380   if (op1->shape != NULL && op2->shape != NULL)
1381     {
1382       for (i = 0; i < op1->rank; i++)
1383         {
1384           if (mpz_cmp (op1->shape[i], op2->shape[i]) != 0)
1385            {
1386              gfc_error ("Shapes for operands at %L and %L are not conformable",
1387                          &op1->where, &op2->where);
1388              t = FAILURE;
1389              break;
1390            }
1391         }
1392     }
1393
1394   return t;
1395 }
1396
1397 /* Resolve an operator expression node.  This can involve replacing the
1398    operation with a user defined function call.  */
1399
1400 static try
1401 resolve_operator (gfc_expr * e)
1402 {
1403   gfc_expr *op1, *op2;
1404   char msg[200];
1405   try t;
1406
1407   /* Resolve all subnodes-- give them types.  */
1408
1409   switch (e->value.op.operator)
1410     {
1411     default:
1412       if (gfc_resolve_expr (e->value.op.op2) == FAILURE)
1413         return FAILURE;
1414
1415     /* Fall through...  */
1416
1417     case INTRINSIC_NOT:
1418     case INTRINSIC_UPLUS:
1419     case INTRINSIC_UMINUS:
1420       if (gfc_resolve_expr (e->value.op.op1) == FAILURE)
1421         return FAILURE;
1422       break;
1423     }
1424
1425   /* Typecheck the new node.  */
1426
1427   op1 = e->value.op.op1;
1428   op2 = e->value.op.op2;
1429
1430   switch (e->value.op.operator)
1431     {
1432     case INTRINSIC_UPLUS:
1433     case INTRINSIC_UMINUS:
1434       if (op1->ts.type == BT_INTEGER
1435           || op1->ts.type == BT_REAL
1436           || op1->ts.type == BT_COMPLEX)
1437         {
1438           e->ts = op1->ts;
1439           break;
1440         }
1441
1442       sprintf (msg, _("Operand of unary numeric operator '%s' at %%L is %s"),
1443                gfc_op2string (e->value.op.operator), gfc_typename (&e->ts));
1444       goto bad_op;
1445
1446     case INTRINSIC_PLUS:
1447     case INTRINSIC_MINUS:
1448     case INTRINSIC_TIMES:
1449     case INTRINSIC_DIVIDE:
1450     case INTRINSIC_POWER:
1451       if (gfc_numeric_ts (&op1->ts) && gfc_numeric_ts (&op2->ts))
1452         {
1453           gfc_type_convert_binary (e);
1454           break;
1455         }
1456
1457       sprintf (msg,
1458                _("Operands of binary numeric operator '%s' at %%L are %s/%s"),
1459                gfc_op2string (e->value.op.operator), gfc_typename (&op1->ts),
1460                gfc_typename (&op2->ts));
1461       goto bad_op;
1462
1463     case INTRINSIC_CONCAT:
1464       if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER)
1465         {
1466           e->ts.type = BT_CHARACTER;
1467           e->ts.kind = op1->ts.kind;
1468           break;
1469         }
1470
1471       sprintf (msg,
1472                _("Operands of string concatenation operator at %%L are %s/%s"),
1473                gfc_typename (&op1->ts), gfc_typename (&op2->ts));
1474       goto bad_op;
1475
1476     case INTRINSIC_AND:
1477     case INTRINSIC_OR:
1478     case INTRINSIC_EQV:
1479     case INTRINSIC_NEQV:
1480       if (op1->ts.type == BT_LOGICAL && op2->ts.type == BT_LOGICAL)
1481         {
1482           e->ts.type = BT_LOGICAL;
1483           e->ts.kind = gfc_kind_max (op1, op2);
1484           if (op1->ts.kind < e->ts.kind)
1485             gfc_convert_type (op1, &e->ts, 2);
1486           else if (op2->ts.kind < e->ts.kind)
1487             gfc_convert_type (op2, &e->ts, 2);
1488           break;
1489         }
1490
1491       sprintf (msg, _("Operands of logical operator '%s' at %%L are %s/%s"),
1492                gfc_op2string (e->value.op.operator), gfc_typename (&op1->ts),
1493                gfc_typename (&op2->ts));
1494
1495       goto bad_op;
1496
1497     case INTRINSIC_NOT:
1498       if (op1->ts.type == BT_LOGICAL)
1499         {
1500           e->ts.type = BT_LOGICAL;
1501           e->ts.kind = op1->ts.kind;
1502           break;
1503         }
1504
1505       sprintf (msg, _("Operand of .NOT. operator at %%L is %s"),
1506                gfc_typename (&op1->ts));
1507       goto bad_op;
1508
1509     case INTRINSIC_GT:
1510     case INTRINSIC_GE:
1511     case INTRINSIC_LT:
1512     case INTRINSIC_LE:
1513       if (op1->ts.type == BT_COMPLEX || op2->ts.type == BT_COMPLEX)
1514         {
1515           strcpy (msg, _("COMPLEX quantities cannot be compared at %L"));
1516           goto bad_op;
1517         }
1518
1519       /* Fall through...  */
1520
1521     case INTRINSIC_EQ:
1522     case INTRINSIC_NE:
1523       if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER)
1524         {
1525           e->ts.type = BT_LOGICAL;
1526           e->ts.kind = gfc_default_logical_kind;
1527           break;
1528         }
1529
1530       if (gfc_numeric_ts (&op1->ts) && gfc_numeric_ts (&op2->ts))
1531         {
1532           gfc_type_convert_binary (e);
1533
1534           e->ts.type = BT_LOGICAL;
1535           e->ts.kind = gfc_default_logical_kind;
1536           break;
1537         }
1538
1539       if (op1->ts.type == BT_LOGICAL && op2->ts.type == BT_LOGICAL)
1540         sprintf (msg,
1541                  _("Logicals at %%L must be compared with %s instead of %s"),
1542                  e->value.op.operator == INTRINSIC_EQ ? ".EQV." : ".NEQV.",
1543                  gfc_op2string (e->value.op.operator));
1544       else
1545         sprintf (msg,
1546                  _("Operands of comparison operator '%s' at %%L are %s/%s"),
1547                  gfc_op2string (e->value.op.operator), gfc_typename (&op1->ts),
1548                  gfc_typename (&op2->ts));
1549
1550       goto bad_op;
1551
1552     case INTRINSIC_USER:
1553       if (op2 == NULL)
1554         sprintf (msg, _("Operand of user operator '%s' at %%L is %s"),
1555                  e->value.op.uop->name, gfc_typename (&op1->ts));
1556       else
1557         sprintf (msg, _("Operands of user operator '%s' at %%L are %s/%s"),
1558                  e->value.op.uop->name, gfc_typename (&op1->ts),
1559                  gfc_typename (&op2->ts));
1560
1561       goto bad_op;
1562
1563     default:
1564       gfc_internal_error ("resolve_operator(): Bad intrinsic");
1565     }
1566
1567   /* Deal with arrayness of an operand through an operator.  */
1568
1569   t = SUCCESS;
1570
1571   switch (e->value.op.operator)
1572     {
1573     case INTRINSIC_PLUS:
1574     case INTRINSIC_MINUS:
1575     case INTRINSIC_TIMES:
1576     case INTRINSIC_DIVIDE:
1577     case INTRINSIC_POWER:
1578     case INTRINSIC_CONCAT:
1579     case INTRINSIC_AND:
1580     case INTRINSIC_OR:
1581     case INTRINSIC_EQV:
1582     case INTRINSIC_NEQV:
1583     case INTRINSIC_EQ:
1584     case INTRINSIC_NE:
1585     case INTRINSIC_GT:
1586     case INTRINSIC_GE:
1587     case INTRINSIC_LT:
1588     case INTRINSIC_LE:
1589
1590       if (op1->rank == 0 && op2->rank == 0)
1591         e->rank = 0;
1592
1593       if (op1->rank == 0 && op2->rank != 0)
1594         {
1595           e->rank = op2->rank;
1596
1597           if (e->shape == NULL)
1598             e->shape = gfc_copy_shape (op2->shape, op2->rank);
1599         }
1600
1601       if (op1->rank != 0 && op2->rank == 0)
1602         {
1603           e->rank = op1->rank;
1604
1605           if (e->shape == NULL)
1606             e->shape = gfc_copy_shape (op1->shape, op1->rank);
1607         }
1608
1609       if (op1->rank != 0 && op2->rank != 0)
1610         {
1611           if (op1->rank == op2->rank)
1612             {
1613               e->rank = op1->rank;
1614               if (e->shape == NULL)
1615                 {
1616                   t = compare_shapes(op1, op2);
1617                   if (t == FAILURE)
1618                     e->shape = NULL;
1619                   else
1620                 e->shape = gfc_copy_shape (op1->shape, op1->rank);
1621                 }
1622             }
1623           else
1624             {
1625               gfc_error ("Inconsistent ranks for operator at %L and %L",
1626                          &op1->where, &op2->where);
1627               t = FAILURE;
1628
1629               /* Allow higher level expressions to work.  */
1630               e->rank = 0;
1631             }
1632         }
1633
1634       break;
1635
1636     case INTRINSIC_NOT:
1637     case INTRINSIC_UPLUS:
1638     case INTRINSIC_UMINUS:
1639       e->rank = op1->rank;
1640
1641       if (e->shape == NULL)
1642         e->shape = gfc_copy_shape (op1->shape, op1->rank);
1643
1644       /* Simply copy arrayness attribute */
1645       break;
1646
1647     default:
1648       break;
1649     }
1650
1651   /* Attempt to simplify the expression.  */
1652   if (t == SUCCESS)
1653     t = gfc_simplify_expr (e, 0);
1654   return t;
1655
1656 bad_op:
1657
1658   if (gfc_extend_expr (e) == SUCCESS)
1659     return SUCCESS;
1660
1661   gfc_error (msg, &e->where);
1662
1663   return FAILURE;
1664 }
1665
1666
1667 /************** Array resolution subroutines **************/
1668
1669
1670 typedef enum
1671 { CMP_LT, CMP_EQ, CMP_GT, CMP_UNKNOWN }
1672 comparison;
1673
1674 /* Compare two integer expressions.  */
1675
1676 static comparison
1677 compare_bound (gfc_expr * a, gfc_expr * b)
1678 {
1679   int i;
1680
1681   if (a == NULL || a->expr_type != EXPR_CONSTANT
1682       || b == NULL || b->expr_type != EXPR_CONSTANT)
1683     return CMP_UNKNOWN;
1684
1685   if (a->ts.type != BT_INTEGER || b->ts.type != BT_INTEGER)
1686     gfc_internal_error ("compare_bound(): Bad expression");
1687
1688   i = mpz_cmp (a->value.integer, b->value.integer);
1689
1690   if (i < 0)
1691     return CMP_LT;
1692   if (i > 0)
1693     return CMP_GT;
1694   return CMP_EQ;
1695 }
1696
1697
1698 /* Compare an integer expression with an integer.  */
1699
1700 static comparison
1701 compare_bound_int (gfc_expr * a, int b)
1702 {
1703   int i;
1704
1705   if (a == NULL || a->expr_type != EXPR_CONSTANT)
1706     return CMP_UNKNOWN;
1707
1708   if (a->ts.type != BT_INTEGER)
1709     gfc_internal_error ("compare_bound_int(): Bad expression");
1710
1711   i = mpz_cmp_si (a->value.integer, b);
1712
1713   if (i < 0)
1714     return CMP_LT;
1715   if (i > 0)
1716     return CMP_GT;
1717   return CMP_EQ;
1718 }
1719
1720
1721 /* Compare a single dimension of an array reference to the array
1722    specification.  */
1723
1724 static try
1725 check_dimension (int i, gfc_array_ref * ar, gfc_array_spec * as)
1726 {
1727
1728 /* Given start, end and stride values, calculate the minimum and
1729    maximum referenced indexes.  */
1730
1731   switch (ar->type)
1732     {
1733     case AR_FULL:
1734       break;
1735
1736     case AR_ELEMENT:
1737       if (compare_bound (ar->start[i], as->lower[i]) == CMP_LT)
1738         goto bound;
1739       if (compare_bound (ar->start[i], as->upper[i]) == CMP_GT)
1740         goto bound;
1741
1742       break;
1743
1744     case AR_SECTION:
1745       if (compare_bound_int (ar->stride[i], 0) == CMP_EQ)
1746         {
1747           gfc_error ("Illegal stride of zero at %L", &ar->c_where[i]);
1748           return FAILURE;
1749         }
1750
1751       if (compare_bound (ar->start[i], as->lower[i]) == CMP_LT)
1752         goto bound;
1753       if (compare_bound (ar->start[i], as->upper[i]) == CMP_GT)
1754         goto bound;
1755
1756       /* TODO: Possibly, we could warn about end[i] being out-of-bound although
1757          it is legal (see 6.2.2.3.1).  */
1758
1759       break;
1760
1761     default:
1762       gfc_internal_error ("check_dimension(): Bad array reference");
1763     }
1764
1765   return SUCCESS;
1766
1767 bound:
1768   gfc_warning ("Array reference at %L is out of bounds", &ar->c_where[i]);
1769   return SUCCESS;
1770 }
1771
1772
1773 /* Compare an array reference with an array specification.  */
1774
1775 static try
1776 compare_spec_to_ref (gfc_array_ref * ar)
1777 {
1778   gfc_array_spec *as;
1779   int i;
1780
1781   as = ar->as;
1782   i = as->rank - 1;
1783   /* TODO: Full array sections are only allowed as actual parameters.  */
1784   if (as->type == AS_ASSUMED_SIZE
1785       && (/*ar->type == AR_FULL
1786           ||*/ (ar->type == AR_SECTION
1787               && ar->dimen_type[i] == DIMEN_RANGE && ar->end[i] == NULL)))
1788     {
1789       gfc_error ("Rightmost upper bound of assumed size array section"
1790                  " not specified at %L", &ar->where);
1791       return FAILURE;
1792     }
1793
1794   if (ar->type == AR_FULL)
1795     return SUCCESS;
1796
1797   if (as->rank != ar->dimen)
1798     {
1799       gfc_error ("Rank mismatch in array reference at %L (%d/%d)",
1800                  &ar->where, ar->dimen, as->rank);
1801       return FAILURE;
1802     }
1803
1804   for (i = 0; i < as->rank; i++)
1805     if (check_dimension (i, ar, as) == FAILURE)
1806       return FAILURE;
1807
1808   return SUCCESS;
1809 }
1810
1811
1812 /* Resolve one part of an array index.  */
1813
1814 try
1815 gfc_resolve_index (gfc_expr * index, int check_scalar)
1816 {
1817   gfc_typespec ts;
1818
1819   if (index == NULL)
1820     return SUCCESS;
1821
1822   if (gfc_resolve_expr (index) == FAILURE)
1823     return FAILURE;
1824
1825   if (check_scalar && index->rank != 0)
1826     {
1827       gfc_error ("Array index at %L must be scalar", &index->where);
1828       return FAILURE;
1829     }
1830
1831   if (index->ts.type != BT_INTEGER && index->ts.type != BT_REAL)
1832     {
1833       gfc_error ("Array index at %L must be of INTEGER type",
1834                  &index->where);
1835       return FAILURE;
1836     }
1837
1838   if (index->ts.type == BT_REAL)
1839     if (gfc_notify_std (GFC_STD_GNU, "Extension: REAL array index at %L",
1840                         &index->where) == FAILURE)
1841       return FAILURE;
1842
1843   if (index->ts.kind != gfc_index_integer_kind
1844       || index->ts.type != BT_INTEGER)
1845     {
1846       ts.type = BT_INTEGER;
1847       ts.kind = gfc_index_integer_kind;
1848
1849       gfc_convert_type_warn (index, &ts, 2, 0);
1850     }
1851
1852   return SUCCESS;
1853 }
1854
1855 /* Resolve a dim argument to an intrinsic function.  */
1856
1857 try
1858 gfc_resolve_dim_arg (gfc_expr *dim)
1859 {
1860   if (dim == NULL)
1861     return SUCCESS;
1862
1863   if (gfc_resolve_expr (dim) == FAILURE)
1864     return FAILURE;
1865
1866   if (dim->rank != 0)
1867     {
1868       gfc_error ("Argument dim at %L must be scalar", &dim->where);
1869       return FAILURE;
1870
1871     }
1872   if (dim->ts.type != BT_INTEGER)
1873     {
1874       gfc_error ("Argument dim at %L must be of INTEGER type", &dim->where);
1875       return FAILURE;
1876     }
1877   if (dim->ts.kind != gfc_index_integer_kind)
1878     {
1879       gfc_typespec ts;
1880
1881       ts.type = BT_INTEGER;
1882       ts.kind = gfc_index_integer_kind;
1883
1884       gfc_convert_type_warn (dim, &ts, 2, 0);
1885     }
1886
1887   return SUCCESS;
1888 }
1889
1890 /* Given an expression that contains array references, update those array
1891    references to point to the right array specifications.  While this is
1892    filled in during matching, this information is difficult to save and load
1893    in a module, so we take care of it here.
1894
1895    The idea here is that the original array reference comes from the
1896    base symbol.  We traverse the list of reference structures, setting
1897    the stored reference to references.  Component references can
1898    provide an additional array specification.  */
1899
1900 static void
1901 find_array_spec (gfc_expr * e)
1902 {
1903   gfc_array_spec *as;
1904   gfc_component *c;
1905   gfc_ref *ref;
1906
1907   as = e->symtree->n.sym->as;
1908   c = e->symtree->n.sym->components;
1909
1910   for (ref = e->ref; ref; ref = ref->next)
1911     switch (ref->type)
1912       {
1913       case REF_ARRAY:
1914         if (as == NULL)
1915           gfc_internal_error ("find_array_spec(): Missing spec");
1916
1917         ref->u.ar.as = as;
1918         as = NULL;
1919         break;
1920
1921       case REF_COMPONENT:
1922         for (; c; c = c->next)
1923           if (c == ref->u.c.component)
1924             break;
1925
1926         if (c == NULL)
1927           gfc_internal_error ("find_array_spec(): Component not found");
1928
1929         if (c->dimension)
1930           {
1931             if (as != NULL)
1932               gfc_internal_error ("find_array_spec(): unused as(1)");
1933             as = c->as;
1934           }
1935
1936         c = c->ts.derived->components;
1937         break;
1938
1939       case REF_SUBSTRING:
1940         break;
1941       }
1942
1943   if (as != NULL)
1944     gfc_internal_error ("find_array_spec(): unused as(2)");
1945 }
1946
1947
1948 /* Resolve an array reference.  */
1949
1950 static try
1951 resolve_array_ref (gfc_array_ref * ar)
1952 {
1953   int i, check_scalar;
1954
1955   for (i = 0; i < ar->dimen; i++)
1956     {
1957       check_scalar = ar->dimen_type[i] == DIMEN_RANGE;
1958
1959       if (gfc_resolve_index (ar->start[i], check_scalar) == FAILURE)
1960         return FAILURE;
1961       if (gfc_resolve_index (ar->end[i], check_scalar) == FAILURE)
1962         return FAILURE;
1963       if (gfc_resolve_index (ar->stride[i], check_scalar) == FAILURE)
1964         return FAILURE;
1965
1966       if (ar->dimen_type[i] == DIMEN_UNKNOWN)
1967         switch (ar->start[i]->rank)
1968           {
1969           case 0:
1970             ar->dimen_type[i] = DIMEN_ELEMENT;
1971             break;
1972
1973           case 1:
1974             ar->dimen_type[i] = DIMEN_VECTOR;
1975             break;
1976
1977           default:
1978             gfc_error ("Array index at %L is an array of rank %d",
1979                        &ar->c_where[i], ar->start[i]->rank);
1980             return FAILURE;
1981           }
1982     }
1983
1984   /* If the reference type is unknown, figure out what kind it is.  */
1985
1986   if (ar->type == AR_UNKNOWN)
1987     {
1988       ar->type = AR_ELEMENT;
1989       for (i = 0; i < ar->dimen; i++)
1990         if (ar->dimen_type[i] == DIMEN_RANGE
1991             || ar->dimen_type[i] == DIMEN_VECTOR)
1992           {
1993             ar->type = AR_SECTION;
1994             break;
1995           }
1996     }
1997
1998   if (compare_spec_to_ref (ar) == FAILURE)
1999     return FAILURE;
2000
2001   return SUCCESS;
2002 }
2003
2004
2005 static try
2006 resolve_substring (gfc_ref * ref)
2007 {
2008
2009   if (ref->u.ss.start != NULL)
2010     {
2011       if (gfc_resolve_expr (ref->u.ss.start) == FAILURE)
2012         return FAILURE;
2013
2014       if (ref->u.ss.start->ts.type != BT_INTEGER)
2015         {
2016           gfc_error ("Substring start index at %L must be of type INTEGER",
2017                      &ref->u.ss.start->where);
2018           return FAILURE;
2019         }
2020
2021       if (ref->u.ss.start->rank != 0)
2022         {
2023           gfc_error ("Substring start index at %L must be scalar",
2024                      &ref->u.ss.start->where);
2025           return FAILURE;
2026         }
2027
2028       if (compare_bound_int (ref->u.ss.start, 1) == CMP_LT)
2029         {
2030           gfc_error ("Substring start index at %L is less than one",
2031                      &ref->u.ss.start->where);
2032           return FAILURE;
2033         }
2034     }
2035
2036   if (ref->u.ss.end != NULL)
2037     {
2038       if (gfc_resolve_expr (ref->u.ss.end) == FAILURE)
2039         return FAILURE;
2040
2041       if (ref->u.ss.end->ts.type != BT_INTEGER)
2042         {
2043           gfc_error ("Substring end index at %L must be of type INTEGER",
2044                      &ref->u.ss.end->where);
2045           return FAILURE;
2046         }
2047
2048       if (ref->u.ss.end->rank != 0)
2049         {
2050           gfc_error ("Substring end index at %L must be scalar",
2051                      &ref->u.ss.end->where);
2052           return FAILURE;
2053         }
2054
2055       if (ref->u.ss.length != NULL
2056           && compare_bound (ref->u.ss.end, ref->u.ss.length->length) == CMP_GT)
2057         {
2058           gfc_error ("Substring end index at %L is out of bounds",
2059                      &ref->u.ss.start->where);
2060           return FAILURE;
2061         }
2062     }
2063
2064   return SUCCESS;
2065 }
2066
2067
2068 /* Resolve subtype references.  */
2069
2070 static try
2071 resolve_ref (gfc_expr * expr)
2072 {
2073   int current_part_dimension, n_components, seen_part_dimension;
2074   gfc_ref *ref;
2075
2076   for (ref = expr->ref; ref; ref = ref->next)
2077     if (ref->type == REF_ARRAY && ref->u.ar.as == NULL)
2078       {
2079         find_array_spec (expr);
2080         break;
2081       }
2082
2083   for (ref = expr->ref; ref; ref = ref->next)
2084     switch (ref->type)
2085       {
2086       case REF_ARRAY:
2087         if (resolve_array_ref (&ref->u.ar) == FAILURE)
2088           return FAILURE;
2089         break;
2090
2091       case REF_COMPONENT:
2092         break;
2093
2094       case REF_SUBSTRING:
2095         resolve_substring (ref);
2096         break;
2097       }
2098
2099   /* Check constraints on part references.  */
2100
2101   current_part_dimension = 0;
2102   seen_part_dimension = 0;
2103   n_components = 0;
2104
2105   for (ref = expr->ref; ref; ref = ref->next)
2106     {
2107       switch (ref->type)
2108         {
2109         case REF_ARRAY:
2110           switch (ref->u.ar.type)
2111             {
2112             case AR_FULL:
2113             case AR_SECTION:
2114               current_part_dimension = 1;
2115               break;
2116
2117             case AR_ELEMENT:
2118               current_part_dimension = 0;
2119               break;
2120
2121             case AR_UNKNOWN:
2122               gfc_internal_error ("resolve_ref(): Bad array reference");
2123             }
2124
2125           break;
2126
2127         case REF_COMPONENT:
2128           if ((current_part_dimension || seen_part_dimension)
2129               && ref->u.c.component->pointer)
2130             {
2131               gfc_error
2132                 ("Component to the right of a part reference with nonzero "
2133                  "rank must not have the POINTER attribute at %L",
2134                  &expr->where);
2135               return FAILURE;
2136             }
2137
2138           n_components++;
2139           break;
2140
2141         case REF_SUBSTRING:
2142           break;
2143         }
2144
2145       if (((ref->type == REF_COMPONENT && n_components > 1)
2146            || ref->next == NULL)
2147           && current_part_dimension
2148           && seen_part_dimension)
2149         {
2150
2151           gfc_error ("Two or more part references with nonzero rank must "
2152                      "not be specified at %L", &expr->where);
2153           return FAILURE;
2154         }
2155
2156       if (ref->type == REF_COMPONENT)
2157         {
2158           if (current_part_dimension)
2159             seen_part_dimension = 1;
2160
2161           /* reset to make sure */
2162           current_part_dimension = 0;
2163         }
2164     }
2165
2166   return SUCCESS;
2167 }
2168
2169
2170 /* Given an expression, determine its shape.  This is easier than it sounds.
2171    Leaves the shape array NULL if it is not possible to determine the shape.  */
2172
2173 static void
2174 expression_shape (gfc_expr * e)
2175 {
2176   mpz_t array[GFC_MAX_DIMENSIONS];
2177   int i;
2178
2179   if (e->rank == 0 || e->shape != NULL)
2180     return;
2181
2182   for (i = 0; i < e->rank; i++)
2183     if (gfc_array_dimen_size (e, i, &array[i]) == FAILURE)
2184       goto fail;
2185
2186   e->shape = gfc_get_shape (e->rank);
2187
2188   memcpy (e->shape, array, e->rank * sizeof (mpz_t));
2189
2190   return;
2191
2192 fail:
2193   for (i--; i >= 0; i--)
2194     mpz_clear (array[i]);
2195 }
2196
2197
2198 /* Given a variable expression node, compute the rank of the expression by
2199    examining the base symbol and any reference structures it may have.  */
2200
2201 static void
2202 expression_rank (gfc_expr * e)
2203 {
2204   gfc_ref *ref;
2205   int i, rank;
2206
2207   if (e->ref == NULL)
2208     {
2209       if (e->expr_type == EXPR_ARRAY)
2210         goto done;
2211       /* Constructors can have a rank different from one via RESHAPE().  */
2212
2213       if (e->symtree == NULL)
2214         {
2215           e->rank = 0;
2216           goto done;
2217         }
2218
2219       e->rank = (e->symtree->n.sym->as == NULL)
2220                   ? 0 : e->symtree->n.sym->as->rank;
2221       goto done;
2222     }
2223
2224   rank = 0;
2225
2226   for (ref = e->ref; ref; ref = ref->next)
2227     {
2228       if (ref->type != REF_ARRAY)
2229         continue;
2230
2231       if (ref->u.ar.type == AR_FULL)
2232         {
2233           rank = ref->u.ar.as->rank;
2234           break;
2235         }
2236
2237       if (ref->u.ar.type == AR_SECTION)
2238         {
2239           /* Figure out the rank of the section.  */
2240           if (rank != 0)
2241             gfc_internal_error ("expression_rank(): Two array specs");
2242
2243           for (i = 0; i < ref->u.ar.dimen; i++)
2244             if (ref->u.ar.dimen_type[i] == DIMEN_RANGE
2245                 || ref->u.ar.dimen_type[i] == DIMEN_VECTOR)
2246               rank++;
2247
2248           break;
2249         }
2250     }
2251
2252   e->rank = rank;
2253
2254 done:
2255   expression_shape (e);
2256 }
2257
2258
2259 /* Resolve a variable expression.  */
2260
2261 static try
2262 resolve_variable (gfc_expr * e)
2263 {
2264   gfc_symbol *sym;
2265
2266   if (e->ref && resolve_ref (e) == FAILURE)
2267     return FAILURE;
2268
2269   if (e->symtree == NULL)
2270     return FAILURE;
2271
2272   sym = e->symtree->n.sym;
2273   if (sym->attr.flavor == FL_PROCEDURE && !sym->attr.function)
2274     {
2275       e->ts.type = BT_PROCEDURE;
2276       return SUCCESS;
2277     }
2278
2279   if (sym->ts.type != BT_UNKNOWN)
2280     gfc_variable_attr (e, &e->ts);
2281   else
2282     {
2283       /* Must be a simple variable reference.  */
2284       if (gfc_set_default_type (sym, 1, NULL) == FAILURE)
2285         return FAILURE;
2286       e->ts = sym->ts;
2287     }
2288
2289   return SUCCESS;
2290 }
2291
2292
2293 /* Resolve an expression.  That is, make sure that types of operands agree
2294    with their operators, intrinsic operators are converted to function calls
2295    for overloaded types and unresolved function references are resolved.  */
2296
2297 try
2298 gfc_resolve_expr (gfc_expr * e)
2299 {
2300   try t;
2301
2302   if (e == NULL)
2303     return SUCCESS;
2304
2305   switch (e->expr_type)
2306     {
2307     case EXPR_OP:
2308       t = resolve_operator (e);
2309       break;
2310
2311     case EXPR_FUNCTION:
2312       t = resolve_function (e);
2313       break;
2314
2315     case EXPR_VARIABLE:
2316       t = resolve_variable (e);
2317       if (t == SUCCESS)
2318         expression_rank (e);
2319       break;
2320
2321     case EXPR_SUBSTRING:
2322       t = resolve_ref (e);
2323       break;
2324
2325     case EXPR_CONSTANT:
2326     case EXPR_NULL:
2327       t = SUCCESS;
2328       break;
2329
2330     case EXPR_ARRAY:
2331       t = FAILURE;
2332       if (resolve_ref (e) == FAILURE)
2333         break;
2334
2335       t = gfc_resolve_array_constructor (e);
2336       /* Also try to expand a constructor.  */
2337       if (t == SUCCESS)
2338         {
2339           expression_rank (e);
2340           gfc_expand_constructor (e);
2341         }
2342
2343       break;
2344
2345     case EXPR_STRUCTURE:
2346       t = resolve_ref (e);
2347       if (t == FAILURE)
2348         break;
2349
2350       t = resolve_structure_cons (e);
2351       if (t == FAILURE)
2352         break;
2353
2354       t = gfc_simplify_expr (e, 0);
2355       break;
2356
2357     default:
2358       gfc_internal_error ("gfc_resolve_expr(): Bad expression type");
2359     }
2360
2361   return t;
2362 }
2363
2364
2365 /* Resolve an expression from an iterator.  They must be scalar and have
2366    INTEGER or (optionally) REAL type.  */
2367
2368 static try
2369 gfc_resolve_iterator_expr (gfc_expr * expr, bool real_ok,
2370                            const char * name_msgid)
2371 {
2372   if (gfc_resolve_expr (expr) == FAILURE)
2373     return FAILURE;
2374
2375   if (expr->rank != 0)
2376     {
2377       gfc_error ("%s at %L must be a scalar", _(name_msgid), &expr->where);
2378       return FAILURE;
2379     }
2380
2381   if (!(expr->ts.type == BT_INTEGER
2382         || (expr->ts.type == BT_REAL && real_ok)))
2383     {
2384       if (real_ok)
2385         gfc_error ("%s at %L must be INTEGER or REAL", _(name_msgid),
2386                    &expr->where);
2387       else
2388         gfc_error ("%s at %L must be INTEGER", _(name_msgid), &expr->where);
2389       return FAILURE;
2390     }
2391   return SUCCESS;
2392 }
2393
2394
2395 /* Resolve the expressions in an iterator structure.  If REAL_OK is
2396    false allow only INTEGER type iterators, otherwise allow REAL types.  */
2397
2398 try
2399 gfc_resolve_iterator (gfc_iterator * iter, bool real_ok)
2400 {
2401
2402   if (iter->var->ts.type == BT_REAL)
2403     gfc_notify_std (GFC_STD_F95_DEL,
2404                     "Obsolete: REAL DO loop iterator at %L",
2405                     &iter->var->where);
2406
2407   if (gfc_resolve_iterator_expr (iter->var, real_ok, "Loop variable")
2408       == FAILURE)
2409     return FAILURE;
2410
2411   if (gfc_pure (NULL) && gfc_impure_variable (iter->var->symtree->n.sym))
2412     {
2413       gfc_error ("Cannot assign to loop variable in PURE procedure at %L",
2414                  &iter->var->where);
2415       return FAILURE;
2416     }
2417
2418   if (gfc_resolve_iterator_expr (iter->start, real_ok,
2419                                  "Start expression in DO loop") == FAILURE)
2420     return FAILURE;
2421
2422   if (gfc_resolve_iterator_expr (iter->end, real_ok,
2423                                  "End expression in DO loop") == FAILURE)
2424     return FAILURE;
2425
2426   if (gfc_resolve_iterator_expr (iter->step, real_ok,
2427                                  "Step expression in DO loop") == FAILURE)
2428     return FAILURE;
2429
2430   if (iter->step->expr_type == EXPR_CONSTANT)
2431     {
2432       if ((iter->step->ts.type == BT_INTEGER
2433            && mpz_cmp_ui (iter->step->value.integer, 0) == 0)
2434           || (iter->step->ts.type == BT_REAL
2435               && mpfr_sgn (iter->step->value.real) == 0))
2436         {
2437           gfc_error ("Step expression in DO loop at %L cannot be zero",
2438                      &iter->step->where);
2439           return FAILURE;
2440         }
2441     }
2442
2443   /* Convert start, end, and step to the same type as var.  */
2444   if (iter->start->ts.kind != iter->var->ts.kind
2445       || iter->start->ts.type != iter->var->ts.type)
2446     gfc_convert_type (iter->start, &iter->var->ts, 2);
2447
2448   if (iter->end->ts.kind != iter->var->ts.kind
2449       || iter->end->ts.type != iter->var->ts.type)
2450     gfc_convert_type (iter->end, &iter->var->ts, 2);
2451
2452   if (iter->step->ts.kind != iter->var->ts.kind
2453       || iter->step->ts.type != iter->var->ts.type)
2454     gfc_convert_type (iter->step, &iter->var->ts, 2);
2455
2456   return SUCCESS;
2457 }
2458
2459
2460 /* Resolve a list of FORALL iterators.  */
2461
2462 static void
2463 resolve_forall_iterators (gfc_forall_iterator * iter)
2464 {
2465
2466   while (iter)
2467     {
2468       if (gfc_resolve_expr (iter->var) == SUCCESS
2469           && iter->var->ts.type != BT_INTEGER)
2470         gfc_error ("FORALL Iteration variable at %L must be INTEGER",
2471                    &iter->var->where);
2472
2473       if (gfc_resolve_expr (iter->start) == SUCCESS
2474           && iter->start->ts.type != BT_INTEGER)
2475         gfc_error ("FORALL start expression at %L must be INTEGER",
2476                    &iter->start->where);
2477       if (iter->var->ts.kind != iter->start->ts.kind)
2478         gfc_convert_type (iter->start, &iter->var->ts, 2);
2479
2480       if (gfc_resolve_expr (iter->end) == SUCCESS
2481           && iter->end->ts.type != BT_INTEGER)
2482         gfc_error ("FORALL end expression at %L must be INTEGER",
2483                    &iter->end->where);
2484       if (iter->var->ts.kind != iter->end->ts.kind)
2485         gfc_convert_type (iter->end, &iter->var->ts, 2);
2486
2487       if (gfc_resolve_expr (iter->stride) == SUCCESS
2488           && iter->stride->ts.type != BT_INTEGER)
2489         gfc_error ("FORALL Stride expression at %L must be INTEGER",
2490                    &iter->stride->where);
2491       if (iter->var->ts.kind != iter->stride->ts.kind)
2492         gfc_convert_type (iter->stride, &iter->var->ts, 2);
2493
2494       iter = iter->next;
2495     }
2496 }
2497
2498
2499 /* Given a pointer to a symbol that is a derived type, see if any components
2500    have the POINTER attribute.  The search is recursive if necessary.
2501    Returns zero if no pointer components are found, nonzero otherwise.  */
2502
2503 static int
2504 derived_pointer (gfc_symbol * sym)
2505 {
2506   gfc_component *c;
2507
2508   for (c = sym->components; c; c = c->next)
2509     {
2510       if (c->pointer)
2511         return 1;
2512
2513       if (c->ts.type == BT_DERIVED && derived_pointer (c->ts.derived))
2514         return 1;
2515     }
2516
2517   return 0;
2518 }
2519
2520
2521 /* Given a pointer to a symbol that is a derived type, see if it's
2522    inaccessible, i.e. if it's defined in another module and the components are
2523    PRIVATE.  The search is recursive if necessary.  Returns zero if no
2524    inaccessible components are found, nonzero otherwise.  */
2525
2526 static int
2527 derived_inaccessible (gfc_symbol *sym)
2528 {
2529   gfc_component *c;
2530
2531   if (sym->attr.use_assoc && sym->component_access == ACCESS_PRIVATE)
2532     return 1;
2533
2534   for (c = sym->components; c; c = c->next)
2535     {
2536         if (c->ts.type == BT_DERIVED && derived_inaccessible (c->ts.derived))
2537           return 1;
2538     }
2539
2540   return 0;
2541 }
2542
2543
2544 /* Resolve the argument of a deallocate expression.  The expression must be
2545    a pointer or a full array.  */
2546
2547 static try
2548 resolve_deallocate_expr (gfc_expr * e)
2549 {
2550   symbol_attribute attr;
2551   int allocatable;
2552   gfc_ref *ref;
2553
2554   if (gfc_resolve_expr (e) == FAILURE)
2555     return FAILURE;
2556
2557   attr = gfc_expr_attr (e);
2558   if (attr.pointer)
2559     return SUCCESS;
2560
2561   if (e->expr_type != EXPR_VARIABLE)
2562     goto bad;
2563
2564   allocatable = e->symtree->n.sym->attr.allocatable;
2565   for (ref = e->ref; ref; ref = ref->next)
2566     switch (ref->type)
2567       {
2568       case REF_ARRAY:
2569         if (ref->u.ar.type != AR_FULL)
2570           allocatable = 0;
2571         break;
2572
2573       case REF_COMPONENT:
2574         allocatable = (ref->u.c.component->as != NULL
2575                        && ref->u.c.component->as->type == AS_DEFERRED);
2576         break;
2577
2578       case REF_SUBSTRING:
2579         allocatable = 0;
2580         break;
2581       }
2582
2583   if (allocatable == 0)
2584     {
2585     bad:
2586       gfc_error ("Expression in DEALLOCATE statement at %L must be "
2587                  "ALLOCATABLE or a POINTER", &e->where);
2588     }
2589
2590   return SUCCESS;
2591 }
2592
2593
2594 /* Resolve the expression in an ALLOCATE statement, doing the additional
2595    checks to see whether the expression is OK or not.  The expression must
2596    have a trailing array reference that gives the size of the array.  */
2597
2598 static try
2599 resolve_allocate_expr (gfc_expr * e)
2600 {
2601   int i, pointer, allocatable, dimension;
2602   symbol_attribute attr;
2603   gfc_ref *ref, *ref2;
2604   gfc_array_ref *ar;
2605
2606   if (gfc_resolve_expr (e) == FAILURE)
2607     return FAILURE;
2608
2609   /* Make sure the expression is allocatable or a pointer.  If it is
2610      pointer, the next-to-last reference must be a pointer.  */
2611
2612   ref2 = NULL;
2613
2614   if (e->expr_type != EXPR_VARIABLE)
2615     {
2616       allocatable = 0;
2617
2618       attr = gfc_expr_attr (e);
2619       pointer = attr.pointer;
2620       dimension = attr.dimension;
2621
2622     }
2623   else
2624     {
2625       allocatable = e->symtree->n.sym->attr.allocatable;
2626       pointer = e->symtree->n.sym->attr.pointer;
2627       dimension = e->symtree->n.sym->attr.dimension;
2628
2629       for (ref = e->ref; ref; ref2 = ref, ref = ref->next)
2630         switch (ref->type)
2631           {
2632           case REF_ARRAY:
2633             if (ref->next != NULL)
2634               pointer = 0;
2635             break;
2636
2637           case REF_COMPONENT:
2638             allocatable = (ref->u.c.component->as != NULL
2639                            && ref->u.c.component->as->type == AS_DEFERRED);
2640
2641             pointer = ref->u.c.component->pointer;
2642             dimension = ref->u.c.component->dimension;
2643             break;
2644
2645           case REF_SUBSTRING:
2646             allocatable = 0;
2647             pointer = 0;
2648             break;
2649           }
2650     }
2651
2652   if (allocatable == 0 && pointer == 0)
2653     {
2654       gfc_error ("Expression in ALLOCATE statement at %L must be "
2655                  "ALLOCATABLE or a POINTER", &e->where);
2656       return FAILURE;
2657     }
2658
2659   if (pointer && dimension == 0)
2660     return SUCCESS;
2661
2662   /* Make sure the next-to-last reference node is an array specification.  */
2663
2664   if (ref2 == NULL || ref2->type != REF_ARRAY || ref2->u.ar.type == AR_FULL)
2665     {
2666       gfc_error ("Array specification required in ALLOCATE statement "
2667                  "at %L", &e->where);
2668       return FAILURE;
2669     }
2670
2671   if (ref2->u.ar.type == AR_ELEMENT)
2672     return SUCCESS;
2673
2674   /* Make sure that the array section reference makes sense in the
2675     context of an ALLOCATE specification.  */
2676
2677   ar = &ref2->u.ar;
2678
2679   for (i = 0; i < ar->dimen; i++)
2680     switch (ar->dimen_type[i])
2681       {
2682       case DIMEN_ELEMENT:
2683         break;
2684
2685       case DIMEN_RANGE:
2686         if (ar->start[i] != NULL
2687             && ar->end[i] != NULL
2688             && ar->stride[i] == NULL)
2689           break;
2690
2691         /* Fall Through...  */
2692
2693       case DIMEN_UNKNOWN:
2694       case DIMEN_VECTOR:
2695         gfc_error ("Bad array specification in ALLOCATE statement at %L",
2696                    &e->where);
2697         return FAILURE;
2698       }
2699
2700   return SUCCESS;
2701 }
2702
2703
2704 /************ SELECT CASE resolution subroutines ************/
2705
2706 /* Callback function for our mergesort variant.  Determines interval
2707    overlaps for CASEs. Return <0 if op1 < op2, 0 for overlap, >0 for
2708    op1 > op2.  Assumes we're not dealing with the default case.
2709    We have op1 = (:L), (K:L) or (K:) and op2 = (:N), (M:N) or (M:).
2710    There are nine situations to check.  */
2711
2712 static int
2713 compare_cases (const gfc_case * op1, const gfc_case * op2)
2714 {
2715   int retval;
2716
2717   if (op1->low == NULL) /* op1 = (:L)  */
2718     {
2719       /* op2 = (:N), so overlap.  */
2720       retval = 0;
2721       /* op2 = (M:) or (M:N),  L < M  */
2722       if (op2->low != NULL
2723           && gfc_compare_expr (op1->high, op2->low) < 0)
2724         retval = -1;
2725     }
2726   else if (op1->high == NULL) /* op1 = (K:)  */
2727     {
2728       /* op2 = (M:), so overlap.  */
2729       retval = 0;
2730       /* op2 = (:N) or (M:N), K > N  */
2731       if (op2->high != NULL
2732           && gfc_compare_expr (op1->low, op2->high) > 0)
2733         retval = 1;
2734     }
2735   else /* op1 = (K:L)  */
2736     {
2737       if (op2->low == NULL)       /* op2 = (:N), K > N  */
2738         retval = (gfc_compare_expr (op1->low, op2->high) > 0) ? 1 : 0;
2739       else if (op2->high == NULL) /* op2 = (M:), L < M  */
2740         retval = (gfc_compare_expr (op1->high, op2->low) < 0) ? -1 : 0;
2741       else                        /* op2 = (M:N)  */
2742         {
2743           retval =  0;
2744           /* L < M  */
2745           if (gfc_compare_expr (op1->high, op2->low) < 0)
2746             retval =  -1;
2747           /* K > N  */
2748           else if (gfc_compare_expr (op1->low, op2->high) > 0)
2749             retval =  1;
2750         }
2751     }
2752
2753   return retval;
2754 }
2755
2756
2757 /* Merge-sort a double linked case list, detecting overlap in the
2758    process.  LIST is the head of the double linked case list before it
2759    is sorted.  Returns the head of the sorted list if we don't see any
2760    overlap, or NULL otherwise.  */
2761
2762 static gfc_case *
2763 check_case_overlap (gfc_case * list)
2764 {
2765   gfc_case *p, *q, *e, *tail;
2766   int insize, nmerges, psize, qsize, cmp, overlap_seen;
2767
2768   /* If the passed list was empty, return immediately.  */
2769   if (!list)
2770     return NULL;
2771
2772   overlap_seen = 0;
2773   insize = 1;
2774
2775   /* Loop unconditionally.  The only exit from this loop is a return
2776      statement, when we've finished sorting the case list.  */
2777   for (;;)
2778     {
2779       p = list;
2780       list = NULL;
2781       tail = NULL;
2782
2783       /* Count the number of merges we do in this pass.  */
2784       nmerges = 0;
2785
2786       /* Loop while there exists a merge to be done.  */
2787       while (p)
2788         {
2789           int i;
2790
2791           /* Count this merge.  */
2792           nmerges++;
2793
2794           /* Cut the list in two pieces by stepping INSIZE places
2795              forward in the list, starting from P.  */
2796           psize = 0;
2797           q = p;
2798           for (i = 0; i < insize; i++)
2799             {
2800               psize++;
2801               q = q->right;
2802               if (!q)
2803                 break;
2804             }
2805           qsize = insize;
2806
2807           /* Now we have two lists.  Merge them!  */
2808           while (psize > 0 || (qsize > 0 && q != NULL))
2809             {
2810
2811               /* See from which the next case to merge comes from.  */
2812               if (psize == 0)
2813                 {
2814                   /* P is empty so the next case must come from Q.  */
2815                   e = q;
2816                   q = q->right;
2817                   qsize--;
2818                 }
2819               else if (qsize == 0 || q == NULL)
2820                 {
2821                   /* Q is empty.  */
2822                   e = p;
2823                   p = p->right;
2824                   psize--;
2825                 }
2826               else
2827                 {
2828                   cmp = compare_cases (p, q);
2829                   if (cmp < 0)
2830                     {
2831                       /* The whole case range for P is less than the
2832                          one for Q.  */
2833                       e = p;
2834                       p = p->right;
2835                       psize--;
2836                     }
2837                   else if (cmp > 0)
2838                     {
2839                       /* The whole case range for Q is greater than
2840                          the case range for P.  */
2841                       e = q;
2842                       q = q->right;
2843                       qsize--;
2844                     }
2845                   else
2846                     {
2847                       /* The cases overlap, or they are the same
2848                          element in the list.  Either way, we must
2849                          issue an error and get the next case from P.  */
2850                       /* FIXME: Sort P and Q by line number.  */
2851                       gfc_error ("CASE label at %L overlaps with CASE "
2852                                  "label at %L", &p->where, &q->where);
2853                       overlap_seen = 1;
2854                       e = p;
2855                       p = p->right;
2856                       psize--;
2857                     }
2858                 }
2859
2860                 /* Add the next element to the merged list.  */
2861               if (tail)
2862                 tail->right = e;
2863               else
2864                 list = e;
2865               e->left = tail;
2866               tail = e;
2867             }
2868
2869           /* P has now stepped INSIZE places along, and so has Q.  So
2870              they're the same.  */
2871           p = q;
2872         }
2873       tail->right = NULL;
2874
2875       /* If we have done only one merge or none at all, we've
2876          finished sorting the cases.  */
2877       if (nmerges <= 1)
2878         {
2879           if (!overlap_seen)
2880             return list;
2881           else
2882             return NULL;
2883         }
2884
2885       /* Otherwise repeat, merging lists twice the size.  */
2886       insize *= 2;
2887     }
2888 }
2889
2890
2891 /* Check to see if an expression is suitable for use in a CASE statement.
2892    Makes sure that all case expressions are scalar constants of the same
2893    type.  Return FAILURE if anything is wrong.  */
2894
2895 static try
2896 validate_case_label_expr (gfc_expr * e, gfc_expr * case_expr)
2897 {
2898   if (e == NULL) return SUCCESS;
2899
2900   if (e->ts.type != case_expr->ts.type)
2901     {
2902       gfc_error ("Expression in CASE statement at %L must be of type %s",
2903                  &e->where, gfc_basic_typename (case_expr->ts.type));
2904       return FAILURE;
2905     }
2906
2907   /* C805 (R808) For a given case-construct, each case-value shall be of
2908      the same type as case-expr.  For character type, length differences
2909      are allowed, but the kind type parameters shall be the same.  */
2910
2911   if (case_expr->ts.type == BT_CHARACTER && e->ts.kind != case_expr->ts.kind)
2912     {
2913       gfc_error("Expression in CASE statement at %L must be kind %d",
2914                 &e->where, case_expr->ts.kind);
2915       return FAILURE;
2916     }
2917
2918   /* Convert the case value kind to that of case expression kind, if needed.
2919      FIXME:  Should a warning be issued?  */
2920   if (e->ts.kind != case_expr->ts.kind)
2921     gfc_convert_type_warn (e, &case_expr->ts, 2, 0);
2922
2923   if (e->rank != 0)
2924     {
2925       gfc_error ("Expression in CASE statement at %L must be scalar",
2926                  &e->where);
2927       return FAILURE;
2928     }
2929
2930   return SUCCESS;
2931 }
2932
2933
2934 /* Given a completely parsed select statement, we:
2935
2936      - Validate all expressions and code within the SELECT.
2937      - Make sure that the selection expression is not of the wrong type.
2938      - Make sure that no case ranges overlap.
2939      - Eliminate unreachable cases and unreachable code resulting from
2940        removing case labels.
2941
2942    The standard does allow unreachable cases, e.g. CASE (5:3).  But
2943    they are a hassle for code generation, and to prevent that, we just
2944    cut them out here.  This is not necessary for overlapping cases
2945    because they are illegal and we never even try to generate code.
2946
2947    We have the additional caveat that a SELECT construct could have
2948    been a computed GOTO in the source code. Fortunately we can fairly
2949    easily work around that here: The case_expr for a "real" SELECT CASE
2950    is in code->expr1, but for a computed GOTO it is in code->expr2. All
2951    we have to do is make sure that the case_expr is a scalar integer
2952    expression.  */
2953
2954 static void
2955 resolve_select (gfc_code * code)
2956 {
2957   gfc_code *body;
2958   gfc_expr *case_expr;
2959   gfc_case *cp, *default_case, *tail, *head;
2960   int seen_unreachable;
2961   int ncases;
2962   bt type;
2963   try t;
2964
2965   if (code->expr == NULL)
2966     {
2967       /* This was actually a computed GOTO statement.  */
2968       case_expr = code->expr2;
2969       if (case_expr->ts.type != BT_INTEGER
2970           || case_expr->rank != 0)
2971         gfc_error ("Selection expression in computed GOTO statement "
2972                    "at %L must be a scalar integer expression",
2973                    &case_expr->where);
2974
2975       /* Further checking is not necessary because this SELECT was built
2976          by the compiler, so it should always be OK.  Just move the
2977          case_expr from expr2 to expr so that we can handle computed
2978          GOTOs as normal SELECTs from here on.  */
2979       code->expr = code->expr2;
2980       code->expr2 = NULL;
2981       return;
2982     }
2983
2984   case_expr = code->expr;
2985
2986   type = case_expr->ts.type;
2987   if (type != BT_LOGICAL && type != BT_INTEGER && type != BT_CHARACTER)
2988     {
2989       gfc_error ("Argument of SELECT statement at %L cannot be %s",
2990                  &case_expr->where, gfc_typename (&case_expr->ts));
2991
2992       /* Punt. Going on here just produce more garbage error messages.  */
2993       return;
2994     }
2995
2996   if (case_expr->rank != 0)
2997     {
2998       gfc_error ("Argument of SELECT statement at %L must be a scalar "
2999                  "expression", &case_expr->where);
3000
3001       /* Punt.  */
3002       return;
3003     }
3004
3005   /* PR 19168 has a long discussion concerning a mismatch of the kinds
3006      of the SELECT CASE expression and its CASE values.  Walk the lists
3007      of case values, and if we find a mismatch, promote case_expr to
3008      the appropriate kind.  */
3009
3010   if (type == BT_LOGICAL || type == BT_INTEGER)
3011     {
3012       for (body = code->block; body; body = body->block)
3013         {
3014           /* Walk the case label list.  */
3015           for (cp = body->ext.case_list; cp; cp = cp->next)
3016             {
3017               /* Intercept the DEFAULT case.  It does not have a kind.  */
3018               if (cp->low == NULL && cp->high == NULL)
3019                 continue;
3020
3021               /* Unreachable case ranges are discarded, so ignore.  */
3022               if (cp->low != NULL && cp->high != NULL
3023                   && cp->low != cp->high
3024                   && gfc_compare_expr (cp->low, cp->high) > 0)
3025                 continue;
3026
3027               /* FIXME: Should a warning be issued?  */
3028               if (cp->low != NULL
3029                   && case_expr->ts.kind != gfc_kind_max(case_expr, cp->low))
3030                 gfc_convert_type_warn (case_expr, &cp->low->ts, 2, 0);
3031
3032               if (cp->high != NULL
3033                   && case_expr->ts.kind != gfc_kind_max(case_expr, cp->high))
3034                 gfc_convert_type_warn (case_expr, &cp->high->ts, 2, 0);
3035             }
3036          }
3037     }
3038
3039   /* Assume there is no DEFAULT case.  */
3040   default_case = NULL;
3041   head = tail = NULL;
3042   ncases = 0;
3043
3044   for (body = code->block; body; body = body->block)
3045     {
3046       /* Assume the CASE list is OK, and all CASE labels can be matched.  */
3047       t = SUCCESS;
3048       seen_unreachable = 0;
3049
3050       /* Walk the case label list, making sure that all case labels
3051          are legal.  */
3052       for (cp = body->ext.case_list; cp; cp = cp->next)
3053         {
3054           /* Count the number of cases in the whole construct.  */
3055           ncases++;
3056
3057           /* Intercept the DEFAULT case.  */
3058           if (cp->low == NULL && cp->high == NULL)
3059             {
3060               if (default_case != NULL)
3061                 {
3062                   gfc_error ("The DEFAULT CASE at %L cannot be followed "
3063                              "by a second DEFAULT CASE at %L",
3064                              &default_case->where, &cp->where);
3065                   t = FAILURE;
3066                   break;
3067                 }
3068               else
3069                 {
3070                   default_case = cp;
3071                   continue;
3072                 }
3073             }
3074
3075           /* Deal with single value cases and case ranges.  Errors are
3076              issued from the validation function.  */
3077           if(validate_case_label_expr (cp->low, case_expr) != SUCCESS
3078              || validate_case_label_expr (cp->high, case_expr) != SUCCESS)
3079             {
3080               t = FAILURE;
3081               break;
3082             }
3083
3084           if (type == BT_LOGICAL
3085               && ((cp->low == NULL || cp->high == NULL)
3086                   || cp->low != cp->high))
3087             {
3088               gfc_error
3089                 ("Logical range in CASE statement at %L is not allowed",
3090                  &cp->low->where);
3091               t = FAILURE;
3092               break;
3093             }
3094
3095           if (cp->low != NULL && cp->high != NULL
3096               && cp->low != cp->high
3097               && gfc_compare_expr (cp->low, cp->high) > 0)
3098             {
3099               if (gfc_option.warn_surprising)
3100                 gfc_warning ("Range specification at %L can never "
3101                              "be matched", &cp->where);
3102
3103               cp->unreachable = 1;
3104               seen_unreachable = 1;
3105             }
3106           else
3107             {
3108               /* If the case range can be matched, it can also overlap with
3109                  other cases.  To make sure it does not, we put it in a
3110                  double linked list here.  We sort that with a merge sort
3111                  later on to detect any overlapping cases.  */
3112               if (!head)
3113                 {
3114                   head = tail = cp;
3115                   head->right = head->left = NULL;
3116                 }
3117               else
3118                 {
3119                   tail->right = cp;
3120                   tail->right->left = tail;
3121                   tail = tail->right;
3122                   tail->right = NULL;
3123                 }
3124             }
3125         }
3126
3127       /* It there was a failure in the previous case label, give up
3128          for this case label list.  Continue with the next block.  */
3129       if (t == FAILURE)
3130         continue;
3131
3132       /* See if any case labels that are unreachable have been seen.
3133          If so, we eliminate them.  This is a bit of a kludge because
3134          the case lists for a single case statement (label) is a
3135          single forward linked lists.  */
3136       if (seen_unreachable)
3137       {
3138         /* Advance until the first case in the list is reachable.  */
3139         while (body->ext.case_list != NULL
3140                && body->ext.case_list->unreachable)
3141           {
3142             gfc_case *n = body->ext.case_list;
3143             body->ext.case_list = body->ext.case_list->next;
3144             n->next = NULL;
3145             gfc_free_case_list (n);
3146           }
3147
3148         /* Strip all other unreachable cases.  */
3149         if (body->ext.case_list)
3150           {
3151             for (cp = body->ext.case_list; cp->next; cp = cp->next)
3152               {
3153                 if (cp->next->unreachable)
3154                   {
3155                     gfc_case *n = cp->next;
3156                     cp->next = cp->next->next;
3157                     n->next = NULL;
3158                     gfc_free_case_list (n);
3159                   }
3160               }
3161           }
3162       }
3163     }
3164
3165   /* See if there were overlapping cases.  If the check returns NULL,
3166      there was overlap.  In that case we don't do anything.  If head
3167      is non-NULL, we prepend the DEFAULT case.  The sorted list can
3168      then used during code generation for SELECT CASE constructs with
3169      a case expression of a CHARACTER type.  */
3170   if (head)
3171     {
3172       head = check_case_overlap (head);
3173
3174       /* Prepend the default_case if it is there.  */
3175       if (head != NULL && default_case)
3176         {
3177           default_case->left = NULL;
3178           default_case->right = head;
3179           head->left = default_case;
3180         }
3181     }
3182
3183   /* Eliminate dead blocks that may be the result if we've seen
3184      unreachable case labels for a block.  */
3185   for (body = code; body && body->block; body = body->block)
3186     {
3187       if (body->block->ext.case_list == NULL)
3188         {
3189           /* Cut the unreachable block from the code chain.  */
3190           gfc_code *c = body->block;
3191           body->block = c->block;
3192
3193           /* Kill the dead block, but not the blocks below it.  */
3194           c->block = NULL;
3195           gfc_free_statements (c);
3196         }
3197     }
3198
3199   /* More than two cases is legal but insane for logical selects.
3200      Issue a warning for it.  */
3201   if (gfc_option.warn_surprising && type == BT_LOGICAL
3202       && ncases > 2)
3203     gfc_warning ("Logical SELECT CASE block at %L has more that two cases",
3204                  &code->loc);
3205 }
3206
3207
3208 /* Resolve a transfer statement. This is making sure that:
3209    -- a derived type being transferred has only non-pointer components
3210    -- a derived type being transferred doesn't have private components, unless
3211       it's being transferred from the module where the type was defined
3212    -- we're not trying to transfer a whole assumed size array.  */
3213
3214 static void
3215 resolve_transfer (gfc_code * code)
3216 {
3217   gfc_typespec *ts;
3218   gfc_symbol *sym;
3219   gfc_ref *ref;
3220   gfc_expr *exp;
3221
3222   exp = code->expr;
3223
3224   if (exp->expr_type != EXPR_VARIABLE)
3225     return;
3226
3227   sym = exp->symtree->n.sym;
3228   ts = &sym->ts;
3229
3230   /* Go to actual component transferred.  */
3231   for (ref = code->expr->ref; ref; ref = ref->next)
3232     if (ref->type == REF_COMPONENT)
3233       ts = &ref->u.c.component->ts;
3234
3235   if (ts->type == BT_DERIVED)
3236     {
3237       /* Check that transferred derived type doesn't contain POINTER
3238          components.  */
3239       if (derived_pointer (ts->derived))
3240         {
3241           gfc_error ("Data transfer element at %L cannot have "
3242                      "POINTER components", &code->loc);
3243           return;
3244         }
3245
3246       if (derived_inaccessible (ts->derived))
3247         {
3248           gfc_error ("Data transfer element at %L cannot have "
3249                      "PRIVATE components",&code->loc);
3250           return;
3251         }
3252     }
3253
3254   if (sym->as != NULL && sym->as->type == AS_ASSUMED_SIZE
3255       && exp->ref->type == REF_ARRAY && exp->ref->u.ar.type == AR_FULL)
3256     {
3257       gfc_error ("Data transfer element at %L cannot be a full reference to "
3258                  "an assumed-size array", &code->loc);
3259       return;
3260     }
3261 }
3262
3263
3264 /*********** Toplevel code resolution subroutines ***********/
3265
3266 /* Given a branch to a label and a namespace, if the branch is conforming.
3267    The code node described where the branch is located.  */
3268
3269 static void
3270 resolve_branch (gfc_st_label * label, gfc_code * code)
3271 {
3272   gfc_code *block, *found;
3273   code_stack *stack;
3274   gfc_st_label *lp;
3275
3276   if (label == NULL)
3277     return;
3278   lp = label;
3279
3280   /* Step one: is this a valid branching target?  */
3281
3282   if (lp->defined == ST_LABEL_UNKNOWN)
3283     {
3284       gfc_error ("Label %d referenced at %L is never defined", lp->value,
3285                  &lp->where);
3286       return;
3287     }
3288
3289   if (lp->defined != ST_LABEL_TARGET)
3290     {
3291       gfc_error ("Statement at %L is not a valid branch target statement "
3292                  "for the branch statement at %L", &lp->where, &code->loc);
3293       return;
3294     }
3295
3296   /* Step two: make sure this branch is not a branch to itself ;-)  */
3297
3298   if (code->here == label)
3299     {
3300       gfc_warning ("Branch at %L causes an infinite loop", &code->loc);
3301       return;
3302     }
3303
3304   /* Step three: Try to find the label in the parse tree. To do this,
3305      we traverse the tree block-by-block: first the block that
3306      contains this GOTO, then the block that it is nested in, etc.  We
3307      can ignore other blocks because branching into another block is
3308      not allowed.  */
3309
3310   found = NULL;
3311
3312   for (stack = cs_base; stack; stack = stack->prev)
3313     {
3314       for (block = stack->head; block; block = block->next)
3315         {
3316           if (block->here == label)
3317             {
3318               found = block;
3319               break;
3320             }
3321         }
3322
3323       if (found)
3324         break;
3325     }
3326
3327   if (found == NULL)
3328     {
3329       /* still nothing, so illegal.  */
3330       gfc_error_now ("Label at %L is not in the same block as the "
3331                      "GOTO statement at %L", &lp->where, &code->loc);
3332       return;
3333     }
3334
3335   /* Step four: Make sure that the branching target is legal if
3336      the statement is an END {SELECT,DO,IF}.  */
3337
3338   if (found->op == EXEC_NOP)
3339     {
3340       for (stack = cs_base; stack; stack = stack->prev)
3341         if (stack->current->next == found)
3342           break;
3343
3344       if (stack == NULL)
3345         gfc_notify_std (GFC_STD_F95_DEL,
3346                         "Obsolete: GOTO at %L jumps to END of construct at %L",
3347                         &code->loc, &found->loc);
3348     }
3349 }
3350
3351
3352 /* Check whether EXPR1 has the same shape as EXPR2.  */
3353
3354 static try
3355 resolve_where_shape (gfc_expr *expr1, gfc_expr *expr2)
3356 {
3357   mpz_t shape[GFC_MAX_DIMENSIONS];
3358   mpz_t shape2[GFC_MAX_DIMENSIONS];
3359   try result = FAILURE;
3360   int i;
3361
3362   /* Compare the rank.  */
3363   if (expr1->rank != expr2->rank)
3364     return result;
3365
3366   /* Compare the size of each dimension.  */
3367   for (i=0; i<expr1->rank; i++)
3368     {
3369       if (gfc_array_dimen_size (expr1, i, &shape[i]) == FAILURE)
3370         goto ignore;
3371
3372       if (gfc_array_dimen_size (expr2, i, &shape2[i]) == FAILURE)
3373         goto ignore;
3374
3375       if (mpz_cmp (shape[i], shape2[i]))
3376         goto over;
3377     }
3378
3379   /* When either of the two expression is an assumed size array, we
3380      ignore the comparison of dimension sizes.  */
3381 ignore:
3382   result = SUCCESS;
3383
3384 over:
3385   for (i--; i>=0; i--)
3386     {
3387       mpz_clear (shape[i]);
3388       mpz_clear (shape2[i]);
3389     }
3390   return result;
3391 }
3392
3393
3394 /* Check whether a WHERE assignment target or a WHERE mask expression
3395    has the same shape as the outmost WHERE mask expression.  */
3396
3397 static void
3398 resolve_where (gfc_code *code, gfc_expr *mask)
3399 {
3400   gfc_code *cblock;
3401   gfc_code *cnext;
3402   gfc_expr *e = NULL;
3403
3404   cblock = code->block;
3405
3406   /* Store the first WHERE mask-expr of the WHERE statement or construct.
3407      In case of nested WHERE, only the outmost one is stored.  */
3408   if (mask == NULL) /* outmost WHERE */
3409     e = cblock->expr;
3410   else /* inner WHERE */
3411     e = mask;
3412
3413   while (cblock)
3414     {
3415       if (cblock->expr)
3416         {
3417           /* Check if the mask-expr has a consistent shape with the
3418              outmost WHERE mask-expr.  */
3419           if (resolve_where_shape (cblock->expr, e) == FAILURE)
3420             gfc_error ("WHERE mask at %L has inconsistent shape",
3421                        &cblock->expr->where);
3422          }
3423
3424       /* the assignment statement of a WHERE statement, or the first
3425          statement in where-body-construct of a WHERE construct */
3426       cnext = cblock->next;
3427       while (cnext)
3428         {
3429           switch (cnext->op)
3430             {
3431             /* WHERE assignment statement */
3432             case EXEC_ASSIGN:
3433
3434               /* Check shape consistent for WHERE assignment target.  */
3435               if (e && resolve_where_shape (cnext->expr, e) == FAILURE)
3436                gfc_error ("WHERE assignment target at %L has "
3437                           "inconsistent shape", &cnext->expr->where);
3438               break;
3439
3440             /* WHERE or WHERE construct is part of a where-body-construct */
3441             case EXEC_WHERE:
3442               resolve_where (cnext, e);
3443               break;
3444
3445             default:
3446               gfc_error ("Unsupported statement inside WHERE at %L",
3447                          &cnext->loc);
3448             }
3449          /* the next statement within the same where-body-construct */
3450          cnext = cnext->next;
3451        }
3452     /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
3453     cblock = cblock->block;
3454   }
3455 }
3456
3457
3458 /* Check whether the FORALL index appears in the expression or not.  */
3459
3460 static try
3461 gfc_find_forall_index (gfc_expr *expr, gfc_symbol *symbol)
3462 {
3463   gfc_array_ref ar;
3464   gfc_ref *tmp;
3465   gfc_actual_arglist *args;
3466   int i;
3467
3468   switch (expr->expr_type)
3469     {
3470     case EXPR_VARIABLE:
3471       gcc_assert (expr->symtree->n.sym);
3472
3473       /* A scalar assignment  */
3474       if (!expr->ref)
3475         {
3476           if (expr->symtree->n.sym == symbol)
3477             return SUCCESS;
3478           else
3479             return FAILURE;
3480         }
3481
3482       /* the expr is array ref, substring or struct component.  */
3483       tmp = expr->ref;
3484       while (tmp != NULL)
3485         {
3486           switch (tmp->type)
3487             {
3488             case  REF_ARRAY:
3489               /* Check if the symbol appears in the array subscript.  */
3490               ar = tmp->u.ar;
3491               for (i = 0; i < GFC_MAX_DIMENSIONS; i++)
3492                 {
3493                   if (ar.start[i])
3494                     if (gfc_find_forall_index (ar.start[i], symbol) == SUCCESS)
3495                       return SUCCESS;
3496
3497                   if (ar.end[i])
3498                     if (gfc_find_forall_index (ar.end[i], symbol) == SUCCESS)
3499                       return SUCCESS;
3500
3501                   if (ar.stride[i])
3502                     if (gfc_find_forall_index (ar.stride[i], symbol) == SUCCESS)
3503                       return SUCCESS;
3504                 }  /* end for  */
3505               break;
3506
3507             case REF_SUBSTRING:
3508               if (expr->symtree->n.sym == symbol)
3509                 return SUCCESS;
3510               tmp = expr->ref;
3511               /* Check if the symbol appears in the substring section.  */
3512               if (gfc_find_forall_index (tmp->u.ss.start, symbol) == SUCCESS)
3513                 return SUCCESS;
3514               if (gfc_find_forall_index (tmp->u.ss.end, symbol) == SUCCESS)
3515                 return SUCCESS;
3516               break;
3517
3518             case REF_COMPONENT:
3519               break;
3520
3521             default:
3522               gfc_error("expresion reference type error at %L", &expr->where);
3523             }
3524           tmp = tmp->next;
3525         }
3526       break;
3527
3528     /* If the expression is a function call, then check if the symbol
3529        appears in the actual arglist of the function.  */
3530     case EXPR_FUNCTION:
3531       for (args = expr->value.function.actual; args; args = args->next)
3532         {
3533           if (gfc_find_forall_index(args->expr,symbol) == SUCCESS)
3534             return SUCCESS;
3535         }
3536       break;
3537
3538     /* It seems not to happen.  */
3539     case EXPR_SUBSTRING:
3540       if (expr->ref)
3541         {
3542           tmp = expr->ref;
3543           gcc_assert (expr->ref->type == REF_SUBSTRING);
3544           if (gfc_find_forall_index (tmp->u.ss.start, symbol) == SUCCESS)
3545             return SUCCESS;
3546           if (gfc_find_forall_index (tmp->u.ss.end, symbol) == SUCCESS)
3547             return SUCCESS;
3548         }
3549       break;
3550
3551     /* It seems not to happen.  */
3552     case EXPR_STRUCTURE:
3553     case EXPR_ARRAY:
3554       gfc_error ("Unsupported statement while finding forall index in "
3555                  "expression");
3556       break;
3557
3558     case EXPR_OP:
3559       /* Find the FORALL index in the first operand.  */
3560       if (expr->value.op.op1)
3561         {
3562           if (gfc_find_forall_index (expr->value.op.op1, symbol) == SUCCESS)
3563             return SUCCESS;
3564         }
3565
3566       /* Find the FORALL index in the second operand.  */
3567       if (expr->value.op.op2)
3568         {
3569           if (gfc_find_forall_index (expr->value.op.op2, symbol) == SUCCESS)
3570             return SUCCESS;
3571         }
3572       break;
3573
3574     default:
3575       break;
3576     }
3577
3578   return FAILURE;
3579 }
3580
3581
3582 /* Resolve assignment in FORALL construct.
3583    NVAR is the number of FORALL index variables, and VAR_EXPR records the
3584    FORALL index variables.  */
3585
3586 static void
3587 gfc_resolve_assign_in_forall (gfc_code *code, int nvar, gfc_expr **var_expr)
3588 {
3589   int n;
3590
3591   for (n = 0; n < nvar; n++)
3592     {
3593       gfc_symbol *forall_index;
3594
3595       forall_index = var_expr[n]->symtree->n.sym;
3596
3597       /* Check whether the assignment target is one of the FORALL index
3598          variable.  */
3599       if ((code->expr->expr_type == EXPR_VARIABLE)
3600           && (code->expr->symtree->n.sym == forall_index))
3601         gfc_error ("Assignment to a FORALL index variable at %L",
3602                    &code->expr->where);
3603       else
3604         {
3605           /* If one of the FORALL index variables doesn't appear in the
3606              assignment target, then there will be a many-to-one
3607              assignment.  */
3608           if (gfc_find_forall_index (code->expr, forall_index) == FAILURE)
3609             gfc_error ("The FORALL with index '%s' cause more than one "
3610                        "assignment to this object at %L",
3611                        var_expr[n]->symtree->name, &code->expr->where);
3612         }
3613     }
3614 }
3615
3616
3617 /* Resolve WHERE statement in FORALL construct.  */
3618
3619 static void
3620 gfc_resolve_where_code_in_forall (gfc_code *code, int nvar, gfc_expr **var_expr){
3621   gfc_code *cblock;
3622   gfc_code *cnext;
3623
3624   cblock = code->block;
3625   while (cblock)
3626     {
3627       /* the assignment statement of a WHERE statement, or the first
3628          statement in where-body-construct of a WHERE construct */
3629       cnext = cblock->next;
3630       while (cnext)
3631         {
3632           switch (cnext->op)
3633             {
3634             /* WHERE assignment statement */
3635             case EXEC_ASSIGN:
3636               gfc_resolve_assign_in_forall (cnext, nvar, var_expr);
3637               break;
3638
3639             /* WHERE or WHERE construct is part of a where-body-construct */
3640             case EXEC_WHERE:
3641               gfc_resolve_where_code_in_forall (cnext, nvar, var_expr);
3642               break;
3643
3644             default:
3645               gfc_error ("Unsupported statement inside WHERE at %L",
3646                          &cnext->loc);
3647             }
3648           /* the next statement within the same where-body-construct */
3649           cnext = cnext->next;
3650         }
3651       /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
3652       cblock = cblock->block;
3653     }
3654 }
3655
3656
3657 /* Traverse the FORALL body to check whether the following errors exist:
3658    1. For assignment, check if a many-to-one assignment happens.
3659    2. For WHERE statement, check the WHERE body to see if there is any
3660       many-to-one assignment.  */
3661
3662 static void
3663 gfc_resolve_forall_body (gfc_code *code, int nvar, gfc_expr **var_expr)
3664 {
3665   gfc_code *c;
3666
3667   c = code->block->next;
3668   while (c)
3669     {
3670       switch (c->op)
3671         {
3672         case EXEC_ASSIGN:
3673         case EXEC_POINTER_ASSIGN:
3674           gfc_resolve_assign_in_forall (c, nvar, var_expr);
3675           break;
3676
3677         /* Because the resolve_blocks() will handle the nested FORALL,
3678            there is no need to handle it here.  */
3679         case EXEC_FORALL:
3680           break;
3681         case EXEC_WHERE:
3682           gfc_resolve_where_code_in_forall(c, nvar, var_expr);
3683           break;
3684         default:
3685           break;
3686         }
3687       /* The next statement in the FORALL body.  */
3688       c = c->next;
3689     }
3690 }
3691
3692
3693 /* Given a FORALL construct, first resolve the FORALL iterator, then call
3694    gfc_resolve_forall_body to resolve the FORALL body.  */
3695
3696 static void resolve_blocks (gfc_code *, gfc_namespace *);
3697
3698 static void
3699 gfc_resolve_forall (gfc_code *code, gfc_namespace *ns, int forall_save)
3700 {
3701   static gfc_expr **var_expr;
3702   static int total_var = 0;
3703   static int nvar = 0;
3704   gfc_forall_iterator *fa;
3705   gfc_symbol *forall_index;
3706   gfc_code *next;
3707   int i;
3708
3709   /* Start to resolve a FORALL construct   */
3710   if (forall_save == 0)
3711     {
3712       /* Count the total number of FORALL index in the nested FORALL
3713          construct in order to allocate the VAR_EXPR with proper size.  */
3714       next = code;
3715       while ((next != NULL) && (next->op == EXEC_FORALL))
3716         {
3717           for (fa = next->ext.forall_iterator; fa; fa = fa->next)
3718             total_var ++;
3719           next = next->block->next;
3720         }
3721
3722       /* Allocate VAR_EXPR with NUMBER_OF_FORALL_INDEX elements.  */
3723       var_expr = (gfc_expr **) gfc_getmem (total_var * sizeof (gfc_expr *));
3724     }
3725
3726   /* The information about FORALL iterator, including FORALL index start, end
3727      and stride. The FORALL index can not appear in start, end or stride.  */
3728   for (fa = code->ext.forall_iterator; fa; fa = fa->next)
3729     {
3730       /* Check if any outer FORALL index name is the same as the current
3731          one.  */
3732       for (i = 0; i < nvar; i++)
3733         {
3734           if (fa->var->symtree->n.sym == var_expr[i]->symtree->n.sym)
3735             {
3736               gfc_error ("An outer FORALL construct already has an index "
3737                          "with this name %L", &fa->var->where);
3738             }
3739         }
3740
3741       /* Record the current FORALL index.  */
3742       var_expr[nvar] = gfc_copy_expr (fa->var);
3743
3744       forall_index = fa->var->symtree->n.sym;
3745
3746       /* Check if the FORALL index appears in start, end or stride.  */
3747       if (gfc_find_forall_index (fa->start, forall_index) == SUCCESS)
3748         gfc_error ("A FORALL index must not appear in a limit or stride "
3749                    "expression in the same FORALL at %L", &fa->start->where);
3750       if (gfc_find_forall_index (fa->end, forall_index) == SUCCESS)
3751         gfc_error ("A FORALL index must not appear in a limit or stride "
3752                    "expression in the same FORALL at %L", &fa->end->where);
3753       if (gfc_find_forall_index (fa->stride, forall_index) == SUCCESS)
3754         gfc_error ("A FORALL index must not appear in a limit or stride "
3755                    "expression in the same FORALL at %L", &fa->stride->where);
3756       nvar++;
3757     }
3758
3759   /* Resolve the FORALL body.  */
3760   gfc_resolve_forall_body (code, nvar, var_expr);
3761
3762   /* May call gfc_resolve_forall to resolve the inner FORALL loop.  */
3763   resolve_blocks (code->block, ns);
3764
3765   /* Free VAR_EXPR after the whole FORALL construct resolved.  */
3766   for (i = 0; i < total_var; i++)
3767     gfc_free_expr (var_expr[i]);
3768
3769   /* Reset the counters.  */
3770   total_var = 0;
3771   nvar = 0;
3772 }
3773
3774
3775 /* Resolve lists of blocks found in IF, SELECT CASE, WHERE, FORALL ,GOTO and
3776    DO code nodes.  */
3777
3778 static void resolve_code (gfc_code *, gfc_namespace *);
3779
3780 static void
3781 resolve_blocks (gfc_code * b, gfc_namespace * ns)
3782 {
3783   try t;
3784
3785   for (; b; b = b->block)
3786     {
3787       t = gfc_resolve_expr (b->expr);
3788       if (gfc_resolve_expr (b->expr2) == FAILURE)
3789         t = FAILURE;
3790
3791       switch (b->op)
3792         {
3793         case EXEC_IF:
3794           if (t == SUCCESS && b->expr != NULL
3795               && (b->expr->ts.type != BT_LOGICAL || b->expr->rank != 0))
3796             gfc_error
3797               ("ELSE IF clause at %L requires a scalar LOGICAL expression",
3798                &b->expr->where);
3799           break;
3800
3801         case EXEC_WHERE:
3802           if (t == SUCCESS
3803               && b->expr != NULL
3804               && (b->expr->ts.type != BT_LOGICAL
3805                   || b->expr->rank == 0))
3806             gfc_error
3807               ("WHERE/ELSEWHERE clause at %L requires a LOGICAL array",
3808                &b->expr->where);
3809           break;
3810
3811         case EXEC_GOTO:
3812           resolve_branch (b->label, b);
3813           break;
3814
3815         case EXEC_SELECT:
3816         case EXEC_FORALL:
3817         case EXEC_DO:
3818         case EXEC_DO_WHILE:
3819           break;
3820
3821         default:
3822           gfc_internal_error ("resolve_block(): Bad block type");
3823         }
3824
3825       resolve_code (b->next, ns);
3826     }
3827 }
3828
3829
3830 /* Given a block of code, recursively resolve everything pointed to by this
3831    code block.  */
3832
3833 static void
3834 resolve_code (gfc_code * code, gfc_namespace * ns)
3835 {
3836   int forall_save = 0;
3837   code_stack frame;
3838   gfc_alloc *a;
3839   try t;
3840
3841   frame.prev = cs_base;
3842   frame.head = code;
3843   cs_base = &frame;
3844
3845   for (; code; code = code->next)
3846     {
3847       frame.current = code;
3848
3849       if (code->op == EXEC_FORALL)
3850         {
3851           forall_save = forall_flag;
3852           forall_flag = 1;
3853           gfc_resolve_forall (code, ns, forall_save);
3854         }
3855       else
3856         resolve_blocks (code->block, ns);
3857
3858       if (code->op == EXEC_FORALL)
3859         forall_flag = forall_save;
3860
3861       t = gfc_resolve_expr (code->expr);
3862       if (gfc_resolve_expr (code->expr2) == FAILURE)
3863         t = FAILURE;
3864
3865       switch (code->op)
3866         {
3867         case EXEC_NOP:
3868         case EXEC_CYCLE:
3869         case EXEC_PAUSE:
3870         case EXEC_STOP:
3871         case EXEC_EXIT:
3872         case EXEC_CONTINUE:
3873         case EXEC_DT_END:
3874         case EXEC_ENTRY:
3875           break;
3876
3877         case EXEC_WHERE:
3878           resolve_where (code, NULL);
3879           break;
3880
3881         case EXEC_GOTO:
3882           if (code->expr != NULL)
3883             {
3884               if (code->expr->ts.type != BT_INTEGER)
3885                 gfc_error ("ASSIGNED GOTO statement at %L requires an INTEGER "
3886                        "variable", &code->expr->where);
3887               else if (code->expr->symtree->n.sym->attr.assign != 1)
3888                 gfc_error ("Variable '%s' has not been assigned a target label "
3889                         "at %L", code->expr->symtree->n.sym->name,
3890                         &code->expr->where);
3891             }
3892           else
3893             resolve_branch (code->label, code);
3894           break;
3895
3896         case EXEC_RETURN:
3897           if (code->expr != NULL && code->expr->ts.type != BT_INTEGER)
3898             gfc_error ("Alternate RETURN statement at %L requires an INTEGER "
3899                        "return specifier", &code->expr->where);
3900           break;
3901
3902         case EXEC_ASSIGN:
3903           if (t == FAILURE)
3904             break;
3905
3906           if (gfc_extend_assign (code, ns) == SUCCESS)
3907             goto call;
3908
3909           if (gfc_pure (NULL))
3910             {
3911               if (gfc_impure_variable (code->expr->symtree->n.sym))
3912                 {
3913                   gfc_error
3914                     ("Cannot assign to variable '%s' in PURE procedure at %L",
3915                      code->expr->symtree->n.sym->name, &code->expr->where);
3916                   break;
3917                 }
3918
3919               if (code->expr2->ts.type == BT_DERIVED
3920                   && derived_pointer (code->expr2->ts.derived))
3921                 {
3922                   gfc_error
3923                     ("Right side of assignment at %L is a derived type "
3924                      "containing a POINTER in a PURE procedure",
3925                      &code->expr2->where);
3926                   break;
3927                 }
3928             }
3929
3930           gfc_check_assign (code->expr, code->expr2, 1);
3931           break;
3932
3933         case EXEC_LABEL_ASSIGN:
3934           if (code->label->defined == ST_LABEL_UNKNOWN)
3935             gfc_error ("Label %d referenced at %L is never defined",
3936                        code->label->value, &code->label->where);
3937           if (t == SUCCESS
3938               && (code->expr->expr_type != EXPR_VARIABLE
3939                   || code->expr->symtree->n.sym->ts.type != BT_INTEGER
3940                   || code->expr->symtree->n.sym->ts.kind
3941                         != gfc_default_integer_kind
3942                   || code->expr->symtree->n.sym->as != NULL))
3943             gfc_error ("ASSIGN statement at %L requires a scalar "
3944                        "default INTEGER variable", &code->expr->where);
3945           break;
3946
3947         case EXEC_POINTER_ASSIGN:
3948           if (t == FAILURE)
3949             break;
3950
3951           gfc_check_pointer_assign (code->expr, code->expr2);
3952           break;
3953
3954         case EXEC_ARITHMETIC_IF:
3955           if (t == SUCCESS
3956               && code->expr->ts.type != BT_INTEGER
3957               && code->expr->ts.type != BT_REAL)
3958             gfc_error ("Arithmetic IF statement at %L requires a numeric "
3959                        "expression", &code->expr->where);
3960
3961           resolve_branch (code->label, code);
3962           resolve_branch (code->label2, code);
3963           resolve_branch (code->label3, code);
3964           break;
3965
3966         case EXEC_IF:
3967           if (t == SUCCESS && code->expr != NULL
3968               && (code->expr->ts.type != BT_LOGICAL
3969                   || code->expr->rank != 0))
3970             gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
3971                        &code->expr->where);
3972           break;
3973
3974         case EXEC_CALL:
3975         call:
3976           resolve_call (code);
3977           break;
3978
3979         case EXEC_SELECT:
3980           /* Select is complicated. Also, a SELECT construct could be
3981              a transformed computed GOTO.  */
3982           resolve_select (code);
3983           break;
3984
3985         case EXEC_DO:
3986           if (code->ext.iterator != NULL)
3987             gfc_resolve_iterator (code->ext.iterator, true);
3988           break;
3989
3990         case EXEC_DO_WHILE:
3991           if (code->expr == NULL)
3992             gfc_internal_error ("resolve_code(): No expression on DO WHILE");
3993           if (t == SUCCESS
3994               && (code->expr->rank != 0
3995                   || code->expr->ts.type != BT_LOGICAL))
3996             gfc_error ("Exit condition of DO WHILE loop at %L must be "
3997                        "a scalar LOGICAL expression", &code->expr->where);
3998           break;
3999
4000         case EXEC_ALLOCATE:
4001           if (t == SUCCESS && code->expr != NULL
4002               && code->expr->ts.type != BT_INTEGER)
4003             gfc_error ("STAT tag in ALLOCATE statement at %L must be "
4004                        "of type INTEGER", &code->expr->where);
4005
4006           for (a = code->ext.alloc_list; a; a = a->next)
4007             resolve_allocate_expr (a->expr);
4008
4009           break;
4010
4011         case EXEC_DEALLOCATE:
4012           if (t == SUCCESS && code->expr != NULL
4013               && code->expr->ts.type != BT_INTEGER)
4014             gfc_error
4015               ("STAT tag in DEALLOCATE statement at %L must be of type "
4016                "INTEGER", &code->expr->where);
4017
4018           for (a = code->ext.alloc_list; a; a = a->next)
4019             resolve_deallocate_expr (a->expr);
4020
4021           break;
4022
4023         case EXEC_OPEN:
4024           if (gfc_resolve_open (code->ext.open) == FAILURE)
4025             break;
4026
4027           resolve_branch (code->ext.open->err, code);
4028           break;
4029
4030         case EXEC_CLOSE:
4031           if (gfc_resolve_close (code->ext.close) == FAILURE)
4032             break;
4033
4034           resolve_branch (code->ext.close->err, code);
4035           break;
4036
4037         case EXEC_BACKSPACE:
4038         case EXEC_ENDFILE:
4039         case EXEC_REWIND:
4040         case EXEC_FLUSH:
4041           if (gfc_resolve_filepos (code->ext.filepos) == FAILURE)
4042             break;
4043
4044           resolve_branch (code->ext.filepos->err, code);
4045           break;
4046
4047         case EXEC_INQUIRE:
4048           if (gfc_resolve_inquire (code->ext.inquire) == FAILURE)
4049               break;
4050
4051           resolve_branch (code->ext.inquire->err, code);
4052           break;
4053
4054         case EXEC_IOLENGTH:
4055           gcc_assert (code->ext.inquire != NULL);
4056           if (gfc_resolve_inquire (code->ext.inquire) == FAILURE)
4057             break;
4058
4059           resolve_branch (code->ext.inquire->err, code);
4060           break;
4061
4062         case EXEC_READ:
4063         case EXEC_WRITE:
4064           if (gfc_resolve_dt (code->ext.dt) == FAILURE)
4065             break;
4066
4067           resolve_branch (code->ext.dt->err, code);
4068           resolve_branch (code->ext.dt->end, code);
4069           resolve_branch (code->ext.dt->eor, code);
4070           break;
4071
4072         case EXEC_TRANSFER:
4073           resolve_transfer (code);
4074           break;
4075
4076         case EXEC_FORALL:
4077           resolve_forall_iterators (code->ext.forall_iterator);
4078
4079           if (code->expr != NULL && code->expr->ts.type != BT_LOGICAL)
4080             gfc_error
4081               ("FORALL mask clause at %L requires a LOGICAL expression",
4082                &code->expr->where);
4083           break;
4084
4085         default:
4086           gfc_internal_error ("resolve_code(): Bad statement code");
4087         }
4088     }
4089
4090   cs_base = frame.prev;
4091 }
4092
4093
4094 /* Resolve initial values and make sure they are compatible with
4095    the variable.  */
4096
4097 static void
4098 resolve_values (gfc_symbol * sym)
4099 {
4100
4101   if (sym->value == NULL)
4102     return;
4103
4104   if (gfc_resolve_expr (sym->value) == FAILURE)
4105     return;
4106
4107   gfc_check_assign_symbol (sym, sym->value);
4108 }
4109
4110
4111 /* Do anything necessary to resolve a symbol.  Right now, we just
4112    assume that an otherwise unknown symbol is a variable.  This sort
4113    of thing commonly happens for symbols in module.  */
4114
4115 static void
4116 resolve_symbol (gfc_symbol * sym)
4117 {
4118   /* Zero if we are checking a formal namespace.  */
4119   static int formal_ns_flag = 1;
4120   int formal_ns_save, check_constant, mp_flag;
4121   int i;
4122   const char *whynot;
4123   gfc_namelist *nl;
4124   gfc_symtree * symtree;
4125   gfc_symtree * this_symtree;
4126   gfc_namespace * ns;
4127
4128   if (sym->attr.flavor == FL_UNKNOWN)
4129     {
4130
4131     /* If we find that a flavorless symbol is an interface in one of the
4132        parent namespaces, find its symtree in this namespace, free the
4133        symbol and set the symtree to point to the interface symbol.  */
4134       for (ns = gfc_current_ns->parent; ns; ns = ns->parent)
4135         {
4136           symtree = gfc_find_symtree (ns->sym_root, sym->name);
4137           if (symtree && symtree->n.sym->generic)
4138             {
4139               this_symtree = gfc_find_symtree (gfc_current_ns->sym_root,
4140                                                sym->name);
4141               sym->refs--;
4142               if (!sym->refs)
4143                 gfc_free_symbol (sym);
4144               symtree->n.sym->refs++;
4145               this_symtree->n.sym = symtree->n.sym;
4146               return;
4147             }
4148         }
4149
4150       /* Otherwise give it a flavor according to such attributes as
4151          it has.  */
4152       if (sym->attr.external == 0 && sym->attr.intrinsic == 0)
4153         sym->attr.flavor = FL_VARIABLE;
4154       else
4155         {
4156           sym->attr.flavor = FL_PROCEDURE;
4157           if (sym->attr.dimension)
4158             sym->attr.function = 1;
4159         }
4160     }
4161
4162   /* Symbols that are module procedures with results (functions) have
4163      the types and array specification copied for type checking in
4164      procedures that call them, as well as for saving to a module
4165      fil