OSDN Git Service

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