OSDN Git Service

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