OSDN Git Service

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