OSDN Git Service

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