OSDN Git Service

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