OSDN Git Service

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