OSDN Git Service

2010-08-04 Tobias Burnus <burnus@net-b.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 /* Resolve common variables.  */
707 static void
708 resolve_common_vars (gfc_symbol *sym, bool named_common)
709 {
710   gfc_symbol *csym = sym;
711
712   for (; csym; csym = csym->common_next)
713     {
714       if (csym->value || csym->attr.data)
715         {
716           if (!csym->ns->is_block_data)
717             gfc_notify_std (GFC_STD_GNU, "Variable '%s' at %L is in COMMON "
718                             "but only in BLOCK DATA initialization is "
719                             "allowed", csym->name, &csym->declared_at);
720           else if (!named_common)
721             gfc_notify_std (GFC_STD_GNU, "Initialized variable '%s' at %L is "
722                             "in a blank COMMON but initialization is only "
723                             "allowed in named common blocks", csym->name,
724                             &csym->declared_at);
725         }
726
727       if (csym->ts.type != BT_DERIVED)
728         continue;
729
730       if (!(csym->ts.u.derived->attr.sequence
731             || csym->ts.u.derived->attr.is_bind_c))
732         gfc_error_now ("Derived type variable '%s' in COMMON at %L "
733                        "has neither the SEQUENCE nor the BIND(C) "
734                        "attribute", csym->name, &csym->declared_at);
735       if (csym->ts.u.derived->attr.alloc_comp)
736         gfc_error_now ("Derived type variable '%s' in COMMON at %L "
737                        "has an ultimate component that is "
738                        "allocatable", csym->name, &csym->declared_at);
739       if (gfc_has_default_initializer (csym->ts.u.derived))
740         gfc_error_now ("Derived type variable '%s' in COMMON at %L "
741                        "may not have default initializer", csym->name,
742                        &csym->declared_at);
743
744       if (csym->attr.flavor == FL_UNKNOWN && !csym->attr.proc_pointer)
745         gfc_add_flavor (&csym->attr, FL_VARIABLE, csym->name, &csym->declared_at);
746     }
747 }
748
749 /* Resolve common blocks.  */
750 static void
751 resolve_common_blocks (gfc_symtree *common_root)
752 {
753   gfc_symbol *sym;
754
755   if (common_root == NULL)
756     return;
757
758   if (common_root->left)
759     resolve_common_blocks (common_root->left);
760   if (common_root->right)
761     resolve_common_blocks (common_root->right);
762
763   resolve_common_vars (common_root->n.common->head, true);
764
765   gfc_find_symbol (common_root->name, gfc_current_ns, 0, &sym);
766   if (sym == NULL)
767     return;
768
769   if (sym->attr.flavor == FL_PARAMETER)
770     gfc_error ("COMMON block '%s' at %L is used as PARAMETER at %L",
771                sym->name, &common_root->n.common->where, &sym->declared_at);
772
773   if (sym->attr.intrinsic)
774     gfc_error ("COMMON block '%s' at %L is also an intrinsic procedure",
775                sym->name, &common_root->n.common->where);
776   else if (sym->attr.result
777            || gfc_is_function_return_value (sym, gfc_current_ns))
778     gfc_notify_std (GFC_STD_F2003, "Fortran 2003: COMMON block '%s' at %L "
779                     "that is also a function result", sym->name,
780                     &common_root->n.common->where);
781   else if (sym->attr.flavor == FL_PROCEDURE && sym->attr.proc != PROC_INTERNAL
782            && sym->attr.proc != PROC_ST_FUNCTION)
783     gfc_notify_std (GFC_STD_F2003, "Fortran 2003: COMMON block '%s' at %L "
784                     "that is also a global procedure", sym->name,
785                     &common_root->n.common->where);
786 }
787
788
789 /* Resolve contained function types.  Because contained functions can call one
790    another, they have to be worked out before any of the contained procedures
791    can be resolved.
792
793    The good news is that if a function doesn't already have a type, the only
794    way it can get one is through an IMPLICIT type or a RESULT variable, because
795    by definition contained functions are contained namespace they're contained
796    in, not in a sibling or parent namespace.  */
797
798 static void
799 resolve_contained_functions (gfc_namespace *ns)
800 {
801   gfc_namespace *child;
802   gfc_entry_list *el;
803
804   resolve_formal_arglists (ns);
805
806   for (child = ns->contained; child; child = child->sibling)
807     {
808       /* Resolve alternate entry points first.  */
809       resolve_entries (child);
810
811       /* Then check function return types.  */
812       resolve_contained_fntype (child->proc_name, child);
813       for (el = child->entries; el; el = el->next)
814         resolve_contained_fntype (el->sym, child);
815     }
816 }
817
818
819 /* Resolve all of the elements of a structure constructor and make sure that
820    the types are correct.  */
821
822 static gfc_try
823 resolve_structure_cons (gfc_expr *expr)
824 {
825   gfc_constructor *cons;
826   gfc_component *comp;
827   gfc_try t;
828   symbol_attribute a;
829
830   t = SUCCESS;
831   cons = gfc_constructor_first (expr->value.constructor);
832   /* A constructor may have references if it is the result of substituting a
833      parameter variable.  In this case we just pull out the component we
834      want.  */
835   if (expr->ref)
836     comp = expr->ref->u.c.sym->components;
837   else
838     comp = expr->ts.u.derived->components;
839
840   /* See if the user is trying to invoke a structure constructor for one of
841      the iso_c_binding derived types.  */
842   if (expr->ts.type == BT_DERIVED && expr->ts.u.derived
843       && expr->ts.u.derived->ts.is_iso_c && cons
844       && (cons->expr == NULL || cons->expr->expr_type != EXPR_NULL))
845     {
846       gfc_error ("Components of structure constructor '%s' at %L are PRIVATE",
847                  expr->ts.u.derived->name, &(expr->where));
848       return FAILURE;
849     }
850
851   /* Return if structure constructor is c_null_(fun)prt.  */
852   if (expr->ts.type == BT_DERIVED && expr->ts.u.derived
853       && expr->ts.u.derived->ts.is_iso_c && cons
854       && cons->expr && cons->expr->expr_type == EXPR_NULL)
855     return SUCCESS;
856
857   for (; comp && cons; comp = comp->next, cons = gfc_constructor_next (cons))
858     {
859       int rank;
860
861       if (!cons->expr)
862         continue;
863
864       if (gfc_resolve_expr (cons->expr) == FAILURE)
865         {
866           t = FAILURE;
867           continue;
868         }
869
870       rank = comp->as ? comp->as->rank : 0;
871       if (cons->expr->expr_type != EXPR_NULL && rank != cons->expr->rank
872           && (comp->attr.allocatable || cons->expr->rank))
873         {
874           gfc_error ("The rank of the element in the derived type "
875                      "constructor at %L does not match that of the "
876                      "component (%d/%d)", &cons->expr->where,
877                      cons->expr->rank, rank);
878           t = FAILURE;
879         }
880
881       /* If we don't have the right type, try to convert it.  */
882
883       if (!gfc_compare_types (&cons->expr->ts, &comp->ts))
884         {
885           t = FAILURE;
886           if (strcmp (comp->name, "$extends") == 0)
887             {
888               /* Can afford to be brutal with the $extends initializer.
889                  The derived type can get lost because it is PRIVATE
890                  but it is not usage constrained by the standard.  */
891               cons->expr->ts = comp->ts;
892               t = SUCCESS;
893             }
894           else if (comp->attr.pointer && cons->expr->ts.type != BT_UNKNOWN)
895             gfc_error ("The element in the derived type constructor at %L, "
896                        "for pointer component '%s', is %s but should be %s",
897                        &cons->expr->where, comp->name,
898                        gfc_basic_typename (cons->expr->ts.type),
899                        gfc_basic_typename (comp->ts.type));
900           else
901             t = gfc_convert_type (cons->expr, &comp->ts, 1);
902         }
903
904       /* For strings, the length of the constructor should be the same as
905          the one of the structure, ensure this if the lengths are known at
906          compile time and when we are dealing with PARAMETER or structure
907          constructors.  */
908       if (cons->expr->ts.type == BT_CHARACTER && comp->ts.u.cl
909           && comp->ts.u.cl->length
910           && comp->ts.u.cl->length->expr_type == EXPR_CONSTANT
911           && cons->expr->ts.u.cl && cons->expr->ts.u.cl->length
912           && cons->expr->ts.u.cl->length->expr_type == EXPR_CONSTANT
913           && mpz_cmp (cons->expr->ts.u.cl->length->value.integer,
914                       comp->ts.u.cl->length->value.integer) != 0)
915         {
916           if (cons->expr->expr_type == EXPR_VARIABLE
917               && cons->expr->symtree->n.sym->attr.flavor == FL_PARAMETER)
918             {
919               /* Wrap the parameter in an array constructor (EXPR_ARRAY)
920                  to make use of the gfc_resolve_character_array_constructor
921                  machinery.  The expression is later simplified away to
922                  an array of string literals.  */
923               gfc_expr *para = cons->expr;
924               cons->expr = gfc_get_expr ();
925               cons->expr->ts = para->ts;
926               cons->expr->where = para->where;
927               cons->expr->expr_type = EXPR_ARRAY;
928               cons->expr->rank = para->rank;
929               cons->expr->shape = gfc_copy_shape (para->shape, para->rank);
930               gfc_constructor_append_expr (&cons->expr->value.constructor,
931                                            para, &cons->expr->where);
932             }
933           if (cons->expr->expr_type == EXPR_ARRAY)
934             {
935               gfc_constructor *p;
936               p = gfc_constructor_first (cons->expr->value.constructor);
937               if (cons->expr->ts.u.cl != p->expr->ts.u.cl)
938                 {
939                   gfc_charlen *cl, *cl2;
940
941                   cl2 = NULL;
942                   for (cl = gfc_current_ns->cl_list; cl; cl = cl->next)
943                     {
944                       if (cl == cons->expr->ts.u.cl)
945                         break;
946                       cl2 = cl;
947                     }
948
949                   gcc_assert (cl);
950
951                   if (cl2)
952                     cl2->next = cl->next;
953
954                   gfc_free_expr (cl->length);
955                   gfc_free (cl);
956                 }
957
958               cons->expr->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
959               cons->expr->ts.u.cl->length_from_typespec = true;
960               cons->expr->ts.u.cl->length = gfc_copy_expr (comp->ts.u.cl->length);
961               gfc_resolve_character_array_constructor (cons->expr);
962             }
963         }
964
965       if (cons->expr->expr_type == EXPR_NULL
966           && !(comp->attr.pointer || comp->attr.allocatable
967                || comp->attr.proc_pointer
968                || (comp->ts.type == BT_CLASS
969                    && (CLASS_DATA (comp)->attr.class_pointer
970                        || CLASS_DATA (comp)->attr.allocatable))))
971         {
972           t = FAILURE;
973           gfc_error ("The NULL in the derived type constructor at %L is "
974                      "being applied to component '%s', which is neither "
975                      "a POINTER nor ALLOCATABLE", &cons->expr->where,
976                      comp->name);
977         }
978
979       if (!comp->attr.pointer || cons->expr->expr_type == EXPR_NULL)
980         continue;
981
982       a = gfc_expr_attr (cons->expr);
983
984       if (!a.pointer && !a.target)
985         {
986           t = FAILURE;
987           gfc_error ("The element in the derived type constructor at %L, "
988                      "for pointer component '%s' should be a POINTER or "
989                      "a TARGET", &cons->expr->where, comp->name);
990         }
991
992       /* F2003, C1272 (3).  */
993       if (gfc_pure (NULL) && cons->expr->expr_type == EXPR_VARIABLE
994           && (gfc_impure_variable (cons->expr->symtree->n.sym)
995               || gfc_is_coindexed (cons->expr)))
996         {
997           t = FAILURE;
998           gfc_error ("Invalid expression in the derived type constructor for "
999                      "pointer component '%s' at %L in PURE procedure",
1000                      comp->name, &cons->expr->where);
1001         }
1002     }
1003
1004   return t;
1005 }
1006
1007
1008 /****************** Expression name resolution ******************/
1009
1010 /* Returns 0 if a symbol was not declared with a type or
1011    attribute declaration statement, nonzero otherwise.  */
1012
1013 static int
1014 was_declared (gfc_symbol *sym)
1015 {
1016   symbol_attribute a;
1017
1018   a = sym->attr;
1019
1020   if (!a.implicit_type && sym->ts.type != BT_UNKNOWN)
1021     return 1;
1022
1023   if (a.allocatable || a.dimension || a.dummy || a.external || a.intrinsic
1024       || a.optional || a.pointer || a.save || a.target || a.volatile_
1025       || a.value || a.access != ACCESS_UNKNOWN || a.intent != INTENT_UNKNOWN
1026       || a.asynchronous || a.codimension)
1027     return 1;
1028
1029   return 0;
1030 }
1031
1032
1033 /* Determine if a symbol is generic or not.  */
1034
1035 static int
1036 generic_sym (gfc_symbol *sym)
1037 {
1038   gfc_symbol *s;
1039
1040   if (sym->attr.generic ||
1041       (sym->attr.intrinsic && gfc_generic_intrinsic (sym->name)))
1042     return 1;
1043
1044   if (was_declared (sym) || sym->ns->parent == NULL)
1045     return 0;
1046
1047   gfc_find_symbol (sym->name, sym->ns->parent, 1, &s);
1048   
1049   if (s != NULL)
1050     {
1051       if (s == sym)
1052         return 0;
1053       else
1054         return generic_sym (s);
1055     }
1056
1057   return 0;
1058 }
1059
1060
1061 /* Determine if a symbol is specific or not.  */
1062
1063 static int
1064 specific_sym (gfc_symbol *sym)
1065 {
1066   gfc_symbol *s;
1067
1068   if (sym->attr.if_source == IFSRC_IFBODY
1069       || sym->attr.proc == PROC_MODULE
1070       || sym->attr.proc == PROC_INTERNAL
1071       || sym->attr.proc == PROC_ST_FUNCTION
1072       || (sym->attr.intrinsic && gfc_specific_intrinsic (sym->name))
1073       || sym->attr.external)
1074     return 1;
1075
1076   if (was_declared (sym) || sym->ns->parent == NULL)
1077     return 0;
1078
1079   gfc_find_symbol (sym->name, sym->ns->parent, 1, &s);
1080
1081   return (s == NULL) ? 0 : specific_sym (s);
1082 }
1083
1084
1085 /* Figure out if the procedure is specific, generic or unknown.  */
1086
1087 typedef enum
1088 { PTYPE_GENERIC = 1, PTYPE_SPECIFIC, PTYPE_UNKNOWN }
1089 proc_type;
1090
1091 static proc_type
1092 procedure_kind (gfc_symbol *sym)
1093 {
1094   if (generic_sym (sym))
1095     return PTYPE_GENERIC;
1096
1097   if (specific_sym (sym))
1098     return PTYPE_SPECIFIC;
1099
1100   return PTYPE_UNKNOWN;
1101 }
1102
1103 /* Check references to assumed size arrays.  The flag need_full_assumed_size
1104    is nonzero when matching actual arguments.  */
1105
1106 static int need_full_assumed_size = 0;
1107
1108 static bool
1109 check_assumed_size_reference (gfc_symbol *sym, gfc_expr *e)
1110 {
1111   if (need_full_assumed_size || !(sym->as && sym->as->type == AS_ASSUMED_SIZE))
1112       return false;
1113
1114   /* FIXME: The comparison "e->ref->u.ar.type == AR_FULL" is wrong.
1115      What should it be?  */
1116   if ((e->ref->u.ar.end[e->ref->u.ar.as->rank - 1] == NULL)
1117           && (e->ref->u.ar.as->type == AS_ASSUMED_SIZE)
1118                && (e->ref->u.ar.type == AR_FULL))
1119     {
1120       gfc_error ("The upper bound in the last dimension must "
1121                  "appear in the reference to the assumed size "
1122                  "array '%s' at %L", sym->name, &e->where);
1123       return true;
1124     }
1125   return false;
1126 }
1127
1128
1129 /* Look for bad assumed size array references in argument expressions
1130   of elemental and array valued intrinsic procedures.  Since this is
1131   called from procedure resolution functions, it only recurses at
1132   operators.  */
1133
1134 static bool
1135 resolve_assumed_size_actual (gfc_expr *e)
1136 {
1137   if (e == NULL)
1138    return false;
1139
1140   switch (e->expr_type)
1141     {
1142     case EXPR_VARIABLE:
1143       if (e->symtree && check_assumed_size_reference (e->symtree->n.sym, e))
1144         return true;
1145       break;
1146
1147     case EXPR_OP:
1148       if (resolve_assumed_size_actual (e->value.op.op1)
1149           || resolve_assumed_size_actual (e->value.op.op2))
1150         return true;
1151       break;
1152
1153     default:
1154       break;
1155     }
1156   return false;
1157 }
1158
1159
1160 /* Check a generic procedure, passed as an actual argument, to see if
1161    there is a matching specific name.  If none, it is an error, and if
1162    more than one, the reference is ambiguous.  */
1163 static int
1164 count_specific_procs (gfc_expr *e)
1165 {
1166   int n;
1167   gfc_interface *p;
1168   gfc_symbol *sym;
1169         
1170   n = 0;
1171   sym = e->symtree->n.sym;
1172
1173   for (p = sym->generic; p; p = p->next)
1174     if (strcmp (sym->name, p->sym->name) == 0)
1175       {
1176         e->symtree = gfc_find_symtree (p->sym->ns->sym_root,
1177                                        sym->name);
1178         n++;
1179       }
1180
1181   if (n > 1)
1182     gfc_error ("'%s' at %L is ambiguous", e->symtree->n.sym->name,
1183                &e->where);
1184
1185   if (n == 0)
1186     gfc_error ("GENERIC procedure '%s' is not allowed as an actual "
1187                "argument at %L", sym->name, &e->where);
1188
1189   return n;
1190 }
1191
1192
1193 /* See if a call to sym could possibly be a not allowed RECURSION because of
1194    a missing RECURIVE declaration.  This means that either sym is the current
1195    context itself, or sym is the parent of a contained procedure calling its
1196    non-RECURSIVE containing procedure.
1197    This also works if sym is an ENTRY.  */
1198
1199 static bool
1200 is_illegal_recursion (gfc_symbol* sym, gfc_namespace* context)
1201 {
1202   gfc_symbol* proc_sym;
1203   gfc_symbol* context_proc;
1204   gfc_namespace* real_context;
1205
1206   if (sym->attr.flavor == FL_PROGRAM)
1207     return false;
1208
1209   gcc_assert (sym->attr.flavor == FL_PROCEDURE);
1210
1211   /* If we've got an ENTRY, find real procedure.  */
1212   if (sym->attr.entry && sym->ns->entries)
1213     proc_sym = sym->ns->entries->sym;
1214   else
1215     proc_sym = sym;
1216
1217   /* If sym is RECURSIVE, all is well of course.  */
1218   if (proc_sym->attr.recursive || gfc_option.flag_recursive)
1219     return false;
1220
1221   /* Find the context procedure's "real" symbol if it has entries.
1222      We look for a procedure symbol, so recurse on the parents if we don't
1223      find one (like in case of a BLOCK construct).  */
1224   for (real_context = context; ; real_context = real_context->parent)
1225     {
1226       /* We should find something, eventually!  */
1227       gcc_assert (real_context);
1228
1229       context_proc = (real_context->entries ? real_context->entries->sym
1230                                             : real_context->proc_name);
1231
1232       /* In some special cases, there may not be a proc_name, like for this
1233          invalid code:
1234          real(bad_kind()) function foo () ...
1235          when checking the call to bad_kind ().
1236          In these cases, we simply return here and assume that the
1237          call is ok.  */
1238       if (!context_proc)
1239         return false;
1240
1241       if (context_proc->attr.flavor != FL_LABEL)
1242         break;
1243     }
1244
1245   /* A call from sym's body to itself is recursion, of course.  */
1246   if (context_proc == proc_sym)
1247     return true;
1248
1249   /* The same is true if context is a contained procedure and sym the
1250      containing one.  */
1251   if (context_proc->attr.contained)
1252     {
1253       gfc_symbol* parent_proc;
1254
1255       gcc_assert (context->parent);
1256       parent_proc = (context->parent->entries ? context->parent->entries->sym
1257                                               : context->parent->proc_name);
1258
1259       if (parent_proc == proc_sym)
1260         return true;
1261     }
1262
1263   return false;
1264 }
1265
1266
1267 /* Resolve an intrinsic procedure: Set its function/subroutine attribute,
1268    its typespec and formal argument list.  */
1269
1270 static gfc_try
1271 resolve_intrinsic (gfc_symbol *sym, locus *loc)
1272 {
1273   gfc_intrinsic_sym* isym;
1274   const char* symstd;
1275
1276   if (sym->formal)
1277     return SUCCESS;
1278
1279   /* We already know this one is an intrinsic, so we don't call
1280      gfc_is_intrinsic for full checking but rather use gfc_find_function and
1281      gfc_find_subroutine directly to check whether it is a function or
1282      subroutine.  */
1283
1284   if ((isym = gfc_find_function (sym->name)))
1285     {
1286       if (sym->ts.type != BT_UNKNOWN && gfc_option.warn_surprising
1287           && !sym->attr.implicit_type)
1288         gfc_warning ("Type specified for intrinsic function '%s' at %L is"
1289                       " ignored", sym->name, &sym->declared_at);
1290
1291       if (!sym->attr.function &&
1292           gfc_add_function (&sym->attr, sym->name, loc) == FAILURE)
1293         return FAILURE;
1294
1295       sym->ts = isym->ts;
1296     }
1297   else if ((isym = gfc_find_subroutine (sym->name)))
1298     {
1299       if (sym->ts.type != BT_UNKNOWN && !sym->attr.implicit_type)
1300         {
1301           gfc_error ("Intrinsic subroutine '%s' at %L shall not have a type"
1302                       " specifier", sym->name, &sym->declared_at);
1303           return FAILURE;
1304         }
1305
1306       if (!sym->attr.subroutine &&
1307           gfc_add_subroutine (&sym->attr, sym->name, loc) == FAILURE)
1308         return FAILURE;
1309     }
1310   else
1311     {
1312       gfc_error ("'%s' declared INTRINSIC at %L does not exist", sym->name,
1313                  &sym->declared_at);
1314       return FAILURE;
1315     }
1316
1317   gfc_copy_formal_args_intr (sym, isym);
1318
1319   /* Check it is actually available in the standard settings.  */
1320   if (gfc_check_intrinsic_standard (isym, &symstd, false, sym->declared_at)
1321       == FAILURE)
1322     {
1323       gfc_error ("The intrinsic '%s' declared INTRINSIC at %L is not"
1324                  " available in the current standard settings but %s.  Use"
1325                  " an appropriate -std=* option or enable -fall-intrinsics"
1326                  " in order to use it.",
1327                  sym->name, &sym->declared_at, symstd);
1328       return FAILURE;
1329     }
1330
1331   return SUCCESS;
1332 }
1333
1334
1335 /* Resolve a procedure expression, like passing it to a called procedure or as
1336    RHS for a procedure pointer assignment.  */
1337
1338 static gfc_try
1339 resolve_procedure_expression (gfc_expr* expr)
1340 {
1341   gfc_symbol* sym;
1342
1343   if (expr->expr_type != EXPR_VARIABLE)
1344     return SUCCESS;
1345   gcc_assert (expr->symtree);
1346
1347   sym = expr->symtree->n.sym;
1348
1349   if (sym->attr.intrinsic)
1350     resolve_intrinsic (sym, &expr->where);
1351
1352   if (sym->attr.flavor != FL_PROCEDURE
1353       || (sym->attr.function && sym->result == sym))
1354     return SUCCESS;
1355
1356   /* A non-RECURSIVE procedure that is used as procedure expression within its
1357      own body is in danger of being called recursively.  */
1358   if (is_illegal_recursion (sym, gfc_current_ns))
1359     gfc_warning ("Non-RECURSIVE procedure '%s' at %L is possibly calling"
1360                  " itself recursively.  Declare it RECURSIVE or use"
1361                  " -frecursive", sym->name, &expr->where);
1362   
1363   return SUCCESS;
1364 }
1365
1366
1367 /* Resolve an actual argument list.  Most of the time, this is just
1368    resolving the expressions in the list.
1369    The exception is that we sometimes have to decide whether arguments
1370    that look like procedure arguments are really simple variable
1371    references.  */
1372
1373 static gfc_try
1374 resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype,
1375                         bool no_formal_args)
1376 {
1377   gfc_symbol *sym;
1378   gfc_symtree *parent_st;
1379   gfc_expr *e;
1380   int save_need_full_assumed_size;
1381   gfc_component *comp;
1382
1383   for (; arg; arg = arg->next)
1384     {
1385       e = arg->expr;
1386       if (e == NULL)
1387         {
1388           /* Check the label is a valid branching target.  */
1389           if (arg->label)
1390             {
1391               if (arg->label->defined == ST_LABEL_UNKNOWN)
1392                 {
1393                   gfc_error ("Label %d referenced at %L is never defined",
1394                              arg->label->value, &arg->label->where);
1395                   return FAILURE;
1396                 }
1397             }
1398           continue;
1399         }
1400
1401       if (gfc_is_proc_ptr_comp (e, &comp))
1402         {
1403           e->ts = comp->ts;
1404           if (e->expr_type == EXPR_PPC)
1405             {
1406               if (comp->as != NULL)
1407                 e->rank = comp->as->rank;
1408               e->expr_type = EXPR_FUNCTION;
1409             }
1410           if (gfc_resolve_expr (e) == FAILURE)                          
1411             return FAILURE; 
1412           goto argument_list;
1413         }
1414
1415       if (e->expr_type == EXPR_VARIABLE
1416             && e->symtree->n.sym->attr.generic
1417             && no_formal_args
1418             && count_specific_procs (e) != 1)
1419         return FAILURE;
1420
1421       if (e->ts.type != BT_PROCEDURE)
1422         {
1423           save_need_full_assumed_size = need_full_assumed_size;
1424           if (e->expr_type != EXPR_VARIABLE)
1425             need_full_assumed_size = 0;
1426           if (gfc_resolve_expr (e) != SUCCESS)
1427             return FAILURE;
1428           need_full_assumed_size = save_need_full_assumed_size;
1429           goto argument_list;
1430         }
1431
1432       /* See if the expression node should really be a variable reference.  */
1433
1434       sym = e->symtree->n.sym;
1435
1436       if (sym->attr.flavor == FL_PROCEDURE
1437           || sym->attr.intrinsic
1438           || sym->attr.external)
1439         {
1440           int actual_ok;
1441
1442           /* If a procedure is not already determined to be something else
1443              check if it is intrinsic.  */
1444           if (!sym->attr.intrinsic
1445               && !(sym->attr.external || sym->attr.use_assoc
1446                    || sym->attr.if_source == IFSRC_IFBODY)
1447               && gfc_is_intrinsic (sym, sym->attr.subroutine, e->where))
1448             sym->attr.intrinsic = 1;
1449
1450           if (sym->attr.proc == PROC_ST_FUNCTION)
1451             {
1452               gfc_error ("Statement function '%s' at %L is not allowed as an "
1453                          "actual argument", sym->name, &e->where);
1454             }
1455
1456           actual_ok = gfc_intrinsic_actual_ok (sym->name,
1457                                                sym->attr.subroutine);
1458           if (sym->attr.intrinsic && actual_ok == 0)
1459             {
1460               gfc_error ("Intrinsic '%s' at %L is not allowed as an "
1461                          "actual argument", sym->name, &e->where);
1462             }
1463
1464           if (sym->attr.contained && !sym->attr.use_assoc
1465               && sym->ns->proc_name->attr.flavor != FL_MODULE)
1466             {
1467               gfc_error ("Internal procedure '%s' is not allowed as an "
1468                          "actual argument at %L", sym->name, &e->where);
1469             }
1470
1471           if (sym->attr.elemental && !sym->attr.intrinsic)
1472             {
1473               gfc_error ("ELEMENTAL non-INTRINSIC procedure '%s' is not "
1474                          "allowed as an actual argument at %L", sym->name,
1475                          &e->where);
1476             }
1477
1478           /* Check if a generic interface has a specific procedure
1479             with the same name before emitting an error.  */
1480           if (sym->attr.generic && count_specific_procs (e) != 1)
1481             return FAILURE;
1482           
1483           /* Just in case a specific was found for the expression.  */
1484           sym = e->symtree->n.sym;
1485
1486           /* If the symbol is the function that names the current (or
1487              parent) scope, then we really have a variable reference.  */
1488
1489           if (gfc_is_function_return_value (sym, sym->ns))
1490             goto got_variable;
1491
1492           /* If all else fails, see if we have a specific intrinsic.  */
1493           if (sym->ts.type == BT_UNKNOWN && sym->attr.intrinsic)
1494             {
1495               gfc_intrinsic_sym *isym;
1496
1497               isym = gfc_find_function (sym->name);
1498               if (isym == NULL || !isym->specific)
1499                 {
1500                   gfc_error ("Unable to find a specific INTRINSIC procedure "
1501                              "for the reference '%s' at %L", sym->name,
1502                              &e->where);
1503                   return FAILURE;
1504                 }
1505               sym->ts = isym->ts;
1506               sym->attr.intrinsic = 1;
1507               sym->attr.function = 1;
1508             }
1509
1510           if (gfc_resolve_expr (e) == FAILURE)
1511             return FAILURE;
1512           goto argument_list;
1513         }
1514
1515       /* See if the name is a module procedure in a parent unit.  */
1516
1517       if (was_declared (sym) || sym->ns->parent == NULL)
1518         goto got_variable;
1519
1520       if (gfc_find_sym_tree (sym->name, sym->ns->parent, 1, &parent_st))
1521         {
1522           gfc_error ("Symbol '%s' at %L is ambiguous", sym->name, &e->where);
1523           return FAILURE;
1524         }
1525
1526       if (parent_st == NULL)
1527         goto got_variable;
1528
1529       sym = parent_st->n.sym;
1530       e->symtree = parent_st;           /* Point to the right thing.  */
1531
1532       if (sym->attr.flavor == FL_PROCEDURE
1533           || sym->attr.intrinsic
1534           || sym->attr.external)
1535         {
1536           if (gfc_resolve_expr (e) == FAILURE)
1537             return FAILURE;
1538           goto argument_list;
1539         }
1540
1541     got_variable:
1542       e->expr_type = EXPR_VARIABLE;
1543       e->ts = sym->ts;
1544       if (sym->as != NULL)
1545         {
1546           e->rank = sym->as->rank;
1547           e->ref = gfc_get_ref ();
1548           e->ref->type = REF_ARRAY;
1549           e->ref->u.ar.type = AR_FULL;
1550           e->ref->u.ar.as = sym->as;
1551         }
1552
1553       /* Expressions are assigned a default ts.type of BT_PROCEDURE in
1554          primary.c (match_actual_arg). If above code determines that it
1555          is a  variable instead, it needs to be resolved as it was not
1556          done at the beginning of this function.  */
1557       save_need_full_assumed_size = need_full_assumed_size;
1558       if (e->expr_type != EXPR_VARIABLE)
1559         need_full_assumed_size = 0;
1560       if (gfc_resolve_expr (e) != SUCCESS)
1561         return FAILURE;
1562       need_full_assumed_size = save_need_full_assumed_size;
1563
1564     argument_list:
1565       /* Check argument list functions %VAL, %LOC and %REF.  There is
1566          nothing to do for %REF.  */
1567       if (arg->name && arg->name[0] == '%')
1568         {
1569           if (strncmp ("%VAL", arg->name, 4) == 0)
1570             {
1571               if (e->ts.type == BT_CHARACTER || e->ts.type == BT_DERIVED)
1572                 {
1573                   gfc_error ("By-value argument at %L is not of numeric "
1574                              "type", &e->where);
1575                   return FAILURE;
1576                 }
1577
1578               if (e->rank)
1579                 {
1580                   gfc_error ("By-value argument at %L cannot be an array or "
1581                              "an array section", &e->where);
1582                 return FAILURE;
1583                 }
1584
1585               /* Intrinsics are still PROC_UNKNOWN here.  However,
1586                  since same file external procedures are not resolvable
1587                  in gfortran, it is a good deal easier to leave them to
1588                  intrinsic.c.  */
1589               if (ptype != PROC_UNKNOWN
1590                   && ptype != PROC_DUMMY
1591                   && ptype != PROC_EXTERNAL
1592                   && ptype != PROC_MODULE)
1593                 {
1594                   gfc_error ("By-value argument at %L is not allowed "
1595                              "in this context", &e->where);
1596                   return FAILURE;
1597                 }
1598             }
1599
1600           /* Statement functions have already been excluded above.  */
1601           else if (strncmp ("%LOC", arg->name, 4) == 0
1602                    && e->ts.type == BT_PROCEDURE)
1603             {
1604               if (e->symtree->n.sym->attr.proc == PROC_INTERNAL)
1605                 {
1606                   gfc_error ("Passing internal procedure at %L by location "
1607                              "not allowed", &e->where);
1608                   return FAILURE;
1609                 }
1610             }
1611         }
1612
1613       /* Fortran 2008, C1237.  */
1614       if (e->expr_type == EXPR_VARIABLE && gfc_is_coindexed (e)
1615           && gfc_has_ultimate_pointer (e))
1616         {
1617           gfc_error ("Coindexed actual argument at %L with ultimate pointer "
1618                      "component", &e->where);
1619           return FAILURE;
1620         }
1621     }
1622
1623   return SUCCESS;
1624 }
1625
1626
1627 /* Do the checks of the actual argument list that are specific to elemental
1628    procedures.  If called with c == NULL, we have a function, otherwise if
1629    expr == NULL, we have a subroutine.  */
1630
1631 static gfc_try
1632 resolve_elemental_actual (gfc_expr *expr, gfc_code *c)
1633 {
1634   gfc_actual_arglist *arg0;
1635   gfc_actual_arglist *arg;
1636   gfc_symbol *esym = NULL;
1637   gfc_intrinsic_sym *isym = NULL;
1638   gfc_expr *e = NULL;
1639   gfc_intrinsic_arg *iformal = NULL;
1640   gfc_formal_arglist *eformal = NULL;
1641   bool formal_optional = false;
1642   bool set_by_optional = false;
1643   int i;
1644   int rank = 0;
1645
1646   /* Is this an elemental procedure?  */
1647   if (expr && expr->value.function.actual != NULL)
1648     {
1649       if (expr->value.function.esym != NULL
1650           && expr->value.function.esym->attr.elemental)
1651         {
1652           arg0 = expr->value.function.actual;
1653           esym = expr->value.function.esym;
1654         }
1655       else if (expr->value.function.isym != NULL
1656                && expr->value.function.isym->elemental)
1657         {
1658           arg0 = expr->value.function.actual;
1659           isym = expr->value.function.isym;
1660         }
1661       else
1662         return SUCCESS;
1663     }
1664   else if (c && c->ext.actual != NULL)
1665     {
1666       arg0 = c->ext.actual;
1667       
1668       if (c->resolved_sym)
1669         esym = c->resolved_sym;
1670       else
1671         esym = c->symtree->n.sym;
1672       gcc_assert (esym);
1673
1674       if (!esym->attr.elemental)
1675         return SUCCESS;
1676     }
1677   else
1678     return SUCCESS;
1679
1680   /* The rank of an elemental is the rank of its array argument(s).  */
1681   for (arg = arg0; arg; arg = arg->next)
1682     {
1683       if (arg->expr != NULL && arg->expr->rank > 0)
1684         {
1685           rank = arg->expr->rank;
1686           if (arg->expr->expr_type == EXPR_VARIABLE
1687               && arg->expr->symtree->n.sym->attr.optional)
1688             set_by_optional = true;
1689
1690           /* Function specific; set the result rank and shape.  */
1691           if (expr)
1692             {
1693               expr->rank = rank;
1694               if (!expr->shape && arg->expr->shape)
1695                 {
1696                   expr->shape = gfc_get_shape (rank);
1697                   for (i = 0; i < rank; i++)
1698                     mpz_init_set (expr->shape[i], arg->expr->shape[i]);
1699                 }
1700             }
1701           break;
1702         }
1703     }
1704
1705   /* If it is an array, it shall not be supplied as an actual argument
1706      to an elemental procedure unless an array of the same rank is supplied
1707      as an actual argument corresponding to a nonoptional dummy argument of
1708      that elemental procedure(12.4.1.5).  */
1709   formal_optional = false;
1710   if (isym)
1711     iformal = isym->formal;
1712   else
1713     eformal = esym->formal;
1714
1715   for (arg = arg0; arg; arg = arg->next)
1716     {
1717       if (eformal)
1718         {
1719           if (eformal->sym && eformal->sym->attr.optional)
1720             formal_optional = true;
1721           eformal = eformal->next;
1722         }
1723       else if (isym && iformal)
1724         {
1725           if (iformal->optional)
1726             formal_optional = true;
1727           iformal = iformal->next;
1728         }
1729       else if (isym)
1730         formal_optional = true;
1731
1732       if (pedantic && arg->expr != NULL
1733           && arg->expr->expr_type == EXPR_VARIABLE
1734           && arg->expr->symtree->n.sym->attr.optional
1735           && formal_optional
1736           && arg->expr->rank
1737           && (set_by_optional || arg->expr->rank != rank)
1738           && !(isym && isym->id == GFC_ISYM_CONVERSION))
1739         {
1740           gfc_warning ("'%s' at %L is an array and OPTIONAL; IF IT IS "
1741                        "MISSING, it cannot be the actual argument of an "
1742                        "ELEMENTAL procedure unless there is a non-optional "
1743                        "argument with the same rank (12.4.1.5)",
1744                        arg->expr->symtree->n.sym->name, &arg->expr->where);
1745           return FAILURE;
1746         }
1747     }
1748
1749   for (arg = arg0; arg; arg = arg->next)
1750     {
1751       if (arg->expr == NULL || arg->expr->rank == 0)
1752         continue;
1753
1754       /* Being elemental, the last upper bound of an assumed size array
1755          argument must be present.  */
1756       if (resolve_assumed_size_actual (arg->expr))
1757         return FAILURE;
1758
1759       /* Elemental procedure's array actual arguments must conform.  */
1760       if (e != NULL)
1761         {
1762           if (gfc_check_conformance (arg->expr, e,
1763                                      "elemental procedure") == FAILURE)
1764             return FAILURE;
1765         }
1766       else
1767         e = arg->expr;
1768     }
1769
1770   /* INTENT(OUT) is only allowed for subroutines; if any actual argument
1771      is an array, the intent inout/out variable needs to be also an array.  */
1772   if (rank > 0 && esym && expr == NULL)
1773     for (eformal = esym->formal, arg = arg0; arg && eformal;
1774          arg = arg->next, eformal = eformal->next)
1775       if ((eformal->sym->attr.intent == INTENT_OUT
1776            || eformal->sym->attr.intent == INTENT_INOUT)
1777           && arg->expr && arg->expr->rank == 0)
1778         {
1779           gfc_error ("Actual argument at %L for INTENT(%s) dummy '%s' of "
1780                      "ELEMENTAL subroutine '%s' is a scalar, but another "
1781                      "actual argument is an array", &arg->expr->where,
1782                      (eformal->sym->attr.intent == INTENT_OUT) ? "OUT"
1783                      : "INOUT", eformal->sym->name, esym->name);
1784           return FAILURE;
1785         }
1786   return SUCCESS;
1787 }
1788
1789
1790 /* Go through each actual argument in ACTUAL and see if it can be
1791    implemented as an inlined, non-copying intrinsic.  FNSYM is the
1792    function being called, or NULL if not known.  */
1793
1794 static void
1795 find_noncopying_intrinsics (gfc_symbol *fnsym, gfc_actual_arglist *actual)
1796 {
1797   gfc_actual_arglist *ap;
1798   gfc_expr *expr;
1799
1800   for (ap = actual; ap; ap = ap->next)
1801     if (ap->expr
1802         && (expr = gfc_get_noncopying_intrinsic_argument (ap->expr))
1803         && !gfc_check_fncall_dependency (expr, INTENT_IN, fnsym, actual,
1804                                          NOT_ELEMENTAL))
1805       ap->expr->inline_noncopying_intrinsic = 1;
1806 }
1807
1808
1809 /* This function does the checking of references to global procedures
1810    as defined in sections 18.1 and 14.1, respectively, of the Fortran
1811    77 and 95 standards.  It checks for a gsymbol for the name, making
1812    one if it does not already exist.  If it already exists, then the
1813    reference being resolved must correspond to the type of gsymbol.
1814    Otherwise, the new symbol is equipped with the attributes of the
1815    reference.  The corresponding code that is called in creating
1816    global entities is parse.c.
1817
1818    In addition, for all but -std=legacy, the gsymbols are used to
1819    check the interfaces of external procedures from the same file.
1820    The namespace of the gsymbol is resolved and then, once this is
1821    done the interface is checked.  */
1822
1823
1824 static bool
1825 not_in_recursive (gfc_symbol *sym, gfc_namespace *gsym_ns)
1826 {
1827   if (!gsym_ns->proc_name->attr.recursive)
1828     return true;
1829
1830   if (sym->ns == gsym_ns)
1831     return false;
1832
1833   if (sym->ns->parent && sym->ns->parent == gsym_ns)
1834     return false;
1835
1836   return true;
1837 }
1838
1839 static bool
1840 not_entry_self_reference  (gfc_symbol *sym, gfc_namespace *gsym_ns)
1841 {
1842   if (gsym_ns->entries)
1843     {
1844       gfc_entry_list *entry = gsym_ns->entries;
1845
1846       for (; entry; entry = entry->next)
1847         {
1848           if (strcmp (sym->name, entry->sym->name) == 0)
1849             {
1850               if (strcmp (gsym_ns->proc_name->name,
1851                           sym->ns->proc_name->name) == 0)
1852                 return false;
1853
1854               if (sym->ns->parent
1855                   && strcmp (gsym_ns->proc_name->name,
1856                              sym->ns->parent->proc_name->name) == 0)
1857                 return false;
1858             }
1859         }
1860     }
1861   return true;
1862 }
1863
1864 static void
1865 resolve_global_procedure (gfc_symbol *sym, locus *where,
1866                           gfc_actual_arglist **actual, int sub)
1867 {
1868   gfc_gsymbol * gsym;
1869   gfc_namespace *ns;
1870   enum gfc_symbol_type type;
1871
1872   type = sub ? GSYM_SUBROUTINE : GSYM_FUNCTION;
1873
1874   gsym = gfc_get_gsymbol (sym->name);
1875
1876   if ((gsym->type != GSYM_UNKNOWN && gsym->type != type))
1877     gfc_global_used (gsym, where);
1878
1879   if (gfc_option.flag_whole_file
1880         && (sym->attr.if_source == IFSRC_UNKNOWN
1881             || sym->attr.if_source == IFSRC_IFBODY)
1882         && gsym->type != GSYM_UNKNOWN
1883         && gsym->ns
1884         && gsym->ns->resolved != -1
1885         && gsym->ns->proc_name
1886         && not_in_recursive (sym, gsym->ns)
1887         && not_entry_self_reference (sym, gsym->ns))
1888     {
1889       gfc_symbol *def_sym;
1890
1891       /* Resolve the gsymbol namespace if needed.  */
1892       if (!gsym->ns->resolved)
1893         {
1894           gfc_dt_list *old_dt_list;
1895
1896           /* Stash away derived types so that the backend_decls do not
1897              get mixed up.  */
1898           old_dt_list = gfc_derived_types;
1899           gfc_derived_types = NULL;
1900
1901           gfc_resolve (gsym->ns);
1902
1903           /* Store the new derived types with the global namespace.  */
1904           if (gfc_derived_types)
1905             gsym->ns->derived_types = gfc_derived_types;
1906
1907           /* Restore the derived types of this namespace.  */
1908           gfc_derived_types = old_dt_list;
1909         }
1910
1911       /* Make sure that translation for the gsymbol occurs before
1912          the procedure currently being resolved.  */
1913       ns = gfc_global_ns_list;
1914       for (; ns && ns != gsym->ns; ns = ns->sibling)
1915         {
1916           if (ns->sibling == gsym->ns)
1917             {
1918               ns->sibling = gsym->ns->sibling;
1919               gsym->ns->sibling = gfc_global_ns_list;
1920               gfc_global_ns_list = gsym->ns;
1921               break;
1922             }
1923         }
1924
1925       def_sym = gsym->ns->proc_name;
1926       if (def_sym->attr.entry_master)
1927         {
1928           gfc_entry_list *entry;
1929           for (entry = gsym->ns->entries; entry; entry = entry->next)
1930             if (strcmp (entry->sym->name, sym->name) == 0)
1931               {
1932                 def_sym = entry->sym;
1933                 break;
1934               }
1935         }
1936
1937       /* Differences in constant character lengths.  */
1938       if (sym->attr.function && sym->ts.type == BT_CHARACTER)
1939         {
1940           long int l1 = 0, l2 = 0;
1941           gfc_charlen *cl1 = sym->ts.u.cl;
1942           gfc_charlen *cl2 = def_sym->ts.u.cl;
1943
1944           if (cl1 != NULL
1945               && cl1->length != NULL
1946               && cl1->length->expr_type == EXPR_CONSTANT)
1947             l1 = mpz_get_si (cl1->length->value.integer);
1948
1949           if (cl2 != NULL
1950               && cl2->length != NULL
1951               && cl2->length->expr_type == EXPR_CONSTANT)
1952             l2 = mpz_get_si (cl2->length->value.integer);
1953
1954           if (l1 && l2 && l1 != l2)
1955             gfc_error ("Character length mismatch in return type of "
1956                        "function '%s' at %L (%ld/%ld)", sym->name,
1957                        &sym->declared_at, l1, l2);
1958         }
1959
1960      /* Type mismatch of function return type and expected type.  */
1961      if (sym->attr.function
1962          && !gfc_compare_types (&sym->ts, &def_sym->ts))
1963         gfc_error ("Return type mismatch of function '%s' at %L (%s/%s)",
1964                    sym->name, &sym->declared_at, gfc_typename (&sym->ts),
1965                    gfc_typename (&def_sym->ts));
1966
1967       if (def_sym->formal && sym->attr.if_source != IFSRC_IFBODY)
1968         {
1969           gfc_formal_arglist *arg = def_sym->formal;
1970           for ( ; arg; arg = arg->next)
1971             if (!arg->sym)
1972               continue;
1973             /* F2003, 12.3.1.1 (2a); F2008, 12.4.2.2 (2a)  */
1974             else if (arg->sym->attr.allocatable
1975                      || arg->sym->attr.asynchronous
1976                      || arg->sym->attr.optional
1977                      || arg->sym->attr.pointer
1978                      || arg->sym->attr.target
1979                      || arg->sym->attr.value
1980                      || arg->sym->attr.volatile_)
1981               {
1982                 gfc_error ("Dummy argument '%s' of procedure '%s' at %L "
1983                            "has an attribute that requires an explicit "
1984                            "interface for this procedure", arg->sym->name,
1985                            sym->name, &sym->declared_at);
1986                 break;
1987               }
1988             /* F2003, 12.3.1.1 (2b); F2008, 12.4.2.2 (2b)  */
1989             else if (arg->sym && arg->sym->as
1990                      && arg->sym->as->type == AS_ASSUMED_SHAPE)
1991               {
1992                 gfc_error ("Procedure '%s' at %L with assumed-shape dummy "
1993                            "argument '%s' must have an explicit interface",
1994                            sym->name, &sym->declared_at, arg->sym->name);
1995                 break;
1996               }
1997             /* F2008, 12.4.2.2 (2c)  */
1998             else if (arg->sym->attr.codimension)
1999               {
2000                 gfc_error ("Procedure '%s' at %L with coarray dummy argument "
2001                            "'%s' must have an explicit interface",
2002                            sym->name, &sym->declared_at, arg->sym->name);
2003                 break;
2004               }
2005             /* F2003, 12.3.1.1 (2c); F2008, 12.4.2.2 (2d)   */
2006             else if (false) /* TODO: is a parametrized derived type  */
2007               {
2008                 gfc_error ("Procedure '%s' at %L with parametrized derived "
2009                            "type argument '%s' must have an explicit "
2010                            "interface", sym->name, &sym->declared_at,
2011                            arg->sym->name);
2012                 break;
2013               }
2014             /* F2003, 12.3.1.1 (2d); F2008, 12.4.2.2 (2e)   */
2015             else if (arg->sym->ts.type == BT_CLASS)
2016               {
2017                 gfc_error ("Procedure '%s' at %L with polymorphic dummy "
2018                            "argument '%s' must have an explicit interface",
2019                            sym->name, &sym->declared_at, arg->sym->name);
2020                 break;
2021               }
2022         }
2023
2024       if (def_sym->attr.function)
2025         {
2026           /* F2003, 12.3.1.1 (3a); F2008, 12.4.2.2 (3a) */
2027           if (def_sym->as && def_sym->as->rank
2028               && (!sym->as || sym->as->rank != def_sym->as->rank))
2029             gfc_error ("The reference to function '%s' at %L either needs an "
2030                        "explicit INTERFACE or the rank is incorrect", sym->name,
2031                        where);
2032
2033           /* F2003, 12.3.1.1 (3b); F2008, 12.4.2.2 (3b) */
2034           if ((def_sym->result->attr.pointer
2035                || def_sym->result->attr.allocatable)
2036                && (sym->attr.if_source != IFSRC_IFBODY
2037                    || def_sym->result->attr.pointer
2038                         != sym->result->attr.pointer
2039                    || def_sym->result->attr.allocatable
2040                         != sym->result->attr.allocatable))
2041             gfc_error ("Function '%s' at %L with a POINTER or ALLOCATABLE "
2042                        "result must have an explicit interface", sym->name,
2043                        where);
2044
2045           /* F2003, 12.3.1.1 (3c); F2008, 12.4.2.2 (3c)  */
2046           if (sym->ts.type == BT_CHARACTER && sym->attr.if_source != IFSRC_IFBODY
2047               && def_sym->ts.u.cl->length != NULL)
2048             {
2049               gfc_charlen *cl = sym->ts.u.cl;
2050
2051               if (!sym->attr.entry_master && sym->attr.if_source == IFSRC_UNKNOWN
2052                   && cl && cl->length && cl->length->expr_type != EXPR_CONSTANT)
2053                 {
2054                   gfc_error ("Nonconstant character-length function '%s' at %L "
2055                              "must have an explicit interface", sym->name,
2056                              &sym->declared_at);
2057                 }
2058             }
2059         }
2060
2061       /* F2003, 12.3.1.1 (4); F2008, 12.4.2.2 (4) */
2062       if (def_sym->attr.elemental && !sym->attr.elemental)
2063         {
2064           gfc_error ("ELEMENTAL procedure '%s' at %L must have an explicit "
2065                      "interface", sym->name, &sym->declared_at);
2066         }
2067
2068       /* F2003, 12.3.1.1 (5); F2008, 12.4.2.2 (5) */
2069       if (def_sym->attr.is_bind_c && !sym->attr.is_bind_c)
2070         {
2071           gfc_error ("Procedure '%s' at %L with BIND(C) attribute must have "
2072                      "an explicit interface", sym->name, &sym->declared_at);
2073         }
2074
2075       if (gfc_option.flag_whole_file == 1
2076           || ((gfc_option.warn_std & GFC_STD_LEGACY)
2077               && !(gfc_option.warn_std & GFC_STD_GNU)))
2078         gfc_errors_to_warnings (1);
2079
2080       if (sym->attr.if_source != IFSRC_IFBODY)  
2081         gfc_procedure_use (def_sym, actual, where);
2082
2083       gfc_errors_to_warnings (0);
2084     }
2085
2086   if (gsym->type == GSYM_UNKNOWN)
2087     {
2088       gsym->type = type;
2089       gsym->where = *where;
2090     }
2091
2092   gsym->used = 1;
2093 }
2094
2095
2096 /************* Function resolution *************/
2097
2098 /* Resolve a function call known to be generic.
2099    Section 14.1.2.4.1.  */
2100
2101 static match
2102 resolve_generic_f0 (gfc_expr *expr, gfc_symbol *sym)
2103 {
2104   gfc_symbol *s;
2105
2106   if (sym->attr.generic)
2107     {
2108       s = gfc_search_interface (sym->generic, 0, &expr->value.function.actual);
2109       if (s != NULL)
2110         {
2111           expr->value.function.name = s->name;
2112           expr->value.function.esym = s;
2113
2114           if (s->ts.type != BT_UNKNOWN)
2115             expr->ts = s->ts;
2116           else if (s->result != NULL && s->result->ts.type != BT_UNKNOWN)
2117             expr->ts = s->result->ts;
2118
2119           if (s->as != NULL)
2120             expr->rank = s->as->rank;
2121           else if (s->result != NULL && s->result->as != NULL)
2122             expr->rank = s->result->as->rank;
2123
2124           gfc_set_sym_referenced (expr->value.function.esym);
2125
2126           return MATCH_YES;
2127         }
2128
2129       /* TODO: Need to search for elemental references in generic
2130          interface.  */
2131     }
2132
2133   if (sym->attr.intrinsic)
2134     return gfc_intrinsic_func_interface (expr, 0);
2135
2136   return MATCH_NO;
2137 }
2138
2139
2140 static gfc_try
2141 resolve_generic_f (gfc_expr *expr)
2142 {
2143   gfc_symbol *sym;
2144   match m;
2145
2146   sym = expr->symtree->n.sym;
2147
2148   for (;;)
2149     {
2150       m = resolve_generic_f0 (expr, sym);
2151       if (m == MATCH_YES)
2152         return SUCCESS;
2153       else if (m == MATCH_ERROR)
2154         return FAILURE;
2155
2156 generic:
2157       if (sym->ns->parent == NULL)
2158         break;
2159       gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
2160
2161       if (sym == NULL)
2162         break;
2163       if (!generic_sym (sym))
2164         goto generic;
2165     }
2166
2167   /* Last ditch attempt.  See if the reference is to an intrinsic
2168      that possesses a matching interface.  14.1.2.4  */
2169   if (sym && !gfc_is_intrinsic (sym, 0, expr->where))
2170     {
2171       gfc_error ("There is no specific function for the generic '%s' at %L",
2172                  expr->symtree->n.sym->name, &expr->where);
2173       return FAILURE;
2174     }
2175
2176   m = gfc_intrinsic_func_interface (expr, 0);
2177   if (m == MATCH_YES)
2178     return SUCCESS;
2179   if (m == MATCH_NO)
2180     gfc_error ("Generic function '%s' at %L is not consistent with a "
2181                "specific intrinsic interface", expr->symtree->n.sym->name,
2182                &expr->where);
2183
2184   return FAILURE;
2185 }
2186
2187
2188 /* Resolve a function call known to be specific.  */
2189
2190 static match
2191 resolve_specific_f0 (gfc_symbol *sym, gfc_expr *expr)
2192 {
2193   match m;
2194
2195   if (sym->attr.external || sym->attr.if_source == IFSRC_IFBODY)
2196     {
2197       if (sym->attr.dummy)
2198         {
2199           sym->attr.proc = PROC_DUMMY;
2200           goto found;
2201         }
2202
2203       sym->attr.proc = PROC_EXTERNAL;
2204       goto found;
2205     }
2206
2207   if (sym->attr.proc == PROC_MODULE
2208       || sym->attr.proc == PROC_ST_FUNCTION
2209       || sym->attr.proc == PROC_INTERNAL)
2210     goto found;
2211
2212   if (sym->attr.intrinsic)
2213     {
2214       m = gfc_intrinsic_func_interface (expr, 1);
2215       if (m == MATCH_YES)
2216         return MATCH_YES;
2217       if (m == MATCH_NO)
2218         gfc_error ("Function '%s' at %L is INTRINSIC but is not compatible "
2219                    "with an intrinsic", sym->name, &expr->where);
2220
2221       return MATCH_ERROR;
2222     }
2223
2224   return MATCH_NO;
2225
2226 found:
2227   gfc_procedure_use (sym, &expr->value.function.actual, &expr->where);
2228
2229   if (sym->result)
2230     expr->ts = sym->result->ts;
2231   else
2232     expr->ts = sym->ts;
2233   expr->value.function.name = sym->name;
2234   expr->value.function.esym = sym;
2235   if (sym->as != NULL)
2236     expr->rank = sym->as->rank;
2237
2238   return MATCH_YES;
2239 }
2240
2241
2242 static gfc_try
2243 resolve_specific_f (gfc_expr *expr)
2244 {
2245   gfc_symbol *sym;
2246   match m;
2247
2248   sym = expr->symtree->n.sym;
2249
2250   for (;;)
2251     {
2252       m = resolve_specific_f0 (sym, expr);
2253       if (m == MATCH_YES)
2254         return SUCCESS;
2255       if (m == MATCH_ERROR)
2256         return FAILURE;
2257
2258       if (sym->ns->parent == NULL)
2259         break;
2260
2261       gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
2262
2263       if (sym == NULL)
2264         break;
2265     }
2266
2267   gfc_error ("Unable to resolve the specific function '%s' at %L",
2268              expr->symtree->n.sym->name, &expr->where);
2269
2270   return SUCCESS;
2271 }
2272
2273
2274 /* Resolve a procedure call not known to be generic nor specific.  */
2275
2276 static gfc_try
2277 resolve_unknown_f (gfc_expr *expr)
2278 {
2279   gfc_symbol *sym;
2280   gfc_typespec *ts;
2281
2282   sym = expr->symtree->n.sym;
2283
2284   if (sym->attr.dummy)
2285     {
2286       sym->attr.proc = PROC_DUMMY;
2287       expr->value.function.name = sym->name;
2288       goto set_type;
2289     }
2290
2291   /* See if we have an intrinsic function reference.  */
2292
2293   if (gfc_is_intrinsic (sym, 0, expr->where))
2294     {
2295       if (gfc_intrinsic_func_interface (expr, 1) == MATCH_YES)
2296         return SUCCESS;
2297       return FAILURE;
2298     }
2299
2300   /* The reference is to an external name.  */
2301
2302   sym->attr.proc = PROC_EXTERNAL;
2303   expr->value.function.name = sym->name;
2304   expr->value.function.esym = expr->symtree->n.sym;
2305
2306   if (sym->as != NULL)
2307     expr->rank = sym->as->rank;
2308
2309   /* Type of the expression is either the type of the symbol or the
2310      default type of the symbol.  */
2311
2312 set_type:
2313   gfc_procedure_use (sym, &expr->value.function.actual, &expr->where);
2314
2315   if (sym->ts.type != BT_UNKNOWN)
2316     expr->ts = sym->ts;
2317   else
2318     {
2319       ts = gfc_get_default_type (sym->name, sym->ns);
2320
2321       if (ts->type == BT_UNKNOWN)
2322         {
2323           gfc_error ("Function '%s' at %L has no IMPLICIT type",
2324                      sym->name, &expr->where);
2325           return FAILURE;
2326         }
2327       else
2328         expr->ts = *ts;
2329     }
2330
2331   return SUCCESS;
2332 }
2333
2334
2335 /* Return true, if the symbol is an external procedure.  */
2336 static bool
2337 is_external_proc (gfc_symbol *sym)
2338 {
2339   if (!sym->attr.dummy && !sym->attr.contained
2340         && !(sym->attr.intrinsic
2341               || gfc_is_intrinsic (sym, sym->attr.subroutine, sym->declared_at))
2342         && sym->attr.proc != PROC_ST_FUNCTION
2343         && !sym->attr.proc_pointer
2344         && !sym->attr.use_assoc
2345         && sym->name)
2346     return true;
2347
2348   return false;
2349 }
2350
2351
2352 /* Figure out if a function reference is pure or not.  Also set the name
2353    of the function for a potential error message.  Return nonzero if the
2354    function is PURE, zero if not.  */
2355 static int
2356 pure_stmt_function (gfc_expr *, gfc_symbol *);
2357
2358 static int
2359 pure_function (gfc_expr *e, const char **name)
2360 {
2361   int pure;
2362
2363   *name = NULL;
2364
2365   if (e->symtree != NULL
2366         && e->symtree->n.sym != NULL
2367         && e->symtree->n.sym->attr.proc == PROC_ST_FUNCTION)
2368     return pure_stmt_function (e, e->symtree->n.sym);
2369
2370   if (e->value.function.esym)
2371     {
2372       pure = gfc_pure (e->value.function.esym);
2373       *name = e->value.function.esym->name;
2374     }
2375   else if (e->value.function.isym)
2376     {
2377       pure = e->value.function.isym->pure
2378              || e->value.function.isym->elemental;
2379       *name = e->value.function.isym->name;
2380     }
2381   else
2382     {
2383       /* Implicit functions are not pure.  */
2384       pure = 0;
2385       *name = e->value.function.name;
2386     }
2387
2388   return pure;
2389 }
2390
2391
2392 static bool
2393 impure_stmt_fcn (gfc_expr *e, gfc_symbol *sym,
2394                  int *f ATTRIBUTE_UNUSED)
2395 {
2396   const char *name;
2397
2398   /* Don't bother recursing into other statement functions
2399      since they will be checked individually for purity.  */
2400   if (e->expr_type != EXPR_FUNCTION
2401         || !e->symtree
2402         || e->symtree->n.sym == sym
2403         || e->symtree->n.sym->attr.proc == PROC_ST_FUNCTION)
2404     return false;
2405
2406   return pure_function (e, &name) ? false : true;
2407 }
2408
2409
2410 static int
2411 pure_stmt_function (gfc_expr *e, gfc_symbol *sym)
2412 {
2413   return gfc_traverse_expr (e, sym, impure_stmt_fcn, 0) ? 0 : 1;
2414 }
2415
2416
2417 static gfc_try
2418 is_scalar_expr_ptr (gfc_expr *expr)
2419 {
2420   gfc_try retval = SUCCESS;
2421   gfc_ref *ref;
2422   int start;
2423   int end;
2424
2425   /* See if we have a gfc_ref, which means we have a substring, array
2426      reference, or a component.  */
2427   if (expr->ref != NULL)
2428     {
2429       ref = expr->ref;
2430       while (ref->next != NULL)
2431         ref = ref->next;
2432
2433       switch (ref->type)
2434         {
2435         case REF_SUBSTRING:
2436           if (ref->u.ss.length != NULL 
2437               && ref->u.ss.length->length != NULL
2438               && ref->u.ss.start
2439               && ref->u.ss.start->expr_type == EXPR_CONSTANT 
2440               && ref->u.ss.end
2441               && ref->u.ss.end->expr_type == EXPR_CONSTANT)
2442             {
2443               start = (int) mpz_get_si (ref->u.ss.start->value.integer);
2444               end = (int) mpz_get_si (ref->u.ss.end->value.integer);
2445               if (end - start + 1 != 1)
2446                 retval = FAILURE;
2447             }
2448           else
2449             retval = FAILURE;
2450           break;
2451         case REF_ARRAY:
2452           if (ref->u.ar.type == AR_ELEMENT)
2453             retval = SUCCESS;
2454           else if (ref->u.ar.type == AR_FULL)
2455             {
2456               /* The user can give a full array if the array is of size 1.  */
2457               if (ref->u.ar.as != NULL
2458                   && ref->u.ar.as->rank == 1
2459                   && ref->u.ar.as->type == AS_EXPLICIT
2460                   && ref->u.ar.as->lower[0] != NULL
2461                   && ref->u.ar.as->lower[0]->expr_type == EXPR_CONSTANT
2462                   && ref->u.ar.as->upper[0] != NULL
2463                   && ref->u.ar.as->upper[0]->expr_type == EXPR_CONSTANT)
2464                 {
2465                   /* If we have a character string, we need to check if
2466                      its length is one.  */
2467                   if (expr->ts.type == BT_CHARACTER)
2468                     {
2469                       if (expr->ts.u.cl == NULL
2470                           || expr->ts.u.cl->length == NULL
2471                           || mpz_cmp_si (expr->ts.u.cl->length->value.integer, 1)
2472                           != 0)
2473                         retval = FAILURE;
2474                     }
2475                   else
2476                     {
2477                       /* We have constant lower and upper bounds.  If the
2478                          difference between is 1, it can be considered a
2479                          scalar.  */
2480                       start = (int) mpz_get_si
2481                                 (ref->u.ar.as->lower[0]->value.integer);
2482                       end = (int) mpz_get_si
2483                                 (ref->u.ar.as->upper[0]->value.integer);
2484                       if (end - start + 1 != 1)
2485                         retval = FAILURE;
2486                    }
2487                 }
2488               else
2489                 retval = FAILURE;
2490             }
2491           else
2492             retval = FAILURE;
2493           break;
2494         default:
2495           retval = SUCCESS;
2496           break;
2497         }
2498     }
2499   else if (expr->ts.type == BT_CHARACTER && expr->rank == 0)
2500     {
2501       /* Character string.  Make sure it's of length 1.  */
2502       if (expr->ts.u.cl == NULL
2503           || expr->ts.u.cl->length == NULL
2504           || mpz_cmp_si (expr->ts.u.cl->length->value.integer, 1) != 0)
2505         retval = FAILURE;
2506     }
2507   else if (expr->rank != 0)
2508     retval = FAILURE;
2509
2510   return retval;
2511 }
2512
2513
2514 /* Match one of the iso_c_binding functions (c_associated or c_loc)
2515    and, in the case of c_associated, set the binding label based on
2516    the arguments.  */
2517
2518 static gfc_try
2519 gfc_iso_c_func_interface (gfc_symbol *sym, gfc_actual_arglist *args,
2520                           gfc_symbol **new_sym)
2521 {
2522   char name[GFC_MAX_SYMBOL_LEN + 1];
2523   char binding_label[GFC_MAX_BINDING_LABEL_LEN + 1];
2524   int optional_arg = 0;
2525   gfc_try retval = SUCCESS;
2526   gfc_symbol *args_sym;
2527   gfc_typespec *arg_ts;
2528   symbol_attribute arg_attr;
2529
2530   if (args->expr->expr_type == EXPR_CONSTANT
2531       || args->expr->expr_type == EXPR_OP
2532       || args->expr->expr_type == EXPR_NULL)
2533     {
2534       gfc_error ("Argument to '%s' at %L is not a variable",
2535                  sym->name, &(args->expr->where));
2536       return FAILURE;
2537     }
2538
2539   args_sym = args->expr->symtree->n.sym;
2540
2541   /* The typespec for the actual arg should be that stored in the expr
2542      and not necessarily that of the expr symbol (args_sym), because
2543      the actual expression could be a part-ref of the expr symbol.  */
2544   arg_ts = &(args->expr->ts);
2545   arg_attr = gfc_expr_attr (args->expr);
2546     
2547   if (sym->intmod_sym_id == ISOCBINDING_ASSOCIATED)
2548     {
2549       /* If the user gave two args then they are providing something for
2550          the optional arg (the second cptr).  Therefore, set the name and
2551          binding label to the c_associated for two cptrs.  Otherwise,
2552          set c_associated to expect one cptr.  */
2553       if (args->next)
2554         {
2555           /* two args.  */
2556           sprintf (name, "%s_2", sym->name);
2557           sprintf (binding_label, "%s_2", sym->binding_label);
2558           optional_arg = 1;
2559         }
2560       else
2561         {
2562           /* one arg.  */
2563           sprintf (name, "%s_1", sym->name);
2564           sprintf (binding_label, "%s_1", sym->binding_label);
2565           optional_arg = 0;
2566         }
2567
2568       /* Get a new symbol for the version of c_associated that
2569          will get called.  */
2570       *new_sym = get_iso_c_sym (sym, name, binding_label, optional_arg);
2571     }
2572   else if (sym->intmod_sym_id == ISOCBINDING_LOC
2573            || sym->intmod_sym_id == ISOCBINDING_FUNLOC)
2574     {
2575       sprintf (name, "%s", sym->name);
2576       sprintf (binding_label, "%s", sym->binding_label);
2577
2578       /* Error check the call.  */
2579       if (args->next != NULL)
2580         {
2581           gfc_error_now ("More actual than formal arguments in '%s' "
2582                          "call at %L", name, &(args->expr->where));
2583           retval = FAILURE;
2584         }
2585       else if (sym->intmod_sym_id == ISOCBINDING_LOC)
2586         {
2587           /* Make sure we have either the target or pointer attribute.  */
2588           if (!arg_attr.target && !arg_attr.pointer)
2589             {
2590               gfc_error_now ("Parameter '%s' to '%s' at %L must be either "
2591                              "a TARGET or an associated pointer",
2592                              args_sym->name,
2593                              sym->name, &(args->expr->where));
2594               retval = FAILURE;
2595             }
2596
2597           /* See if we have interoperable type and type param.  */
2598           if (verify_c_interop (arg_ts) == SUCCESS
2599               || gfc_check_any_c_kind (arg_ts) == SUCCESS)
2600             {
2601               if (args_sym->attr.target == 1)
2602                 {
2603                   /* Case 1a, section 15.1.2.5, J3/04-007: variable that
2604                      has the target attribute and is interoperable.  */
2605                   /* Case 1b, section 15.1.2.5, J3/04-007: allocated
2606                      allocatable variable that has the TARGET attribute and
2607                      is not an array of zero size.  */
2608                   if (args_sym->attr.allocatable == 1)
2609                     {
2610                       if (args_sym->attr.dimension != 0 
2611                           && (args_sym->as && args_sym->as->rank == 0))
2612                         {
2613                           gfc_error_now ("Allocatable variable '%s' used as a "
2614                                          "parameter to '%s' at %L must not be "
2615                                          "an array of zero size",
2616                                          args_sym->name, sym->name,
2617                                          &(args->expr->where));
2618                           retval = FAILURE;
2619                         }
2620                     }
2621                   else
2622                     {
2623                       /* A non-allocatable target variable with C
2624                          interoperable type and type parameters must be
2625                          interoperable.  */
2626                       if (args_sym && args_sym->attr.dimension)
2627                         {
2628                           if (args_sym->as->type == AS_ASSUMED_SHAPE)
2629                             {
2630                               gfc_error ("Assumed-shape array '%s' at %L "
2631                                          "cannot be an argument to the "
2632                                          "procedure '%s' because "
2633                                          "it is not C interoperable",
2634                                          args_sym->name,
2635                                          &(args->expr->where), sym->name);
2636                               retval = FAILURE;
2637                             }
2638                           else if (args_sym->as->type == AS_DEFERRED)
2639                             {
2640                               gfc_error ("Deferred-shape array '%s' at %L "
2641                                          "cannot be an argument to the "
2642                                          "procedure '%s' because "
2643                                          "it is not C interoperable",
2644                                          args_sym->name,
2645                                          &(args->expr->where), sym->name);
2646                               retval = FAILURE;
2647                             }
2648                         }
2649                               
2650                       /* Make sure it's not a character string.  Arrays of
2651                          any type should be ok if the variable is of a C
2652                          interoperable type.  */
2653                       if (arg_ts->type == BT_CHARACTER)
2654                         if (arg_ts->u.cl != NULL
2655                             && (arg_ts->u.cl->length == NULL
2656                                 || arg_ts->u.cl->length->expr_type
2657                                    != EXPR_CONSTANT
2658                                 || mpz_cmp_si
2659                                     (arg_ts->u.cl->length->value.integer, 1)
2660                                    != 0)
2661                             && is_scalar_expr_ptr (args->expr) != SUCCESS)
2662                           {
2663                             gfc_error_now ("CHARACTER argument '%s' to '%s' "
2664                                            "at %L must have a length of 1",
2665                                            args_sym->name, sym->name,
2666                                            &(args->expr->where));
2667                             retval = FAILURE;
2668                           }
2669                     }
2670                 }
2671               else if (arg_attr.pointer
2672                        && is_scalar_expr_ptr (args->expr) != SUCCESS)
2673                 {
2674                   /* Case 1c, section 15.1.2.5, J3/04-007: an associated
2675                      scalar pointer.  */
2676                   gfc_error_now ("Argument '%s' to '%s' at %L must be an "
2677                                  "associated scalar POINTER", args_sym->name,
2678                                  sym->name, &(args->expr->where));
2679                   retval = FAILURE;
2680                 }
2681             }
2682           else
2683             {
2684               /* The parameter is not required to be C interoperable.  If it
2685                  is not C interoperable, it must be a nonpolymorphic scalar
2686                  with no length type parameters.  It still must have either
2687                  the pointer or target attribute, and it can be
2688                  allocatable (but must be allocated when c_loc is called).  */
2689               if (args->expr->rank != 0 
2690                   && is_scalar_expr_ptr (args->expr) != SUCCESS)
2691                 {
2692                   gfc_error_now ("Parameter '%s' to '%s' at %L must be a "
2693                                  "scalar", args_sym->name, sym->name,
2694                                  &(args->expr->where));
2695                   retval = FAILURE;
2696                 }
2697               else if (arg_ts->type == BT_CHARACTER 
2698                        && is_scalar_expr_ptr (args->expr) != SUCCESS)
2699                 {
2700                   gfc_error_now ("CHARACTER argument '%s' to '%s' at "
2701                                  "%L must have a length of 1",
2702                                  args_sym->name, sym->name,
2703                                  &(args->expr->where));
2704                   retval = FAILURE;
2705                 }
2706               else if (arg_ts->type == BT_CLASS)
2707                 {
2708                   gfc_error_now ("Parameter '%s' to '%s' at %L must not be "
2709                                  "polymorphic", args_sym->name, sym->name,
2710                                  &(args->expr->where));
2711                   retval = FAILURE;
2712                 }
2713             }
2714         }
2715       else if (sym->intmod_sym_id == ISOCBINDING_FUNLOC)
2716         {
2717           if (args_sym->attr.flavor != FL_PROCEDURE)
2718             {
2719               /* TODO: Update this error message to allow for procedure
2720                  pointers once they are implemented.  */
2721               gfc_error_now ("Parameter '%s' to '%s' at %L must be a "
2722                              "procedure",
2723                              args_sym->name, sym->name,
2724                              &(args->expr->where));
2725               retval = FAILURE;
2726             }
2727           else if (args_sym->attr.is_bind_c != 1)
2728             {
2729               gfc_error_now ("Parameter '%s' to '%s' at %L must be "
2730                              "BIND(C)",
2731                              args_sym->name, sym->name,
2732                              &(args->expr->where));
2733               retval = FAILURE;
2734             }
2735         }
2736       
2737       /* for c_loc/c_funloc, the new symbol is the same as the old one */
2738       *new_sym = sym;
2739     }
2740   else
2741     {
2742       gfc_internal_error ("gfc_iso_c_func_interface(): Unhandled "
2743                           "iso_c_binding function: '%s'!\n", sym->name);
2744     }
2745
2746   return retval;
2747 }
2748
2749
2750 /* Resolve a function call, which means resolving the arguments, then figuring
2751    out which entity the name refers to.  */
2752 /* TODO: Check procedure arguments so that an INTENT(IN) isn't passed
2753    to INTENT(OUT) or INTENT(INOUT).  */
2754
2755 static gfc_try
2756 resolve_function (gfc_expr *expr)
2757 {
2758   gfc_actual_arglist *arg;
2759   gfc_symbol *sym;
2760   const char *name;
2761   gfc_try t;
2762   int temp;
2763   procedure_type p = PROC_INTRINSIC;
2764   bool no_formal_args;
2765
2766   sym = NULL;
2767   if (expr->symtree)
2768     sym = expr->symtree->n.sym;
2769
2770   /* If this is a procedure pointer component, it has already been resolved.  */
2771   if (gfc_is_proc_ptr_comp (expr, NULL))
2772     return SUCCESS;
2773   
2774   if (sym && sym->attr.intrinsic
2775       && resolve_intrinsic (sym, &expr->where) == FAILURE)
2776     return FAILURE;
2777
2778   if (sym && (sym->attr.flavor == FL_VARIABLE || sym->attr.subroutine))
2779     {
2780       gfc_error ("'%s' at %L is not a function", sym->name, &expr->where);
2781       return FAILURE;
2782     }
2783
2784   /* If this ia a deferred TBP with an abstract interface (which may
2785      of course be referenced), expr->value.function.esym will be set.  */
2786   if (sym && sym->attr.abstract && !expr->value.function.esym)
2787     {
2788       gfc_error ("ABSTRACT INTERFACE '%s' must not be referenced at %L",
2789                  sym->name, &expr->where);
2790       return FAILURE;
2791     }
2792
2793   /* Switch off assumed size checking and do this again for certain kinds
2794      of procedure, once the procedure itself is resolved.  */
2795   need_full_assumed_size++;
2796
2797   if (expr->symtree && expr->symtree->n.sym)
2798     p = expr->symtree->n.sym->attr.proc;
2799
2800   if (expr->value.function.isym && expr->value.function.isym->inquiry)
2801     inquiry_argument = true;
2802   no_formal_args = sym && is_external_proc (sym) && sym->formal == NULL;
2803
2804   if (resolve_actual_arglist (expr->value.function.actual,
2805                               p, no_formal_args) == FAILURE)
2806     {
2807       inquiry_argument = false;
2808       return FAILURE;
2809     }
2810
2811   inquiry_argument = false;
2812  
2813   /* Need to setup the call to the correct c_associated, depending on
2814      the number of cptrs to user gives to compare.  */
2815   if (sym && sym->attr.is_iso_c == 1)
2816     {
2817       if (gfc_iso_c_func_interface (sym, expr->value.function.actual, &sym)
2818           == FAILURE)
2819         return FAILURE;
2820       
2821       /* Get the symtree for the new symbol (resolved func).
2822          the old one will be freed later, when it's no longer used.  */
2823       gfc_find_sym_tree (sym->name, sym->ns, 1, &(expr->symtree));
2824     }
2825   
2826   /* Resume assumed_size checking.  */
2827   need_full_assumed_size--;
2828
2829   /* If the procedure is external, check for usage.  */
2830   if (sym && is_external_proc (sym))
2831     resolve_global_procedure (sym, &expr->where,
2832                               &expr->value.function.actual, 0);
2833
2834   if (sym && sym->ts.type == BT_CHARACTER
2835       && sym->ts.u.cl
2836       && sym->ts.u.cl->length == NULL
2837       && !sym->attr.dummy
2838       && expr->value.function.esym == NULL
2839       && !sym->attr.contained)
2840     {
2841       /* Internal procedures are taken care of in resolve_contained_fntype.  */
2842       gfc_error ("Function '%s' is declared CHARACTER(*) and cannot "
2843                  "be used at %L since it is not a dummy argument",
2844                  sym->name, &expr->where);
2845       return FAILURE;
2846     }
2847
2848   /* See if function is already resolved.  */
2849
2850   if (expr->value.function.name != NULL)
2851     {
2852       if (expr->ts.type == BT_UNKNOWN)
2853         expr->ts = sym->ts;
2854       t = SUCCESS;
2855     }
2856   else
2857     {
2858       /* Apply the rules of section 14.1.2.  */
2859
2860       switch (procedure_kind (sym))
2861         {
2862         case PTYPE_GENERIC:
2863           t = resolve_generic_f (expr);
2864           break;
2865
2866         case PTYPE_SPECIFIC:
2867           t = resolve_specific_f (expr);
2868           break;
2869
2870         case PTYPE_UNKNOWN:
2871           t = resolve_unknown_f (expr);
2872           break;
2873
2874         default:
2875           gfc_internal_error ("resolve_function(): bad function type");
2876         }
2877     }
2878
2879   /* If the expression is still a function (it might have simplified),
2880      then we check to see if we are calling an elemental function.  */
2881
2882   if (expr->expr_type != EXPR_FUNCTION)
2883     return t;
2884
2885   temp = need_full_assumed_size;
2886   need_full_assumed_size = 0;
2887
2888   if (resolve_elemental_actual (expr, NULL) == FAILURE)
2889     return FAILURE;
2890
2891   if (omp_workshare_flag
2892       && expr->value.function.esym
2893       && ! gfc_elemental (expr->value.function.esym))
2894     {
2895       gfc_error ("User defined non-ELEMENTAL function '%s' at %L not allowed "
2896                  "in WORKSHARE construct", expr->value.function.esym->name,
2897                  &expr->where);
2898       t = FAILURE;
2899     }
2900
2901 #define GENERIC_ID expr->value.function.isym->id
2902   else if (expr->value.function.actual != NULL
2903            && expr->value.function.isym != NULL
2904            && GENERIC_ID != GFC_ISYM_LBOUND
2905            && GENERIC_ID != GFC_ISYM_LEN
2906            && GENERIC_ID != GFC_ISYM_LOC
2907            && GENERIC_ID != GFC_ISYM_PRESENT)
2908     {
2909       /* Array intrinsics must also have the last upper bound of an
2910          assumed size array argument.  UBOUND and SIZE have to be
2911          excluded from the check if the second argument is anything
2912          than a constant.  */
2913
2914       for (arg = expr->value.function.actual; arg; arg = arg->next)
2915         {
2916           if ((GENERIC_ID == GFC_ISYM_UBOUND || GENERIC_ID == GFC_ISYM_SIZE)
2917               && arg->next != NULL && arg->next->expr)
2918             {
2919               if (arg->next->expr->expr_type != EXPR_CONSTANT)
2920                 break;
2921
2922               if (arg->next->name && strncmp(arg->next->name, "kind", 4) == 0)
2923                 break;
2924
2925               if ((int)mpz_get_si (arg->next->expr->value.integer)
2926                         < arg->expr->rank)
2927                 break;
2928             }
2929
2930           if (arg->expr != NULL
2931               && arg->expr->rank > 0
2932               && resolve_assumed_size_actual (arg->expr))
2933             return FAILURE;
2934         }
2935     }
2936 #undef GENERIC_ID
2937
2938   need_full_assumed_size = temp;
2939   name = NULL;
2940
2941   if (!pure_function (expr, &name) && name)
2942     {
2943       if (forall_flag)
2944         {
2945           gfc_error ("reference to non-PURE function '%s' at %L inside a "
2946                      "FORALL %s", name, &expr->where,
2947                      forall_flag == 2 ? "mask" : "block");
2948           t = FAILURE;
2949         }
2950       else if (gfc_pure (NULL))
2951         {
2952           gfc_error ("Function reference to '%s' at %L is to a non-PURE "
2953                      "procedure within a PURE procedure", name, &expr->where);
2954           t = FAILURE;
2955         }
2956     }
2957
2958   /* Functions without the RECURSIVE attribution are not allowed to
2959    * call themselves.  */
2960   if (expr->value.function.esym && !expr->value.function.esym->attr.recursive)
2961     {
2962       gfc_symbol *esym;
2963       esym = expr->value.function.esym;
2964
2965       if (is_illegal_recursion (esym, gfc_current_ns))
2966       {
2967         if (esym->attr.entry && esym->ns->entries)
2968           gfc_error ("ENTRY '%s' at %L cannot be called recursively, as"
2969                      " function '%s' is not RECURSIVE",
2970                      esym->name, &expr->where, esym->ns->entries->sym->name);
2971         else
2972           gfc_error ("Function '%s' at %L cannot be called recursively, as it"
2973                      " is not RECURSIVE", esym->name, &expr->where);
2974
2975         t = FAILURE;
2976       }
2977     }
2978
2979   /* Character lengths of use associated functions may contains references to
2980      symbols not referenced from the current program unit otherwise.  Make sure
2981      those symbols are marked as referenced.  */
2982
2983   if (expr->ts.type == BT_CHARACTER && expr->value.function.esym
2984       && expr->value.function.esym->attr.use_assoc)
2985     {
2986       gfc_expr_set_symbols_referenced (expr->ts.u.cl->length);
2987     }
2988
2989   if (t == SUCCESS
2990         && !((expr->value.function.esym
2991                 && expr->value.function.esym->attr.elemental)
2992                         ||
2993              (expr->value.function.isym
2994                 && expr->value.function.isym->elemental)))
2995     find_noncopying_intrinsics (expr->value.function.esym,
2996                                 expr->value.function.actual);
2997
2998   /* Make sure that the expression has a typespec that works.  */
2999   if (expr->ts.type == BT_UNKNOWN)
3000     {
3001       if (expr->symtree->n.sym->result
3002             && expr->symtree->n.sym->result->ts.type != BT_UNKNOWN
3003             && !expr->symtree->n.sym->result->attr.proc_pointer)
3004         expr->ts = expr->symtree->n.sym->result->ts;
3005     }
3006
3007   return t;
3008 }
3009
3010
3011 /************* Subroutine resolution *************/
3012
3013 static void
3014 pure_subroutine (gfc_code *c, gfc_symbol *sym)
3015 {
3016   if (gfc_pure (sym))
3017     return;
3018
3019   if (forall_flag)
3020     gfc_error ("Subroutine call to '%s' in FORALL block at %L is not PURE",
3021                sym->name, &c->loc);
3022   else if (gfc_pure (NULL))
3023     gfc_error ("Subroutine call to '%s' at %L is not PURE", sym->name,
3024                &c->loc);
3025 }
3026
3027
3028 static match
3029 resolve_generic_s0 (gfc_code *c, gfc_symbol *sym)
3030 {
3031   gfc_symbol *s;
3032
3033   if (sym->attr.generic)
3034     {
3035       s = gfc_search_interface (sym->generic, 1, &c->ext.actual);
3036       if (s != NULL)
3037         {
3038           c->resolved_sym = s;
3039           pure_subroutine (c, s);
3040           return MATCH_YES;
3041         }
3042
3043       /* TODO: Need to search for elemental references in generic interface.  */
3044     }
3045
3046   if (sym->attr.intrinsic)
3047     return gfc_intrinsic_sub_interface (c, 0);
3048
3049   return MATCH_NO;
3050 }
3051
3052
3053 static gfc_try
3054 resolve_generic_s (gfc_code *c)
3055 {
3056   gfc_symbol *sym;
3057   match m;
3058
3059   sym = c->symtree->n.sym;
3060
3061   for (;;)
3062     {
3063       m = resolve_generic_s0 (c, sym);
3064       if (m == MATCH_YES)
3065         return SUCCESS;
3066       else if (m == MATCH_ERROR)
3067         return FAILURE;
3068
3069 generic:
3070       if (sym->ns->parent == NULL)
3071         break;
3072       gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
3073
3074       if (sym == NULL)
3075         break;
3076       if (!generic_sym (sym))
3077         goto generic;
3078     }
3079
3080   /* Last ditch attempt.  See if the reference is to an intrinsic
3081      that possesses a matching interface.  14.1.2.4  */
3082   sym = c->symtree->n.sym;
3083
3084   if (!gfc_is_intrinsic (sym, 1, c->loc))
3085     {
3086       gfc_error ("There is no specific subroutine for the generic '%s' at %L",
3087                  sym->name, &c->loc);
3088       return FAILURE;
3089     }
3090
3091   m = gfc_intrinsic_sub_interface (c, 0);
3092   if (m == MATCH_YES)
3093     return SUCCESS;
3094   if (m == MATCH_NO)
3095     gfc_error ("Generic subroutine '%s' at %L is not consistent with an "
3096                "intrinsic subroutine interface", sym->name, &c->loc);
3097
3098   return FAILURE;
3099 }
3100
3101
3102 /* Set the name and binding label of the subroutine symbol in the call
3103    expression represented by 'c' to include the type and kind of the
3104    second parameter.  This function is for resolving the appropriate
3105    version of c_f_pointer() and c_f_procpointer().  For example, a
3106    call to c_f_pointer() for a default integer pointer could have a
3107    name of c_f_pointer_i4.  If no second arg exists, which is an error
3108    for these two functions, it defaults to the generic symbol's name
3109    and binding label.  */
3110
3111 static void
3112 set_name_and_label (gfc_code *c, gfc_symbol *sym,
3113                     char *name, char *binding_label)
3114 {
3115   gfc_expr *arg = NULL;
3116   char type;
3117   int kind;
3118
3119   /* The second arg of c_f_pointer and c_f_procpointer determines
3120      the type and kind for the procedure name.  */
3121   arg = c->ext.actual->next->expr;
3122
3123   if (arg != NULL)
3124     {
3125       /* Set up the name to have the given symbol's name,
3126          plus the type and kind.  */
3127       /* a derived type is marked with the type letter 'u' */
3128       if (arg->ts.type == BT_DERIVED)
3129         {
3130           type = 'd';
3131           kind = 0; /* set the kind as 0 for now */
3132         }
3133       else
3134         {
3135           type = gfc_type_letter (arg->ts.type);
3136           kind = arg->ts.kind;
3137         }
3138
3139       if (arg->ts.type == BT_CHARACTER)
3140         /* Kind info for character strings not needed.  */
3141         kind = 0;
3142
3143       sprintf (name, "%s_%c%d", sym->name, type, kind);
3144       /* Set up the binding label as the given symbol's label plus
3145          the type and kind.  */
3146       sprintf (binding_label, "%s_%c%d", sym->binding_label, type, kind);
3147     }
3148   else
3149     {
3150       /* If the second arg is missing, set the name and label as
3151          was, cause it should at least be found, and the missing
3152          arg error will be caught by compare_parameters().  */
3153       sprintf (name, "%s", sym->name);
3154       sprintf (binding_label, "%s", sym->binding_label);
3155     }
3156    
3157   return;
3158 }
3159
3160
3161 /* Resolve a generic version of the iso_c_binding procedure given
3162    (sym) to the specific one based on the type and kind of the
3163    argument(s).  Currently, this function resolves c_f_pointer() and
3164    c_f_procpointer based on the type and kind of the second argument
3165    (FPTR).  Other iso_c_binding procedures aren't specially handled.
3166    Upon successfully exiting, c->resolved_sym will hold the resolved
3167    symbol.  Returns MATCH_ERROR if an error occurred; MATCH_YES
3168    otherwise.  */
3169
3170 match
3171 gfc_iso_c_sub_interface (gfc_code *c, gfc_symbol *sym)
3172 {
3173   gfc_symbol *new_sym;
3174   /* this is fine, since we know the names won't use the max */
3175   char name[GFC_MAX_SYMBOL_LEN + 1];
3176   char binding_label[GFC_MAX_BINDING_LABEL_LEN + 1];
3177   /* default to success; will override if find error */
3178   match m = MATCH_YES;
3179
3180   /* Make sure the actual arguments are in the necessary order (based on the 
3181      formal args) before resolving.  */
3182   gfc_procedure_use (sym, &c->ext.actual, &(c->loc));
3183
3184   if ((sym->intmod_sym_id == ISOCBINDING_F_POINTER) ||
3185       (sym->intmod_sym_id == ISOCBINDING_F_PROCPOINTER))
3186     {
3187       set_name_and_label (c, sym, name, binding_label);
3188       
3189       if (sym->intmod_sym_id == ISOCBINDING_F_POINTER)
3190         {
3191           if (c->ext.actual != NULL && c->ext.actual->next != NULL)
3192             {
3193               /* Make sure we got a third arg if the second arg has non-zero
3194                  rank.  We must also check that the type and rank are
3195                  correct since we short-circuit this check in
3196                  gfc_procedure_use() (called above to sort actual args).  */
3197               if (c->ext.actual->next->expr->rank != 0)
3198                 {
3199                   if(c->ext.actual->next->next == NULL 
3200                      || c->ext.actual->next->next->expr == NULL)
3201                     {
3202                       m = MATCH_ERROR;
3203                       gfc_error ("Missing SHAPE parameter for call to %s "
3204                                  "at %L", sym->name, &(c->loc));
3205                     }
3206                   else if (c->ext.actual->next->next->expr->ts.type
3207                            != BT_INTEGER
3208                            || c->ext.actual->next->next->expr->rank != 1)
3209                     {
3210                       m = MATCH_ERROR;
3211                       gfc_error ("SHAPE parameter for call to %s at %L must "
3212                                  "be a rank 1 INTEGER array", sym->name,
3213                                  &(c->loc));
3214                     }
3215                 }
3216             }
3217         }
3218       
3219       if (m != MATCH_ERROR)
3220         {
3221           /* the 1 means to add the optional arg to formal list */
3222           new_sym = get_iso_c_sym (sym, name, binding_label, 1);
3223          
3224           /* for error reporting, say it's declared where the original was */
3225           new_sym->declared_at = sym->declared_at;
3226         }
3227     }
3228   else
3229     {
3230       /* no differences for c_loc or c_funloc */
3231       new_sym = sym;
3232     }
3233
3234   /* set the resolved symbol */
3235   if (m != MATCH_ERROR)
3236     c->resolved_sym = new_sym;
3237   else
3238     c->resolved_sym = sym;
3239   
3240   return m;
3241 }
3242
3243
3244 /* Resolve a subroutine call known to be specific.  */
3245
3246 static match
3247 resolve_specific_s0 (gfc_code *c, gfc_symbol *sym)
3248 {
3249   match m;
3250
3251   if(sym->attr.is_iso_c)
3252     {
3253       m = gfc_iso_c_sub_interface (c,sym);
3254       return m;
3255     }
3256   
3257   if (sym->attr.external || sym->attr.if_source == IFSRC_IFBODY)
3258     {
3259       if (sym->attr.dummy)
3260         {
3261           sym->attr.proc = PROC_DUMMY;
3262           goto found;
3263         }
3264
3265       sym->attr.proc = PROC_EXTERNAL;
3266       goto found;
3267     }
3268
3269   if (sym->attr.proc == PROC_MODULE || sym->attr.proc == PROC_INTERNAL)
3270     goto found;
3271
3272   if (sym->attr.intrinsic)
3273     {
3274       m = gfc_intrinsic_sub_interface (c, 1);
3275       if (m == MATCH_YES)
3276         return MATCH_YES;
3277       if (m == MATCH_NO)
3278         gfc_error ("Subroutine '%s' at %L is INTRINSIC but is not compatible "
3279                    "with an intrinsic", sym->name, &c->loc);
3280
3281       return MATCH_ERROR;
3282     }
3283
3284   return MATCH_NO;
3285
3286 found:
3287   gfc_procedure_use (sym, &c->ext.actual, &c->loc);
3288
3289   c->resolved_sym = sym;
3290   pure_subroutine (c, sym);
3291
3292   return MATCH_YES;
3293 }
3294
3295
3296 static gfc_try
3297 resolve_specific_s (gfc_code *c)
3298 {
3299   gfc_symbol *sym;
3300   match m;
3301
3302   sym = c->symtree->n.sym;
3303
3304   for (;;)
3305     {
3306       m = resolve_specific_s0 (c, sym);
3307       if (m == MATCH_YES)
3308         return SUCCESS;
3309       if (m == MATCH_ERROR)
3310         return FAILURE;
3311
3312       if (sym->ns->parent == NULL)
3313         break;
3314
3315       gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
3316
3317       if (sym == NULL)
3318         break;
3319     }
3320
3321   sym = c->symtree->n.sym;
3322   gfc_error ("Unable to resolve the specific subroutine '%s' at %L",
3323              sym->name, &c->loc);
3324
3325   return FAILURE;
3326 }
3327
3328
3329 /* Resolve a subroutine call not known to be generic nor specific.  */
3330
3331 static gfc_try
3332 resolve_unknown_s (gfc_code *c)
3333 {
3334   gfc_symbol *sym;
3335
3336   sym = c->symtree->n.sym;
3337
3338   if (sym->attr.dummy)
3339     {
3340       sym->attr.proc = PROC_DUMMY;
3341       goto found;
3342     }
3343
3344   /* See if we have an intrinsic function reference.  */
3345
3346   if (gfc_is_intrinsic (sym, 1, c->loc))
3347     {
3348       if (gfc_intrinsic_sub_interface (c, 1) == MATCH_YES)