OSDN Git Service

PR fortran/15976
[pf3gnuchains/gcc-fork.git] / gcc / fortran / resolve.c
1 /* Perform type resolution on the various stuctures.
2    Copyright (C) 2001, 2002, 2003, 2004, 2005 Free Software Foundation, Inc.
3    Contributed by Andy Vaught
4
5 This file is part of GCC.
6
7 GCC is free software; you can redistribute it and/or modify it under
8 the terms of the GNU General Public License as published by the Free
9 Software Foundation; either version 2, or (at your option) any later
10 version.
11
12 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
13 WARRANTY; without even the implied warranty of MERCHANTABILITY or
14 FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
15 for more details.
16
17 You should have received a copy of the GNU General Public License
18 along with GCC; see the file COPYING.  If not, write to the Free
19 Software Foundation, 51 Franklin Street, Fifth Floor,Boston, MA
20 02110-1301, USA.  */
21
22
23 #include "config.h"
24 #include "system.h"
25 #include "gfortran.h"
26 #include "arith.h"  /* For gfc_compare_expr().  */
27
28 /* Types used in equivalence statements.  */
29
30 typedef enum seq_type
31 {
32   SEQ_NONDEFAULT, SEQ_NUMERIC, SEQ_CHARACTER, SEQ_MIXED
33 }
34 seq_type;
35
36 /* Stack to push the current if we descend into a block during
37    resolution.  See resolve_branch() and resolve_code().  */
38
39 typedef struct code_stack
40 {
41   struct gfc_code *head, *current;
42   struct code_stack *prev;
43 }
44 code_stack;
45
46 static code_stack *cs_base = NULL;
47
48
49 /* Nonzero if we're inside a FORALL block */
50
51 static int forall_flag;
52
53 /* Nonzero if we are processing a formal arglist. The corresponding function
54    resets the flag each time that it is read.  */
55 static int formal_arg_flag = 0;
56
57 int
58 gfc_is_formal_arg (void)
59 {
60   return formal_arg_flag;
61 }
62
63 /* Resolve types of formal argument lists.  These have to be done early so that
64    the formal argument lists of module procedures can be copied to the
65    containing module before the individual procedures are resolved
66    individually.  We also resolve argument lists of procedures in interface
67    blocks because they are self-contained scoping units.
68
69    Since a dummy argument cannot be a non-dummy procedure, the only
70    resort left for untyped names are the IMPLICIT types.  */
71
72 static void
73 resolve_formal_arglist (gfc_symbol * proc)
74 {
75   gfc_formal_arglist *f;
76   gfc_symbol *sym;
77   int i;
78
79   /* TODO: Procedures whose return character length parameter is not constant
80      or assumed must also have explicit interfaces.  */
81   if (proc->result != NULL)
82     sym = proc->result;
83   else
84     sym = proc;
85
86   if (gfc_elemental (proc)
87       || sym->attr.pointer || sym->attr.allocatable
88       || (sym->as && sym->as->rank > 0))
89     proc->attr.always_explicit = 1;
90
91   formal_arg_flag = 1;
92
93   for (f = proc->formal; f; f = f->next)
94     {
95       sym = f->sym;
96
97       if (sym == NULL)
98         {
99           /* Alternate return placeholder.  */
100           if (gfc_elemental (proc))
101             gfc_error ("Alternate return specifier in elemental subroutine "
102                        "'%s' at %L is not allowed", proc->name,
103                        &proc->declared_at);
104           if (proc->attr.function)
105             gfc_error ("Alternate return specifier in function "
106                        "'%s' at %L is not allowed", proc->name,
107                        &proc->declared_at);
108           continue;
109         }
110
111       if (sym->attr.if_source != IFSRC_UNKNOWN)
112         resolve_formal_arglist (sym);
113
114       if (sym->attr.subroutine || sym->attr.external || sym->attr.intrinsic)
115         {
116           if (gfc_pure (proc) && !gfc_pure (sym))
117             {
118               gfc_error
119                 ("Dummy procedure '%s' of PURE procedure at %L must also "
120                  "be PURE", sym->name, &sym->declared_at);
121               continue;
122             }
123
124           if (gfc_elemental (proc))
125             {
126               gfc_error
127                 ("Dummy procedure at %L not allowed in ELEMENTAL procedure",
128                  &sym->declared_at);
129               continue;
130             }
131
132           continue;
133         }
134
135       if (sym->ts.type == BT_UNKNOWN)
136         {
137           if (!sym->attr.function || sym->result == sym)
138             gfc_set_default_type (sym, 1, sym->ns);
139           else
140             {
141               /* Set the type of the RESULT, then copy.  */
142               if (sym->result->ts.type == BT_UNKNOWN)
143                 gfc_set_default_type (sym->result, 1, sym->result->ns);
144
145               sym->ts = sym->result->ts;
146               if (sym->as == NULL)
147                 sym->as = gfc_copy_array_spec (sym->result->as);
148             }
149         }
150
151       gfc_resolve_array_spec (sym->as, 0);
152
153       /* We can't tell if an array with dimension (:) is assumed or deferred
154          shape until we know if it has the pointer or allocatable attributes.
155       */
156       if (sym->as && sym->as->rank > 0 && sym->as->type == AS_DEFERRED
157           && !(sym->attr.pointer || sym->attr.allocatable))
158         {
159           sym->as->type = AS_ASSUMED_SHAPE;
160           for (i = 0; i < sym->as->rank; i++)
161             sym->as->lower[i] = gfc_int_expr (1);
162         }
163
164       if ((sym->as && sym->as->rank > 0 && sym->as->type == AS_ASSUMED_SHAPE)
165           || sym->attr.pointer || sym->attr.allocatable || sym->attr.target
166           || sym->attr.optional)
167         proc->attr.always_explicit = 1;
168
169       /* If the flavor is unknown at this point, it has to be a variable.
170          A procedure specification would have already set the type.  */
171
172       if (sym->attr.flavor == FL_UNKNOWN)
173         gfc_add_flavor (&sym->attr, FL_VARIABLE, sym->name, &sym->declared_at);
174
175       if (gfc_pure (proc))
176         {
177           if (proc->attr.function && !sym->attr.pointer
178               && sym->attr.flavor != FL_PROCEDURE
179               && sym->attr.intent != INTENT_IN)
180
181             gfc_error ("Argument '%s' of pure function '%s' at %L must be "
182                        "INTENT(IN)", sym->name, proc->name,
183                        &sym->declared_at);
184
185           if (proc->attr.subroutine && !sym->attr.pointer
186               && sym->attr.intent == INTENT_UNKNOWN)
187
188             gfc_error
189               ("Argument '%s' of pure subroutine '%s' at %L must have "
190                "its INTENT specified", sym->name, proc->name,
191                &sym->declared_at);
192         }
193
194
195       if (gfc_elemental (proc))
196         {
197           if (sym->as != NULL)
198             {
199               gfc_error
200                 ("Argument '%s' of elemental procedure at %L must be scalar",
201                  sym->name, &sym->declared_at);
202               continue;
203             }
204
205           if (sym->attr.pointer)
206             {
207               gfc_error
208                 ("Argument '%s' of elemental procedure at %L cannot have "
209                  "the POINTER attribute", sym->name, &sym->declared_at);
210               continue;
211             }
212         }
213
214       /* Each dummy shall be specified to be scalar.  */
215       if (proc->attr.proc == PROC_ST_FUNCTION)
216         {
217           if (sym->as != NULL)
218             {
219               gfc_error
220                 ("Argument '%s' of statement function at %L must be scalar",
221                  sym->name, &sym->declared_at);
222               continue;
223             }
224
225           if (sym->ts.type == BT_CHARACTER)
226             {
227               gfc_charlen *cl = sym->ts.cl;
228               if (!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT)
229                 {
230                   gfc_error
231                     ("Character-valued argument '%s' of statement function at "
232                      "%L must has constant length",
233                      sym->name, &sym->declared_at);
234                   continue;
235                 }
236             }
237         }
238     }
239   formal_arg_flag = 0;
240 }
241
242
243 /* Work function called when searching for symbols that have argument lists
244    associated with them.  */
245
246 static void
247 find_arglists (gfc_symbol * sym)
248 {
249
250   if (sym->attr.if_source == IFSRC_UNKNOWN || sym->ns != gfc_current_ns)
251     return;
252
253   resolve_formal_arglist (sym);
254 }
255
256
257 /* Given a namespace, resolve all formal argument lists within the namespace.
258  */
259
260 static void
261 resolve_formal_arglists (gfc_namespace * ns)
262 {
263
264   if (ns == NULL)
265     return;
266
267   gfc_traverse_ns (ns, find_arglists);
268 }
269
270
271 static void
272 resolve_contained_fntype (gfc_symbol * sym, gfc_namespace * ns)
273 {
274   try t;
275   
276   /* If this namespace is not a function, ignore it.  */
277   if (! sym
278       || !(sym->attr.function
279            || sym->attr.flavor == FL_VARIABLE))
280     return;
281
282   /* Try to find out of what the return type is.  */
283   if (sym->result != NULL)
284     sym = sym->result;
285
286   if (sym->ts.type == BT_UNKNOWN)
287     {
288       t = gfc_set_default_type (sym, 0, ns);
289
290       if (t == FAILURE && !sym->attr.untyped)
291         {
292           gfc_error ("Contained function '%s' at %L has no IMPLICIT type",
293                      sym->name, &sym->declared_at); /* FIXME */
294           sym->attr.untyped = 1;
295         }
296     }
297 }
298
299
300 /* Add NEW_ARGS to the formal argument list of PROC, taking care not to
301    introduce duplicates.  */
302
303 static void
304 merge_argument_lists (gfc_symbol *proc, gfc_formal_arglist *new_args)
305 {
306   gfc_formal_arglist *f, *new_arglist;
307   gfc_symbol *new_sym;
308
309   for (; new_args != NULL; new_args = new_args->next)
310     {
311       new_sym = new_args->sym;
312       /* See if ths arg is already in the formal argument list.  */
313       for (f = proc->formal; f; f = f->next)
314         {
315           if (new_sym == f->sym)
316             break;
317         }
318
319       if (f)
320         continue;
321
322       /* Add a new argument.  Argument order is not important.  */
323       new_arglist = gfc_get_formal_arglist ();
324       new_arglist->sym = new_sym;
325       new_arglist->next = proc->formal;
326       proc->formal  = new_arglist;
327     }
328 }
329
330
331 /* Resolve alternate entry points.  If a symbol has multiple entry points we
332    create a new master symbol for the main routine, and turn the existing
333    symbol into an entry point.  */
334
335 static void
336 resolve_entries (gfc_namespace * ns)
337 {
338   gfc_namespace *old_ns;
339   gfc_code *c;
340   gfc_symbol *proc;
341   gfc_entry_list *el;
342   char name[GFC_MAX_SYMBOL_LEN + 1];
343   static int master_count = 0;
344
345   if (ns->proc_name == NULL)
346     return;
347
348   /* No need to do anything if this procedure doesn't have alternate entry
349      points.  */
350   if (!ns->entries)
351     return;
352
353   /* We may already have resolved alternate entry points.  */
354   if (ns->proc_name->attr.entry_master)
355     return;
356
357   /* If this isn't a procedure something has gone horribly wrong.  */
358   gcc_assert (ns->proc_name->attr.flavor == FL_PROCEDURE);
359   
360   /* Remember the current namespace.  */
361   old_ns = gfc_current_ns;
362
363   gfc_current_ns = ns;
364
365   /* Add the main entry point to the list of entry points.  */
366   el = gfc_get_entry_list ();
367   el->sym = ns->proc_name;
368   el->id = 0;
369   el->next = ns->entries;
370   ns->entries = el;
371   ns->proc_name->attr.entry = 1;
372
373   /* Add an entry statement for it.  */
374   c = gfc_get_code ();
375   c->op = EXEC_ENTRY;
376   c->ext.entry = el;
377   c->next = ns->code;
378   ns->code = c;
379
380   /* Create a new symbol for the master function.  */
381   /* Give the internal function a unique name (within this file).
382      Also include the function name so the user has some hope of figuring
383      out what is going on.  */
384   snprintf (name, GFC_MAX_SYMBOL_LEN, "master.%d.%s",
385             master_count++, ns->proc_name->name);
386   gfc_get_ha_symbol (name, &proc);
387   gcc_assert (proc != NULL);
388
389   gfc_add_procedure (&proc->attr, PROC_INTERNAL, proc->name, NULL);
390   if (ns->proc_name->attr.subroutine)
391     gfc_add_subroutine (&proc->attr, proc->name, NULL);
392   else
393     {
394       gfc_symbol *sym;
395       gfc_typespec *ts, *fts;
396
397       gfc_add_function (&proc->attr, proc->name, NULL);
398       proc->result = proc;
399       fts = &ns->entries->sym->result->ts;
400       if (fts->type == BT_UNKNOWN)
401         fts = gfc_get_default_type (ns->entries->sym->result, NULL);
402       for (el = ns->entries->next; el; el = el->next)
403         {
404           ts = &el->sym->result->ts;
405           if (ts->type == BT_UNKNOWN)
406             ts = gfc_get_default_type (el->sym->result, NULL);
407           if (! gfc_compare_types (ts, fts)
408               || (el->sym->result->attr.dimension
409                   != ns->entries->sym->result->attr.dimension)
410               || (el->sym->result->attr.pointer
411                   != ns->entries->sym->result->attr.pointer))
412             break;
413         }
414
415       if (el == NULL)
416         {
417           sym = ns->entries->sym->result;
418           /* All result types the same.  */
419           proc->ts = *fts;
420           if (sym->attr.dimension)
421             gfc_set_array_spec (proc, gfc_copy_array_spec (sym->as), NULL);
422           if (sym->attr.pointer)
423             gfc_add_pointer (&proc->attr, NULL);
424         }
425       else
426         {
427           /* Otherwise the result will be passed through a union by
428              reference.  */
429           proc->attr.mixed_entry_master = 1;
430           for (el = ns->entries; el; el = el->next)
431             {
432               sym = el->sym->result;
433               if (sym->attr.dimension)
434               {
435                 if (el == ns->entries)
436                   gfc_error
437                   ("FUNCTION result %s can't be an array in FUNCTION %s at %L",
438                    sym->name, ns->entries->sym->name, &sym->declared_at);
439                 else
440                   gfc_error
441                     ("ENTRY result %s can't be an array in FUNCTION %s at %L",
442                      sym->name, ns->entries->sym->name, &sym->declared_at);
443               }
444               else if (sym->attr.pointer)
445               {
446                 if (el == ns->entries)
447                   gfc_error
448                   ("FUNCTION result %s can't be a POINTER in FUNCTION %s at %L",
449                    sym->name, ns->entries->sym->name, &sym->declared_at);
450                 else
451                   gfc_error
452                     ("ENTRY result %s can't be a POINTER in FUNCTION %s at %L",
453                      sym->name, ns->entries->sym->name, &sym->declared_at);
454               }
455               else
456                 {
457                   ts = &sym->ts;
458                   if (ts->type == BT_UNKNOWN)
459                     ts = gfc_get_default_type (sym, NULL);
460                   switch (ts->type)
461                     {
462                     case BT_INTEGER:
463                       if (ts->kind == gfc_default_integer_kind)
464                         sym = NULL;
465                       break;
466                     case BT_REAL:
467                       if (ts->kind == gfc_default_real_kind
468                           || ts->kind == gfc_default_double_kind)
469                         sym = NULL;
470                       break;
471                     case BT_COMPLEX:
472                       if (ts->kind == gfc_default_complex_kind)
473                         sym = NULL;
474                       break;
475                     case BT_LOGICAL:
476                       if (ts->kind == gfc_default_logical_kind)
477                         sym = NULL;
478                       break;
479                     case BT_UNKNOWN:
480                       /* We will issue error elsewhere.  */
481                       sym = NULL;
482                       break;
483                     default:
484                       break;
485                     }
486                   if (sym)
487                   {
488                     if (el == ns->entries)
489                       gfc_error
490                         ("FUNCTION result %s can't be of type %s in FUNCTION %s at %L",
491                          sym->name, gfc_typename (ts), ns->entries->sym->name,
492                          &sym->declared_at);
493                     else
494                       gfc_error
495                         ("ENTRY result %s can't be of type %s in FUNCTION %s at %L",
496                          sym->name, gfc_typename (ts), ns->entries->sym->name,
497                          &sym->declared_at);
498                   }
499                 }
500             }
501         }
502     }
503   proc->attr.access = ACCESS_PRIVATE;
504   proc->attr.entry_master = 1;
505
506   /* Merge all the entry point arguments.  */
507   for (el = ns->entries; el; el = el->next)
508     merge_argument_lists (proc, el->sym->formal);
509
510   /* Use the master function for the function body.  */
511   ns->proc_name = proc;
512
513   /* Finalize the new symbols.  */
514   gfc_commit_symbols ();
515
516   /* Restore the original namespace.  */
517   gfc_current_ns = old_ns;
518 }
519
520
521 /* Resolve contained function types.  Because contained functions can call one
522    another, they have to be worked out before any of the contained procedures
523    can be resolved.
524
525    The good news is that if a function doesn't already have a type, the only
526    way it can get one is through an IMPLICIT type or a RESULT variable, because
527    by definition contained functions are contained namespace they're contained
528    in, not in a sibling or parent namespace.  */
529
530 static void
531 resolve_contained_functions (gfc_namespace * ns)
532 {
533   gfc_namespace *child;
534   gfc_entry_list *el;
535
536   resolve_formal_arglists (ns);
537
538   for (child = ns->contained; child; child = child->sibling)
539     {
540       /* Resolve alternate entry points first.  */
541       resolve_entries (child); 
542
543       /* Then check function return types.  */
544       resolve_contained_fntype (child->proc_name, child);
545       for (el = child->entries; el; el = el->next)
546         resolve_contained_fntype (el->sym, child);
547     }
548 }
549
550
551 /* Resolve all of the elements of a structure constructor and make sure that
552    the types are correct.  */
553
554 static try
555 resolve_structure_cons (gfc_expr * expr)
556 {
557   gfc_constructor *cons;
558   gfc_component *comp;
559   try t;
560
561   t = SUCCESS;
562   cons = expr->value.constructor;
563   /* A constructor may have references if it is the result of substituting a
564      parameter variable.  In this case we just pull out the component we
565      want.  */
566   if (expr->ref)
567     comp = expr->ref->u.c.sym->components;
568   else
569     comp = expr->ts.derived->components;
570
571   for (; comp; comp = comp->next, cons = cons->next)
572     {
573       if (! cons->expr)
574         {
575           t = FAILURE;
576           continue;
577         }
578
579       if (gfc_resolve_expr (cons->expr) == FAILURE)
580         {
581           t = FAILURE;
582           continue;
583         }
584
585       /* If we don't have the right type, try to convert it.  */
586
587       if (!gfc_compare_types (&cons->expr->ts, &comp->ts)
588           && gfc_convert_type (cons->expr, &comp->ts, 1) == FAILURE)
589         t = FAILURE;
590     }
591
592   return t;
593 }
594
595
596
597 /****************** Expression name resolution ******************/
598
599 /* Returns 0 if a symbol was not declared with a type or
600    attribute declaration statement, nonzero otherwise.  */
601
602 static int
603 was_declared (gfc_symbol * sym)
604 {
605   symbol_attribute a;
606
607   a = sym->attr;
608
609   if (!a.implicit_type && sym->ts.type != BT_UNKNOWN)
610     return 1;
611
612   if (a.allocatable || a.dimension || a.dummy || a.external || a.intrinsic
613       || a.optional || a.pointer || a.save || a.target
614       || a.access != ACCESS_UNKNOWN || a.intent != INTENT_UNKNOWN)
615     return 1;
616
617   return 0;
618 }
619
620
621 /* Determine if a symbol is generic or not.  */
622
623 static int
624 generic_sym (gfc_symbol * sym)
625 {
626   gfc_symbol *s;
627
628   if (sym->attr.generic ||
629       (sym->attr.intrinsic && gfc_generic_intrinsic (sym->name)))
630     return 1;
631
632   if (was_declared (sym) || sym->ns->parent == NULL)
633     return 0;
634
635   gfc_find_symbol (sym->name, sym->ns->parent, 1, &s);
636
637   return (s == NULL) ? 0 : generic_sym (s);
638 }
639
640
641 /* Determine if a symbol is specific or not.  */
642
643 static int
644 specific_sym (gfc_symbol * sym)
645 {
646   gfc_symbol *s;
647
648   if (sym->attr.if_source == IFSRC_IFBODY
649       || sym->attr.proc == PROC_MODULE
650       || sym->attr.proc == PROC_INTERNAL
651       || sym->attr.proc == PROC_ST_FUNCTION
652       || (sym->attr.intrinsic &&
653           gfc_specific_intrinsic (sym->name))
654       || sym->attr.external)
655     return 1;
656
657   if (was_declared (sym) || sym->ns->parent == NULL)
658     return 0;
659
660   gfc_find_symbol (sym->name, sym->ns->parent, 1, &s);
661
662   return (s == NULL) ? 0 : specific_sym (s);
663 }
664
665
666 /* Figure out if the procedure is specific, generic or unknown.  */
667
668 typedef enum
669 { PTYPE_GENERIC = 1, PTYPE_SPECIFIC, PTYPE_UNKNOWN }
670 proc_type;
671
672 static proc_type
673 procedure_kind (gfc_symbol * sym)
674 {
675
676   if (generic_sym (sym))
677     return PTYPE_GENERIC;
678
679   if (specific_sym (sym))
680     return PTYPE_SPECIFIC;
681
682   return PTYPE_UNKNOWN;
683 }
684
685
686 /* Resolve an actual argument list.  Most of the time, this is just
687    resolving the expressions in the list.
688    The exception is that we sometimes have to decide whether arguments
689    that look like procedure arguments are really simple variable
690    references.  */
691
692 static try
693 resolve_actual_arglist (gfc_actual_arglist * arg)
694 {
695   gfc_symbol *sym;
696   gfc_symtree *parent_st;
697   gfc_expr *e;
698
699   for (; arg; arg = arg->next)
700     {
701
702       e = arg->expr;
703       if (e == NULL)
704         {
705           /* Check the label is a valid branching target.  */
706           if (arg->label)
707             {
708               if (arg->label->defined == ST_LABEL_UNKNOWN)
709                 {
710                   gfc_error ("Label %d referenced at %L is never defined",
711                              arg->label->value, &arg->label->where);
712                   return FAILURE;
713                 }
714             }
715           continue;
716         }
717
718       if (e->ts.type != BT_PROCEDURE)
719         {
720           if (gfc_resolve_expr (e) != SUCCESS)
721             return FAILURE;
722           continue;
723         }
724
725       /* See if the expression node should really be a variable
726          reference.  */
727
728       sym = e->symtree->n.sym;
729
730       if (sym->attr.flavor == FL_PROCEDURE
731           || sym->attr.intrinsic
732           || sym->attr.external)
733         {
734
735           if (sym->attr.proc == PROC_ST_FUNCTION)
736             {
737               gfc_error ("Statement function '%s' at %L is not allowed as an "
738                          "actual argument", sym->name, &e->where);
739             }
740
741           /* If the symbol is the function that names the current (or
742              parent) scope, then we really have a variable reference.  */
743
744           if (sym->attr.function && sym->result == sym
745               && (sym->ns->proc_name == sym
746                   || (sym->ns->parent != NULL
747                       && sym->ns->parent->proc_name == sym)))
748             goto got_variable;
749
750           continue;
751         }
752
753       /* See if the name is a module procedure in a parent unit.  */
754
755       if (was_declared (sym) || sym->ns->parent == NULL)
756         goto got_variable;
757
758       if (gfc_find_sym_tree (sym->name, sym->ns->parent, 1, &parent_st))
759         {
760           gfc_error ("Symbol '%s' at %L is ambiguous", sym->name, &e->where);
761           return FAILURE;
762         }
763
764       if (parent_st == NULL)
765         goto got_variable;
766
767       sym = parent_st->n.sym;
768       e->symtree = parent_st;           /* Point to the right thing.  */
769
770       if (sym->attr.flavor == FL_PROCEDURE
771           || sym->attr.intrinsic
772           || sym->attr.external)
773         {
774           continue;
775         }
776
777     got_variable:
778       e->expr_type = EXPR_VARIABLE;
779       e->ts = sym->ts;
780       if (sym->as != NULL)
781         {
782           e->rank = sym->as->rank;
783           e->ref = gfc_get_ref ();
784           e->ref->type = REF_ARRAY;
785           e->ref->u.ar.type = AR_FULL;
786           e->ref->u.ar.as = sym->as;
787         }
788     }
789
790   return SUCCESS;
791 }
792
793
794 /************* Function resolution *************/
795
796 /* Resolve a function call known to be generic.
797    Section 14.1.2.4.1.  */
798
799 static match
800 resolve_generic_f0 (gfc_expr * expr, gfc_symbol * sym)
801 {
802   gfc_symbol *s;
803
804   if (sym->attr.generic)
805     {
806       s =
807         gfc_search_interface (sym->generic, 0, &expr->value.function.actual);
808       if (s != NULL)
809         {
810           expr->value.function.name = s->name;
811           expr->value.function.esym = s;
812           expr->ts = s->ts;
813           if (s->as != NULL)
814             expr->rank = s->as->rank;
815           return MATCH_YES;
816         }
817
818       /* TODO: Need to search for elemental references in generic interface */
819     }
820
821   if (sym->attr.intrinsic)
822     return gfc_intrinsic_func_interface (expr, 0);
823
824   return MATCH_NO;
825 }
826
827
828 static try
829 resolve_generic_f (gfc_expr * expr)
830 {
831   gfc_symbol *sym;
832   match m;
833
834   sym = expr->symtree->n.sym;
835
836   for (;;)
837     {
838       m = resolve_generic_f0 (expr, sym);
839       if (m == MATCH_YES)
840         return SUCCESS;
841       else if (m == MATCH_ERROR)
842         return FAILURE;
843
844 generic:
845       if (sym->ns->parent == NULL)
846         break;
847       gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
848
849       if (sym == NULL)
850         break;
851       if (!generic_sym (sym))
852         goto generic;
853     }
854
855   /* Last ditch attempt.  */
856
857   if (!gfc_generic_intrinsic (expr->symtree->n.sym->name))
858     {
859       gfc_error ("Generic function '%s' at %L is not an intrinsic function",
860                  expr->symtree->n.sym->name, &expr->where);
861       return FAILURE;
862     }
863
864   m = gfc_intrinsic_func_interface (expr, 0);
865   if (m == MATCH_YES)
866     return SUCCESS;
867   if (m == MATCH_NO)
868     gfc_error
869       ("Generic function '%s' at %L is not consistent with a specific "
870        "intrinsic interface", expr->symtree->n.sym->name, &expr->where);
871
872   return FAILURE;
873 }
874
875
876 /* Resolve a function call known to be specific.  */
877
878 static match
879 resolve_specific_f0 (gfc_symbol * sym, gfc_expr * expr)
880 {
881   match m;
882
883   if (sym->attr.external || sym->attr.if_source == IFSRC_IFBODY)
884     {
885       if (sym->attr.dummy)
886         {
887           sym->attr.proc = PROC_DUMMY;
888           goto found;
889         }
890
891       sym->attr.proc = PROC_EXTERNAL;
892       goto found;
893     }
894
895   if (sym->attr.proc == PROC_MODULE
896       || sym->attr.proc == PROC_ST_FUNCTION
897       || sym->attr.proc == PROC_INTERNAL)
898     goto found;
899
900   if (sym->attr.intrinsic)
901     {
902       m = gfc_intrinsic_func_interface (expr, 1);
903       if (m == MATCH_YES)
904         return MATCH_YES;
905       if (m == MATCH_NO)
906         gfc_error
907           ("Function '%s' at %L is INTRINSIC but is not compatible with "
908            "an intrinsic", sym->name, &expr->where);
909
910       return MATCH_ERROR;
911     }
912
913   return MATCH_NO;
914
915 found:
916   gfc_procedure_use (sym, &expr->value.function.actual, &expr->where);
917
918   expr->ts = sym->ts;
919   expr->value.function.name = sym->name;
920   expr->value.function.esym = sym;
921   if (sym->as != NULL)
922     expr->rank = sym->as->rank;
923
924   return MATCH_YES;
925 }
926
927
928 static try
929 resolve_specific_f (gfc_expr * expr)
930 {
931   gfc_symbol *sym;
932   match m;
933
934   sym = expr->symtree->n.sym;
935
936   for (;;)
937     {
938       m = resolve_specific_f0 (sym, expr);
939       if (m == MATCH_YES)
940         return SUCCESS;
941       if (m == MATCH_ERROR)
942         return FAILURE;
943
944       if (sym->ns->parent == NULL)
945         break;
946
947       gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
948
949       if (sym == NULL)
950         break;
951     }
952
953   gfc_error ("Unable to resolve the specific function '%s' at %L",
954              expr->symtree->n.sym->name, &expr->where);
955
956   return SUCCESS;
957 }
958
959
960 /* Resolve a procedure call not known to be generic nor specific.  */
961
962 static try
963 resolve_unknown_f (gfc_expr * expr)
964 {
965   gfc_symbol *sym;
966   gfc_typespec *ts;
967
968   sym = expr->symtree->n.sym;
969
970   if (sym->attr.dummy)
971     {
972       sym->attr.proc = PROC_DUMMY;
973       expr->value.function.name = sym->name;
974       goto set_type;
975     }
976
977   /* See if we have an intrinsic function reference.  */
978
979   if (gfc_intrinsic_name (sym->name, 0))
980     {
981       if (gfc_intrinsic_func_interface (expr, 1) == MATCH_YES)
982         return SUCCESS;
983       return FAILURE;
984     }
985
986   /* The reference is to an external name.  */
987
988   sym->attr.proc = PROC_EXTERNAL;
989   expr->value.function.name = sym->name;
990   expr->value.function.esym = expr->symtree->n.sym;
991
992   if (sym->as != NULL)
993     expr->rank = sym->as->rank;
994
995   /* Type of the expression is either the type of the symbol or the
996      default type of the symbol.  */
997
998 set_type:
999   gfc_procedure_use (sym, &expr->value.function.actual, &expr->where);
1000
1001   if (sym->ts.type != BT_UNKNOWN)
1002     expr->ts = sym->ts;
1003   else
1004     {
1005       ts = gfc_get_default_type (sym, sym->ns);
1006
1007       if (ts->type == BT_UNKNOWN)
1008         {
1009           gfc_error ("Function '%s' at %L has no IMPLICIT type",
1010                      sym->name, &expr->where);
1011           return FAILURE;
1012         }
1013       else
1014         expr->ts = *ts;
1015     }
1016
1017   return SUCCESS;
1018 }
1019
1020
1021 /* Figure out if a function reference is pure or not.  Also set the name
1022    of the function for a potential error message.  Return nonzero if the
1023    function is PURE, zero if not.  */
1024
1025 static int
1026 pure_function (gfc_expr * e, const char **name)
1027 {
1028   int pure;
1029
1030   if (e->value.function.esym)
1031     {
1032       pure = gfc_pure (e->value.function.esym);
1033       *name = e->value.function.esym->name;
1034     }
1035   else if (e->value.function.isym)
1036     {
1037       pure = e->value.function.isym->pure
1038         || e->value.function.isym->elemental;
1039       *name = e->value.function.isym->name;
1040     }
1041   else
1042     {
1043       /* Implicit functions are not pure.  */
1044       pure = 0;
1045       *name = e->value.function.name;
1046     }
1047
1048   return pure;
1049 }
1050
1051
1052 /* Resolve a function call, which means resolving the arguments, then figuring
1053    out which entity the name refers to.  */
1054 /* TODO: Check procedure arguments so that an INTENT(IN) isn't passed
1055    to INTENT(OUT) or INTENT(INOUT).  */
1056
1057 static try
1058 resolve_function (gfc_expr * expr)
1059 {
1060   gfc_actual_arglist *arg;
1061   const char *name;
1062   try t;
1063
1064   if (resolve_actual_arglist (expr->value.function.actual) == FAILURE)
1065     return FAILURE;
1066
1067 /* See if function is already resolved.  */
1068
1069   if (expr->value.function.name != NULL)
1070     {
1071       if (expr->ts.type == BT_UNKNOWN)
1072         expr->ts = expr->symtree->n.sym->ts;
1073       t = SUCCESS;
1074     }
1075   else
1076     {
1077       /* Apply the rules of section 14.1.2.  */
1078
1079       switch (procedure_kind (expr->symtree->n.sym))
1080         {
1081         case PTYPE_GENERIC:
1082           t = resolve_generic_f (expr);
1083           break;
1084
1085         case PTYPE_SPECIFIC:
1086           t = resolve_specific_f (expr);
1087           break;
1088
1089         case PTYPE_UNKNOWN:
1090           t = resolve_unknown_f (expr);
1091           break;
1092
1093         default:
1094           gfc_internal_error ("resolve_function(): bad function type");
1095         }
1096     }
1097
1098   /* If the expression is still a function (it might have simplified),
1099      then we check to see if we are calling an elemental function.  */
1100
1101   if (expr->expr_type != EXPR_FUNCTION)
1102     return t;
1103
1104   if (expr->value.function.actual != NULL
1105       && ((expr->value.function.esym != NULL
1106            && expr->value.function.esym->attr.elemental)
1107           || (expr->value.function.isym != NULL
1108               && expr->value.function.isym->elemental)))
1109     {
1110
1111       /* The rank of an elemental is the rank of its array argument(s).  */
1112
1113       for (arg = expr->value.function.actual; arg; arg = arg->next)
1114         {
1115           if (arg->expr != NULL && arg->expr->rank > 0)
1116             {
1117               expr->rank = arg->expr->rank;
1118               break;
1119             }
1120         }
1121     }
1122
1123   if (!pure_function (expr, &name))
1124     {
1125       if (forall_flag)
1126         {
1127           gfc_error
1128             ("Function reference to '%s' at %L is inside a FORALL block",
1129              name, &expr->where);
1130           t = FAILURE;
1131         }
1132       else if (gfc_pure (NULL))
1133         {
1134           gfc_error ("Function reference to '%s' at %L is to a non-PURE "
1135                      "procedure within a PURE procedure", name, &expr->where);
1136           t = FAILURE;
1137         }
1138     }
1139
1140   return t;
1141 }
1142
1143
1144 /************* Subroutine resolution *************/
1145
1146 static void
1147 pure_subroutine (gfc_code * c, gfc_symbol * sym)
1148 {
1149
1150   if (gfc_pure (sym))
1151     return;
1152
1153   if (forall_flag)
1154     gfc_error ("Subroutine call to '%s' in FORALL block at %L is not PURE",
1155                sym->name, &c->loc);
1156   else if (gfc_pure (NULL))
1157     gfc_error ("Subroutine call to '%s' at %L is not PURE", sym->name,
1158                &c->loc);
1159 }
1160
1161
1162 static match
1163 resolve_generic_s0 (gfc_code * c, gfc_symbol * sym)
1164 {
1165   gfc_symbol *s;
1166
1167   if (sym->attr.generic)
1168     {
1169       s = gfc_search_interface (sym->generic, 1, &c->ext.actual);
1170       if (s != NULL)
1171         {
1172           c->resolved_sym = s;
1173           pure_subroutine (c, s);
1174           return MATCH_YES;
1175         }
1176
1177       /* TODO: Need to search for elemental references in generic interface.  */
1178     }
1179
1180   if (sym->attr.intrinsic)
1181     return gfc_intrinsic_sub_interface (c, 0);
1182
1183   return MATCH_NO;
1184 }
1185
1186
1187 static try
1188 resolve_generic_s (gfc_code * c)
1189 {
1190   gfc_symbol *sym;
1191   match m;
1192
1193   sym = c->symtree->n.sym;
1194
1195   m = resolve_generic_s0 (c, sym);
1196   if (m == MATCH_YES)
1197     return SUCCESS;
1198   if (m == MATCH_ERROR)
1199     return FAILURE;
1200
1201   if (sym->ns->parent != NULL)
1202     {
1203       gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
1204       if (sym != NULL)
1205         {
1206           m = resolve_generic_s0 (c, sym);
1207           if (m == MATCH_YES)
1208             return SUCCESS;
1209           if (m == MATCH_ERROR)
1210             return FAILURE;
1211         }
1212     }
1213
1214   /* Last ditch attempt.  */
1215
1216   if (!gfc_generic_intrinsic (sym->name))
1217     {
1218       gfc_error
1219         ("Generic subroutine '%s' at %L is not an intrinsic subroutine",
1220          sym->name, &c->loc);
1221       return FAILURE;
1222     }
1223
1224   m = gfc_intrinsic_sub_interface (c, 0);
1225   if (m == MATCH_YES)
1226     return SUCCESS;
1227   if (m == MATCH_NO)
1228     gfc_error ("Generic subroutine '%s' at %L is not consistent with an "
1229                "intrinsic subroutine interface", sym->name, &c->loc);
1230
1231   return FAILURE;
1232 }
1233
1234
1235 /* Resolve a subroutine call known to be specific.  */
1236
1237 static match
1238 resolve_specific_s0 (gfc_code * c, gfc_symbol * sym)
1239 {
1240   match m;
1241
1242   if (sym->attr.external || sym->attr.if_source == IFSRC_IFBODY)
1243     {
1244       if (sym->attr.dummy)
1245         {
1246           sym->attr.proc = PROC_DUMMY;
1247           goto found;
1248         }
1249
1250       sym->attr.proc = PROC_EXTERNAL;
1251       goto found;
1252     }
1253
1254   if (sym->attr.proc == PROC_MODULE || sym->attr.proc == PROC_INTERNAL)
1255     goto found;
1256
1257   if (sym->attr.intrinsic)
1258     {
1259       m = gfc_intrinsic_sub_interface (c, 1);
1260       if (m == MATCH_YES)
1261         return MATCH_YES;
1262       if (m == MATCH_NO)
1263         gfc_error ("Subroutine '%s' at %L is INTRINSIC but is not compatible "
1264                    "with an intrinsic", sym->name, &c->loc);
1265
1266       return MATCH_ERROR;
1267     }
1268
1269   return MATCH_NO;
1270
1271 found:
1272   gfc_procedure_use (sym, &c->ext.actual, &c->loc);
1273
1274   c->resolved_sym = sym;
1275   pure_subroutine (c, sym);
1276
1277   return MATCH_YES;
1278 }
1279
1280
1281 static try
1282 resolve_specific_s (gfc_code * c)
1283 {
1284   gfc_symbol *sym;
1285   match m;
1286
1287   sym = c->symtree->n.sym;
1288
1289   m = resolve_specific_s0 (c, sym);
1290   if (m == MATCH_YES)
1291     return SUCCESS;
1292   if (m == MATCH_ERROR)
1293     return FAILURE;
1294
1295   gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
1296
1297   if (sym != NULL)
1298     {
1299       m = resolve_specific_s0 (c, sym);
1300       if (m == MATCH_YES)
1301         return SUCCESS;
1302       if (m == MATCH_ERROR)
1303         return FAILURE;
1304     }
1305
1306   gfc_error ("Unable to resolve the specific subroutine '%s' at %L",
1307              sym->name, &c->loc);
1308
1309   return FAILURE;
1310 }
1311
1312
1313 /* Resolve a subroutine call not known to be generic nor specific.  */
1314
1315 static try
1316 resolve_unknown_s (gfc_code * c)
1317 {
1318   gfc_symbol *sym;
1319
1320   sym = c->symtree->n.sym;
1321
1322   if (sym->attr.dummy)
1323     {
1324       sym->attr.proc = PROC_DUMMY;
1325       goto found;
1326     }
1327
1328   /* See if we have an intrinsic function reference.  */
1329
1330   if (gfc_intrinsic_name (sym->name, 1))
1331     {
1332       if (gfc_intrinsic_sub_interface (c, 1) == MATCH_YES)
1333         return SUCCESS;
1334       return FAILURE;
1335     }
1336
1337   /* The reference is to an external name.  */
1338
1339 found:
1340   gfc_procedure_use (sym, &c->ext.actual, &c->loc);
1341
1342   c->resolved_sym = sym;
1343
1344   pure_subroutine (c, sym);
1345
1346   return SUCCESS;
1347 }
1348
1349
1350 /* Resolve a subroutine call.  Although it was tempting to use the same code
1351    for functions, subroutines and functions are stored differently and this
1352    makes things awkward.  */
1353
1354 static try
1355 resolve_call (gfc_code * c)
1356 {
1357   try t;
1358
1359   if (resolve_actual_arglist (c->ext.actual) == FAILURE)
1360     return FAILURE;
1361
1362   if (c->resolved_sym != NULL)
1363     return SUCCESS;
1364
1365   switch (procedure_kind (c->symtree->n.sym))
1366     {
1367     case PTYPE_GENERIC:
1368       t = resolve_generic_s (c);
1369       break;
1370
1371     case PTYPE_SPECIFIC:
1372       t = resolve_specific_s (c);
1373       break;
1374
1375     case PTYPE_UNKNOWN:
1376       t = resolve_unknown_s (c);
1377       break;
1378
1379     default:
1380       gfc_internal_error ("resolve_subroutine(): bad function type");
1381     }
1382
1383   return t;
1384 }
1385
1386 /* Compare the shapes of two arrays that have non-NULL shapes.  If both
1387    op1->shape and op2->shape are non-NULL return SUCCESS if their shapes
1388    match.  If both op1->shape and op2->shape are non-NULL return FAILURE
1389    if their shapes do not match.  If either op1->shape or op2->shape is
1390    NULL, return SUCCESS.  */
1391
1392 static try
1393 compare_shapes (gfc_expr * op1, gfc_expr * op2)
1394 {
1395   try t;
1396   int i;
1397
1398   t = SUCCESS;
1399                   
1400   if (op1->shape != NULL && op2->shape != NULL)
1401     {
1402       for (i = 0; i < op1->rank; i++)
1403         {
1404           if (mpz_cmp (op1->shape[i], op2->shape[i]) != 0)
1405            {
1406              gfc_error ("Shapes for operands at %L and %L are not conformable",
1407                          &op1->where, &op2->where);
1408              t = FAILURE;
1409              break;
1410            }
1411         }
1412     }
1413
1414   return t;
1415 }
1416
1417 /* Resolve an operator expression node.  This can involve replacing the
1418    operation with a user defined function call.  */
1419
1420 static try
1421 resolve_operator (gfc_expr * e)
1422 {
1423   gfc_expr *op1, *op2;
1424   char msg[200];
1425   try t;
1426
1427   /* Resolve all subnodes-- give them types.  */
1428
1429   switch (e->value.op.operator)
1430     {
1431     default:
1432       if (gfc_resolve_expr (e->value.op.op2) == FAILURE)
1433         return FAILURE;
1434
1435     /* Fall through...  */
1436
1437     case INTRINSIC_NOT:
1438     case INTRINSIC_UPLUS:
1439     case INTRINSIC_UMINUS:
1440       if (gfc_resolve_expr (e->value.op.op1) == FAILURE)
1441         return FAILURE;
1442       break;
1443     }
1444
1445   /* Typecheck the new node.  */
1446
1447   op1 = e->value.op.op1;
1448   op2 = e->value.op.op2;
1449
1450   switch (e->value.op.operator)
1451     {
1452     case INTRINSIC_UPLUS:
1453     case INTRINSIC_UMINUS:
1454       if (op1->ts.type == BT_INTEGER
1455           || op1->ts.type == BT_REAL
1456           || op1->ts.type == BT_COMPLEX)
1457         {
1458           e->ts = op1->ts;
1459           break;
1460         }
1461
1462       sprintf (msg, _("Operand of unary numeric operator '%s' at %%L is %s"),
1463                gfc_op2string (e->value.op.operator), gfc_typename (&e->ts));
1464       goto bad_op;
1465
1466     case INTRINSIC_PLUS:
1467     case INTRINSIC_MINUS:
1468     case INTRINSIC_TIMES:
1469     case INTRINSIC_DIVIDE:
1470     case INTRINSIC_POWER:
1471       if (gfc_numeric_ts (&op1->ts) && gfc_numeric_ts (&op2->ts))
1472         {
1473           gfc_type_convert_binary (e);
1474           break;
1475         }
1476
1477       sprintf (msg,
1478                _("Operands of binary numeric operator '%s' at %%L are %s/%s"),
1479                gfc_op2string (e->value.op.operator), gfc_typename (&op1->ts),
1480                gfc_typename (&op2->ts));
1481       goto bad_op;
1482
1483     case INTRINSIC_CONCAT:
1484       if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER)
1485         {
1486           e->ts.type = BT_CHARACTER;
1487           e->ts.kind = op1->ts.kind;
1488           break;
1489         }
1490
1491       sprintf (msg,
1492                _("Operands of string concatenation operator at %%L are %s/%s"),
1493                gfc_typename (&op1->ts), gfc_typename (&op2->ts));
1494       goto bad_op;
1495
1496     case INTRINSIC_AND:
1497     case INTRINSIC_OR:
1498     case INTRINSIC_EQV:
1499     case INTRINSIC_NEQV:
1500       if (op1->ts.type == BT_LOGICAL && op2->ts.type == BT_LOGICAL)
1501         {
1502           e->ts.type = BT_LOGICAL;
1503           e->ts.kind = gfc_kind_max (op1, op2);
1504           if (op1->ts.kind < e->ts.kind)
1505             gfc_convert_type (op1, &e->ts, 2);
1506           else if (op2->ts.kind < e->ts.kind)
1507             gfc_convert_type (op2, &e->ts, 2);
1508           break;
1509         }
1510
1511       sprintf (msg, _("Operands of logical operator '%s' at %%L are %s/%s"),
1512                gfc_op2string (e->value.op.operator), gfc_typename (&op1->ts),
1513                gfc_typename (&op2->ts));
1514
1515       goto bad_op;
1516
1517     case INTRINSIC_NOT:
1518       if (op1->ts.type == BT_LOGICAL)
1519         {
1520           e->ts.type = BT_LOGICAL;
1521           e->ts.kind = op1->ts.kind;
1522           break;
1523         }
1524
1525       sprintf (msg, _("Operand of .NOT. operator at %%L is %s"),
1526                gfc_typename (&op1->ts));
1527       goto bad_op;
1528
1529     case INTRINSIC_GT:
1530     case INTRINSIC_GE:
1531     case INTRINSIC_LT:
1532     case INTRINSIC_LE:
1533       if (op1->ts.type == BT_COMPLEX || op2->ts.type == BT_COMPLEX)
1534         {
1535           strcpy (msg, _("COMPLEX quantities cannot be compared at %L"));
1536           goto bad_op;
1537         }
1538
1539       /* Fall through...  */
1540
1541     case INTRINSIC_EQ:
1542     case INTRINSIC_NE:
1543       if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER)
1544         {
1545           e->ts.type = BT_LOGICAL;
1546           e->ts.kind = gfc_default_logical_kind;
1547           break;
1548         }
1549
1550       if (gfc_numeric_ts (&op1->ts) && gfc_numeric_ts (&op2->ts))
1551         {
1552           gfc_type_convert_binary (e);
1553
1554           e->ts.type = BT_LOGICAL;
1555           e->ts.kind = gfc_default_logical_kind;
1556           break;
1557         }
1558
1559       if (op1->ts.type == BT_LOGICAL && op2->ts.type == BT_LOGICAL)
1560         sprintf (msg,
1561                  _("Logicals at %%L must be compared with %s instead of %s"),
1562                  e->value.op.operator == INTRINSIC_EQ ? ".EQV." : ".NEQV.",
1563                  gfc_op2string (e->value.op.operator));
1564       else
1565         sprintf (msg,
1566                  _("Operands of comparison operator '%s' at %%L are %s/%s"),
1567                  gfc_op2string (e->value.op.operator), gfc_typename (&op1->ts),
1568                  gfc_typename (&op2->ts));
1569
1570       goto bad_op;
1571
1572     case INTRINSIC_USER:
1573       if (op2 == NULL)
1574         sprintf (msg, _("Operand of user operator '%s' at %%L is %s"),
1575                  e->value.op.uop->name, gfc_typename (&op1->ts));
1576       else
1577         sprintf (msg, _("Operands of user operator '%s' at %%L are %s/%s"),
1578                  e->value.op.uop->name, gfc_typename (&op1->ts),
1579                  gfc_typename (&op2->ts));
1580
1581       goto bad_op;
1582
1583     default:
1584       gfc_internal_error ("resolve_operator(): Bad intrinsic");
1585     }
1586
1587   /* Deal with arrayness of an operand through an operator.  */
1588
1589   t = SUCCESS;
1590
1591   switch (e->value.op.operator)
1592     {
1593     case INTRINSIC_PLUS:
1594     case INTRINSIC_MINUS:
1595     case INTRINSIC_TIMES:
1596     case INTRINSIC_DIVIDE:
1597     case INTRINSIC_POWER:
1598     case INTRINSIC_CONCAT:
1599     case INTRINSIC_AND:
1600     case INTRINSIC_OR:
1601     case INTRINSIC_EQV:
1602     case INTRINSIC_NEQV:
1603     case INTRINSIC_EQ:
1604     case INTRINSIC_NE:
1605     case INTRINSIC_GT:
1606     case INTRINSIC_GE:
1607     case INTRINSIC_LT:
1608     case INTRINSIC_LE:
1609
1610       if (op1->rank == 0 && op2->rank == 0)
1611         e->rank = 0;
1612
1613       if (op1->rank == 0 && op2->rank != 0)
1614         {
1615           e->rank = op2->rank;
1616
1617           if (e->shape == NULL)
1618             e->shape = gfc_copy_shape (op2->shape, op2->rank);
1619         }
1620
1621       if (op1->rank != 0 && op2->rank == 0)
1622         {
1623           e->rank = op1->rank;
1624
1625           if (e->shape == NULL)
1626             e->shape = gfc_copy_shape (op1->shape, op1->rank);
1627         }
1628
1629       if (op1->rank != 0 && op2->rank != 0)
1630         {
1631           if (op1->rank == op2->rank)
1632             {
1633               e->rank = op1->rank;
1634               if (e->shape == NULL)
1635                 {
1636                   t = compare_shapes(op1, op2);
1637                   if (t == FAILURE)
1638                     e->shape = NULL;
1639                   else
1640                 e->shape = gfc_copy_shape (op1->shape, op1->rank);
1641                 }
1642             }
1643           else
1644             {
1645               gfc_error ("Inconsistent ranks for operator at %L and %L",
1646                          &op1->where, &op2->where);
1647               t = FAILURE;
1648
1649               /* Allow higher level expressions to work.  */
1650               e->rank = 0;
1651             }
1652         }
1653
1654       break;
1655
1656     case INTRINSIC_NOT:
1657     case INTRINSIC_UPLUS:
1658     case INTRINSIC_UMINUS:
1659       e->rank = op1->rank;
1660
1661       if (e->shape == NULL)
1662         e->shape = gfc_copy_shape (op1->shape, op1->rank);
1663
1664       /* Simply copy arrayness attribute */
1665       break;
1666
1667     default:
1668       break;
1669     }
1670
1671   /* Attempt to simplify the expression.  */
1672   if (t == SUCCESS)
1673     t = gfc_simplify_expr (e, 0);
1674   return t;
1675
1676 bad_op:
1677
1678   if (gfc_extend_expr (e) == SUCCESS)
1679     return SUCCESS;
1680
1681   gfc_error (msg, &e->where);
1682
1683   return FAILURE;
1684 }
1685
1686
1687 /************** Array resolution subroutines **************/
1688
1689
1690 typedef enum
1691 { CMP_LT, CMP_EQ, CMP_GT, CMP_UNKNOWN }
1692 comparison;
1693
1694 /* Compare two integer expressions.  */
1695
1696 static comparison
1697 compare_bound (gfc_expr * a, gfc_expr * b)
1698 {
1699   int i;
1700
1701   if (a == NULL || a->expr_type != EXPR_CONSTANT
1702       || b == NULL || b->expr_type != EXPR_CONSTANT)
1703     return CMP_UNKNOWN;
1704
1705   if (a->ts.type != BT_INTEGER || b->ts.type != BT_INTEGER)
1706     gfc_internal_error ("compare_bound(): Bad expression");
1707
1708   i = mpz_cmp (a->value.integer, b->value.integer);
1709
1710   if (i < 0)
1711     return CMP_LT;
1712   if (i > 0)
1713     return CMP_GT;
1714   return CMP_EQ;
1715 }
1716
1717
1718 /* Compare an integer expression with an integer.  */
1719
1720 static comparison
1721 compare_bound_int (gfc_expr * a, int b)
1722 {
1723   int i;
1724
1725   if (a == NULL || a->expr_type != EXPR_CONSTANT)
1726     return CMP_UNKNOWN;
1727
1728   if (a->ts.type != BT_INTEGER)
1729     gfc_internal_error ("compare_bound_int(): Bad expression");
1730
1731   i = mpz_cmp_si (a->value.integer, b);
1732
1733   if (i < 0)
1734     return CMP_LT;
1735   if (i > 0)
1736     return CMP_GT;
1737   return CMP_EQ;
1738 }
1739
1740
1741 /* Compare a single dimension of an array reference to the array
1742    specification.  */
1743
1744 static try
1745 check_dimension (int i, gfc_array_ref * ar, gfc_array_spec * as)
1746 {
1747
1748 /* Given start, end and stride values, calculate the minimum and
1749    maximum referenced indexes.  */
1750
1751   switch (ar->type)
1752     {
1753     case AR_FULL:
1754       break;
1755
1756     case AR_ELEMENT:
1757       if (compare_bound (ar->start[i], as->lower[i]) == CMP_LT)
1758         goto bound;
1759       if (compare_bound (ar->start[i], as->upper[i]) == CMP_GT)
1760         goto bound;
1761
1762       break;
1763
1764     case AR_SECTION:
1765       if (compare_bound_int (ar->stride[i], 0) == CMP_EQ)
1766         {
1767           gfc_error ("Illegal stride of zero at %L", &ar->c_where[i]);
1768           return FAILURE;
1769         }
1770
1771       if (compare_bound (ar->start[i], as->lower[i]) == CMP_LT)
1772         goto bound;
1773       if (compare_bound (ar->start[i], as->upper[i]) == CMP_GT)
1774         goto bound;
1775
1776       /* TODO: Possibly, we could warn about end[i] being out-of-bound although
1777          it is legal (see 6.2.2.3.1).  */
1778
1779       break;
1780
1781     default:
1782       gfc_internal_error ("check_dimension(): Bad array reference");
1783     }
1784
1785   return SUCCESS;
1786
1787 bound:
1788   gfc_warning ("Array reference at %L is out of bounds", &ar->c_where[i]);
1789   return SUCCESS;
1790 }
1791
1792
1793 /* Compare an array reference with an array specification.  */
1794
1795 static try
1796 compare_spec_to_ref (gfc_array_ref * ar)
1797 {
1798   gfc_array_spec *as;
1799   int i;
1800
1801   as = ar->as;
1802   i = as->rank - 1;
1803   /* TODO: Full array sections are only allowed as actual parameters.  */
1804   if (as->type == AS_ASSUMED_SIZE
1805       && (/*ar->type == AR_FULL
1806           ||*/ (ar->type == AR_SECTION
1807               && ar->dimen_type[i] == DIMEN_RANGE && ar->end[i] == NULL)))
1808     {
1809       gfc_error ("Rightmost upper bound of assumed size array section"
1810                  " not specified at %L", &ar->where);
1811       return FAILURE;
1812     }
1813
1814   if (ar->type == AR_FULL)
1815     return SUCCESS;
1816
1817   if (as->rank != ar->dimen)
1818     {
1819       gfc_error ("Rank mismatch in array reference at %L (%d/%d)",
1820                  &ar->where, ar->dimen, as->rank);
1821       return FAILURE;
1822     }
1823
1824   for (i = 0; i < as->rank; i++)
1825     if (check_dimension (i, ar, as) == FAILURE)
1826       return FAILURE;
1827
1828   return SUCCESS;
1829 }
1830
1831
1832 /* Resolve one part of an array index.  */
1833
1834 try
1835 gfc_resolve_index (gfc_expr * index, int check_scalar)
1836 {
1837   gfc_typespec ts;
1838
1839   if (index == NULL)
1840     return SUCCESS;
1841
1842   if (gfc_resolve_expr (index) == FAILURE)
1843     return FAILURE;
1844
1845   if (check_scalar && index->rank != 0)
1846     {
1847       gfc_error ("Array index at %L must be scalar", &index->where);
1848       return FAILURE;
1849     }
1850
1851   if (index->ts.type != BT_INTEGER && index->ts.type != BT_REAL)
1852     {
1853       gfc_error ("Array index at %L must be of INTEGER type",
1854                  &index->where);
1855       return FAILURE;
1856     }
1857
1858   if (index->ts.type == BT_REAL)
1859     if (gfc_notify_std (GFC_STD_GNU, "Extension: REAL array index at %L",
1860                         &index->where) == FAILURE)
1861       return FAILURE;
1862
1863   if (index->ts.kind != gfc_index_integer_kind
1864       || index->ts.type != BT_INTEGER)
1865     {
1866       ts.type = BT_INTEGER;
1867       ts.kind = gfc_index_integer_kind;
1868
1869       gfc_convert_type_warn (index, &ts, 2, 0);
1870     }
1871
1872   return SUCCESS;
1873 }
1874
1875 /* Resolve a dim argument to an intrinsic function.  */
1876
1877 try
1878 gfc_resolve_dim_arg (gfc_expr *dim)
1879 {
1880   if (dim == NULL)
1881     return SUCCESS;
1882
1883   if (gfc_resolve_expr (dim) == FAILURE)
1884     return FAILURE;
1885
1886   if (dim->rank != 0)
1887     {
1888       gfc_error ("Argument dim at %L must be scalar", &dim->where);
1889       return FAILURE;
1890   
1891     }
1892   if (dim->ts.type != BT_INTEGER)
1893     {
1894       gfc_error ("Argument dim at %L must be of INTEGER type", &dim->where);
1895       return FAILURE;
1896     }
1897   if (dim->ts.kind != gfc_index_integer_kind)
1898     {
1899       gfc_typespec ts;
1900
1901       ts.type = BT_INTEGER;
1902       ts.kind = gfc_index_integer_kind;
1903
1904       gfc_convert_type_warn (dim, &ts, 2, 0);
1905     }
1906
1907   return SUCCESS;
1908 }
1909
1910 /* Given an expression that contains array references, update those array
1911    references to point to the right array specifications.  While this is
1912    filled in during matching, this information is difficult to save and load
1913    in a module, so we take care of it here.
1914
1915    The idea here is that the original array reference comes from the
1916    base symbol.  We traverse the list of reference structures, setting
1917    the stored reference to references.  Component references can
1918    provide an additional array specification.  */
1919
1920 static void
1921 find_array_spec (gfc_expr * e)
1922 {
1923   gfc_array_spec *as;
1924   gfc_component *c;
1925   gfc_ref *ref;
1926
1927   as = e->symtree->n.sym->as;
1928
1929   for (ref = e->ref; ref; ref = ref->next)
1930     switch (ref->type)
1931       {
1932       case REF_ARRAY:
1933         if (as == NULL)
1934           gfc_internal_error ("find_array_spec(): Missing spec");
1935
1936         ref->u.ar.as = as;
1937         as = NULL;
1938         break;
1939
1940       case REF_COMPONENT:
1941         for (c = e->symtree->n.sym->ts.derived->components; c; c = c->next)
1942           if (c == ref->u.c.component)
1943             break;
1944
1945         if (c == NULL)
1946           gfc_internal_error ("find_array_spec(): Component not found");
1947
1948         if (c->dimension)
1949           {
1950             if (as != NULL)
1951               gfc_internal_error ("find_array_spec(): unused as(1)");
1952             as = c->as;
1953           }
1954
1955         break;
1956
1957       case REF_SUBSTRING:
1958         break;
1959       }
1960
1961   if (as != NULL)
1962     gfc_internal_error ("find_array_spec(): unused as(2)");
1963 }
1964
1965
1966 /* Resolve an array reference.  */
1967
1968 static try
1969 resolve_array_ref (gfc_array_ref * ar)
1970 {
1971   int i, check_scalar;
1972
1973   for (i = 0; i < ar->dimen; i++)
1974     {
1975       check_scalar = ar->dimen_type[i] == DIMEN_RANGE;
1976
1977       if (gfc_resolve_index (ar->start[i], check_scalar) == FAILURE)
1978         return FAILURE;
1979       if (gfc_resolve_index (ar->end[i], check_scalar) == FAILURE)
1980         return FAILURE;
1981       if (gfc_resolve_index (ar->stride[i], check_scalar) == FAILURE)
1982         return FAILURE;
1983
1984       if (ar->dimen_type[i] == DIMEN_UNKNOWN)
1985         switch (ar->start[i]->rank)
1986           {
1987           case 0:
1988             ar->dimen_type[i] = DIMEN_ELEMENT;
1989             break;
1990
1991           case 1:
1992             ar->dimen_type[i] = DIMEN_VECTOR;
1993             break;
1994
1995           default:
1996             gfc_error ("Array index at %L is an array of rank %d",
1997                        &ar->c_where[i], ar->start[i]->rank);
1998             return FAILURE;
1999           }
2000     }
2001
2002   /* If the reference type is unknown, figure out what kind it is.  */
2003
2004   if (ar->type == AR_UNKNOWN)
2005     {
2006       ar->type = AR_ELEMENT;
2007       for (i = 0; i < ar->dimen; i++)
2008         if (ar->dimen_type[i] == DIMEN_RANGE
2009             || ar->dimen_type[i] == DIMEN_VECTOR)
2010           {
2011             ar->type = AR_SECTION;
2012             break;
2013           }
2014     }
2015
2016   if (!ar->as->cray_pointee && compare_spec_to_ref (ar) == FAILURE)
2017     return FAILURE;
2018
2019   return SUCCESS;
2020 }
2021
2022
2023 static try
2024 resolve_substring (gfc_ref * ref)
2025 {
2026
2027   if (ref->u.ss.start != NULL)
2028     {
2029       if (gfc_resolve_expr (ref->u.ss.start) == FAILURE)
2030         return FAILURE;
2031
2032       if (ref->u.ss.start->ts.type != BT_INTEGER)
2033         {
2034           gfc_error ("Substring start index at %L must be of type INTEGER",
2035                      &ref->u.ss.start->where);
2036           return FAILURE;
2037         }
2038
2039       if (ref->u.ss.start->rank != 0)
2040         {
2041           gfc_error ("Substring start index at %L must be scalar",
2042                      &ref->u.ss.start->where);
2043           return FAILURE;
2044         }
2045
2046       if (compare_bound_int (ref->u.ss.start, 1) == CMP_LT)
2047         {
2048           gfc_error ("Substring start index at %L is less than one",
2049                      &ref->u.ss.start->where);
2050           return FAILURE;
2051         }
2052     }
2053
2054   if (ref->u.ss.end != NULL)
2055     {
2056       if (gfc_resolve_expr (ref->u.ss.end) == FAILURE)
2057         return FAILURE;
2058
2059       if (ref->u.ss.end->ts.type != BT_INTEGER)
2060         {
2061           gfc_error ("Substring end index at %L must be of type INTEGER",
2062                      &ref->u.ss.end->where);
2063           return FAILURE;
2064         }
2065
2066       if (ref->u.ss.end->rank != 0)
2067         {
2068           gfc_error ("Substring end index at %L must be scalar",
2069                      &ref->u.ss.end->where);
2070           return FAILURE;
2071         }
2072
2073       if (ref->u.ss.length != NULL
2074           && compare_bound (ref->u.ss.end, ref->u.ss.length->length) == CMP_GT)
2075         {
2076           gfc_error ("Substring end index at %L is out of bounds",
2077                      &ref->u.ss.start->where);
2078           return FAILURE;
2079         }
2080     }
2081
2082   return SUCCESS;
2083 }
2084
2085
2086 /* Resolve subtype references.  */
2087
2088 static try
2089 resolve_ref (gfc_expr * expr)
2090 {
2091   int current_part_dimension, n_components, seen_part_dimension;
2092   gfc_ref *ref;
2093
2094   for (ref = expr->ref; ref; ref = ref->next)
2095     if (ref->type == REF_ARRAY && ref->u.ar.as == NULL)
2096       {
2097         find_array_spec (expr);
2098         break;
2099       }
2100
2101   for (ref = expr->ref; ref; ref = ref->next)
2102     switch (ref->type)
2103       {
2104       case REF_ARRAY:
2105         if (resolve_array_ref (&ref->u.ar) == FAILURE)
2106           return FAILURE;
2107         break;
2108
2109       case REF_COMPONENT:
2110         break;
2111
2112       case REF_SUBSTRING:
2113         resolve_substring (ref);
2114         break;
2115       }
2116
2117   /* Check constraints on part references.  */
2118
2119   current_part_dimension = 0;
2120   seen_part_dimension = 0;
2121   n_components = 0;
2122
2123   for (ref = expr->ref; ref; ref = ref->next)
2124     {
2125       switch (ref->type)
2126         {
2127         case REF_ARRAY:
2128           switch (ref->u.ar.type)
2129             {
2130             case AR_FULL:
2131             case AR_SECTION:
2132               current_part_dimension = 1;
2133               break;
2134
2135             case AR_ELEMENT:
2136               current_part_dimension = 0;
2137               break;
2138
2139             case AR_UNKNOWN:
2140               gfc_internal_error ("resolve_ref(): Bad array reference");
2141             }
2142
2143           break;
2144
2145         case REF_COMPONENT:
2146           if ((current_part_dimension || seen_part_dimension)
2147               && ref->u.c.component->pointer)
2148             {
2149               gfc_error
2150                 ("Component to the right of a part reference with nonzero "
2151                  "rank must not have the POINTER attribute at %L",
2152                  &expr->where);
2153               return FAILURE;
2154             }
2155
2156           n_components++;
2157           break;
2158
2159         case REF_SUBSTRING:
2160           break;
2161         }
2162
2163       if (((ref->type == REF_COMPONENT && n_components > 1)
2164            || ref->next == NULL)
2165           && current_part_dimension
2166           && seen_part_dimension)
2167         {
2168
2169           gfc_error ("Two or more part references with nonzero rank must "
2170                      "not be specified at %L", &expr->where);
2171           return FAILURE;
2172         }
2173
2174       if (ref->type == REF_COMPONENT)
2175         {
2176           if (current_part_dimension)
2177             seen_part_dimension = 1;
2178
2179           /* reset to make sure */
2180           current_part_dimension = 0;
2181         }
2182     }
2183
2184   return SUCCESS;
2185 }
2186
2187
2188 /* Given an expression, determine its shape.  This is easier than it sounds.
2189    Leaves the shape array NULL if it is not possible to determine the shape.  */
2190
2191 static void
2192 expression_shape (gfc_expr * e)
2193 {
2194   mpz_t array[GFC_MAX_DIMENSIONS];
2195   int i;
2196
2197   if (e->rank == 0 || e->shape != NULL)
2198     return;
2199
2200   for (i = 0; i < e->rank; i++)
2201     if (gfc_array_dimen_size (e, i, &array[i]) == FAILURE)
2202       goto fail;
2203
2204   e->shape = gfc_get_shape (e->rank);
2205
2206   memcpy (e->shape, array, e->rank * sizeof (mpz_t));
2207
2208   return;
2209
2210 fail:
2211   for (i--; i >= 0; i--)
2212     mpz_clear (array[i]);
2213 }
2214
2215
2216 /* Given a variable expression node, compute the rank of the expression by
2217    examining the base symbol and any reference structures it may have.  */
2218
2219 static void
2220 expression_rank (gfc_expr * e)
2221 {
2222   gfc_ref *ref;
2223   int i, rank;
2224
2225   if (e->ref == NULL)
2226     {
2227       if (e->expr_type == EXPR_ARRAY)
2228         goto done;
2229       /* Constructors can have a rank different from one via RESHAPE().  */
2230
2231       if (e->symtree == NULL)
2232         {
2233           e->rank = 0;
2234           goto done;
2235         }
2236
2237       e->rank = (e->symtree->n.sym->as == NULL)
2238                   ? 0 : e->symtree->n.sym->as->rank;
2239       goto done;
2240     }
2241
2242   rank = 0;
2243
2244   for (ref = e->ref; ref; ref = ref->next)
2245     {
2246       if (ref->type != REF_ARRAY)
2247         continue;
2248
2249       if (ref->u.ar.type == AR_FULL)
2250         {
2251           rank = ref->u.ar.as->rank;
2252           break;
2253         }
2254
2255       if (ref->u.ar.type == AR_SECTION)
2256         {
2257           /* Figure out the rank of the section.  */
2258           if (rank != 0)
2259             gfc_internal_error ("expression_rank(): Two array specs");
2260
2261           for (i = 0; i < ref->u.ar.dimen; i++)
2262             if (ref->u.ar.dimen_type[i] == DIMEN_RANGE
2263                 || ref->u.ar.dimen_type[i] == DIMEN_VECTOR)
2264               rank++;
2265
2266           break;
2267         }
2268     }
2269
2270   e->rank = rank;
2271
2272 done:
2273   expression_shape (e);
2274 }
2275
2276
2277 /* Resolve a variable expression.  */
2278
2279 static try
2280 resolve_variable (gfc_expr * e)
2281 {
2282   gfc_symbol *sym;
2283
2284   if (e->ref && resolve_ref (e) == FAILURE)
2285     return FAILURE;
2286
2287   if (e->symtree == NULL)
2288     return FAILURE;
2289
2290   sym = e->symtree->n.sym;
2291   if (sym->attr.flavor == FL_PROCEDURE && !sym->attr.function)
2292     {
2293       e->ts.type = BT_PROCEDURE;
2294       return SUCCESS;
2295     }
2296
2297   if (sym->ts.type != BT_UNKNOWN)
2298     gfc_variable_attr (e, &e->ts);
2299   else
2300     {
2301       /* Must be a simple variable reference.  */
2302       if (gfc_set_default_type (sym, 1, NULL) == FAILURE)
2303         return FAILURE;
2304       e->ts = sym->ts;
2305     }
2306
2307   return SUCCESS;
2308 }
2309
2310
2311 /* Resolve an expression.  That is, make sure that types of operands agree
2312    with their operators, intrinsic operators are converted to function calls
2313    for overloaded types and unresolved function references are resolved.  */
2314
2315 try
2316 gfc_resolve_expr (gfc_expr * e)
2317 {
2318   try t;
2319
2320   if (e == NULL)
2321     return SUCCESS;
2322
2323   switch (e->expr_type)
2324     {
2325     case EXPR_OP:
2326       t = resolve_operator (e);
2327       break;
2328
2329     case EXPR_FUNCTION:
2330       t = resolve_function (e);
2331       break;
2332
2333     case EXPR_VARIABLE:
2334       t = resolve_variable (e);
2335       if (t == SUCCESS)
2336         expression_rank (e);
2337       break;
2338
2339     case EXPR_SUBSTRING:
2340       t = resolve_ref (e);
2341       break;
2342
2343     case EXPR_CONSTANT:
2344     case EXPR_NULL:
2345       t = SUCCESS;
2346       break;
2347
2348     case EXPR_ARRAY:
2349       t = FAILURE;
2350       if (resolve_ref (e) == FAILURE)
2351         break;
2352
2353       t = gfc_resolve_array_constructor (e);
2354       /* Also try to expand a constructor.  */
2355       if (t == SUCCESS)
2356         {
2357           expression_rank (e);
2358           gfc_expand_constructor (e);
2359         }
2360
2361       break;
2362
2363     case EXPR_STRUCTURE:
2364       t = resolve_ref (e);
2365       if (t == FAILURE)
2366         break;
2367
2368       t = resolve_structure_cons (e);
2369       if (t == FAILURE)
2370         break;
2371
2372       t = gfc_simplify_expr (e, 0);
2373       break;
2374
2375     default:
2376       gfc_internal_error ("gfc_resolve_expr(): Bad expression type");
2377     }
2378
2379   return t;
2380 }
2381
2382
2383 /* Resolve an expression from an iterator.  They must be scalar and have
2384    INTEGER or (optionally) REAL type.  */
2385
2386 static try
2387 gfc_resolve_iterator_expr (gfc_expr * expr, bool real_ok,
2388                            const char * name_msgid)
2389 {
2390   if (gfc_resolve_expr (expr) == FAILURE)
2391     return FAILURE;
2392
2393   if (expr->rank != 0)
2394     {
2395       gfc_error ("%s at %L must be a scalar", _(name_msgid), &expr->where);
2396       return FAILURE;
2397     }
2398
2399   if (!(expr->ts.type == BT_INTEGER
2400         || (expr->ts.type == BT_REAL && real_ok)))
2401     {
2402       if (real_ok)
2403         gfc_error ("%s at %L must be INTEGER or REAL", _(name_msgid),
2404                    &expr->where);
2405       else
2406         gfc_error ("%s at %L must be INTEGER", _(name_msgid), &expr->where);
2407       return FAILURE;
2408     }
2409   return SUCCESS;
2410 }
2411
2412
2413 /* Resolve the expressions in an iterator structure.  If REAL_OK is
2414    false allow only INTEGER type iterators, otherwise allow REAL types.  */
2415
2416 try
2417 gfc_resolve_iterator (gfc_iterator * iter, bool real_ok)
2418 {
2419
2420   if (iter->var->ts.type == BT_REAL)
2421     gfc_notify_std (GFC_STD_F95_DEL,
2422                     "Obsolete: REAL DO loop iterator at %L",
2423                     &iter->var->where);
2424
2425   if (gfc_resolve_iterator_expr (iter->var, real_ok, "Loop variable")
2426       == FAILURE)
2427     return FAILURE;
2428
2429   if (gfc_pure (NULL) && gfc_impure_variable (iter->var->symtree->n.sym))
2430     {
2431       gfc_error ("Cannot assign to loop variable in PURE procedure at %L",
2432                  &iter->var->where);
2433       return FAILURE;
2434     }
2435
2436   if (gfc_resolve_iterator_expr (iter->start, real_ok,
2437                                  "Start expression in DO loop") == FAILURE)
2438     return FAILURE;
2439
2440   if (gfc_resolve_iterator_expr (iter->end, real_ok,
2441                                  "End expression in DO loop") == FAILURE)
2442     return FAILURE;
2443
2444   if (gfc_resolve_iterator_expr (iter->step, real_ok,
2445                                  "Step expression in DO loop") == FAILURE)
2446     return FAILURE;
2447
2448   if (iter->step->expr_type == EXPR_CONSTANT)
2449     {
2450       if ((iter->step->ts.type == BT_INTEGER
2451            && mpz_cmp_ui (iter->step->value.integer, 0) == 0)
2452           || (iter->step->ts.type == BT_REAL
2453               && mpfr_sgn (iter->step->value.real) == 0))
2454         {
2455           gfc_error ("Step expression in DO loop at %L cannot be zero",
2456                      &iter->step->where);
2457           return FAILURE;
2458         }
2459     }
2460
2461   /* Convert start, end, and step to the same type as var.  */
2462   if (iter->start->ts.kind != iter->var->ts.kind
2463       || iter->start->ts.type != iter->var->ts.type)
2464     gfc_convert_type (iter->start, &iter->var->ts, 2);
2465
2466   if (iter->end->ts.kind != iter->var->ts.kind
2467       || iter->end->ts.type != iter->var->ts.type)
2468     gfc_convert_type (iter->end, &iter->var->ts, 2);
2469
2470   if (iter->step->ts.kind != iter->var->ts.kind
2471       || iter->step->ts.type != iter->var->ts.type)
2472     gfc_convert_type (iter->step, &iter->var->ts, 2);
2473
2474   return SUCCESS;
2475 }
2476
2477
2478 /* Resolve a list of FORALL iterators.  */
2479
2480 static void
2481 resolve_forall_iterators (gfc_forall_iterator * iter)
2482 {
2483
2484   while (iter)
2485     {
2486       if (gfc_resolve_expr (iter->var) == SUCCESS
2487           && iter->var->ts.type != BT_INTEGER)
2488         gfc_error ("FORALL Iteration variable at %L must be INTEGER",
2489                    &iter->var->where);
2490
2491       if (gfc_resolve_expr (iter->start) == SUCCESS
2492           && iter->start->ts.type != BT_INTEGER)
2493         gfc_error ("FORALL start expression at %L must be INTEGER",
2494                    &iter->start->where);
2495       if (iter->var->ts.kind != iter->start->ts.kind)
2496         gfc_convert_type (iter->start, &iter->var->ts, 2);
2497
2498       if (gfc_resolve_expr (iter->end) == SUCCESS
2499           && iter->end->ts.type != BT_INTEGER)
2500         gfc_error ("FORALL end expression at %L must be INTEGER",
2501                    &iter->end->where);
2502       if (iter->var->ts.kind != iter->end->ts.kind)
2503         gfc_convert_type (iter->end, &iter->var->ts, 2);
2504
2505       if (gfc_resolve_expr (iter->stride) == SUCCESS
2506           && iter->stride->ts.type != BT_INTEGER)
2507         gfc_error ("FORALL Stride expression at %L must be INTEGER",
2508                    &iter->stride->where);
2509       if (iter->var->ts.kind != iter->stride->ts.kind)
2510         gfc_convert_type (iter->stride, &iter->var->ts, 2);
2511
2512       iter = iter->next;
2513     }
2514 }
2515
2516
2517 /* Given a pointer to a symbol that is a derived type, see if any components
2518    have the POINTER attribute.  The search is recursive if necessary.
2519    Returns zero if no pointer components are found, nonzero otherwise.  */
2520
2521 static int
2522 derived_pointer (gfc_symbol * sym)
2523 {
2524   gfc_component *c;
2525
2526   for (c = sym->components; c; c = c->next)
2527     {
2528       if (c->pointer)
2529         return 1;
2530
2531       if (c->ts.type == BT_DERIVED && derived_pointer (c->ts.derived))
2532         return 1;
2533     }
2534
2535   return 0;
2536 }
2537
2538
2539 /* Given a pointer to a symbol that is a derived type, see if it's
2540    inaccessible, i.e. if it's defined in another module and the components are
2541    PRIVATE.  The search is recursive if necessary.  Returns zero if no
2542    inaccessible components are found, nonzero otherwise.  */
2543
2544 static int
2545 derived_inaccessible (gfc_symbol *sym)
2546 {
2547   gfc_component *c;
2548
2549   if (sym->attr.use_assoc && sym->component_access == ACCESS_PRIVATE)
2550     return 1;
2551
2552   for (c = sym->components; c; c = c->next)
2553     {
2554         if (c->ts.type == BT_DERIVED && derived_inaccessible (c->ts.derived))
2555           return 1;
2556     }
2557
2558   return 0;
2559 }
2560
2561
2562 /* Resolve the argument of a deallocate expression.  The expression must be
2563    a pointer or a full array.  */
2564
2565 static try
2566 resolve_deallocate_expr (gfc_expr * e)
2567 {
2568   symbol_attribute attr;
2569   int allocatable;
2570   gfc_ref *ref;
2571
2572   if (gfc_resolve_expr (e) == FAILURE)
2573     return FAILURE;
2574
2575   attr = gfc_expr_attr (e);
2576   if (attr.pointer)
2577     return SUCCESS;
2578
2579   if (e->expr_type != EXPR_VARIABLE)
2580     goto bad;
2581
2582   allocatable = e->symtree->n.sym->attr.allocatable;
2583   for (ref = e->ref; ref; ref = ref->next)
2584     switch (ref->type)
2585       {
2586       case REF_ARRAY:
2587         if (ref->u.ar.type != AR_FULL)
2588           allocatable = 0;
2589         break;
2590
2591       case REF_COMPONENT:
2592         allocatable = (ref->u.c.component->as != NULL
2593                        && ref->u.c.component->as->type == AS_DEFERRED);
2594         break;
2595
2596       case REF_SUBSTRING:
2597         allocatable = 0;
2598         break;
2599       }
2600
2601   if (allocatable == 0)
2602     {
2603     bad:
2604       gfc_error ("Expression in DEALLOCATE statement at %L must be "
2605                  "ALLOCATABLE or a POINTER", &e->where);
2606     }
2607
2608   return SUCCESS;
2609 }
2610
2611
2612 /* Given the expression node e for an allocatable/pointer of derived type to be
2613    allocated, get the expression node to be initialized afterwards (needed for
2614    derived types with default initializers).  */
2615
2616 static gfc_expr *
2617 expr_to_initialize (gfc_expr * e)
2618 {
2619   gfc_expr *result;
2620   gfc_ref *ref;
2621   int i;
2622
2623   result = gfc_copy_expr (e);
2624
2625   /* Change the last array reference from AR_ELEMENT to AR_FULL.  */
2626   for (ref = result->ref; ref; ref = ref->next)
2627     if (ref->type == REF_ARRAY && ref->next == NULL)
2628       {
2629         ref->u.ar.type = AR_FULL;
2630
2631         for (i = 0; i < ref->u.ar.dimen; i++)
2632           ref->u.ar.start[i] = ref->u.ar.end[i] = ref->u.ar.stride[i] = NULL;
2633
2634         result->rank = ref->u.ar.dimen; 
2635         break;
2636       }
2637
2638   return result;
2639 }
2640
2641
2642 /* Resolve the expression in an ALLOCATE statement, doing the additional
2643    checks to see whether the expression is OK or not.  The expression must
2644    have a trailing array reference that gives the size of the array.  */
2645
2646 static try
2647 resolve_allocate_expr (gfc_expr * e, gfc_code * code)
2648 {
2649   int i, pointer, allocatable, dimension;
2650   symbol_attribute attr;
2651   gfc_ref *ref, *ref2;
2652   gfc_array_ref *ar;
2653   gfc_code *init_st;
2654   gfc_expr *init_e;
2655
2656   if (gfc_resolve_expr (e) == FAILURE)
2657     return FAILURE;
2658
2659   /* Make sure the expression is allocatable or a pointer.  If it is
2660      pointer, the next-to-last reference must be a pointer.  */
2661
2662   ref2 = NULL;
2663
2664   if (e->expr_type != EXPR_VARIABLE)
2665     {
2666       allocatable = 0;
2667
2668       attr = gfc_expr_attr (e);
2669       pointer = attr.pointer;
2670       dimension = attr.dimension;
2671
2672     }
2673   else
2674     {
2675       allocatable = e->symtree->n.sym->attr.allocatable;
2676       pointer = e->symtree->n.sym->attr.pointer;
2677       dimension = e->symtree->n.sym->attr.dimension;
2678
2679       for (ref = e->ref; ref; ref2 = ref, ref = ref->next)
2680         switch (ref->type)
2681           {
2682           case REF_ARRAY:
2683             if (ref->next != NULL)
2684               pointer = 0;
2685             break;
2686
2687           case REF_COMPONENT:
2688             allocatable = (ref->u.c.component->as != NULL
2689                            && ref->u.c.component->as->type == AS_DEFERRED);
2690
2691             pointer = ref->u.c.component->pointer;
2692             dimension = ref->u.c.component->dimension;
2693             break;
2694
2695           case REF_SUBSTRING:
2696             allocatable = 0;
2697             pointer = 0;
2698             break;
2699           }
2700     }
2701
2702   if (allocatable == 0 && pointer == 0)
2703     {
2704       gfc_error ("Expression in ALLOCATE statement at %L must be "
2705                  "ALLOCATABLE or a POINTER", &e->where);
2706       return FAILURE;
2707     }
2708
2709   /* Add default initializer for those derived types that need them.  */
2710   if (e->ts.type == BT_DERIVED && (init_e = gfc_default_initializer (&e->ts)))
2711     {
2712         init_st = gfc_get_code ();
2713         init_st->loc = code->loc;
2714         init_st->op = EXEC_ASSIGN;
2715         init_st->expr = expr_to_initialize (e);
2716         init_st->expr2 = init_e;
2717
2718         init_st->next = code->next;
2719         code->next = init_st;
2720     }
2721
2722   if (pointer && dimension == 0)
2723     return SUCCESS;
2724
2725   /* Make sure the next-to-last reference node is an array specification.  */
2726
2727   if (ref2 == NULL || ref2->type != REF_ARRAY || ref2->u.ar.type == AR_FULL)
2728     {
2729       gfc_error ("Array specification required in ALLOCATE statement "
2730                  "at %L", &e->where);
2731       return FAILURE;
2732     }
2733
2734   if (ref2->u.ar.type == AR_ELEMENT)
2735     return SUCCESS;
2736
2737   /* Make sure that the array section reference makes sense in the
2738     context of an ALLOCATE specification.  */
2739
2740   ar = &ref2->u.ar;
2741
2742   for (i = 0; i < ar->dimen; i++)
2743     switch (ar->dimen_type[i])
2744       {
2745       case DIMEN_ELEMENT:
2746         break;
2747
2748       case DIMEN_RANGE:
2749         if (ar->start[i] != NULL
2750             && ar->end[i] != NULL
2751             && ar->stride[i] == NULL)
2752           break;
2753
2754         /* Fall Through...  */
2755
2756       case DIMEN_UNKNOWN:
2757       case DIMEN_VECTOR:
2758         gfc_error ("Bad array specification in ALLOCATE statement at %L",
2759                    &e->where);
2760         return FAILURE;
2761       }
2762
2763   return SUCCESS;
2764 }
2765
2766
2767 /************ SELECT CASE resolution subroutines ************/
2768
2769 /* Callback function for our mergesort variant.  Determines interval
2770    overlaps for CASEs. Return <0 if op1 < op2, 0 for overlap, >0 for
2771    op1 > op2.  Assumes we're not dealing with the default case.  
2772    We have op1 = (:L), (K:L) or (K:) and op2 = (:N), (M:N) or (M:).
2773    There are nine situations to check.  */
2774
2775 static int
2776 compare_cases (const gfc_case * op1, const gfc_case * op2)
2777 {
2778   int retval;
2779
2780   if (op1->low == NULL) /* op1 = (:L)  */
2781     {
2782       /* op2 = (:N), so overlap.  */
2783       retval = 0;
2784       /* op2 = (M:) or (M:N),  L < M  */
2785       if (op2->low != NULL
2786           && gfc_compare_expr (op1->high, op2->low) < 0)
2787         retval = -1;
2788     }
2789   else if (op1->high == NULL) /* op1 = (K:)  */
2790     {
2791       /* op2 = (M:), so overlap.  */
2792       retval = 0;
2793       /* op2 = (:N) or (M:N), K > N  */
2794       if (op2->high != NULL
2795           && gfc_compare_expr (op1->low, op2->high) > 0)
2796         retval = 1;
2797     }
2798   else /* op1 = (K:L)  */
2799     {
2800       if (op2->low == NULL)       /* op2 = (:N), K > N  */
2801         retval = (gfc_compare_expr (op1->low, op2->high) > 0) ? 1 : 0;
2802       else if (op2->high == NULL) /* op2 = (M:), L < M  */
2803         retval = (gfc_compare_expr (op1->high, op2->low) < 0) ? -1 : 0;
2804       else                        /* op2 = (M:N)  */
2805         {
2806           retval =  0;
2807           /* L < M  */
2808           if (gfc_compare_expr (op1->high, op2->low) < 0)
2809             retval =  -1;
2810           /* K > N  */
2811           else if (gfc_compare_expr (op1->low, op2->high) > 0)
2812             retval =  1;
2813         }
2814     }
2815
2816   return retval;
2817 }
2818
2819
2820 /* Merge-sort a double linked case list, detecting overlap in the
2821    process.  LIST is the head of the double linked case list before it
2822    is sorted.  Returns the head of the sorted list if we don't see any
2823    overlap, or NULL otherwise.  */
2824
2825 static gfc_case *
2826 check_case_overlap (gfc_case * list)
2827 {
2828   gfc_case *p, *q, *e, *tail;
2829   int insize, nmerges, psize, qsize, cmp, overlap_seen;
2830
2831   /* If the passed list was empty, return immediately.  */
2832   if (!list)
2833     return NULL;
2834
2835   overlap_seen = 0;
2836   insize = 1;
2837
2838   /* Loop unconditionally.  The only exit from this loop is a return
2839      statement, when we've finished sorting the case list.  */
2840   for (;;)
2841     {
2842       p = list;
2843       list = NULL;
2844       tail = NULL;
2845
2846       /* Count the number of merges we do in this pass.  */
2847       nmerges = 0;
2848
2849       /* Loop while there exists a merge to be done.  */
2850       while (p)
2851         {
2852           int i;
2853
2854           /* Count this merge.  */
2855           nmerges++;
2856
2857           /* Cut the list in two pieces by stepping INSIZE places
2858              forward in the list, starting from P.  */
2859           psize = 0;
2860           q = p;
2861           for (i = 0; i < insize; i++)
2862             {
2863               psize++;
2864               q = q->right;
2865               if (!q)
2866                 break;
2867             }
2868           qsize = insize;
2869
2870           /* Now we have two lists.  Merge them!  */
2871           while (psize > 0 || (qsize > 0 && q != NULL))
2872             {
2873
2874               /* See from which the next case to merge comes from.  */
2875               if (psize == 0)
2876                 {
2877                   /* P is empty so the next case must come from Q.  */
2878                   e = q;
2879                   q = q->right;
2880                   qsize--;
2881                 }
2882               else if (qsize == 0 || q == NULL)
2883                 {
2884                   /* Q is empty.  */
2885                   e = p;
2886                   p = p->right;
2887                   psize--;
2888                 }
2889               else
2890                 {
2891                   cmp = compare_cases (p, q);
2892                   if (cmp < 0)
2893                     {
2894                       /* The whole case range for P is less than the
2895                          one for Q.  */
2896                       e = p;
2897                       p = p->right;
2898                       psize--;
2899                     }
2900                   else if (cmp > 0)
2901                     {
2902                       /* The whole case range for Q is greater than
2903                          the case range for P.  */
2904                       e = q;
2905                       q = q->right;
2906                       qsize--;
2907                     }
2908                   else
2909                     {
2910                       /* The cases overlap, or they are the same
2911                          element in the list.  Either way, we must
2912                          issue an error and get the next case from P.  */
2913                       /* FIXME: Sort P and Q by line number.  */
2914                       gfc_error ("CASE label at %L overlaps with CASE "
2915                                  "label at %L", &p->where, &q->where);
2916                       overlap_seen = 1;
2917                       e = p;
2918                       p = p->right;
2919                       psize--;
2920                     }
2921                 }
2922
2923                 /* Add the next element to the merged list.  */
2924               if (tail)
2925                 tail->right = e;
2926               else
2927                 list = e;
2928               e->left = tail;
2929               tail = e;
2930             }
2931
2932           /* P has now stepped INSIZE places along, and so has Q.  So
2933              they're the same.  */
2934           p = q;
2935         }
2936       tail->right = NULL;
2937
2938       /* If we have done only one merge or none at all, we've
2939          finished sorting the cases.  */
2940       if (nmerges <= 1)
2941         {
2942           if (!overlap_seen)
2943             return list;
2944           else
2945             return NULL;
2946         }
2947
2948       /* Otherwise repeat, merging lists twice the size.  */
2949       insize *= 2;
2950     }
2951 }
2952
2953
2954 /* Check to see if an expression is suitable for use in a CASE statement.
2955    Makes sure that all case expressions are scalar constants of the same
2956    type.  Return FAILURE if anything is wrong.  */
2957
2958 static try
2959 validate_case_label_expr (gfc_expr * e, gfc_expr * case_expr)
2960 {
2961   if (e == NULL) return SUCCESS;
2962
2963   if (e->ts.type != case_expr->ts.type)
2964     {
2965       gfc_error ("Expression in CASE statement at %L must be of type %s",
2966                  &e->where, gfc_basic_typename (case_expr->ts.type));
2967       return FAILURE;
2968     }
2969
2970   /* C805 (R808) For a given case-construct, each case-value shall be of
2971      the same type as case-expr.  For character type, length differences
2972      are allowed, but the kind type parameters shall be the same.  */
2973
2974   if (case_expr->ts.type == BT_CHARACTER && e->ts.kind != case_expr->ts.kind)
2975     {
2976       gfc_error("Expression in CASE statement at %L must be kind %d",
2977                 &e->where, case_expr->ts.kind);
2978       return FAILURE;
2979     }
2980
2981   /* Convert the case value kind to that of case expression kind, if needed.
2982      FIXME:  Should a warning be issued?  */
2983   if (e->ts.kind != case_expr->ts.kind)
2984     gfc_convert_type_warn (e, &case_expr->ts, 2, 0);
2985
2986   if (e->rank != 0)
2987     {
2988       gfc_error ("Expression in CASE statement at %L must be scalar",
2989                  &e->where);
2990       return FAILURE;
2991     }
2992
2993   return SUCCESS;
2994 }
2995
2996
2997 /* Given a completely parsed select statement, we:
2998
2999      - Validate all expressions and code within the SELECT.
3000      - Make sure that the selection expression is not of the wrong type.
3001      - Make sure that no case ranges overlap.
3002      - Eliminate unreachable cases and unreachable code resulting from
3003        removing case labels.
3004
3005    The standard does allow unreachable cases, e.g. CASE (5:3).  But
3006    they are a hassle for code generation, and to prevent that, we just
3007    cut them out here.  This is not necessary for overlapping cases
3008    because they are illegal and we never even try to generate code.
3009
3010    We have the additional caveat that a SELECT construct could have
3011    been a computed GOTO in the source code. Fortunately we can fairly
3012    easily work around that here: The case_expr for a "real" SELECT CASE
3013    is in code->expr1, but for a computed GOTO it is in code->expr2. All
3014    we have to do is make sure that the case_expr is a scalar integer
3015    expression.  */
3016
3017 static void
3018 resolve_select (gfc_code * code)
3019 {
3020   gfc_code *body;
3021   gfc_expr *case_expr;
3022   gfc_case *cp, *default_case, *tail, *head;
3023   int seen_unreachable;
3024   int ncases;
3025   bt type;
3026   try t;
3027
3028   if (code->expr == NULL)
3029     {
3030       /* This was actually a computed GOTO statement.  */
3031       case_expr = code->expr2;
3032       if (case_expr->ts.type != BT_INTEGER
3033           || case_expr->rank != 0)
3034         gfc_error ("Selection expression in computed GOTO statement "
3035                    "at %L must be a scalar integer expression",
3036                    &case_expr->where);
3037
3038       /* Further checking is not necessary because this SELECT was built
3039          by the compiler, so it should always be OK.  Just move the
3040          case_expr from expr2 to expr so that we can handle computed
3041          GOTOs as normal SELECTs from here on.  */
3042       code->expr = code->expr2;
3043       code->expr2 = NULL;
3044       return;
3045     }
3046
3047   case_expr = code->expr;
3048
3049   type = case_expr->ts.type;
3050   if (type != BT_LOGICAL && type != BT_INTEGER && type != BT_CHARACTER)
3051     {
3052       gfc_error ("Argument of SELECT statement at %L cannot be %s",
3053                  &case_expr->where, gfc_typename (&case_expr->ts));
3054
3055       /* Punt. Going on here just produce more garbage error messages.  */
3056       return;
3057     }
3058
3059   if (case_expr->rank != 0)
3060     {
3061       gfc_error ("Argument of SELECT statement at %L must be a scalar "
3062                  "expression", &case_expr->where);
3063
3064       /* Punt.  */
3065       return;
3066     }
3067
3068   /* PR 19168 has a long discussion concerning a mismatch of the kinds
3069      of the SELECT CASE expression and its CASE values.  Walk the lists
3070      of case values, and if we find a mismatch, promote case_expr to
3071      the appropriate kind.  */
3072
3073   if (type == BT_LOGICAL || type == BT_INTEGER)
3074     {
3075       for (body = code->block; body; body = body->block)
3076         {
3077           /* Walk the case label list.  */
3078           for (cp = body->ext.case_list; cp; cp = cp->next)
3079             {
3080               /* Intercept the DEFAULT case.  It does not have a kind.  */
3081               if (cp->low == NULL && cp->high == NULL)
3082                 continue;
3083
3084               /* Unreachable case ranges are discarded, so ignore.  */  
3085               if (cp->low != NULL && cp->high != NULL
3086                   && cp->low != cp->high
3087                   && gfc_compare_expr (cp->low, cp->high) > 0)
3088                 continue;
3089
3090               /* FIXME: Should a warning be issued?  */
3091               if (cp->low != NULL
3092                   && case_expr->ts.kind != gfc_kind_max(case_expr, cp->low))
3093                 gfc_convert_type_warn (case_expr, &cp->low->ts, 2, 0);
3094
3095               if (cp->high != NULL
3096                   && case_expr->ts.kind != gfc_kind_max(case_expr, cp->high))
3097                 gfc_convert_type_warn (case_expr, &cp->high->ts, 2, 0);
3098             }
3099          }
3100     }
3101
3102   /* Assume there is no DEFAULT case.  */
3103   default_case = NULL;
3104   head = tail = NULL;
3105   ncases = 0;
3106
3107   for (body = code->block; body; body = body->block)
3108     {
3109       /* Assume the CASE list is OK, and all CASE labels can be matched.  */
3110       t = SUCCESS;
3111       seen_unreachable = 0;
3112
3113       /* Walk the case label list, making sure that all case labels
3114          are legal.  */
3115       for (cp = body->ext.case_list; cp; cp = cp->next)
3116         {
3117           /* Count the number of cases in the whole construct.  */
3118           ncases++;
3119
3120           /* Intercept the DEFAULT case.  */
3121           if (cp->low == NULL && cp->high == NULL)
3122             {
3123               if (default_case != NULL)
3124                 {
3125                   gfc_error ("The DEFAULT CASE at %L cannot be followed "
3126                              "by a second DEFAULT CASE at %L",
3127                              &default_case->where, &cp->where);
3128                   t = FAILURE;
3129                   break;
3130                 }
3131               else
3132                 {
3133                   default_case = cp;
3134                   continue;
3135                 }
3136             }
3137
3138           /* Deal with single value cases and case ranges.  Errors are
3139              issued from the validation function.  */
3140           if(validate_case_label_expr (cp->low, case_expr) != SUCCESS
3141              || validate_case_label_expr (cp->high, case_expr) != SUCCESS)
3142             {
3143               t = FAILURE;
3144               break;
3145             }
3146
3147           if (type == BT_LOGICAL
3148               && ((cp->low == NULL || cp->high == NULL)
3149                   || cp->low != cp->high))
3150             {
3151               gfc_error
3152                 ("Logical range in CASE statement at %L is not allowed",
3153                  &cp->low->where);
3154               t = FAILURE;
3155               break;
3156             }
3157
3158           if (cp->low != NULL && cp->high != NULL
3159               && cp->low != cp->high
3160               && gfc_compare_expr (cp->low, cp->high) > 0)
3161             {
3162               if (gfc_option.warn_surprising)
3163                 gfc_warning ("Range specification at %L can never "
3164                              "be matched", &cp->where);
3165
3166               cp->unreachable = 1;
3167               seen_unreachable = 1;
3168             }
3169           else
3170             {
3171               /* If the case range can be matched, it can also overlap with
3172                  other cases.  To make sure it does not, we put it in a
3173                  double linked list here.  We sort that with a merge sort
3174                  later on to detect any overlapping cases.  */
3175               if (!head)
3176                 {
3177                   head = tail = cp;
3178                   head->right = head->left = NULL;
3179                 }
3180               else
3181                 {
3182                   tail->right = cp;
3183                   tail->right->left = tail;
3184                   tail = tail->right;
3185                   tail->right = NULL;
3186                 }
3187             }
3188         }
3189
3190       /* It there was a failure in the previous case label, give up
3191          for this case label list.  Continue with the next block.  */
3192       if (t == FAILURE)
3193         continue;
3194
3195       /* See if any case labels that are unreachable have been seen.
3196          If so, we eliminate them.  This is a bit of a kludge because
3197          the case lists for a single case statement (label) is a
3198          single forward linked lists.  */
3199       if (seen_unreachable)
3200       {
3201         /* Advance until the first case in the list is reachable.  */
3202         while (body->ext.case_list != NULL
3203                && body->ext.case_list->unreachable)
3204           {
3205             gfc_case *n = body->ext.case_list;
3206             body->ext.case_list = body->ext.case_list->next;
3207             n->next = NULL;
3208             gfc_free_case_list (n);
3209           }
3210
3211         /* Strip all other unreachable cases.  */
3212         if (body->ext.case_list)
3213           {
3214             for (cp = body->ext.case_list; cp->next; cp = cp->next)
3215               {
3216                 if (cp->next->unreachable)
3217                   {
3218                     gfc_case *n = cp->next;
3219                     cp->next = cp->next->next;
3220                     n->next = NULL;
3221                     gfc_free_case_list (n);
3222                   }
3223               }
3224           }
3225       }
3226     }
3227
3228   /* See if there were overlapping cases.  If the check returns NULL,
3229      there was overlap.  In that case we don't do anything.  If head
3230      is non-NULL, we prepend the DEFAULT case.  The sorted list can
3231      then used during code generation for SELECT CASE constructs with
3232      a case expression of a CHARACTER type.  */
3233   if (head)
3234     {
3235       head = check_case_overlap (head);
3236
3237       /* Prepend the default_case if it is there.  */
3238       if (head != NULL && default_case)
3239         {
3240           default_case->left = NULL;
3241           default_case->right = head;
3242           head->left = default_case;
3243         }
3244     }
3245
3246   /* Eliminate dead blocks that may be the result if we've seen
3247      unreachable case labels for a block.  */
3248   for (body = code; body && body->block; body = body->block)
3249     {
3250       if (body->block->ext.case_list == NULL)
3251         {
3252           /* Cut the unreachable block from the code chain.  */
3253           gfc_code *c = body->block;
3254           body->block = c->block;
3255
3256           /* Kill the dead block, but not the blocks below it.  */
3257           c->block = NULL;
3258           gfc_free_statements (c);
3259         }
3260     }
3261
3262   /* More than two cases is legal but insane for logical selects.
3263      Issue a warning for it.  */
3264   if (gfc_option.warn_surprising && type == BT_LOGICAL
3265       && ncases > 2)
3266     gfc_warning ("Logical SELECT CASE block at %L has more that two cases",
3267                  &code->loc);
3268 }
3269
3270
3271 /* Resolve a transfer statement. This is making sure that:
3272    -- a derived type being transferred has only non-pointer components
3273    -- a derived type being transferred doesn't have private components, unless 
3274       it's being transferred from the module where the type was defined
3275    -- we're not trying to transfer a whole assumed size array.  */
3276
3277 static void
3278 resolve_transfer (gfc_code * code)
3279 {
3280   gfc_typespec *ts;
3281   gfc_symbol *sym;
3282   gfc_ref *ref;
3283   gfc_expr *exp;
3284
3285   exp = code->expr;
3286
3287   if (exp->expr_type != EXPR_VARIABLE)
3288     return;
3289
3290   sym = exp->symtree->n.sym;
3291   ts = &sym->ts;
3292
3293   /* Go to actual component transferred.  */
3294   for (ref = code->expr->ref; ref; ref = ref->next)
3295     if (ref->type == REF_COMPONENT)
3296       ts = &ref->u.c.component->ts;
3297
3298   if (ts->type == BT_DERIVED)
3299     {
3300       /* Check that transferred derived type doesn't contain POINTER
3301          components.  */
3302       if (derived_pointer (ts->derived))
3303         {
3304           gfc_error ("Data transfer element at %L cannot have "
3305                      "POINTER components", &code->loc);
3306           return;
3307         }
3308
3309       if (derived_inaccessible (ts->derived))
3310         {
3311           gfc_error ("Data transfer element at %L cannot have "
3312                      "PRIVATE components",&code->loc);
3313           return;
3314         }
3315     }
3316
3317   if (sym->as != NULL && sym->as->type == AS_ASSUMED_SIZE
3318       && exp->ref->type == REF_ARRAY && exp->ref->u.ar.type == AR_FULL)
3319     {
3320       gfc_error ("Data transfer element at %L cannot be a full reference to "
3321                  "an assumed-size array", &code->loc);
3322       return;
3323     }
3324 }
3325
3326
3327 /*********** Toplevel code resolution subroutines ***********/
3328
3329 /* Given a branch to a label and a namespace, if the branch is conforming.
3330    The code node described where the branch is located.  */
3331
3332 static void
3333 resolve_branch (gfc_st_label * label, gfc_code * code)
3334 {
3335   gfc_code *block, *found;
3336   code_stack *stack;
3337   gfc_st_label *lp;
3338
3339   if (label == NULL)
3340     return;
3341   lp = label;
3342
3343   /* Step one: is this a valid branching target?  */
3344
3345   if (lp->defined == ST_LABEL_UNKNOWN)
3346     {
3347       gfc_error ("Label %d referenced at %L is never defined", lp->value,
3348                  &lp->where);
3349       return;
3350     }
3351
3352   if (lp->defined != ST_LABEL_TARGET)
3353     {
3354       gfc_error ("Statement at %L is not a valid branch target statement "
3355                  "for the branch statement at %L", &lp->where, &code->loc);
3356       return;
3357     }
3358
3359   /* Step two: make sure this branch is not a branch to itself ;-)  */
3360
3361   if (code->here == label)
3362     {
3363       gfc_warning ("Branch at %L causes an infinite loop", &code->loc);
3364       return;
3365     }
3366
3367   /* Step three: Try to find the label in the parse tree. To do this,
3368      we traverse the tree block-by-block: first the block that
3369      contains this GOTO, then the block that it is nested in, etc.  We
3370      can ignore other blocks because branching into another block is
3371      not allowed.  */
3372
3373   found = NULL;
3374
3375   for (stack = cs_base; stack; stack = stack->prev)
3376     {
3377       for (block = stack->head; block; block = block->next)
3378         {
3379           if (block->here == label)
3380             {
3381               found = block;
3382               break;
3383             }
3384         }
3385
3386       if (found)
3387         break;
3388     }
3389
3390   if (found == NULL)
3391     {
3392       /* still nothing, so illegal.  */
3393       gfc_error_now ("Label at %L is not in the same block as the "
3394                      "GOTO statement at %L", &lp->where, &code->loc);
3395       return;
3396     }
3397
3398   /* Step four: Make sure that the branching target is legal if
3399      the statement is an END {SELECT,DO,IF}.  */
3400
3401   if (found->op == EXEC_NOP)
3402     {
3403       for (stack = cs_base; stack; stack = stack->prev)
3404         if (stack->current->next == found)
3405           break;
3406
3407       if (stack == NULL)
3408         gfc_notify_std (GFC_STD_F95_DEL,
3409                         "Obsolete: GOTO at %L jumps to END of construct at %L",
3410                         &code->loc, &found->loc);
3411     }
3412 }
3413
3414
3415 /* Check whether EXPR1 has the same shape as EXPR2.  */
3416
3417 static try
3418 resolve_where_shape (gfc_expr *expr1, gfc_expr *expr2)
3419 {
3420   mpz_t shape[GFC_MAX_DIMENSIONS];
3421   mpz_t shape2[GFC_MAX_DIMENSIONS];
3422   try result = FAILURE;
3423   int i;
3424
3425   /* Compare the rank.  */
3426   if (expr1->rank != expr2->rank)
3427     return result;
3428
3429   /* Compare the size of each dimension.  */
3430   for (i=0; i<expr1->rank; i++)
3431     {
3432       if (gfc_array_dimen_size (expr1, i, &shape[i]) == FAILURE)
3433         goto ignore;
3434
3435       if (gfc_array_dimen_size (expr2, i, &shape2[i]) == FAILURE)
3436         goto ignore;
3437
3438       if (mpz_cmp (shape[i], shape2[i]))
3439         goto over;
3440     }
3441
3442   /* When either of the two expression is an assumed size array, we
3443      ignore the comparison of dimension sizes.  */
3444 ignore:
3445   result = SUCCESS;
3446
3447 over:
3448   for (i--; i>=0; i--)
3449     {
3450       mpz_clear (shape[i]);
3451       mpz_clear (shape2[i]);
3452     }
3453   return result;
3454 }
3455
3456
3457 /* Check whether a WHERE assignment target or a WHERE mask expression
3458    has the same shape as the outmost WHERE mask expression.  */
3459
3460 static void
3461 resolve_where (gfc_code *code, gfc_expr *mask)
3462 {
3463   gfc_code *cblock;
3464   gfc_code *cnext;
3465   gfc_expr *e = NULL;
3466
3467   cblock = code->block;
3468
3469   /* Store the first WHERE mask-expr of the WHERE statement or construct.
3470      In case of nested WHERE, only the outmost one is stored.  */
3471   if (mask == NULL) /* outmost WHERE */
3472     e = cblock->expr;
3473   else /* inner WHERE */
3474     e = mask;
3475
3476   while (cblock)
3477     {
3478       if (cblock->expr)
3479         {
3480           /* Check if the mask-expr has a consistent shape with the
3481              outmost WHERE mask-expr.  */
3482           if (resolve_where_shape (cblock->expr, e) == FAILURE)
3483             gfc_error ("WHERE mask at %L has inconsistent shape",
3484                        &cblock->expr->where);
3485          }
3486
3487       /* the assignment statement of a WHERE statement, or the first
3488          statement in where-body-construct of a WHERE construct */
3489       cnext = cblock->next;
3490       while (cnext)
3491         {
3492           switch (cnext->op)
3493             {
3494             /* WHERE assignment statement */
3495             case EXEC_ASSIGN:
3496
3497               /* Check shape consistent for WHERE assignment target.  */
3498               if (e && resolve_where_shape (cnext->expr, e) == FAILURE)
3499                gfc_error ("WHERE assignment target at %L has "
3500                           "inconsistent shape", &cnext->expr->where);
3501               break;
3502
3503             /* WHERE or WHERE construct is part of a where-body-construct */
3504             case EXEC_WHERE:
3505               resolve_where (cnext, e);
3506               break;
3507
3508             default:
3509               gfc_error ("Unsupported statement inside WHERE at %L",
3510                          &cnext->loc);
3511             }
3512          /* the next statement within the same where-body-construct */
3513          cnext = cnext->next;
3514        }
3515     /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
3516     cblock = cblock->block;
3517   }
3518 }
3519
3520
3521 /* Check whether the FORALL index appears in the expression or not.  */
3522
3523 static try
3524 gfc_find_forall_index (gfc_expr *expr, gfc_symbol *symbol)
3525 {
3526   gfc_array_ref ar;
3527   gfc_ref *tmp;
3528   gfc_actual_arglist *args;
3529   int i;
3530
3531   switch (expr->expr_type)
3532     {
3533     case EXPR_VARIABLE:
3534       gcc_assert (expr->symtree->n.sym);
3535
3536       /* A scalar assignment  */
3537       if (!expr->ref)
3538         {
3539           if (expr->symtree->n.sym == symbol)
3540             return SUCCESS;
3541           else
3542             return FAILURE;
3543         }
3544
3545       /* the expr is array ref, substring or struct component.  */
3546       tmp = expr->ref;
3547       while (tmp != NULL)
3548         {
3549           switch (tmp->type)
3550             {
3551             case  REF_ARRAY:
3552               /* Check if the symbol appears in the array subscript.  */
3553               ar = tmp->u.ar;
3554               for (i = 0; i < GFC_MAX_DIMENSIONS; i++)
3555                 {
3556                   if (ar.start[i])
3557                     if (gfc_find_forall_index (ar.start[i], symbol) == SUCCESS)
3558                       return SUCCESS;
3559
3560                   if (ar.end[i])
3561                     if (gfc_find_forall_index (ar.end[i], symbol) == SUCCESS)
3562                       return SUCCESS;
3563
3564                   if (ar.stride[i])
3565                     if (gfc_find_forall_index (ar.stride[i], symbol) == SUCCESS)
3566                       return SUCCESS;
3567                 }  /* end for  *