OSDN Git Service

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