OSDN Git Service

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