OSDN Git Service

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