gcc/fortran/resolve.c

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