OSDN Git Service

4d98f462a827ba35e215a17f9436d3e4cf00ee36
[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
1253 /* Resolve an operator expression node.  This can involve replacing the
1254    operation with a user defined function call.  */
1255
1256 static try
1257 resolve_operator (gfc_expr * e)
1258 {
1259   gfc_expr *op1, *op2;
1260   char msg[200];
1261   try t;
1262
1263   /* Resolve all subnodes-- give them types.  */
1264
1265   switch (e->value.op.operator)
1266     {
1267     default:
1268       if (gfc_resolve_expr (e->value.op.op2) == FAILURE)
1269         return FAILURE;
1270
1271     /* Fall through...  */
1272
1273     case INTRINSIC_NOT:
1274     case INTRINSIC_UPLUS:
1275     case INTRINSIC_UMINUS:
1276       if (gfc_resolve_expr (e->value.op.op1) == FAILURE)
1277         return FAILURE;
1278       break;
1279     }
1280
1281   /* Typecheck the new node.  */
1282
1283   op1 = e->value.op.op1;
1284   op2 = e->value.op.op2;
1285
1286   switch (e->value.op.operator)
1287     {
1288     case INTRINSIC_UPLUS:
1289     case INTRINSIC_UMINUS:
1290       if (op1->ts.type == BT_INTEGER
1291           || op1->ts.type == BT_REAL
1292           || op1->ts.type == BT_COMPLEX)
1293         {
1294           e->ts = op1->ts;
1295           break;
1296         }
1297
1298       sprintf (msg, "Operand of unary numeric operator '%s' at %%L is %s",
1299                gfc_op2string (e->value.op.operator), gfc_typename (&e->ts));
1300       goto bad_op;
1301
1302     case INTRINSIC_PLUS:
1303     case INTRINSIC_MINUS:
1304     case INTRINSIC_TIMES:
1305     case INTRINSIC_DIVIDE:
1306     case INTRINSIC_POWER:
1307       if (gfc_numeric_ts (&op1->ts) && gfc_numeric_ts (&op2->ts))
1308         {
1309           gfc_type_convert_binary (e);
1310           break;
1311         }
1312
1313       sprintf (msg,
1314                "Operands of binary numeric operator '%s' at %%L are %s/%s",
1315                gfc_op2string (e->value.op.operator), gfc_typename (&op1->ts),
1316                gfc_typename (&op2->ts));
1317       goto bad_op;
1318
1319     case INTRINSIC_CONCAT:
1320       if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER)
1321         {
1322           e->ts.type = BT_CHARACTER;
1323           e->ts.kind = op1->ts.kind;
1324           break;
1325         }
1326
1327       sprintf (msg,
1328                "Operands of string concatenation operator at %%L are %s/%s",
1329                gfc_typename (&op1->ts), gfc_typename (&op2->ts));
1330       goto bad_op;
1331
1332     case INTRINSIC_AND:
1333     case INTRINSIC_OR:
1334     case INTRINSIC_EQV:
1335     case INTRINSIC_NEQV:
1336       if (op1->ts.type == BT_LOGICAL && op2->ts.type == BT_LOGICAL)
1337         {
1338           e->ts.type = BT_LOGICAL;
1339           e->ts.kind = gfc_kind_max (op1, op2);
1340           if (op1->ts.kind < e->ts.kind)
1341             gfc_convert_type (op1, &e->ts, 2);
1342           else if (op2->ts.kind < e->ts.kind)
1343             gfc_convert_type (op2, &e->ts, 2);
1344           break;
1345         }
1346
1347       sprintf (msg, "Operands of logical operator '%s' at %%L are %s/%s",
1348                gfc_op2string (e->value.op.operator), gfc_typename (&op1->ts),
1349                gfc_typename (&op2->ts));
1350
1351       goto bad_op;
1352
1353     case INTRINSIC_NOT:
1354       if (op1->ts.type == BT_LOGICAL)
1355         {
1356           e->ts.type = BT_LOGICAL;
1357           e->ts.kind = op1->ts.kind;
1358           break;
1359         }
1360
1361       sprintf (msg, "Operand of .NOT. operator at %%L is %s",
1362                gfc_typename (&op1->ts));
1363       goto bad_op;
1364
1365     case INTRINSIC_GT:
1366     case INTRINSIC_GE:
1367     case INTRINSIC_LT:
1368     case INTRINSIC_LE:
1369       if (op1->ts.type == BT_COMPLEX || op2->ts.type == BT_COMPLEX)
1370         {
1371           strcpy (msg, "COMPLEX quantities cannot be compared at %L");
1372           goto bad_op;
1373         }
1374
1375       /* Fall through...  */
1376
1377     case INTRINSIC_EQ:
1378     case INTRINSIC_NE:
1379       if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER)
1380         {
1381           e->ts.type = BT_LOGICAL;
1382           e->ts.kind = gfc_default_logical_kind;
1383           break;
1384         }
1385
1386       if (gfc_numeric_ts (&op1->ts) && gfc_numeric_ts (&op2->ts))
1387         {
1388           gfc_type_convert_binary (e);
1389
1390           e->ts.type = BT_LOGICAL;
1391           e->ts.kind = gfc_default_logical_kind;
1392           break;
1393         }
1394
1395       sprintf (msg, "Operands of comparison operator '%s' at %%L are %s/%s",
1396                gfc_op2string (e->value.op.operator), gfc_typename (&op1->ts),
1397                gfc_typename (&op2->ts));
1398
1399       goto bad_op;
1400
1401     case INTRINSIC_USER:
1402       if (op2 == NULL)
1403         sprintf (msg, "Operand of user operator '%s' at %%L is %s",
1404                  e->value.op.uop->name, gfc_typename (&op1->ts));
1405       else
1406         sprintf (msg, "Operands of user operator '%s' at %%L are %s/%s",
1407                  e->value.op.uop->name, gfc_typename (&op1->ts),
1408                  gfc_typename (&op2->ts));
1409
1410       goto bad_op;
1411
1412     default:
1413       gfc_internal_error ("resolve_operator(): Bad intrinsic");
1414     }
1415
1416   /* Deal with arrayness of an operand through an operator.  */
1417
1418   t = SUCCESS;
1419
1420   switch (e->value.op.operator)
1421     {
1422     case INTRINSIC_PLUS:
1423     case INTRINSIC_MINUS:
1424     case INTRINSIC_TIMES:
1425     case INTRINSIC_DIVIDE:
1426     case INTRINSIC_POWER:
1427     case INTRINSIC_CONCAT:
1428     case INTRINSIC_AND:
1429     case INTRINSIC_OR:
1430     case INTRINSIC_EQV:
1431     case INTRINSIC_NEQV:
1432     case INTRINSIC_EQ:
1433     case INTRINSIC_NE:
1434     case INTRINSIC_GT:
1435     case INTRINSIC_GE:
1436     case INTRINSIC_LT:
1437     case INTRINSIC_LE:
1438
1439       if (op1->rank == 0 && op2->rank == 0)
1440         e->rank = 0;
1441
1442       if (op1->rank == 0 && op2->rank != 0)
1443         {
1444           e->rank = op2->rank;
1445
1446           if (e->shape == NULL)
1447             e->shape = gfc_copy_shape (op2->shape, op2->rank);
1448         }
1449
1450       if (op1->rank != 0 && op2->rank == 0)
1451         {
1452           e->rank = op1->rank;
1453
1454           if (e->shape == NULL)
1455             e->shape = gfc_copy_shape (op1->shape, op1->rank);
1456         }
1457
1458       if (op1->rank != 0 && op2->rank != 0)
1459         {
1460           if (op1->rank == op2->rank)
1461             {
1462               e->rank = op1->rank;
1463
1464               if (e->shape == NULL)
1465                 e->shape = gfc_copy_shape (op1->shape, op1->rank);
1466
1467             }
1468           else
1469             {
1470               gfc_error ("Inconsistent ranks for operator at %L and %L",
1471                          &op1->where, &op2->where);
1472               t = FAILURE;
1473
1474               /* Allow higher level expressions to work.  */
1475               e->rank = 0;
1476             }
1477         }
1478
1479       break;
1480
1481     case INTRINSIC_NOT:
1482     case INTRINSIC_UPLUS:
1483     case INTRINSIC_UMINUS:
1484       e->rank = op1->rank;
1485
1486       if (e->shape == NULL)
1487         e->shape = gfc_copy_shape (op1->shape, op1->rank);
1488
1489       /* Simply copy arrayness attribute */
1490       break;
1491
1492     default:
1493       break;
1494     }
1495
1496   /* Attempt to simplify the expression.  */
1497   if (t == SUCCESS)
1498     t = gfc_simplify_expr (e, 0);
1499   return t;
1500
1501 bad_op:
1502   if (gfc_extend_expr (e) == SUCCESS)
1503     return SUCCESS;
1504
1505   gfc_error (msg, &e->where);
1506   return FAILURE;
1507 }
1508
1509
1510 /************** Array resolution subroutines **************/
1511
1512
1513 typedef enum
1514 { CMP_LT, CMP_EQ, CMP_GT, CMP_UNKNOWN }
1515 comparison;
1516
1517 /* Compare two integer expressions.  */
1518
1519 static comparison
1520 compare_bound (gfc_expr * a, gfc_expr * b)
1521 {
1522   int i;
1523
1524   if (a == NULL || a->expr_type != EXPR_CONSTANT
1525       || b == NULL || b->expr_type != EXPR_CONSTANT)
1526     return CMP_UNKNOWN;
1527
1528   if (a->ts.type != BT_INTEGER || b->ts.type != BT_INTEGER)
1529     gfc_internal_error ("compare_bound(): Bad expression");
1530
1531   i = mpz_cmp (a->value.integer, b->value.integer);
1532
1533   if (i < 0)
1534     return CMP_LT;
1535   if (i > 0)
1536     return CMP_GT;
1537   return CMP_EQ;
1538 }
1539
1540
1541 /* Compare an integer expression with an integer.  */
1542
1543 static comparison
1544 compare_bound_int (gfc_expr * a, int b)
1545 {
1546   int i;
1547
1548   if (a == NULL || a->expr_type != EXPR_CONSTANT)
1549     return CMP_UNKNOWN;
1550
1551   if (a->ts.type != BT_INTEGER)
1552     gfc_internal_error ("compare_bound_int(): Bad expression");
1553
1554   i = mpz_cmp_si (a->value.integer, b);
1555
1556   if (i < 0)
1557     return CMP_LT;
1558   if (i > 0)
1559     return CMP_GT;
1560   return CMP_EQ;
1561 }
1562
1563
1564 /* Compare a single dimension of an array reference to the array
1565    specification.  */
1566
1567 static try
1568 check_dimension (int i, gfc_array_ref * ar, gfc_array_spec * as)
1569 {
1570
1571 /* Given start, end and stride values, calculate the minimum and
1572    maximum referenced indexes.  */
1573
1574   switch (ar->type)
1575     {
1576     case AR_FULL:
1577       break;
1578
1579     case AR_ELEMENT:
1580       if (compare_bound (ar->start[i], as->lower[i]) == CMP_LT)
1581         goto bound;
1582       if (compare_bound (ar->start[i], as->upper[i]) == CMP_GT)
1583         goto bound;
1584
1585       break;
1586
1587     case AR_SECTION:
1588       if (compare_bound_int (ar->stride[i], 0) == CMP_EQ)
1589         {
1590           gfc_error ("Illegal stride of zero at %L", &ar->c_where[i]);
1591           return FAILURE;
1592         }
1593
1594       if (compare_bound (ar->start[i], as->lower[i]) == CMP_LT)
1595         goto bound;
1596       if (compare_bound (ar->start[i], as->upper[i]) == CMP_GT)
1597         goto bound;
1598
1599       /* TODO: Possibly, we could warn about end[i] being out-of-bound although
1600          it is legal (see 6.2.2.3.1).  */
1601
1602       break;
1603
1604     default:
1605       gfc_internal_error ("check_dimension(): Bad array reference");
1606     }
1607
1608   return SUCCESS;
1609
1610 bound:
1611   gfc_warning ("Array reference at %L is out of bounds", &ar->c_where[i]);
1612   return SUCCESS;
1613 }
1614
1615
1616 /* Compare an array reference with an array specification.  */
1617
1618 static try
1619 compare_spec_to_ref (gfc_array_ref * ar)
1620 {
1621   gfc_array_spec *as;
1622   int i;
1623
1624   as = ar->as;
1625   i = as->rank - 1;
1626   /* TODO: Full array sections are only allowed as actual parameters.  */
1627   if (as->type == AS_ASSUMED_SIZE
1628       && (/*ar->type == AR_FULL
1629           ||*/ (ar->type == AR_SECTION
1630               && ar->dimen_type[i] == DIMEN_RANGE && ar->end[i] == NULL)))
1631     {
1632       gfc_error ("Rightmost upper bound of assumed size array section"
1633                  " not specified at %L", &ar->where);
1634       return FAILURE;
1635     }
1636
1637   if (ar->type == AR_FULL)
1638     return SUCCESS;
1639
1640   if (as->rank != ar->dimen)
1641     {
1642       gfc_error ("Rank mismatch in array reference at %L (%d/%d)",
1643                  &ar->where, ar->dimen, as->rank);
1644       return FAILURE;
1645     }
1646
1647   for (i = 0; i < as->rank; i++)
1648     if (check_dimension (i, ar, as) == FAILURE)
1649       return FAILURE;
1650
1651   return SUCCESS;
1652 }
1653
1654
1655 /* Resolve one part of an array index.  */
1656
1657 try
1658 gfc_resolve_index (gfc_expr * index, int check_scalar)
1659 {
1660   gfc_typespec ts;
1661
1662   if (index == NULL)
1663     return SUCCESS;
1664
1665   if (gfc_resolve_expr (index) == FAILURE)
1666     return FAILURE;
1667
1668   if (index->ts.type != BT_INTEGER)
1669     {
1670       gfc_error ("Array index at %L must be of INTEGER type", &index->where);
1671       return FAILURE;
1672     }
1673
1674   if (check_scalar && index->rank != 0)
1675     {
1676       gfc_error ("Array index at %L must be scalar", &index->where);
1677       return FAILURE;
1678     }
1679
1680   if (index->ts.kind != gfc_index_integer_kind)
1681     {
1682       ts.type = BT_INTEGER;
1683       ts.kind = gfc_index_integer_kind;
1684
1685       gfc_convert_type_warn (index, &ts, 2, 0);
1686     }
1687
1688   return SUCCESS;
1689 }
1690
1691
1692 /* Given an expression that contains array references, update those array
1693    references to point to the right array specifications.  While this is
1694    filled in during matching, this information is difficult to save and load
1695    in a module, so we take care of it here.
1696
1697    The idea here is that the original array reference comes from the
1698    base symbol.  We traverse the list of reference structures, setting
1699    the stored reference to references.  Component references can
1700    provide an additional array specification.  */
1701
1702 static void
1703 find_array_spec (gfc_expr * e)
1704 {
1705   gfc_array_spec *as;
1706   gfc_component *c;
1707   gfc_ref *ref;
1708
1709   as = e->symtree->n.sym->as;
1710   c = e->symtree->n.sym->components;
1711
1712   for (ref = e->ref; ref; ref = ref->next)
1713     switch (ref->type)
1714       {
1715       case REF_ARRAY:
1716         if (as == NULL)
1717           gfc_internal_error ("find_array_spec(): Missing spec");
1718
1719         ref->u.ar.as = as;
1720         as = NULL;
1721         break;
1722
1723       case REF_COMPONENT:
1724         for (; c; c = c->next)
1725           if (c == ref->u.c.component)
1726             break;
1727
1728         if (c == NULL)
1729           gfc_internal_error ("find_array_spec(): Component not found");
1730
1731         if (c->dimension)
1732           {
1733             if (as != NULL)
1734               gfc_internal_error ("find_array_spec(): unused as(1)");
1735             as = c->as;
1736           }
1737
1738         c = c->ts.derived->components;
1739         break;
1740
1741       case REF_SUBSTRING:
1742         break;
1743       }
1744
1745   if (as != NULL)
1746     gfc_internal_error ("find_array_spec(): unused as(2)");
1747 }
1748
1749
1750 /* Resolve an array reference.  */
1751
1752 static try
1753 resolve_array_ref (gfc_array_ref * ar)
1754 {
1755   int i, check_scalar;
1756
1757   for (i = 0; i < ar->dimen; i++)
1758     {
1759       check_scalar = ar->dimen_type[i] == DIMEN_RANGE;
1760
1761       if (gfc_resolve_index (ar->start[i], check_scalar) == FAILURE)
1762         return FAILURE;
1763       if (gfc_resolve_index (ar->end[i], check_scalar) == FAILURE)
1764         return FAILURE;
1765       if (gfc_resolve_index (ar->stride[i], check_scalar) == FAILURE)
1766         return FAILURE;
1767
1768       if (ar->dimen_type[i] == DIMEN_UNKNOWN)
1769         switch (ar->start[i]->rank)
1770           {
1771           case 0:
1772             ar->dimen_type[i] = DIMEN_ELEMENT;
1773             break;
1774
1775           case 1:
1776             ar->dimen_type[i] = DIMEN_VECTOR;
1777             break;
1778
1779           default:
1780             gfc_error ("Array index at %L is an array of rank %d",
1781                        &ar->c_where[i], ar->start[i]->rank);
1782             return FAILURE;
1783           }
1784     }
1785
1786   /* If the reference type is unknown, figure out what kind it is.  */
1787
1788   if (ar->type == AR_UNKNOWN)
1789     {
1790       ar->type = AR_ELEMENT;
1791       for (i = 0; i < ar->dimen; i++)
1792         if (ar->dimen_type[i] == DIMEN_RANGE
1793             || ar->dimen_type[i] == DIMEN_VECTOR)
1794           {
1795             ar->type = AR_SECTION;
1796             break;
1797           }
1798     }
1799
1800   if (compare_spec_to_ref (ar) == FAILURE)
1801     return FAILURE;
1802
1803   return SUCCESS;
1804 }
1805
1806
1807 static try
1808 resolve_substring (gfc_ref * ref)
1809 {
1810
1811   if (ref->u.ss.start != NULL)
1812     {
1813       if (gfc_resolve_expr (ref->u.ss.start) == FAILURE)
1814         return FAILURE;
1815
1816       if (ref->u.ss.start->ts.type != BT_INTEGER)
1817         {
1818           gfc_error ("Substring start index at %L must be of type INTEGER",
1819                      &ref->u.ss.start->where);
1820           return FAILURE;
1821         }
1822
1823       if (ref->u.ss.start->rank != 0)
1824         {
1825           gfc_error ("Substring start index at %L must be scalar",
1826                      &ref->u.ss.start->where);
1827           return FAILURE;
1828         }
1829
1830       if (compare_bound_int (ref->u.ss.start, 1) == CMP_LT)
1831         {
1832           gfc_error ("Substring start index at %L is less than one",
1833                      &ref->u.ss.start->where);
1834           return FAILURE;
1835         }
1836     }
1837
1838   if (ref->u.ss.end != NULL)
1839     {
1840       if (gfc_resolve_expr (ref->u.ss.end) == FAILURE)
1841         return FAILURE;
1842
1843       if (ref->u.ss.end->ts.type != BT_INTEGER)
1844         {
1845           gfc_error ("Substring end index at %L must be of type INTEGER",
1846                      &ref->u.ss.end->where);
1847           return FAILURE;
1848         }
1849
1850       if (ref->u.ss.end->rank != 0)
1851         {
1852           gfc_error ("Substring end index at %L must be scalar",
1853                      &ref->u.ss.end->where);
1854           return FAILURE;
1855         }
1856
1857       if (ref->u.ss.length != NULL
1858           && compare_bound (ref->u.ss.end, ref->u.ss.length->length) == CMP_GT)
1859         {
1860           gfc_error ("Substring end index at %L is out of bounds",
1861                      &ref->u.ss.start->where);
1862           return FAILURE;
1863         }
1864     }
1865
1866   return SUCCESS;
1867 }
1868
1869
1870 /* Resolve subtype references.  */
1871
1872 static try
1873 resolve_ref (gfc_expr * expr)
1874 {
1875   int current_part_dimension, n_components, seen_part_dimension;
1876   gfc_ref *ref;
1877
1878   for (ref = expr->ref; ref; ref = ref->next)
1879     if (ref->type == REF_ARRAY && ref->u.ar.as == NULL)
1880       {
1881         find_array_spec (expr);
1882         break;
1883       }
1884
1885   for (ref = expr->ref; ref; ref = ref->next)
1886     switch (ref->type)
1887       {
1888       case REF_ARRAY:
1889         if (resolve_array_ref (&ref->u.ar) == FAILURE)
1890           return FAILURE;
1891         break;
1892
1893       case REF_COMPONENT:
1894         break;
1895
1896       case REF_SUBSTRING:
1897         resolve_substring (ref);
1898         break;
1899       }
1900
1901   /* Check constraints on part references.  */
1902
1903   current_part_dimension = 0;
1904   seen_part_dimension = 0;
1905   n_components = 0;
1906
1907   for (ref = expr->ref; ref; ref = ref->next)
1908     {
1909       switch (ref->type)
1910         {
1911         case REF_ARRAY:
1912           switch (ref->u.ar.type)
1913             {
1914             case AR_FULL:
1915             case AR_SECTION:
1916               current_part_dimension = 1;
1917               break;
1918
1919             case AR_ELEMENT:
1920               current_part_dimension = 0;
1921               break;
1922
1923             case AR_UNKNOWN:
1924               gfc_internal_error ("resolve_ref(): Bad array reference");
1925             }
1926
1927           break;
1928
1929         case REF_COMPONENT:
1930           if ((current_part_dimension || seen_part_dimension)
1931               && ref->u.c.component->pointer)
1932             {
1933               gfc_error
1934                 ("Component to the right of a part reference with nonzero "
1935                  "rank must not have the POINTER attribute at %L",
1936                  &expr->where);
1937               return FAILURE;
1938             }
1939
1940           n_components++;
1941           break;
1942
1943         case REF_SUBSTRING:
1944           break;
1945         }
1946
1947       if (((ref->type == REF_COMPONENT && n_components > 1)
1948            || ref->next == NULL)
1949           && current_part_dimension
1950           && seen_part_dimension)
1951         {
1952
1953           gfc_error ("Two or more part references with nonzero rank must "
1954                      "not be specified at %L", &expr->where);
1955           return FAILURE;
1956         }
1957
1958       if (ref->type == REF_COMPONENT)
1959         {
1960           if (current_part_dimension)
1961             seen_part_dimension = 1;
1962
1963           /* reset to make sure */
1964           current_part_dimension = 0;
1965         }
1966     }
1967
1968   return SUCCESS;
1969 }
1970
1971
1972 /* Given an expression, determine its shape.  This is easier than it sounds.
1973    Leaves the shape array NULL if it is not possible to determine the shape.  */
1974
1975 static void
1976 expression_shape (gfc_expr * e)
1977 {
1978   mpz_t array[GFC_MAX_DIMENSIONS];
1979   int i;
1980
1981   if (e->rank == 0 || e->shape != NULL)
1982     return;
1983
1984   for (i = 0; i < e->rank; i++)
1985     if (gfc_array_dimen_size (e, i, &array[i]) == FAILURE)
1986       goto fail;
1987
1988   e->shape = gfc_get_shape (e->rank);
1989
1990   memcpy (e->shape, array, e->rank * sizeof (mpz_t));
1991
1992   return;
1993
1994 fail:
1995   for (i--; i >= 0; i--)
1996     mpz_clear (array[i]);
1997 }
1998
1999
2000 /* Given a variable expression node, compute the rank of the expression by
2001    examining the base symbol and any reference structures it may have.  */
2002
2003 static void
2004 expression_rank (gfc_expr * e)
2005 {
2006   gfc_ref *ref;
2007   int i, rank;
2008
2009   if (e->ref == NULL)
2010     {
2011       if (e->expr_type == EXPR_ARRAY)
2012         goto done;
2013       /* Constructors can have a rank different from one via RESHAPE().  */
2014
2015       if (e->symtree == NULL)
2016         {
2017           e->rank = 0;
2018           goto done;
2019         }
2020
2021       e->rank = (e->symtree->n.sym->as == NULL)
2022                   ? 0 : e->symtree->n.sym->as->rank;
2023       goto done;
2024     }
2025
2026   rank = 0;
2027
2028   for (ref = e->ref; ref; ref = ref->next)
2029     {
2030       if (ref->type != REF_ARRAY)
2031         continue;
2032
2033       if (ref->u.ar.type == AR_FULL)
2034         {
2035           rank = ref->u.ar.as->rank;
2036           break;
2037         }
2038
2039       if (ref->u.ar.type == AR_SECTION)
2040         {
2041           /* Figure out the rank of the section.  */
2042           if (rank != 0)
2043             gfc_internal_error ("expression_rank(): Two array specs");
2044
2045           for (i = 0; i < ref->u.ar.dimen; i++)
2046             if (ref->u.ar.dimen_type[i] == DIMEN_RANGE
2047                 || ref->u.ar.dimen_type[i] == DIMEN_VECTOR)
2048               rank++;
2049
2050           break;
2051         }
2052     }
2053
2054   e->rank = rank;
2055
2056 done:
2057   expression_shape (e);
2058 }
2059
2060
2061 /* Resolve a variable expression.  */
2062
2063 static try
2064 resolve_variable (gfc_expr * e)
2065 {
2066   gfc_symbol *sym;
2067
2068   if (e->ref && resolve_ref (e) == FAILURE)
2069     return FAILURE;
2070
2071   sym = e->symtree->n.sym;
2072   if (sym->attr.flavor == FL_PROCEDURE && !sym->attr.function)
2073     {
2074       e->ts.type = BT_PROCEDURE;
2075       return SUCCESS;
2076     }
2077
2078   if (sym->ts.type != BT_UNKNOWN)
2079     gfc_variable_attr (e, &e->ts);
2080   else
2081     {
2082       /* Must be a simple variable reference.  */
2083       if (gfc_set_default_type (sym, 1, NULL) == FAILURE)
2084         return FAILURE;
2085       e->ts = sym->ts;
2086     }
2087
2088   return SUCCESS;
2089 }
2090
2091
2092 /* Resolve an expression.  That is, make sure that types of operands agree
2093    with their operators, intrinsic operators are converted to function calls
2094    for overloaded types and unresolved function references are resolved.  */
2095
2096 try
2097 gfc_resolve_expr (gfc_expr * e)
2098 {
2099   try t;
2100
2101   if (e == NULL)
2102     return SUCCESS;
2103
2104   switch (e->expr_type)
2105     {
2106     case EXPR_OP:
2107       t = resolve_operator (e);
2108       break;
2109
2110     case EXPR_FUNCTION:
2111       t = resolve_function (e);
2112       break;
2113
2114     case EXPR_VARIABLE:
2115       t = resolve_variable (e);
2116       if (t == SUCCESS)
2117         expression_rank (e);
2118       break;
2119
2120     case EXPR_SUBSTRING:
2121       t = resolve_ref (e);
2122       break;
2123
2124     case EXPR_CONSTANT:
2125     case EXPR_NULL:
2126       t = SUCCESS;
2127       break;
2128
2129     case EXPR_ARRAY:
2130       t = FAILURE;
2131       if (resolve_ref (e) == FAILURE)
2132         break;
2133
2134       t = gfc_resolve_array_constructor (e);
2135       /* Also try to expand a constructor.  */
2136       if (t == SUCCESS)
2137         {
2138           expression_rank (e);
2139           gfc_expand_constructor (e);
2140         }
2141
2142       break;
2143
2144     case EXPR_STRUCTURE:
2145       t = resolve_ref (e);
2146       if (t == FAILURE)
2147         break;
2148
2149       t = resolve_structure_cons (e);
2150       if (t == FAILURE)
2151         break;
2152
2153       t = gfc_simplify_expr (e, 0);
2154       break;
2155
2156     default:
2157       gfc_internal_error ("gfc_resolve_expr(): Bad expression type");
2158     }
2159
2160   return t;
2161 }
2162
2163
2164 /* Resolve an expression from an iterator.  They must be scalar and have
2165    INTEGER or (optionally) REAL type.  */
2166
2167 static try
2168 gfc_resolve_iterator_expr (gfc_expr * expr, bool real_ok, const char * name)
2169 {
2170   if (gfc_resolve_expr (expr) == FAILURE)
2171     return FAILURE;
2172
2173   if (expr->rank != 0)
2174     {
2175       gfc_error ("%s at %L must be a scalar", name, &expr->where);
2176       return FAILURE;
2177     }
2178
2179   if (!(expr->ts.type == BT_INTEGER
2180         || (expr->ts.type == BT_REAL && real_ok)))
2181     {
2182       gfc_error ("%s at %L must be INTEGER%s",
2183                  name,
2184                  &expr->where,
2185                  real_ok ? " or REAL" : "");
2186       return FAILURE;
2187     }
2188   return SUCCESS;
2189 }
2190
2191
2192 /* Resolve the expressions in an iterator structure.  If REAL_OK is
2193    false allow only INTEGER type iterators, otherwise allow REAL types.  */
2194
2195 try
2196 gfc_resolve_iterator (gfc_iterator * iter, bool real_ok)
2197 {
2198
2199   if (iter->var->ts.type == BT_REAL)
2200     gfc_notify_std (GFC_STD_F95_DEL,
2201                     "Obsolete: REAL DO loop iterator at %L",
2202                     &iter->var->where);
2203
2204   if (gfc_resolve_iterator_expr (iter->var, real_ok, "Loop variable")
2205       == FAILURE)
2206     return FAILURE;
2207
2208   if (gfc_pure (NULL) && gfc_impure_variable (iter->var->symtree->n.sym))
2209     {
2210       gfc_error ("Cannot assign to loop variable in PURE procedure at %L",
2211                  &iter->var->where);
2212       return FAILURE;
2213     }
2214
2215   if (gfc_resolve_iterator_expr (iter->start, real_ok,
2216                                  "Start expression in DO loop") == FAILURE)
2217     return FAILURE;
2218
2219   if (gfc_resolve_iterator_expr (iter->end, real_ok,
2220                                  "End expression in DO loop") == FAILURE)
2221     return FAILURE;
2222
2223   if (gfc_resolve_iterator_expr (iter->step, real_ok,
2224                                  "Step expression in DO loop") == FAILURE)
2225     return FAILURE;
2226
2227   if (iter->step->expr_type == EXPR_CONSTANT)
2228     {
2229       if ((iter->step->ts.type == BT_INTEGER
2230            && mpz_cmp_ui (iter->step->value.integer, 0) == 0)
2231           || (iter->step->ts.type == BT_REAL
2232               && mpfr_sgn (iter->step->value.real) == 0))
2233         {
2234           gfc_error ("Step expression in DO loop at %L cannot be zero",
2235                      &iter->step->where);
2236           return FAILURE;
2237         }
2238     }
2239
2240   /* Convert start, end, and step to the same type as var.  */
2241   if (iter->start->ts.kind != iter->var->ts.kind
2242       || iter->start->ts.type != iter->var->ts.type)
2243     gfc_convert_type (iter->start, &iter->var->ts, 2);
2244
2245   if (iter->end->ts.kind != iter->var->ts.kind
2246       || iter->end->ts.type != iter->var->ts.type)
2247     gfc_convert_type (iter->end, &iter->var->ts, 2);
2248
2249   if (iter->step->ts.kind != iter->var->ts.kind
2250       || iter->step->ts.type != iter->var->ts.type)
2251     gfc_convert_type (iter->step, &iter->var->ts, 2);
2252
2253   return SUCCESS;
2254 }
2255
2256
2257 /* Resolve a list of FORALL iterators.  */
2258
2259 static void
2260 resolve_forall_iterators (gfc_forall_iterator * iter)
2261 {
2262
2263   while (iter)
2264     {
2265       if (gfc_resolve_expr (iter->var) == SUCCESS
2266           && iter->var->ts.type != BT_INTEGER)
2267         gfc_error ("FORALL Iteration variable at %L must be INTEGER",
2268                    &iter->var->where);
2269
2270       if (gfc_resolve_expr (iter->start) == SUCCESS
2271           && iter->start->ts.type != BT_INTEGER)
2272         gfc_error ("FORALL start expression at %L must be INTEGER",
2273                    &iter->start->where);
2274       if (iter->var->ts.kind != iter->start->ts.kind)
2275         gfc_convert_type (iter->start, &iter->var->ts, 2);
2276
2277       if (gfc_resolve_expr (iter->end) == SUCCESS
2278           && iter->end->ts.type != BT_INTEGER)
2279         gfc_error ("FORALL end expression at %L must be INTEGER",
2280                    &iter->end->where);
2281       if (iter->var->ts.kind != iter->end->ts.kind)
2282         gfc_convert_type (iter->end, &iter->var->ts, 2);
2283
2284       if (gfc_resolve_expr (iter->stride) == SUCCESS
2285           && iter->stride->ts.type != BT_INTEGER)
2286         gfc_error ("FORALL Stride expression at %L must be INTEGER",
2287                    &iter->stride->where);
2288       if (iter->var->ts.kind != iter->stride->ts.kind)
2289         gfc_convert_type (iter->stride, &iter->var->ts, 2);
2290
2291       iter = iter->next;
2292     }
2293 }
2294
2295
2296 /* Given a pointer to a symbol that is a derived type, see if any components
2297    have the POINTER attribute.  The search is recursive if necessary.
2298    Returns zero if no pointer components are found, nonzero otherwise.  */
2299
2300 static int
2301 derived_pointer (gfc_symbol * sym)
2302 {
2303   gfc_component *c;
2304
2305   for (c = sym->components; c; c = c->next)
2306     {
2307       if (c->pointer)
2308         return 1;
2309
2310       if (c->ts.type == BT_DERIVED && derived_pointer (c->ts.derived))
2311         return 1;
2312     }
2313
2314   return 0;
2315 }
2316
2317
2318 /* Resolve the argument of a deallocate expression.  The expression must be
2319    a pointer or a full array.  */
2320
2321 static try
2322 resolve_deallocate_expr (gfc_expr * e)
2323 {
2324   symbol_attribute attr;
2325   int allocatable;
2326   gfc_ref *ref;
2327
2328   if (gfc_resolve_expr (e) == FAILURE)
2329     return FAILURE;
2330
2331   attr = gfc_expr_attr (e);
2332   if (attr.pointer)
2333     return SUCCESS;
2334
2335   if (e->expr_type != EXPR_VARIABLE)
2336     goto bad;
2337
2338   allocatable = e->symtree->n.sym->attr.allocatable;
2339   for (ref = e->ref; ref; ref = ref->next)
2340     switch (ref->type)
2341       {
2342       case REF_ARRAY:
2343         if (ref->u.ar.type != AR_FULL)
2344           allocatable = 0;
2345         break;
2346
2347       case REF_COMPONENT:
2348         allocatable = (ref->u.c.component->as != NULL
2349                        && ref->u.c.component->as->type == AS_DEFERRED);
2350         break;
2351
2352       case REF_SUBSTRING:
2353         allocatable = 0;
2354         break;
2355       }
2356
2357   if (allocatable == 0)
2358     {
2359     bad:
2360       gfc_error ("Expression in DEALLOCATE statement at %L must be "
2361                  "ALLOCATABLE or a POINTER", &e->where);
2362     }
2363
2364   return SUCCESS;
2365 }
2366
2367
2368 /* Resolve the expression in an ALLOCATE statement, doing the additional
2369    checks to see whether the expression is OK or not.  The expression must
2370    have a trailing array reference that gives the size of the array.  */
2371
2372 static try
2373 resolve_allocate_expr (gfc_expr * e)
2374 {
2375   int i, pointer, allocatable, dimension;
2376   symbol_attribute attr;
2377   gfc_ref *ref, *ref2;
2378   gfc_array_ref *ar;
2379
2380   if (gfc_resolve_expr (e) == FAILURE)
2381     return FAILURE;
2382
2383   /* Make sure the expression is allocatable or a pointer.  If it is
2384      pointer, the next-to-last reference must be a pointer.  */
2385
2386   ref2 = NULL;
2387
2388   if (e->expr_type != EXPR_VARIABLE)
2389     {
2390       allocatable = 0;
2391
2392       attr = gfc_expr_attr (e);
2393       pointer = attr.pointer;
2394       dimension = attr.dimension;
2395
2396     }
2397   else
2398     {
2399       allocatable = e->symtree->n.sym->attr.allocatable;
2400       pointer = e->symtree->n.sym->attr.pointer;
2401       dimension = e->symtree->n.sym->attr.dimension;
2402
2403       for (ref = e->ref; ref; ref2 = ref, ref = ref->next)
2404         switch (ref->type)
2405           {
2406           case REF_ARRAY:
2407             if (ref->next != NULL)
2408               pointer = 0;
2409             break;
2410
2411           case REF_COMPONENT:
2412             allocatable = (ref->u.c.component->as != NULL
2413                            && ref->u.c.component->as->type == AS_DEFERRED);
2414
2415             pointer = ref->u.c.component->pointer;
2416             dimension = ref->u.c.component->dimension;
2417             break;
2418
2419           case REF_SUBSTRING:
2420             allocatable = 0;
2421             pointer = 0;
2422             break;
2423           }
2424     }
2425
2426   if (allocatable == 0 && pointer == 0)
2427     {
2428       gfc_error ("Expression in ALLOCATE statement at %L must be "
2429                  "ALLOCATABLE or a POINTER", &e->where);
2430       return FAILURE;
2431     }
2432
2433   if (pointer && dimension == 0)
2434     return SUCCESS;
2435
2436   /* Make sure the next-to-last reference node is an array specification.  */
2437
2438   if (ref2 == NULL || ref2->type != REF_ARRAY || ref2->u.ar.type == AR_FULL)
2439     {
2440       gfc_error ("Array specification required in ALLOCATE statement "
2441                  "at %L", &e->where);
2442       return FAILURE;
2443     }
2444
2445   if (ref2->u.ar.type == AR_ELEMENT)
2446     return SUCCESS;
2447
2448   /* Make sure that the array section reference makes sense in the
2449     context of an ALLOCATE specification.  */
2450
2451   ar = &ref2->u.ar;
2452
2453   for (i = 0; i < ar->dimen; i++)
2454     switch (ar->dimen_type[i])
2455       {
2456       case DIMEN_ELEMENT:
2457         break;
2458
2459       case DIMEN_RANGE:
2460         if (ar->start[i] != NULL
2461             && ar->end[i] != NULL
2462             && ar->stride[i] == NULL)
2463           break;
2464
2465         /* Fall Through...  */
2466
2467       case DIMEN_UNKNOWN:
2468       case DIMEN_VECTOR:
2469         gfc_error ("Bad array specification in ALLOCATE statement at %L",
2470                    &e->where);
2471         return FAILURE;
2472       }
2473
2474   return SUCCESS;
2475 }
2476
2477
2478 /************ SELECT CASE resolution subroutines ************/
2479
2480 /* Callback function for our mergesort variant.  Determines interval
2481    overlaps for CASEs. Return <0 if op1 < op2, 0 for overlap, >0 for
2482    op1 > op2.  Assumes we're not dealing with the default case.  
2483    We have op1 = (:L), (K:L) or (K:) and op2 = (:N), (M:N) or (M:).
2484    There are nine situations to check.  */
2485
2486 static int
2487 compare_cases (const gfc_case * op1, const gfc_case * op2)
2488 {
2489   int retval;
2490
2491   if (op1->low == NULL) /* op1 = (:L)  */
2492     {
2493       /* op2 = (:N), so overlap.  */
2494       retval = 0;
2495       /* op2 = (M:) or (M:N),  L < M  */
2496       if (op2->low != NULL
2497           && gfc_compare_expr (op1->high, op2->low) < 0)
2498         retval = -1;
2499     }
2500   else if (op1->high == NULL) /* op1 = (K:)  */
2501     {
2502       /* op2 = (M:), so overlap.  */
2503       retval = 0;
2504       /* op2 = (:N) or (M:N), K > N  */
2505       if (op2->high != NULL
2506           && gfc_compare_expr (op1->low, op2->high) > 0)
2507         retval = 1;
2508     }
2509   else /* op1 = (K:L)  */
2510     {
2511       if (op2->low == NULL)       /* op2 = (:N), K > N  */
2512         retval = (gfc_compare_expr (op1->low, op2->high) > 0) ? 1 : 0;
2513       else if (op2->high == NULL) /* op2 = (M:), L < M  */
2514         retval = (gfc_compare_expr (op1->high, op2->low) < 0) ? -1 : 0;
2515       else                        /* op2 = (M:N)  */
2516         {
2517           retval =  0;
2518           /* L < M  */
2519           if (gfc_compare_expr (op1->high, op2->low) < 0)
2520             retval =  -1;
2521           /* K > N  */
2522           else if (gfc_compare_expr (op1->low, op2->high) > 0)
2523             retval =  1;
2524         }
2525     }
2526
2527   return retval;
2528 }
2529
2530
2531 /* Merge-sort a double linked case list, detecting overlap in the
2532    process.  LIST is the head of the double linked case list before it
2533    is sorted.  Returns the head of the sorted list if we don't see any
2534    overlap, or NULL otherwise.  */
2535
2536 static gfc_case *
2537 check_case_overlap (gfc_case * list)
2538 {
2539   gfc_case *p, *q, *e, *tail;
2540   int insize, nmerges, psize, qsize, cmp, overlap_seen;
2541
2542   /* If the passed list was empty, return immediately.  */
2543   if (!list)
2544     return NULL;
2545
2546   overlap_seen = 0;
2547   insize = 1;
2548
2549   /* Loop unconditionally.  The only exit from this loop is a return
2550      statement, when we've finished sorting the case list.  */
2551   for (;;)
2552     {
2553       p = list;
2554       list = NULL;
2555       tail = NULL;
2556
2557       /* Count the number of merges we do in this pass.  */
2558       nmerges = 0;
2559
2560       /* Loop while there exists a merge to be done.  */
2561       while (p)
2562         {
2563           int i;
2564
2565           /* Count this merge.  */
2566           nmerges++;
2567
2568           /* Cut the list in two pieces by stepping INSIZE places
2569              forward in the list, starting from P.  */
2570           psize = 0;
2571           q = p;
2572           for (i = 0; i < insize; i++)
2573             {
2574               psize++;
2575               q = q->right;
2576               if (!q)
2577                 break;
2578             }
2579           qsize = insize;
2580
2581           /* Now we have two lists.  Merge them!  */
2582           while (psize > 0 || (qsize > 0 && q != NULL))
2583             {
2584
2585               /* See from which the next case to merge comes from.  */
2586               if (psize == 0)
2587                 {
2588                   /* P is empty so the next case must come from Q.  */
2589                   e = q;
2590                   q = q->right;
2591                   qsize--;
2592                 }
2593               else if (qsize == 0 || q == NULL)
2594                 {
2595                   /* Q is empty.  */
2596                   e = p;
2597                   p = p->right;
2598                   psize--;
2599                 }
2600               else
2601                 {
2602                   cmp = compare_cases (p, q);
2603                   if (cmp < 0)
2604                     {
2605                       /* The whole case range for P is less than the
2606                          one for Q.  */
2607                       e = p;
2608                       p = p->right;
2609                       psize--;
2610                     }
2611                   else if (cmp > 0)
2612                     {
2613                       /* The whole case range for Q is greater than
2614                          the case range for P.  */
2615                       e = q;
2616                       q = q->right;
2617                       qsize--;
2618                     }
2619                   else
2620                     {
2621                       /* The cases overlap, or they are the same
2622                          element in the list.  Either way, we must
2623                          issue an error and get the next case from P.  */
2624                       /* FIXME: Sort P and Q by line number.  */
2625                       gfc_error ("CASE label at %L overlaps with CASE "
2626                                  "label at %L", &p->where, &q->where);
2627                       overlap_seen = 1;
2628                       e = p;
2629                       p = p->right;
2630                       psize--;
2631                     }
2632                 }
2633
2634                 /* Add the next element to the merged list.  */
2635               if (tail)
2636                 tail->right = e;
2637               else
2638                 list = e;
2639               e->left = tail;
2640               tail = e;
2641             }
2642
2643           /* P has now stepped INSIZE places along, and so has Q.  So
2644              they're the same.  */
2645           p = q;
2646         }
2647       tail->right = NULL;
2648
2649       /* If we have done only one merge or none at all, we've
2650          finished sorting the cases.  */
2651       if (nmerges <= 1)
2652         {
2653           if (!overlap_seen)
2654             return list;
2655           else
2656             return NULL;
2657         }
2658
2659       /* Otherwise repeat, merging lists twice the size.  */
2660       insize *= 2;
2661     }
2662 }
2663
2664
2665 /* Check to see if an expression is suitable for use in a CASE statement.
2666    Makes sure that all case expressions are scalar constants of the same
2667    type.  Return FAILURE if anything is wrong.  */
2668
2669 static try
2670 validate_case_label_expr (gfc_expr * e, gfc_expr * case_expr)
2671 {
2672   if (e == NULL) return SUCCESS;
2673
2674   if (e->ts.type != case_expr->ts.type)
2675     {
2676       gfc_error ("Expression in CASE statement at %L must be of type %s",
2677                  &e->where, gfc_basic_typename (case_expr->ts.type));
2678       return FAILURE;
2679     }
2680
2681   /* C805 (R808) For a given case-construct, each case-value shall be of
2682      the same type as case-expr.  For character type, length differences
2683      are allowed, but the kind type parameters shall be the same.  */
2684
2685   if (case_expr->ts.type == BT_CHARACTER && e->ts.kind != case_expr->ts.kind)
2686     {
2687       gfc_error("Expression in CASE statement at %L must be kind %d",
2688                 &e->where, case_expr->ts.kind);
2689       return FAILURE;
2690     }
2691
2692   /* Convert the case value kind to that of case expression kind, if needed.
2693      FIXME:  Should a warning be issued?  */
2694   if (e->ts.kind != case_expr->ts.kind)
2695     gfc_convert_type_warn (e, &case_expr->ts, 2, 0);
2696
2697   if (e->rank != 0)
2698     {
2699       gfc_error ("Expression in CASE statement at %L must be scalar",
2700                  &e->where);
2701       return FAILURE;
2702     }
2703
2704   return SUCCESS;
2705 }
2706
2707
2708 /* Given a completely parsed select statement, we:
2709
2710      - Validate all expressions and code within the SELECT.
2711      - Make sure that the selection expression is not of the wrong type.
2712      - Make sure that no case ranges overlap.
2713      - Eliminate unreachable cases and unreachable code resulting from
2714        removing case labels.
2715
2716    The standard does allow unreachable cases, e.g. CASE (5:3).  But
2717    they are a hassle for code generation, and to prevent that, we just
2718    cut them out here.  This is not necessary for overlapping cases
2719    because they are illegal and we never even try to generate code.
2720
2721    We have the additional caveat that a SELECT construct could have
2722    been a computed GOTO in the source code. Fortunately we can fairly
2723    easily work around that here: The case_expr for a "real" SELECT CASE
2724    is in code->expr1, but for a computed GOTO it is in code->expr2. All
2725    we have to do is make sure that the case_expr is a scalar integer
2726    expression.  */
2727
2728 static void
2729 resolve_select (gfc_code * code)
2730 {
2731   gfc_code *body;
2732   gfc_expr *case_expr;
2733   gfc_case *cp, *default_case, *tail, *head;
2734   int seen_unreachable;
2735   int ncases;
2736   bt type;
2737   try t;
2738
2739   if (code->expr == NULL)
2740     {
2741       /* This was actually a computed GOTO statement.  */
2742       case_expr = code->expr2;
2743       if (case_expr->ts.type != BT_INTEGER
2744           || case_expr->rank != 0)
2745         gfc_error ("Selection expression in computed GOTO statement "
2746                    "at %L must be a scalar integer expression",
2747                    &case_expr->where);
2748
2749       /* Further checking is not necessary because this SELECT was built
2750          by the compiler, so it should always be OK.  Just move the
2751          case_expr from expr2 to expr so that we can handle computed
2752          GOTOs as normal SELECTs from here on.  */
2753       code->expr = code->expr2;
2754       code->expr2 = NULL;
2755       return;
2756     }
2757
2758   case_expr = code->expr;
2759
2760   type = case_expr->ts.type;
2761   if (type != BT_LOGICAL && type != BT_INTEGER && type != BT_CHARACTER)
2762     {
2763       gfc_error ("Argument of SELECT statement at %L cannot be %s",
2764                  &case_expr->where, gfc_typename (&case_expr->ts));
2765
2766       /* Punt. Going on here just produce more garbage error messages.  */
2767       return;
2768     }
2769
2770   if (case_expr->rank != 0)
2771     {
2772       gfc_error ("Argument of SELECT statement at %L must be a scalar "
2773                  "expression", &case_expr->where);
2774
2775       /* Punt.  */
2776       return;
2777     }
2778
2779   /* PR 19168 has a long discussion concerning a mismatch of the kinds
2780      of the SELECT CASE expression and its CASE values.  Walk the lists
2781      of case values, and if we find a mismatch, promote case_expr to
2782      the appropriate kind.  */
2783
2784   if (type == BT_LOGICAL || type == BT_INTEGER)
2785     {
2786       for (body = code->block; body; body = body->block)
2787         {
2788           /* Walk the case label list.  */
2789           for (cp = body->ext.case_list; cp; cp = cp->next)
2790             {
2791               /* Intercept the DEFAULT case.  It does not have a kind.  */
2792               if (cp->low == NULL && cp->high == NULL)
2793                 continue;
2794
2795               /* Unreachable case ranges are discarded, so ignore.  */  
2796               if (cp->low != NULL && cp->high != NULL
2797                   && cp->low != cp->high
2798                   && gfc_compare_expr (cp->low, cp->high) > 0)
2799                 continue;
2800
2801               /* FIXME: Should a warning be issued?  */
2802               if (cp->low != NULL
2803                   && case_expr->ts.kind != gfc_kind_max(case_expr, cp->low))
2804                 gfc_convert_type_warn (case_expr, &cp->low->ts, 2, 0);
2805
2806               if (cp->high != NULL
2807                   && case_expr->ts.kind != gfc_kind_max(case_expr, cp->high))
2808                 gfc_convert_type_warn (case_expr, &cp->high->ts, 2, 0);
2809             }
2810          }
2811     }
2812
2813   /* Assume there is no DEFAULT case.  */
2814   default_case = NULL;
2815   head = tail = NULL;
2816   ncases = 0;
2817
2818   for (body = code->block; body; body = body->block)
2819     {
2820       /* Assume the CASE list is OK, and all CASE labels can be matched.  */
2821       t = SUCCESS;
2822       seen_unreachable = 0;
2823
2824       /* Walk the case label list, making sure that all case labels
2825          are legal.  */
2826       for (cp = body->ext.case_list; cp; cp = cp->next)
2827         {
2828           /* Count the number of cases in the whole construct.  */
2829           ncases++;
2830
2831           /* Intercept the DEFAULT case.  */
2832           if (cp->low == NULL && cp->high == NULL)
2833             {
2834               if (default_case != NULL)
2835                 {
2836                   gfc_error ("The DEFAULT CASE at %L cannot be followed "
2837                              "by a second DEFAULT CASE at %L",
2838                              &default_case->where, &cp->where);
2839                   t = FAILURE;
2840                   break;
2841                 }
2842               else
2843                 {
2844                   default_case = cp;
2845                   continue;
2846                 }
2847             }
2848
2849           /* Deal with single value cases and case ranges.  Errors are
2850              issued from the validation function.  */
2851           if(validate_case_label_expr (cp->low, case_expr) != SUCCESS
2852              || validate_case_label_expr (cp->high, case_expr) != SUCCESS)
2853             {
2854               t = FAILURE;
2855               break;
2856             }
2857
2858           if (type == BT_LOGICAL
2859               && ((cp->low == NULL || cp->high == NULL)
2860                   || cp->low != cp->high))
2861             {
2862               gfc_error
2863                 ("Logical range in CASE statement at %L is not allowed",
2864                  &cp->low->where);
2865               t = FAILURE;
2866               break;
2867             }
2868
2869           if (cp->low != NULL && cp->high != NULL
2870               && cp->low != cp->high
2871               && gfc_compare_expr (cp->low, cp->high) > 0)
2872             {
2873               if (gfc_option.warn_surprising)
2874                 gfc_warning ("Range specification at %L can never "
2875                              "be matched", &cp->where);
2876
2877               cp->unreachable = 1;
2878               seen_unreachable = 1;
2879             }
2880           else
2881             {
2882               /* If the case range can be matched, it can also overlap with
2883                  other cases.  To make sure it does not, we put it in a
2884                  double linked list here.  We sort that with a merge sort
2885                  later on to detect any overlapping cases.  */
2886               if (!head)
2887                 {
2888                   head = tail = cp;
2889                   head->right = head->left = NULL;
2890                 }
2891               else
2892                 {
2893                   tail->right = cp;
2894                   tail->right->left = tail;
2895                   tail = tail->right;
2896                   tail->right = NULL;
2897                 }
2898             }
2899         }
2900
2901       /* It there was a failure in the previous case label, give up
2902          for this case label list.  Continue with the next block.  */
2903       if (t == FAILURE)
2904         continue;
2905
2906       /* See if any case labels that are unreachable have been seen.
2907          If so, we eliminate them.  This is a bit of a kludge because
2908          the case lists for a single case statement (label) is a
2909          single forward linked lists.  */
2910       if (seen_unreachable)
2911       {
2912         /* Advance until the first case in the list is reachable.  */
2913         while (body->ext.case_list != NULL
2914                && body->ext.case_list->unreachable)
2915           {
2916             gfc_case *n = body->ext.case_list;
2917             body->ext.case_list = body->ext.case_list->next;
2918             n->next = NULL;
2919             gfc_free_case_list (n);
2920           }
2921
2922         /* Strip all other unreachable cases.  */
2923         if (body->ext.case_list)
2924           {
2925             for (cp = body->ext.case_list; cp->next; cp = cp->next)
2926               {
2927                 if (cp->next->unreachable)
2928                   {
2929                     gfc_case *n = cp->next;
2930                     cp->next = cp->next->next;
2931                     n->next = NULL;
2932                     gfc_free_case_list (n);
2933                   }
2934               }
2935           }
2936       }
2937     }
2938
2939   /* See if there were overlapping cases.  If the check returns NULL,
2940      there was overlap.  In that case we don't do anything.  If head
2941      is non-NULL, we prepend the DEFAULT case.  The sorted list can
2942      then used during code generation for SELECT CASE constructs with
2943      a case expression of a CHARACTER type.  */
2944   if (head)
2945     {
2946       head = check_case_overlap (head);
2947
2948       /* Prepend the default_case if it is there.  */
2949       if (head != NULL && default_case)
2950         {
2951           default_case->left = NULL;
2952           default_case->right = head;
2953           head->left = default_case;
2954         }
2955     }
2956
2957   /* Eliminate dead blocks that may be the result if we've seen
2958      unreachable case labels for a block.  */
2959   for (body = code; body && body->block; body = body->block)
2960     {
2961       if (body->block->ext.case_list == NULL)
2962         {
2963           /* Cut the unreachable block from the code chain.  */
2964           gfc_code *c = body->block;
2965           body->block = c->block;
2966
2967           /* Kill the dead block, but not the blocks below it.  */
2968           c->block = NULL;
2969           gfc_free_statements (c);
2970         }
2971     }
2972
2973   /* More than two cases is legal but insane for logical selects.
2974      Issue a warning for it.  */
2975   if (gfc_option.warn_surprising && type == BT_LOGICAL
2976       && ncases > 2)
2977     gfc_warning ("Logical SELECT CASE block at %L has more that two cases",
2978                  &code->loc);
2979 }
2980
2981
2982 /* Resolve a transfer statement. This is making sure that:
2983    -- a derived type being transferred has only non-pointer components
2984    -- a derived type being transferred doesn't have private components
2985    -- we're not trying to transfer a whole assumed size array.  */
2986
2987 static void
2988 resolve_transfer (gfc_code * code)
2989 {
2990   gfc_typespec *ts;
2991   gfc_symbol *sym;
2992   gfc_ref *ref;
2993   gfc_expr *exp;
2994
2995   exp = code->expr;
2996
2997   if (exp->expr_type != EXPR_VARIABLE)
2998     return;
2999
3000   sym = exp->symtree->n.sym;
3001   ts = &sym->ts;
3002
3003   /* Go to actual component transferred.  */
3004   for (ref = code->expr->ref; ref; ref = ref->next)
3005     if (ref->type == REF_COMPONENT)
3006       ts = &ref->u.c.component->ts;
3007
3008   if (ts->type == BT_DERIVED)
3009     {
3010       /* Check that transferred derived type doesn't contain POINTER
3011          components.  */
3012       if (derived_pointer (ts->derived))
3013         {
3014           gfc_error ("Data transfer element at %L cannot have "
3015                      "POINTER components", &code->loc);
3016           return;
3017         }
3018
3019       if (ts->derived->component_access == ACCESS_PRIVATE)
3020         {
3021           gfc_error ("Data transfer element at %L cannot have "
3022                      "PRIVATE components",&code->loc);
3023           return;
3024         }
3025     }
3026
3027   if (sym->as != NULL && sym->as->type == AS_ASSUMED_SIZE
3028       && exp->ref->type == REF_ARRAY && exp->ref->u.ar.type == AR_FULL)
3029     {
3030       gfc_error ("Data transfer element at %L cannot be a full reference to "
3031                  "an assumed-size array", &code->loc);
3032       return;
3033     }
3034 }
3035
3036
3037 /*********** Toplevel code resolution subroutines ***********/
3038
3039 /* Given a branch to a label and a namespace, if the branch is conforming.
3040    The code node described where the branch is located.  */
3041
3042 static void
3043 resolve_branch (gfc_st_label * label, gfc_code * code)
3044 {
3045   gfc_code *block, *found;
3046   code_stack *stack;
3047   gfc_st_label *lp;
3048
3049   if (label == NULL)
3050     return;
3051   lp = label;
3052
3053   /* Step one: is this a valid branching target?  */
3054
3055   if (lp->defined == ST_LABEL_UNKNOWN)
3056     {
3057       gfc_error ("Label %d referenced at %L is never defined", lp->value,
3058                  &lp->where);
3059       return;
3060     }
3061
3062   if (lp->defined != ST_LABEL_TARGET)
3063     {
3064       gfc_error ("Statement at %L is not a valid branch target statement "
3065                  "for the branch statement at %L", &lp->where, &code->loc);
3066       return;
3067     }
3068
3069   /* Step two: make sure this branch is not a branch to itself ;-)  */
3070
3071   if (code->here == label)
3072     {
3073       gfc_warning ("Branch at %L causes an infinite loop", &code->loc);
3074       return;
3075     }
3076
3077   /* Step three: Try to find the label in the parse tree. To do this,
3078      we traverse the tree block-by-block: first the block that
3079      contains this GOTO, then the block that it is nested in, etc.  We
3080      can ignore other blocks because branching into another block is
3081      not allowed.  */
3082
3083   found = NULL;
3084
3085   for (stack = cs_base; stack; stack = stack->prev)
3086     {
3087       for (block = stack->head; block; block = block->next)
3088         {
3089           if (block->here == label)
3090             {
3091               found = block;
3092               break;
3093             }
3094         }
3095
3096       if (found)
3097         break;
3098     }
3099
3100   if (found == NULL)
3101     {
3102       /* still nothing, so illegal.  */
3103       gfc_error_now ("Label at %L is not in the same block as the "
3104                      "GOTO statement at %L", &lp->where, &code->loc);
3105       return;
3106     }
3107
3108   /* Step four: Make sure that the branching target is legal if
3109      the statement is an END {SELECT,DO,IF}.  */
3110
3111   if (found->op == EXEC_NOP)
3112     {
3113       for (stack = cs_base; stack; stack = stack->prev)
3114         if (stack->current->next == found)
3115           break;
3116
3117       if (stack == NULL)
3118         gfc_notify_std (GFC_STD_F95_DEL,
3119                         "Obsolete: GOTO at %L jumps to END of construct at %L",
3120                         &code->loc, &found->loc);
3121     }
3122 }
3123
3124
3125 /* Check whether EXPR1 has the same shape as EXPR2.  */
3126
3127 static try
3128 resolve_where_shape (gfc_expr *expr1, gfc_expr *expr2)
3129 {
3130   mpz_t shape[GFC_MAX_DIMENSIONS];
3131   mpz_t shape2[GFC_MAX_DIMENSIONS];
3132   try result = FAILURE;
3133   int i;
3134
3135   /* Compare the rank.  */
3136   if (expr1->rank != expr2->rank)
3137     return result;
3138
3139   /* Compare the size of each dimension.  */
3140   for (i=0; i<expr1->rank; i++)
3141     {
3142       if (gfc_array_dimen_size (expr1, i, &shape[i]) == FAILURE)
3143         goto ignore;
3144
3145       if (gfc_array_dimen_size (expr2, i, &shape2[i]) == FAILURE)
3146         goto ignore;
3147
3148       if (mpz_cmp (shape[i], shape2[i]))
3149         goto over;
3150     }
3151
3152   /* When either of the two expression is an assumed size array, we
3153      ignore the comparison of dimension sizes.  */
3154 ignore:
3155   result = SUCCESS;
3156
3157 over:
3158   for (i--; i>=0; i--)
3159     {
3160       mpz_clear (shape[i]);
3161       mpz_clear (shape2[i]);
3162     }
3163   return result;
3164 }
3165
3166
3167 /* Check whether a WHERE assignment target or a WHERE mask expression
3168    has the same shape as the outmost WHERE mask expression.  */
3169
3170 static void
3171 resolve_where (gfc_code *code, gfc_expr *mask)
3172 {
3173   gfc_code *cblock;
3174   gfc_code *cnext;
3175   gfc_expr *e = NULL;
3176
3177   cblock = code->block;
3178
3179   /* Store the first WHERE mask-expr of the WHERE statement or construct.
3180      In case of nested WHERE, only the outmost one is stored.  */
3181   if (mask == NULL) /* outmost WHERE */
3182     e = cblock->expr;
3183   else /* inner WHERE */
3184     e = mask;
3185
3186   while (cblock)
3187     {
3188       if (cblock->expr)
3189         {
3190           /* Check if the mask-expr has a consistent shape with the
3191              outmost WHERE mask-expr.  */
3192           if (resolve_where_shape (cblock->expr, e) == FAILURE)
3193             gfc_error ("WHERE mask at %L has inconsistent shape",
3194                        &cblock->expr->where);
3195          }
3196
3197       /* the assignment statement of a WHERE statement, or the first
3198          statement in where-body-construct of a WHERE construct */
3199       cnext = cblock->next;
3200       while (cnext)
3201         {
3202           switch (cnext->op)
3203             {
3204             /* WHERE assignment statement */
3205             case EXEC_ASSIGN:
3206
3207               /* Check shape consistent for WHERE assignment target.  */
3208               if (e && resolve_where_shape (cnext->expr, e) == FAILURE)
3209                gfc_error ("WHERE assignment target at %L has "
3210                           "inconsistent shape", &cnext->expr->where);
3211               break;
3212
3213             /* WHERE or WHERE construct is part of a where-body-construct */
3214             case EXEC_WHERE:
3215               resolve_where (cnext, e);
3216               break;
3217
3218             default:
3219               gfc_error ("Unsupported statement inside WHERE at %L",
3220                          &cnext->loc);
3221             }
3222          /* the next statement within the same where-body-construct */
3223          cnext = cnext->next;
3224        }
3225     /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
3226     cblock = cblock->block;
3227   }
3228 }
3229
3230
3231 /* Check whether the FORALL index appears in the expression or not.  */
3232
3233 static try
3234 gfc_find_forall_index (gfc_expr *expr, gfc_symbol *symbol)
3235 {
3236   gfc_array_ref ar;
3237   gfc_ref *tmp;
3238   gfc_actual_arglist *args;
3239   int i;
3240
3241   switch (expr->expr_type)
3242     {
3243     case EXPR_VARIABLE:
3244       gcc_assert (expr->symtree->n.sym);
3245
3246       /* A scalar assignment  */
3247       if (!expr->ref)
3248         {
3249           if (expr->symtree->n.sym == symbol)
3250             return SUCCESS;
3251           else
3252             return FAILURE;
3253         }
3254
3255       /* the expr is array ref, substring or struct component.  */
3256       tmp = expr->ref;
3257       while (tmp != NULL)
3258         {
3259           switch (tmp->type)
3260             {
3261             case  REF_ARRAY:
3262               /* Check if the symbol appears in the array subscript.  */
3263               ar = tmp->u.ar;
3264               for (i = 0; i < GFC_MAX_DIMENSIONS; i++)
3265                 {
3266                   if (ar.start[i])
3267                     if (gfc_find_forall_index (ar.start[i], symbol) == SUCCESS)
3268                       return SUCCESS;
3269
3270                   if (ar.end[i])
3271                     if (gfc_find_forall_index (ar.end[i], symbol) == SUCCESS)
3272                       return SUCCESS;
3273
3274                   if (ar.stride[i])
3275                     if (gfc_find_forall_index (ar.stride[i], symbol) == SUCCESS)
3276                       return SUCCESS;
3277                 }  /* end for  */
3278               break;
3279
3280             case REF_SUBSTRING:
3281               if (expr->symtree->n.sym == symbol)
3282                 return SUCCESS;
3283               tmp = expr->ref;
3284               /* Check if the symbol appears in the substring section.  */
3285               if (gfc_find_forall_index (tmp->u.ss.start, symbol) == SUCCESS)
3286                 return SUCCESS;
3287               if (gfc_find_forall_index (tmp->u.ss.end, symbol) == SUCCESS)
3288                 return SUCCESS;
3289               break;
3290
3291             case REF_COMPONENT:
3292               break;
3293
3294             default:
3295               gfc_error("expresion reference type error at %L", &expr->where);
3296             }
3297           tmp = tmp->next;
3298         }
3299       break;
3300
3301     /* If the expression is a function call, then check if the symbol
3302        appears in the actual arglist of the function.  */
3303     case EXPR_FUNCTION:
3304       for (args = expr->value.function.actual; args; args = args->next)
3305         {
3306           if (gfc_find_forall_index(args->expr,symbol) == SUCCESS)
3307             return SUCCESS;
3308         }
3309       break;
3310
3311     /* It seems not to happen.  */
3312     case EXPR_SUBSTRING:
3313       if (expr->ref)
3314         {
3315           tmp = expr->ref;
3316           gcc_assert (expr->ref->type == REF_SUBSTRING);
3317           if (gfc_find_forall_index (tmp->u.ss.start, symbol) == SUCCESS)
3318             return SUCCESS;
3319           if (gfc_find_forall_index (tmp->u.ss.end, symbol) == SUCCESS)
3320             return SUCCESS;
3321         }
3322       break;
3323
3324     /* It seems not to happen.  */
3325     case EXPR_STRUCTURE:
3326     case EXPR_ARRAY:
3327       gfc_error ("Unsupported statement while finding forall index in "
3328                  "expression");
3329       break;
3330
3331     case EXPR_OP:
3332       /* Find the FORALL index in the first operand.  */
3333       if (expr->value.op.op1)
3334         {
3335           if (gfc_find_forall_index (expr->value.op.op1, symbol) == SUCCESS)
3336             return SUCCESS;
3337         }
3338
3339       /* Find the FORALL index in the second operand.  */
3340       if (expr->value.op.op2)
3341         {
3342           if (gfc_find_forall_index (expr->value.op.op2, symbol) == SUCCESS)
3343             return SUCCESS;
3344         }
3345       break;
3346
3347     default:
3348       break;
3349     }
3350
3351   return FAILURE;
3352 }
3353
3354
3355 /* Resolve assignment in FORALL construct.
3356    NVAR is the number of FORALL index variables, and VAR_EXPR records the
3357    FORALL index variables.  */
3358
3359 static void
3360 gfc_resolve_assign_in_forall (gfc_code *code, int nvar, gfc_expr **var_expr)
3361 {
3362   int n;
3363
3364   for (n = 0; n < nvar; n++)
3365     {
3366       gfc_symbol *forall_index;
3367
3368       forall_index = var_expr[n]->symtree->n.sym;
3369
3370       /* Check whether the assignment target is one of the FORALL index
3371          variable.  */
3372       if ((code->expr->expr_type == EXPR_VARIABLE)
3373           && (code->expr->symtree->n.sym == forall_index))
3374         gfc_error ("Assignment to a FORALL index variable at %L",
3375                    &code->expr->where);
3376       else
3377         {
3378           /* If one of the FORALL index variables doesn't appear in the
3379              assignment target, then there will be a many-to-one
3380              assignment.  */
3381           if (gfc_find_forall_index (code->expr, forall_index) == FAILURE)
3382             gfc_error ("The FORALL with index '%s' cause more than one "
3383                        "assignment to this object at %L",
3384                        var_expr[n]->symtree->name, &code->expr->where);
3385         }
3386     }
3387 }
3388
3389
3390 /* Resolve WHERE statement in FORALL construct.  */
3391
3392 static void
3393 gfc_resolve_where_code_in_forall (gfc_code *code, int nvar, gfc_expr **var_expr){
3394   gfc_code *cblock;
3395   gfc_code *cnext;
3396
3397   cblock = code->block;
3398   while (cblock)
3399     {
3400       /* the assignment statement of a WHERE statement, or the first
3401          statement in where-body-construct of a WHERE construct */
3402       cnext = cblock->next;
3403       while (cnext)
3404         {
3405           switch (cnext->op)
3406             {
3407             /* WHERE assignment statement */
3408             case EXEC_ASSIGN:
3409               gfc_resolve_assign_in_forall (cnext, nvar, var_expr);
3410               break;
3411
3412             /* WHERE or WHERE construct is part of a where-body-construct */
3413             case EXEC_WHERE:
3414               gfc_resolve_where_code_in_forall (cnext, nvar, var_expr);
3415               break;
3416
3417             default:
3418               gfc_error ("Unsupported statement inside WHERE at %L",
3419                          &cnext->loc);
3420             }
3421           /* the next statement within the same where-body-construct */
3422           cnext = cnext->next;
3423         }
3424       /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
3425       cblock = cblock->block;
3426     }
3427 }
3428
3429
3430 /* Traverse the FORALL body to check whether the following errors exist:
3431    1. For assignment, check if a many-to-one assignment happens.
3432    2. For WHERE statement, check the WHERE body to see if there is any
3433       many-to-one assignment.  */
3434
3435 static void
3436 gfc_resolve_forall_body (gfc_code *code, int nvar, gfc_expr **var_expr)
3437 {
3438   gfc_code *c;
3439
3440   c = code->block->next;
3441   while (c)
3442     {
3443       switch (c->op)
3444         {
3445         case EXEC_ASSIGN:
3446         case EXEC_POINTER_ASSIGN:
3447           gfc_resolve_assign_in_forall (c, nvar, var_expr);
3448           break;
3449
3450         /* Because the resolve_blocks() will handle the nested FORALL,
3451            there is no need to handle it here.  */
3452         case EXEC_FORALL:
3453           break;
3454         case EXEC_WHERE:
3455           gfc_resolve_where_code_in_forall(c, nvar, var_expr);
3456           break;
3457         default:
3458           break;
3459         }
3460       /* The next statement in the FORALL body.  */
3461       c = c->next;
3462     }
3463 }
3464
3465
3466 /* Given a FORALL construct, first resolve the FORALL iterator, then call
3467    gfc_resolve_forall_body to resolve the FORALL body.  */
3468
3469 static void resolve_blocks (gfc_code *, gfc_namespace *);
3470
3471 static void
3472 gfc_resolve_forall (gfc_code *code, gfc_namespace *ns, int forall_save)
3473 {
3474   static gfc_expr **var_expr;
3475   static int total_var = 0;
3476   static int nvar = 0;
3477   gfc_forall_iterator *fa;
3478   gfc_symbol *forall_index;
3479   gfc_code *next;
3480   int i;
3481
3482   /* Start to resolve a FORALL construct   */
3483   if (forall_save == 0)
3484     {
3485       /* Count the total number of FORALL index in the nested FORALL
3486          construct in order to allocate the VAR_EXPR with proper size.  */
3487       next = code;
3488       while ((next != NULL) && (next->op == EXEC_FORALL))
3489         {
3490           for (fa = next->ext.forall_iterator; fa; fa = fa->next)
3491             total_var ++;
3492           next = next->block->next;
3493         }
3494
3495       /* Allocate VAR_EXPR with NUMBER_OF_FORALL_INDEX elements.  */
3496       var_expr = (gfc_expr **) gfc_getmem (total_var * sizeof (gfc_expr *));
3497     }
3498
3499   /* The information about FORALL iterator, including FORALL index start, end
3500      and stride. The FORALL index can not appear in start, end or stride.  */
3501   for (fa = code->ext.forall_iterator; fa; fa = fa->next)
3502     {
3503       /* Check if any outer FORALL index name is the same as the current
3504          one.  */
3505       for (i = 0; i < nvar; i++)
3506         {
3507           if (fa->var->symtree->n.sym == var_expr[i]->symtree->n.sym)
3508             {
3509               gfc_error ("An outer FORALL construct already has an index "
3510                          "with this name %L", &fa->var->where);
3511             }
3512         }
3513
3514       /* Record the current FORALL index.  */
3515       var_expr[nvar] = gfc_copy_expr (fa->var);
3516
3517       forall_index = fa->var->symtree->n.sym;
3518
3519       /* Check if the FORALL index appears in start, end or stride.  */
3520       if (gfc_find_forall_index (fa->start, forall_index) == SUCCESS)
3521         gfc_error ("A FORALL index must not appear in a limit or stride "
3522                    "expression in the same FORALL at %L", &fa->start->where);
3523       if (gfc_find_forall_index (fa->end, forall_index) == SUCCESS)
3524         gfc_error ("A FORALL index must not appear in a limit or stride "
3525                    "expression in the same FORALL at %L", &fa->end->where);
3526       if (gfc_find_forall_index (fa->stride, forall_index) == SUCCESS)
3527         gfc_error ("A FORALL index must not appear in a limit or stride "
3528                    "expression in the same FORALL at %L", &fa->stride->where);
3529       nvar++;
3530     }
3531
3532   /* Resolve the FORALL body.  */
3533   gfc_resolve_forall_body (code, nvar, var_expr);
3534
3535   /* May call gfc_resolve_forall to resolve the inner FORALL loop.  */
3536   resolve_blocks (code->block, ns);
3537
3538   /* Free VAR_EXPR after the whole FORALL construct resolved.  */
3539   for (i = 0; i < total_var; i++)
3540     gfc_free_expr (var_expr[i]);
3541
3542   /* Reset the counters.  */
3543   total_var = 0;
3544   nvar = 0;
3545 }
3546
3547
3548 /* Resolve lists of blocks found in IF, SELECT CASE, WHERE, FORALL ,GOTO and
3549    DO code nodes.  */
3550
3551 static void resolve_code (gfc_code *, gfc_namespace *);
3552
3553 static void
3554 resolve_blocks (gfc_code * b, gfc_namespace * ns)
3555 {
3556   try t;
3557
3558   for (; b; b = b->block)
3559     {
3560       t = gfc_resolve_expr (b->expr);
3561       if (gfc_resolve_expr (b->expr2) == FAILURE)
3562         t = FAILURE;
3563
3564       switch (b->op)
3565         {
3566         case EXEC_IF:
3567           if (t == SUCCESS && b->expr != NULL
3568               && (b->expr->ts.type != BT_LOGICAL || b->expr->rank != 0))
3569             gfc_error
3570               ("ELSE IF clause at %L requires a scalar LOGICAL expression",
3571                &b->expr->where);
3572           break;
3573
3574         case EXEC_WHERE:
3575           if (t == SUCCESS
3576               && b->expr != NULL
3577               && (b->expr->ts.type != BT_LOGICAL
3578                   || b->expr->rank == 0))
3579             gfc_error
3580               ("WHERE/ELSEWHERE clause at %L requires a LOGICAL array",
3581                &b->expr->where);
3582           break;
3583
3584         case EXEC_GOTO:
3585           resolve_branch (b->label, b);
3586           break;
3587
3588         case EXEC_SELECT:
3589         case EXEC_FORALL:
3590         case EXEC_DO:
3591         case EXEC_DO_WHILE:
3592           break;
3593
3594         default:
3595           gfc_internal_error ("resolve_block(): Bad block type");
3596         }
3597
3598       resolve_code (b->next, ns);
3599     }
3600 }
3601
3602
3603 /* Given a block of code, recursively resolve everything pointed to by this
3604    code block.  */
3605
3606 static void
3607 resolve_code (gfc_code * code, gfc_namespace * ns)
3608 {
3609   int forall_save = 0;
3610   code_stack frame;
3611   gfc_alloc *a;
3612   try t;
3613
3614   frame.prev = cs_base;
3615   frame.head = code;
3616   cs_base = &frame;
3617
3618   for (; code; code = code->next)
3619     {
3620       frame.current = code;
3621
3622       if (code->op == EXEC_FORALL)
3623         {
3624           forall_save = forall_flag;
3625           forall_flag = 1;
3626           gfc_resolve_forall (code, ns, forall_save);
3627         }
3628       else
3629         resolve_blocks (code->block, ns);
3630
3631       if (code->op == EXEC_FORALL)
3632         forall_flag = forall_save;
3633
3634       t = gfc_resolve_expr (code->expr);
3635       if (gfc_resolve_expr (code->expr2) == FAILURE)
3636         t = FAILURE;
3637
3638       switch (code->op)
3639         {
3640         case EXEC_NOP:
3641         case EXEC_CYCLE:
3642         case EXEC_PAUSE:
3643         case EXEC_STOP:
3644         case EXEC_EXIT:
3645         case EXEC_CONTINUE:
3646         case EXEC_DT_END:
3647         case EXEC_ENTRY:
3648           break;
3649
3650         case EXEC_WHERE:
3651           resolve_where (code, NULL);
3652           break;
3653
3654         case EXEC_GOTO:
3655           if (code->expr != NULL && code->expr->ts.type != BT_INTEGER)
3656             gfc_error ("ASSIGNED GOTO statement at %L requires an INTEGER "
3657                        "variable", &code->expr->where);
3658           else
3659             resolve_branch (code->label, code);
3660           break;
3661
3662         case EXEC_RETURN:
3663           if (code->expr != NULL && code->expr->ts.type != BT_INTEGER)
3664             gfc_error ("Alternate RETURN statement at %L requires an INTEGER "
3665                        "return specifier", &code->expr->where);
3666           break;
3667
3668         case EXEC_ASSIGN:
3669           if (t == FAILURE)
3670             break;
3671
3672           if (gfc_extend_assign (code, ns) == SUCCESS)
3673             goto call;
3674
3675           if (gfc_pure (NULL))
3676             {
3677               if (gfc_impure_variable (code->expr->symtree->n.sym))
3678                 {
3679                   gfc_error
3680                     ("Cannot assign to variable '%s' in PURE procedure at %L",
3681                      code->expr->symtree->n.sym->name, &code->expr->where);
3682                   break;
3683                 }
3684
3685               if (code->expr2->ts.type == BT_DERIVED
3686                   && derived_pointer (code->expr2->ts.derived))
3687                 {
3688                   gfc_error
3689                     ("Right side of assignment at %L is a derived type "
3690                      "containing a POINTER in a PURE procedure",
3691                      &code->expr2->where);
3692                   break;
3693                 }
3694             }
3695
3696           gfc_check_assign (code->expr, code->expr2, 1);
3697           break;
3698
3699         case EXEC_LABEL_ASSIGN:
3700           if (code->label->defined == ST_LABEL_UNKNOWN)
3701             gfc_error ("Label %d referenced at %L is never defined",
3702                        code->label->value, &code->label->where);
3703           if (t == SUCCESS
3704               && (code->expr->expr_type != EXPR_VARIABLE
3705                   || code->expr->symtree->n.sym->ts.type != BT_INTEGER
3706                   || code->expr->symtree->n.sym->ts.kind 
3707                         != gfc_default_integer_kind
3708                   || code->expr->symtree->n.sym->as != NULL))
3709             gfc_error ("ASSIGN statement at %L requires a scalar "
3710                        "default INTEGER variable", &code->expr->where);
3711           break;
3712
3713         case EXEC_POINTER_ASSIGN:
3714           if (t == FAILURE)
3715             break;
3716
3717           gfc_check_pointer_assign (code->expr, code->expr2);
3718           break;
3719
3720         case EXEC_ARITHMETIC_IF:
3721           if (t == SUCCESS
3722               && code->expr->ts.type != BT_INTEGER
3723               && code->expr->ts.type != BT_REAL)
3724             gfc_error ("Arithmetic IF statement at %L requires a numeric "
3725                        "expression", &code->expr->where);
3726
3727           resolve_branch (code->label, code);
3728           resolve_branch (code->label2, code);
3729           resolve_branch (code->label3, code);
3730           break;
3731
3732         case EXEC_IF:
3733           if (t == SUCCESS && code->expr != NULL
3734               && (code->expr->ts.type != BT_LOGICAL
3735                   || code->expr->rank != 0))
3736             gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
3737                        &code->expr->where);
3738           break;
3739
3740         case EXEC_CALL:
3741         call:
3742           resolve_call (code);
3743           break;
3744
3745         case EXEC_SELECT:
3746           /* Select is complicated. Also, a SELECT construct could be
3747              a transformed computed GOTO.  */
3748           resolve_select (code);
3749           break;
3750
3751         case EXEC_DO:
3752           if (code->ext.iterator != NULL)
3753             gfc_resolve_iterator (code->ext.iterator, true);
3754           break;
3755
3756         case EXEC_DO_WHILE:
3757           if (code->expr == NULL)
3758             gfc_internal_error ("resolve_code(): No expression on DO WHILE");
3759           if (t == SUCCESS
3760               && (code->expr->rank != 0
3761                   || code->expr->ts.type != BT_LOGICAL))
3762             gfc_error ("Exit condition of DO WHILE loop at %L must be "
3763                        "a scalar LOGICAL expression", &code->expr->where);
3764           break;
3765
3766         case EXEC_ALLOCATE:
3767           if (t == SUCCESS && code->expr != NULL
3768               && code->expr->ts.type != BT_INTEGER)
3769             gfc_error ("STAT tag in ALLOCATE statement at %L must be "
3770                        "of type INTEGER", &code->expr->where);
3771
3772           for (a = code->ext.alloc_list; a; a = a->next)
3773             resolve_allocate_expr (a->expr);
3774
3775           break;
3776
3777         case EXEC_DEALLOCATE:
3778           if (t == SUCCESS && code->expr != NULL
3779               && code->expr->ts.type != BT_INTEGER)
3780             gfc_error
3781               ("STAT tag in DEALLOCATE statement at %L must be of type "
3782                "INTEGER", &code->expr->where);
3783
3784           for (a = code->ext.alloc_list; a; a = a->next)
3785             resolve_deallocate_expr (a->expr);
3786
3787           break;
3788
3789         case EXEC_OPEN:
3790           if (gfc_resolve_open (code->ext.open) == FAILURE)
3791             break;
3792
3793           resolve_branch (code->ext.open->err, code);
3794           break;
3795
3796         case EXEC_CLOSE:
3797           if (gfc_resolve_close (code->ext.close) == FAILURE)
3798             break;
3799
3800           resolve_branch (code->ext.close->err, code);
3801           break;
3802
3803         case EXEC_BACKSPACE:
3804         case EXEC_ENDFILE:
3805         case EXEC_REWIND:
3806           if (gfc_resolve_filepos (code->ext.filepos) == FAILURE)
3807             break;
3808
3809           resolve_branch (code->ext.filepos->err, code);
3810           break;
3811
3812         case EXEC_INQUIRE:
3813           if (gfc_resolve_inquire (code->ext.inquire) == FAILURE)
3814               break;
3815
3816           resolve_branch (code->ext.inquire->err, code);
3817           break;
3818
3819         case EXEC_IOLENGTH:
3820           gcc_assert (code->ext.inquire != NULL);
3821           if (gfc_resolve_inquire (code->ext.inquire) == FAILURE)
3822             break;
3823
3824           resolve_branch (code->ext.inquire->err, code);
3825           break;
3826
3827         case EXEC_READ:
3828         case EXEC_WRITE:
3829           if (gfc_resolve_dt (code->ext.dt) == FAILURE)
3830             break;
3831
3832           resolve_branch (code->ext.dt->err, code);
3833           resolve_branch (code->ext.dt->end, code);
3834           resolve_branch (code->ext.dt->eor, code);
3835           break;
3836
3837         case EXEC_TRANSFER:
3838           resolve_transfer (code);
3839           break;
3840
3841         case EXEC_FORALL:
3842           resolve_forall_iterators (code->ext.forall_iterator);
3843
3844           if (code->expr != NULL && code->expr->ts.type != BT_LOGICAL)
3845             gfc_error
3846               ("FORALL mask clause at %L requires a LOGICAL expression",
3847                &code->expr->where);
3848           break;
3849
3850         default:
3851           gfc_internal_error ("resolve_code(): Bad statement code");
3852         }
3853     }
3854
3855   cs_base = frame.prev;
3856 }
3857
3858
3859 /* Resolve initial values and make sure they are compatible with
3860    the variable.  */
3861
3862 static void
3863 resolve_values (gfc_symbol * sym)
3864 {
3865
3866   if (sym->value == NULL)
3867     return;
3868
3869   if (gfc_resolve_expr (sym->value) == FAILURE)
3870     return;
3871
3872   gfc_check_assign_symbol (sym, sym->value);
3873 }
3874
3875
3876 /* Do anything necessary to resolve a symbol.  Right now, we just
3877    assume that an otherwise unknown symbol is a variable.  This sort
3878    of thing commonly happens for symbols in module.  */
3879
3880 static void
3881 resolve_symbol (gfc_symbol * sym)
3882 {
3883   /* Zero if we are checking a formal namespace.  */
3884   static int formal_ns_flag = 1;
3885   int formal_ns_save, check_constant, mp_flag;
3886   int i;
3887   const char *whynot;
3888   gfc_namelist *nl;
3889
3890   if (sym->attr.flavor == FL_UNKNOWN)
3891     {
3892       if (sym->attr.external == 0 && sym->attr.intrinsic == 0)
3893         sym->attr.flavor = FL_VARIABLE;
3894       else
3895         {
3896           sym->attr.flavor = FL_PROCEDURE;
3897           if (sym->attr.dimension)
3898             sym->attr.function = 1;
3899         }
3900     }
3901
3902   /* Symbols that are module procedures with results (functions) have
3903      the types and array specification copied for type checking in
3904      procedures that call them, as well as for saving to a module
3905      file.  These symbols can't stand the scrutiny that their results
3906      can.  */
3907   mp_flag = (sym->result != NULL && sym->result != sym);
3908
3909   /* Assign default type to symbols that need one and don't have one.  */
3910   if (sym->ts.type == BT_UNKNOWN)
3911     {
3912       if (sym->attr.flavor == FL_VARIABLE || sym->attr.flavor == FL_PARAMETER)
3913         gfc_set_default_type (sym, 1, NULL);
3914
3915       if (sym->attr.flavor == FL_PROCEDURE && sym->attr.function)
3916         {
3917           if (!mp_flag)
3918             gfc_set_default_type (sym, 0, NULL);
3919           else
3920             {
3921               /* Result may be in another namespace.  */
3922               resolve_symbol (sym->result);
3923
3924               sym->ts = sym->result->ts;
3925               sym->as = gfc_copy_array_spec (sym->result->as);
3926             }
3927         }
3928     }
3929
3930   /* Assumed size arrays and assumed shape arrays must be dummy
3931      arguments.  */ 
3932
3933   if (sym->as != NULL
3934       && (sym->as->type == AS_ASSUMED_SIZE
3935           || sym->as->type == AS_ASSUMED_SHAPE)
3936       && sym->attr.dummy == 0)
3937     {
3938       gfc_error ("Assumed %s array at %L must be a dummy argument",
3939                  sym->as->type == AS_ASSUMED_SIZE ? "size" : "shape",
3940                  &sym->declared_at);
3941       return;
3942     }
3943
3944   /* A parameter array's shape needs to be constant.  */
3945
3946   if (sym->attr.flavor == FL_PARAMETER && sym->as != NULL 
3947       && !gfc_is_compile_time_shape (sym->as))
3948     {
3949       gfc_error ("Parameter array '%s' at %L cannot be automatic "
3950                  "or assumed shape", sym->name, &sym->declared_at);
3951           return;
3952     }
3953
3954   /* Make sure that character string variables with assumed length are
3955      dummy arguments.  */
3956
3957   if (sym->attr.flavor == FL_VARIABLE && !sym->attr.result
3958       && sym->ts.type == BT_CHARACTER
3959       && sym->ts.cl->length == NULL && sym->attr.dummy == 0)
3960     {
3961       gfc_error ("Entity with assumed character length at %L must be a "
3962                  "dummy argument or a PARAMETER", &sym->declared_at);
3963       return;
3964     }
3965
3966   /* Make sure a parameter that has been implicitly typed still
3967      matches the implicit type, since PARAMETER statements can precede
3968      IMPLICIT statements.  */
3969
3970   if (sym->attr.flavor == FL_PARAMETER
3971       && sym->attr.implicit_type
3972       && !gfc_compare_types (&sym->ts, gfc_get_default_type (sym, sym->ns)))
3973     gfc_error ("Implicitly typed PARAMETER '%s' at %L doesn't match a "
3974                "later IMPLICIT type", sym->name, &sym->declared_at);
3975
3976   /* Make sure the types of derived parameters are consistent.  This
3977      type checking is deferred until resolution because the type may
3978      refer to a derived type from the host.  */
3979
3980   if (sym->attr.flavor == FL_PARAMETER
3981       && sym->ts.type == BT_DERIVED
3982       && !gfc_compare_types (&sym->ts, &sym->value->ts))
3983     gfc_error ("Incompatible derived type in PARAMETER at %L",
3984                &sym->value->where);
3985
3986   /* Make sure symbols with known intent or optional are really dummy
3987      variable.  Because of ENTRY statement, this has to be deferred
3988      until resolution time.  */
3989
3990   if (! sym->attr.dummy
3991       && (sym->attr.optional
3992           || sym->attr.intent != INTENT_UNKNOWN))
3993     {
3994       gfc_error ("Symbol at %L is not a DUMMY variable", &sym->declared_at);
3995       return;
3996     }
3997
3998   if (sym->attr.proc == PROC_ST_FUNCTION)
3999     {
4000       if (sym->ts.type == BT_CHARACTER)
4001         {
4002           gfc_charlen *cl = sym->ts.cl;
4003           if (!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT)
4004             {
4005               gfc_error ("Character-valued statement function '%s' at %L must "
4006                          "have constant length", sym->name, &sym->declared_at);
4007               return;
4008             }
4009         }
4010     }
4011
4012   /* Constraints on deferred shape variable.  */
4013   if (sym->attr.flavor == FL_VARIABLE
4014       || (sym->attr.flavor == FL_PROCEDURE
4015           && sym->attr.function))
4016     {
4017       if (sym->as == NULL || sym->as->type != AS_DEFERRED)
4018         {
4019           if (sym->attr.allocatable)
4020             {
4021               if (sym->attr.dimension)
4022                 gfc_error ("Allocatable array at %L must have a deferred shape",
4023                            &sym->declared_at);
4024               else
4025                 gfc_error ("Object at %L may not be ALLOCATABLE",
4026                            &sym->declared_at);
4027               return;
4028             }
4029
4030           if (sym->attr.pointer && sym->attr.dimension)
4031             {
4032               gfc_error ("Pointer to array at %L must have a deferred shape",
4033                          &sym->declared_at);
4034               return;
4035             }
4036
4037         }
4038       else
4039         {
4040           if (!mp_flag && !sym->attr.allocatable
4041               && !sym->attr.pointer && !sym->attr.dummy)
4042             {
4043               gfc_error ("Array at %L cannot have a deferred shape",
4044                          &sym->declared_at);
4045               return;
4046             }
4047         }
4048     }
4049
4050   switch (sym->attr.flavor)
4051     {
4052     case FL_VARIABLE:
4053       /* Can the sybol have an initializer?  */
4054       whynot = NULL;
4055       if (sym->attr.allocatable)
4056         whynot = "Allocatable";
4057       else if (sym->attr.external)
4058         whynot = "External";
4059       else if (sym->attr.dummy)
4060         whynot = "Dummy";
4061       else if (sym->attr.intrinsic)
4062         whynot = "Intrinsic";
4063       else if (sym->attr.result)
4064         whynot = "Function Result";
4065       else if (sym->attr.dimension && !sym->attr.pointer)
4066         {
4067           /* Don't allow initialization of automatic arrays.  */
4068           for (i = 0; i < sym->as->rank; i++)
4069             {
4070               if (sym->as->lower[i] == NULL
4071                   || sym->as->lower[i]->expr_type != EXPR_CONSTANT
4072                   || sym->as->upper[i] == NULL
4073                   || sym->as->upper[i]->expr_type != EXPR_CONSTANT)
4074                 {
4075                   whynot = "Automatic array";
4076                   break;
4077                 }
4078             }
4079         }
4080
4081       /* Reject illegal initializers.  */
4082       if (sym->value && whynot)
4083         {
4084           gfc_error ("%s '%s' at %L cannot have an initializer",
4085                      whynot, sym->name, &sym->declared_at);
4086           return;
4087         }
4088
4089       /* Assign default initializer.  */
4090       if (sym->ts.type == BT_DERIVED && !(sym->value || whynot))
4091         sym->value = gfc_default_initializer (&sym->ts);
4092       break;
4093
4094     case FL_NAMELIST:
4095       /* Reject PRIVATE objects in a PUBLIC namelist.  */
4096       if (gfc_check_access(sym->attr.access, sym->ns->default_access))
4097         {
4098           for (nl = sym->namelist; nl; nl = nl->next)
4099             {
4100               if (!gfc_check_access(nl->sym->attr.access,
4101                                     nl->sym->ns->default_access))
4102                 gfc_error ("PRIVATE symbol '%s' cannot be member of "
4103                            "PUBLIC namelist at %L", nl->sym->name,
4104                            &sym->declared_at);
4105             }
4106         }
4107       break;
4108
4109     default:
4110       break;
4111     }
4112
4113
4114   /* Make sure that intrinsic exist */
4115   if (sym->attr.intrinsic
4116       && ! gfc_intrinsic_name(sym->name, 0)
4117       && ! gfc_intrinsic_name(sym->name, 1))
4118     gfc_error("Intrinsic at %L does not exist", &sym->declared_at);
4119
4120   /* Resolve array specifier. Check as well some constraints
4121      on COMMON blocks.  */
4122
4123   check_constant = sym->attr.in_common && !sym->attr.pointer;
4124   gfc_resolve_array_spec (sym->as, check_constant);
4125
4126   /* Resolve formal namespaces.  */
4127
4128   if (formal_ns_flag && sym != NULL && sym->formal_ns != NULL)
4129     {
4130       formal_ns_save = formal_ns_flag;
4131       formal_ns_flag = 0;
4132       gfc_resolve (sym->formal_ns);
4133       formal_ns_flag = formal_ns_save;
4134     }
4135 }
4136
4137
4138
4139 /************* Resolve DATA statements *************/
4140
4141 static struct
4142 {
4143   gfc_data_value *vnode;
4144   unsigned int left;
4145 }
4146 values;
4147
4148
4149 /* Advance the values structure to point to the next value in the data list.  */
4150
4151 static try
4152 next_data_value (void)
4153 {
4154   while (values.left == 0)
4155     {
4156       if (values.vnode->next == NULL)
4157         return FAILURE;
4158
4159       values.vnode = values.vnode->next;
4160       values.left = values.vnode->repeat;
4161     }
4162
4163   return SUCCESS;
4164 }
4165
4166
4167 static try
4168 check_data_variable (gfc_data_variable * var, locus * where)
4169 {
4170   gfc_expr *e;
4171   mpz_t size;
4172   mpz_t offset;
4173   try t;
4174   ar_type mark = AR_UNKNOWN;
4175   int i;
4176   mpz_t section_index[GFC_MAX_DIMENSIONS];
4177   gfc_ref *ref;
4178   gfc_array_ref *ar;
4179
4180   if (gfc_resolve_expr (var->expr) == FAILURE)
4181     return FAILURE;
4182
4183   ar = NULL;
4184   mpz_init_set_si (offset, 0);
4185   e = var->expr;
4186
4187   if (e->expr_type != EXPR_VARIABLE)
4188     gfc_internal_error ("check_data_variable(): Bad expression");
4189
4190   if (e->rank == 0)