OSDN Git Service

2010-07-26 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             || sym->attr.if_source == IFSRC_IFBODY)
1821         && gsym->type != GSYM_UNKNOWN
1822         && gsym->ns
1823         && gsym->ns->resolved != -1
1824         && gsym->ns->proc_name
1825         && not_in_recursive (sym, gsym->ns)
1826         && not_entry_self_reference (sym, gsym->ns))
1827     {
1828       gfc_symbol *def_sym;
1829
1830       /* Resolve the gsymbol namespace if needed.  */
1831       if (!gsym->ns->resolved)
1832         {
1833           gfc_dt_list *old_dt_list;
1834
1835           /* Stash away derived types so that the backend_decls do not
1836              get mixed up.  */
1837           old_dt_list = gfc_derived_types;
1838           gfc_derived_types = NULL;
1839
1840           gfc_resolve (gsym->ns);
1841
1842           /* Store the new derived types with the global namespace.  */
1843           if (gfc_derived_types)
1844             gsym->ns->derived_types = gfc_derived_types;
1845
1846           /* Restore the derived types of this namespace.  */
1847           gfc_derived_types = old_dt_list;
1848         }
1849
1850       /* Make sure that translation for the gsymbol occurs before
1851          the procedure currently being resolved.  */
1852       ns = gfc_global_ns_list;
1853       for (; ns && ns != gsym->ns; ns = ns->sibling)
1854         {
1855           if (ns->sibling == gsym->ns)
1856             {
1857               ns->sibling = gsym->ns->sibling;
1858               gsym->ns->sibling = gfc_global_ns_list;
1859               gfc_global_ns_list = gsym->ns;
1860               break;
1861             }
1862         }
1863
1864       def_sym = gsym->ns->proc_name;
1865       if (def_sym->attr.entry_master)
1866         {
1867           gfc_entry_list *entry;
1868           for (entry = gsym->ns->entries; entry; entry = entry->next)
1869             if (strcmp (entry->sym->name, sym->name) == 0)
1870               {
1871                 def_sym = entry->sym;
1872                 break;
1873               }
1874         }
1875
1876       /* Differences in constant character lengths.  */
1877       if (sym->attr.function && sym->ts.type == BT_CHARACTER)
1878         {
1879           long int l1 = 0, l2 = 0;
1880           gfc_charlen *cl1 = sym->ts.u.cl;
1881           gfc_charlen *cl2 = def_sym->ts.u.cl;
1882
1883           if (cl1 != NULL
1884               && cl1->length != NULL
1885               && cl1->length->expr_type == EXPR_CONSTANT)
1886             l1 = mpz_get_si (cl1->length->value.integer);
1887
1888           if (cl2 != NULL
1889               && cl2->length != NULL
1890               && cl2->length->expr_type == EXPR_CONSTANT)
1891             l2 = mpz_get_si (cl2->length->value.integer);
1892
1893           if (l1 && l2 && l1 != l2)
1894             gfc_error ("Character length mismatch in return type of "
1895                        "function '%s' at %L (%ld/%ld)", sym->name,
1896                        &sym->declared_at, l1, l2);
1897         }
1898
1899      /* Type mismatch of function return type and expected type.  */
1900      if (sym->attr.function
1901          && !gfc_compare_types (&sym->ts, &def_sym->ts))
1902         gfc_error ("Return type mismatch of function '%s' at %L (%s/%s)",
1903                    sym->name, &sym->declared_at, gfc_typename (&sym->ts),
1904                    gfc_typename (&def_sym->ts));
1905
1906       if (def_sym->formal && sym->attr.if_source != IFSRC_IFBODY)
1907         {
1908           gfc_formal_arglist *arg = def_sym->formal;
1909           for ( ; arg; arg = arg->next)
1910             if (!arg->sym)
1911               continue;
1912             /* F2003, 12.3.1.1 (2a); F2008, 12.4.2.2 (2a)  */
1913             else if (arg->sym->attr.allocatable
1914                      || arg->sym->attr.asynchronous
1915                      || arg->sym->attr.optional
1916                      || arg->sym->attr.pointer
1917                      || arg->sym->attr.target
1918                      || arg->sym->attr.value
1919                      || arg->sym->attr.volatile_)
1920               {
1921                 gfc_error ("Dummy argument '%s' of procedure '%s' at %L "
1922                            "has an attribute that requires an explicit "
1923                            "interface for this procedure", arg->sym->name,
1924                            sym->name, &sym->declared_at);
1925                 break;
1926               }
1927             /* F2003, 12.3.1.1 (2b); F2008, 12.4.2.2 (2b)  */
1928             else if (arg->sym && arg->sym->as
1929                      && arg->sym->as->type == AS_ASSUMED_SHAPE)
1930               {
1931                 gfc_error ("Procedure '%s' at %L with assumed-shape dummy "
1932                            "argument '%s' must have an explicit interface",
1933                            sym->name, &sym->declared_at, arg->sym->name);
1934                 break;
1935               }
1936             /* F2008, 12.4.2.2 (2c)  */
1937             else if (arg->sym->attr.codimension)
1938               {
1939                 gfc_error ("Procedure '%s' at %L with coarray dummy argument "
1940                            "'%s' must have an explicit interface",
1941                            sym->name, &sym->declared_at, arg->sym->name);
1942                 break;
1943               }
1944             /* F2003, 12.3.1.1 (2c); F2008, 12.4.2.2 (2d)   */
1945             else if (false) /* TODO: is a parametrized derived type  */
1946               {
1947                 gfc_error ("Procedure '%s' at %L with parametrized derived "
1948                            "type argument '%s' must have an explicit "
1949                            "interface", sym->name, &sym->declared_at,
1950                            arg->sym->name);
1951                 break;
1952               }
1953             /* F2003, 12.3.1.1 (2d); F2008, 12.4.2.2 (2e)   */
1954             else if (arg->sym->ts.type == BT_CLASS)
1955               {
1956                 gfc_error ("Procedure '%s' at %L with polymorphic dummy "
1957                            "argument '%s' must have an explicit interface",
1958                            sym->name, &sym->declared_at, arg->sym->name);
1959                 break;
1960               }
1961         }
1962
1963       if (def_sym->attr.function)
1964         {
1965           /* F2003, 12.3.1.1 (3a); F2008, 12.4.2.2 (3a) */
1966           if (def_sym->as && def_sym->as->rank
1967               && (!sym->as || sym->as->rank != def_sym->as->rank))
1968             gfc_error ("The reference to function '%s' at %L either needs an "
1969                        "explicit INTERFACE or the rank is incorrect", sym->name,
1970                        where);
1971
1972           /* F2003, 12.3.1.1 (3b); F2008, 12.4.2.2 (3b) */
1973           if ((def_sym->result->attr.pointer
1974                || def_sym->result->attr.allocatable)
1975                && (sym->attr.if_source != IFSRC_IFBODY
1976                    || def_sym->result->attr.pointer
1977                         != sym->result->attr.pointer
1978                    || def_sym->result->attr.allocatable
1979                         != sym->result->attr.allocatable))
1980             gfc_error ("Function '%s' at %L with a POINTER or ALLOCATABLE "
1981                        "result must have an explicit interface", sym->name,
1982                        where);
1983
1984           /* F2003, 12.3.1.1 (3c); F2008, 12.4.2.2 (3c)  */
1985           if (sym->ts.type == BT_CHARACTER && sym->attr.if_source != IFSRC_IFBODY
1986               && def_sym->ts.u.cl->length != NULL)
1987             {
1988               gfc_charlen *cl = sym->ts.u.cl;
1989
1990               if (!sym->attr.entry_master && sym->attr.if_source == IFSRC_UNKNOWN
1991                   && cl && cl->length && cl->length->expr_type != EXPR_CONSTANT)
1992                 {
1993                   gfc_error ("Nonconstant character-length function '%s' at %L "
1994                              "must have an explicit interface", sym->name,
1995                              &sym->declared_at);
1996                 }
1997             }
1998         }
1999
2000       /* F2003, 12.3.1.1 (4); F2008, 12.4.2.2 (4) */
2001       if (def_sym->attr.elemental && !sym->attr.elemental)
2002         {
2003           gfc_error ("ELEMENTAL procedure '%s' at %L must have an explicit "
2004                      "interface", sym->name, &sym->declared_at);
2005         }
2006
2007       /* F2003, 12.3.1.1 (5); F2008, 12.4.2.2 (5) */
2008       if (def_sym->attr.is_bind_c && !sym->attr.is_bind_c)
2009         {
2010           gfc_error ("Procedure '%s' at %L with BIND(C) attribute must have "
2011                      "an explicit interface", sym->name, &sym->declared_at);
2012         }
2013
2014       if (gfc_option.flag_whole_file == 1
2015           || ((gfc_option.warn_std & GFC_STD_LEGACY)
2016               && !(gfc_option.warn_std & GFC_STD_GNU)))
2017         gfc_errors_to_warnings (1);
2018
2019       if (sym->attr.if_source != IFSRC_IFBODY)  
2020         gfc_procedure_use (def_sym, actual, where);
2021
2022       gfc_errors_to_warnings (0);
2023     }
2024
2025   if (gsym->type == GSYM_UNKNOWN)
2026     {
2027       gsym->type = type;
2028       gsym->where = *where;
2029     }
2030
2031   gsym->used = 1;
2032 }
2033
2034
2035 /************* Function resolution *************/
2036
2037 /* Resolve a function call known to be generic.
2038    Section 14.1.2.4.1.  */
2039
2040 static match
2041 resolve_generic_f0 (gfc_expr *expr, gfc_symbol *sym)
2042 {
2043   gfc_symbol *s;
2044
2045   if (sym->attr.generic)
2046     {
2047       s = gfc_search_interface (sym->generic, 0, &expr->value.function.actual);
2048       if (s != NULL)
2049         {
2050           expr->value.function.name = s->name;
2051           expr->value.function.esym = s;
2052
2053           if (s->ts.type != BT_UNKNOWN)
2054             expr->ts = s->ts;
2055           else if (s->result != NULL && s->result->ts.type != BT_UNKNOWN)
2056             expr->ts = s->result->ts;
2057
2058           if (s->as != NULL)
2059             expr->rank = s->as->rank;
2060           else if (s->result != NULL && s->result->as != NULL)
2061             expr->rank = s->result->as->rank;
2062
2063           gfc_set_sym_referenced (expr->value.function.esym);
2064
2065           return MATCH_YES;
2066         }
2067
2068       /* TODO: Need to search for elemental references in generic
2069          interface.  */
2070     }
2071
2072   if (sym->attr.intrinsic)
2073     return gfc_intrinsic_func_interface (expr, 0);
2074
2075   return MATCH_NO;
2076 }
2077
2078
2079 static gfc_try
2080 resolve_generic_f (gfc_expr *expr)
2081 {
2082   gfc_symbol *sym;
2083   match m;
2084
2085   sym = expr->symtree->n.sym;
2086
2087   for (;;)
2088     {
2089       m = resolve_generic_f0 (expr, sym);
2090       if (m == MATCH_YES)
2091         return SUCCESS;
2092       else if (m == MATCH_ERROR)
2093         return FAILURE;
2094
2095 generic:
2096       if (sym->ns->parent == NULL)
2097         break;
2098       gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
2099
2100       if (sym == NULL)
2101         break;
2102       if (!generic_sym (sym))
2103         goto generic;
2104     }
2105
2106   /* Last ditch attempt.  See if the reference is to an intrinsic
2107      that possesses a matching interface.  14.1.2.4  */
2108   if (sym && !gfc_is_intrinsic (sym, 0, expr->where))
2109     {
2110       gfc_error ("There is no specific function for the generic '%s' at %L",
2111                  expr->symtree->n.sym->name, &expr->where);
2112       return FAILURE;
2113     }
2114
2115   m = gfc_intrinsic_func_interface (expr, 0);
2116   if (m == MATCH_YES)
2117     return SUCCESS;
2118   if (m == MATCH_NO)
2119     gfc_error ("Generic function '%s' at %L is not consistent with a "
2120                "specific intrinsic interface", expr->symtree->n.sym->name,
2121                &expr->where);
2122
2123   return FAILURE;
2124 }
2125
2126
2127 /* Resolve a function call known to be specific.  */
2128
2129 static match
2130 resolve_specific_f0 (gfc_symbol *sym, gfc_expr *expr)
2131 {
2132   match m;
2133
2134   if (sym->attr.external || sym->attr.if_source == IFSRC_IFBODY)
2135     {
2136       if (sym->attr.dummy)
2137         {
2138           sym->attr.proc = PROC_DUMMY;
2139           goto found;
2140         }
2141
2142       sym->attr.proc = PROC_EXTERNAL;
2143       goto found;
2144     }
2145
2146   if (sym->attr.proc == PROC_MODULE
2147       || sym->attr.proc == PROC_ST_FUNCTION
2148       || sym->attr.proc == PROC_INTERNAL)
2149     goto found;
2150
2151   if (sym->attr.intrinsic)
2152     {
2153       m = gfc_intrinsic_func_interface (expr, 1);
2154       if (m == MATCH_YES)
2155         return MATCH_YES;
2156       if (m == MATCH_NO)
2157         gfc_error ("Function '%s' at %L is INTRINSIC but is not compatible "
2158                    "with an intrinsic", sym->name, &expr->where);
2159
2160       return MATCH_ERROR;
2161     }
2162
2163   return MATCH_NO;
2164
2165 found:
2166   gfc_procedure_use (sym, &expr->value.function.actual, &expr->where);
2167
2168   if (sym->result)
2169     expr->ts = sym->result->ts;
2170   else
2171     expr->ts = sym->ts;
2172   expr->value.function.name = sym->name;
2173   expr->value.function.esym = sym;
2174   if (sym->as != NULL)
2175     expr->rank = sym->as->rank;
2176
2177   return MATCH_YES;
2178 }
2179
2180
2181 static gfc_try
2182 resolve_specific_f (gfc_expr *expr)
2183 {
2184   gfc_symbol *sym;
2185   match m;
2186
2187   sym = expr->symtree->n.sym;
2188
2189   for (;;)
2190     {
2191       m = resolve_specific_f0 (sym, expr);
2192       if (m == MATCH_YES)
2193         return SUCCESS;
2194       if (m == MATCH_ERROR)
2195         return FAILURE;
2196
2197       if (sym->ns->parent == NULL)
2198         break;
2199
2200       gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
2201
2202       if (sym == NULL)
2203         break;
2204     }
2205
2206   gfc_error ("Unable to resolve the specific function '%s' at %L",
2207              expr->symtree->n.sym->name, &expr->where);
2208
2209   return SUCCESS;
2210 }
2211
2212
2213 /* Resolve a procedure call not known to be generic nor specific.  */
2214
2215 static gfc_try
2216 resolve_unknown_f (gfc_expr *expr)
2217 {
2218   gfc_symbol *sym;
2219   gfc_typespec *ts;
2220
2221   sym = expr->symtree->n.sym;
2222
2223   if (sym->attr.dummy)
2224     {
2225       sym->attr.proc = PROC_DUMMY;
2226       expr->value.function.name = sym->name;
2227       goto set_type;
2228     }
2229
2230   /* See if we have an intrinsic function reference.  */
2231
2232   if (gfc_is_intrinsic (sym, 0, expr->where))
2233     {
2234       if (gfc_intrinsic_func_interface (expr, 1) == MATCH_YES)
2235         return SUCCESS;
2236       return FAILURE;
2237     }
2238
2239   /* The reference is to an external name.  */
2240
2241   sym->attr.proc = PROC_EXTERNAL;
2242   expr->value.function.name = sym->name;
2243   expr->value.function.esym = expr->symtree->n.sym;
2244
2245   if (sym->as != NULL)
2246     expr->rank = sym->as->rank;
2247
2248   /* Type of the expression is either the type of the symbol or the
2249      default type of the symbol.  */
2250
2251 set_type:
2252   gfc_procedure_use (sym, &expr->value.function.actual, &expr->where);
2253
2254   if (sym->ts.type != BT_UNKNOWN)
2255     expr->ts = sym->ts;
2256   else
2257     {
2258       ts = gfc_get_default_type (sym->name, sym->ns);
2259
2260       if (ts->type == BT_UNKNOWN)
2261         {
2262           gfc_error ("Function '%s' at %L has no IMPLICIT type",
2263                      sym->name, &expr->where);
2264           return FAILURE;
2265         }
2266       else
2267         expr->ts = *ts;
2268     }
2269
2270   return SUCCESS;
2271 }
2272
2273
2274 /* Return true, if the symbol is an external procedure.  */
2275 static bool
2276 is_external_proc (gfc_symbol *sym)
2277 {
2278   if (!sym->attr.dummy && !sym->attr.contained
2279         && !(sym->attr.intrinsic
2280               || gfc_is_intrinsic (sym, sym->attr.subroutine, sym->declared_at))
2281         && sym->attr.proc != PROC_ST_FUNCTION
2282         && !sym->attr.proc_pointer
2283         && !sym->attr.use_assoc
2284         && sym->name)
2285     return true;
2286
2287   return false;
2288 }
2289
2290
2291 /* Figure out if a function reference is pure or not.  Also set the name
2292    of the function for a potential error message.  Return nonzero if the
2293    function is PURE, zero if not.  */
2294 static int
2295 pure_stmt_function (gfc_expr *, gfc_symbol *);
2296
2297 static int
2298 pure_function (gfc_expr *e, const char **name)
2299 {
2300   int pure;
2301
2302   *name = NULL;
2303
2304   if (e->symtree != NULL
2305         && e->symtree->n.sym != NULL
2306         && e->symtree->n.sym->attr.proc == PROC_ST_FUNCTION)
2307     return pure_stmt_function (e, e->symtree->n.sym);
2308
2309   if (e->value.function.esym)
2310     {
2311       pure = gfc_pure (e->value.function.esym);
2312       *name = e->value.function.esym->name;
2313     }
2314   else if (e->value.function.isym)
2315     {
2316       pure = e->value.function.isym->pure
2317              || e->value.function.isym->elemental;
2318       *name = e->value.function.isym->name;
2319     }
2320   else
2321     {
2322       /* Implicit functions are not pure.  */
2323       pure = 0;
2324       *name = e->value.function.name;
2325     }
2326
2327   return pure;
2328 }
2329
2330
2331 static bool
2332 impure_stmt_fcn (gfc_expr *e, gfc_symbol *sym,
2333                  int *f ATTRIBUTE_UNUSED)
2334 {
2335   const char *name;
2336
2337   /* Don't bother recursing into other statement functions
2338      since they will be checked individually for purity.  */
2339   if (e->expr_type != EXPR_FUNCTION
2340         || !e->symtree
2341         || e->symtree->n.sym == sym
2342         || e->symtree->n.sym->attr.proc == PROC_ST_FUNCTION)
2343     return false;
2344
2345   return pure_function (e, &name) ? false : true;
2346 }
2347
2348
2349 static int
2350 pure_stmt_function (gfc_expr *e, gfc_symbol *sym)
2351 {
2352   return gfc_traverse_expr (e, sym, impure_stmt_fcn, 0) ? 0 : 1;
2353 }
2354
2355
2356 static gfc_try
2357 is_scalar_expr_ptr (gfc_expr *expr)
2358 {
2359   gfc_try retval = SUCCESS;
2360   gfc_ref *ref;
2361   int start;
2362   int end;
2363
2364   /* See if we have a gfc_ref, which means we have a substring, array
2365      reference, or a component.  */
2366   if (expr->ref != NULL)
2367     {
2368       ref = expr->ref;
2369       while (ref->next != NULL)
2370         ref = ref->next;
2371
2372       switch (ref->type)
2373         {
2374         case REF_SUBSTRING:
2375           if (ref->u.ss.length != NULL 
2376               && ref->u.ss.length->length != NULL
2377               && ref->u.ss.start
2378               && ref->u.ss.start->expr_type == EXPR_CONSTANT 
2379               && ref->u.ss.end
2380               && ref->u.ss.end->expr_type == EXPR_CONSTANT)
2381             {
2382               start = (int) mpz_get_si (ref->u.ss.start->value.integer);
2383               end = (int) mpz_get_si (ref->u.ss.end->value.integer);
2384               if (end - start + 1 != 1)
2385                 retval = FAILURE;
2386             }
2387           else
2388             retval = FAILURE;
2389           break;
2390         case REF_ARRAY:
2391           if (ref->u.ar.type == AR_ELEMENT)
2392             retval = SUCCESS;
2393           else if (ref->u.ar.type == AR_FULL)
2394             {
2395               /* The user can give a full array if the array is of size 1.  */
2396               if (ref->u.ar.as != NULL
2397                   && ref->u.ar.as->rank == 1
2398                   && ref->u.ar.as->type == AS_EXPLICIT
2399                   && ref->u.ar.as->lower[0] != NULL
2400                   && ref->u.ar.as->lower[0]->expr_type == EXPR_CONSTANT
2401                   && ref->u.ar.as->upper[0] != NULL
2402                   && ref->u.ar.as->upper[0]->expr_type == EXPR_CONSTANT)
2403                 {
2404                   /* If we have a character string, we need to check if
2405                      its length is one.  */
2406                   if (expr->ts.type == BT_CHARACTER)
2407                     {
2408                       if (expr->ts.u.cl == NULL
2409                           || expr->ts.u.cl->length == NULL
2410                           || mpz_cmp_si (expr->ts.u.cl->length->value.integer, 1)
2411                           != 0)
2412                         retval = FAILURE;
2413                     }
2414                   else
2415                     {
2416                       /* We have constant lower and upper bounds.  If the
2417                          difference between is 1, it can be considered a
2418                          scalar.  */
2419                       start = (int) mpz_get_si
2420                                 (ref->u.ar.as->lower[0]->value.integer);
2421                       end = (int) mpz_get_si
2422                                 (ref->u.ar.as->upper[0]->value.integer);
2423                       if (end - start + 1 != 1)
2424                         retval = FAILURE;
2425                    }
2426                 }
2427               else
2428                 retval = FAILURE;
2429             }
2430           else
2431             retval = FAILURE;
2432           break;
2433         default:
2434           retval = SUCCESS;
2435           break;
2436         }
2437     }
2438   else if (expr->ts.type == BT_CHARACTER && expr->rank == 0)
2439     {
2440       /* Character string.  Make sure it's of length 1.  */
2441       if (expr->ts.u.cl == NULL
2442           || expr->ts.u.cl->length == NULL
2443           || mpz_cmp_si (expr->ts.u.cl->length->value.integer, 1) != 0)
2444         retval = FAILURE;
2445     }
2446   else if (expr->rank != 0)
2447     retval = FAILURE;
2448
2449   return retval;
2450 }
2451
2452
2453 /* Match one of the iso_c_binding functions (c_associated or c_loc)
2454    and, in the case of c_associated, set the binding label based on
2455    the arguments.  */
2456
2457 static gfc_try
2458 gfc_iso_c_func_interface (gfc_symbol *sym, gfc_actual_arglist *args,
2459                           gfc_symbol **new_sym)
2460 {
2461   char name[GFC_MAX_SYMBOL_LEN + 1];
2462   char binding_label[GFC_MAX_BINDING_LABEL_LEN + 1];
2463   int optional_arg = 0;
2464   gfc_try retval = SUCCESS;
2465   gfc_symbol *args_sym;
2466   gfc_typespec *arg_ts;
2467   symbol_attribute arg_attr;
2468
2469   if (args->expr->expr_type == EXPR_CONSTANT
2470       || args->expr->expr_type == EXPR_OP
2471       || args->expr->expr_type == EXPR_NULL)
2472     {
2473       gfc_error ("Argument to '%s' at %L is not a variable",
2474                  sym->name, &(args->expr->where));
2475       return FAILURE;
2476     }
2477
2478   args_sym = args->expr->symtree->n.sym;
2479
2480   /* The typespec for the actual arg should be that stored in the expr
2481      and not necessarily that of the expr symbol (args_sym), because
2482      the actual expression could be a part-ref of the expr symbol.  */
2483   arg_ts = &(args->expr->ts);
2484   arg_attr = gfc_expr_attr (args->expr);
2485     
2486   if (sym->intmod_sym_id == ISOCBINDING_ASSOCIATED)
2487     {
2488       /* If the user gave two args then they are providing something for
2489          the optional arg (the second cptr).  Therefore, set the name and
2490          binding label to the c_associated for two cptrs.  Otherwise,
2491          set c_associated to expect one cptr.  */
2492       if (args->next)
2493         {
2494           /* two args.  */
2495           sprintf (name, "%s_2", sym->name);
2496           sprintf (binding_label, "%s_2", sym->binding_label);
2497           optional_arg = 1;
2498         }
2499       else
2500         {
2501           /* one arg.  */
2502           sprintf (name, "%s_1", sym->name);
2503           sprintf (binding_label, "%s_1", sym->binding_label);
2504           optional_arg = 0;
2505         }
2506
2507       /* Get a new symbol for the version of c_associated that
2508          will get called.  */
2509       *new_sym = get_iso_c_sym (sym, name, binding_label, optional_arg);
2510     }
2511   else if (sym->intmod_sym_id == ISOCBINDING_LOC
2512            || sym->intmod_sym_id == ISOCBINDING_FUNLOC)
2513     {
2514       sprintf (name, "%s", sym->name);
2515       sprintf (binding_label, "%s", sym->binding_label);
2516
2517       /* Error check the call.  */
2518       if (args->next != NULL)
2519         {
2520           gfc_error_now ("More actual than formal arguments in '%s' "
2521                          "call at %L", name, &(args->expr->where));
2522           retval = FAILURE;
2523         }
2524       else if (sym->intmod_sym_id == ISOCBINDING_LOC)
2525         {
2526           /* Make sure we have either the target or pointer attribute.  */
2527           if (!arg_attr.target && !arg_attr.pointer)
2528             {
2529               gfc_error_now ("Parameter '%s' to '%s' at %L must be either "
2530                              "a TARGET or an associated pointer",
2531                              args_sym->name,
2532                              sym->name, &(args->expr->where));
2533               retval = FAILURE;
2534             }
2535
2536           /* See if we have interoperable type and type param.  */
2537           if (verify_c_interop (arg_ts) == SUCCESS
2538               || gfc_check_any_c_kind (arg_ts) == SUCCESS)
2539             {
2540               if (args_sym->attr.target == 1)
2541                 {
2542                   /* Case 1a, section 15.1.2.5, J3/04-007: variable that
2543                      has the target attribute and is interoperable.  */
2544                   /* Case 1b, section 15.1.2.5, J3/04-007: allocated
2545                      allocatable variable that has the TARGET attribute and
2546                      is not an array of zero size.  */
2547                   if (args_sym->attr.allocatable == 1)
2548                     {
2549                       if (args_sym->attr.dimension != 0 
2550                           && (args_sym->as && args_sym->as->rank == 0))
2551                         {
2552                           gfc_error_now ("Allocatable variable '%s' used as a "
2553                                          "parameter to '%s' at %L must not be "
2554                                          "an array of zero size",
2555                                          args_sym->name, sym->name,
2556                                          &(args->expr->where));
2557                           retval = FAILURE;
2558                         }
2559                     }
2560                   else
2561                     {
2562                       /* A non-allocatable target variable with C
2563                          interoperable type and type parameters must be
2564                          interoperable.  */
2565                       if (args_sym && args_sym->attr.dimension)
2566                         {
2567                           if (args_sym->as->type == AS_ASSUMED_SHAPE)
2568                             {
2569                               gfc_error ("Assumed-shape array '%s' at %L "
2570                                          "cannot be an argument to the "
2571                                          "procedure '%s' because "
2572                                          "it is not C interoperable",
2573                                          args_sym->name,
2574                                          &(args->expr->where), sym->name);
2575                               retval = FAILURE;
2576                             }
2577                           else if (args_sym->as->type == AS_DEFERRED)
2578                             {
2579                               gfc_error ("Deferred-shape array '%s' at %L "
2580                                          "cannot be an argument to the "
2581                                          "procedure '%s' because "
2582                                          "it is not C interoperable",
2583                                          args_sym->name,
2584                                          &(args->expr->where), sym->name);
2585                               retval = FAILURE;
2586                             }
2587                         }
2588                               
2589                       /* Make sure it's not a character string.  Arrays of
2590                          any type should be ok if the variable is of a C
2591                          interoperable type.  */
2592                       if (arg_ts->type == BT_CHARACTER)
2593                         if (arg_ts->u.cl != NULL
2594                             && (arg_ts->u.cl->length == NULL
2595                                 || arg_ts->u.cl->length->expr_type
2596                                    != EXPR_CONSTANT
2597                                 || mpz_cmp_si
2598                                     (arg_ts->u.cl->length->value.integer, 1)
2599                                    != 0)
2600                             && is_scalar_expr_ptr (args->expr) != SUCCESS)
2601                           {
2602                             gfc_error_now ("CHARACTER argument '%s' to '%s' "
2603                                            "at %L must have a length of 1",
2604                                            args_sym->name, sym->name,
2605                                            &(args->expr->where));
2606                             retval = FAILURE;
2607                           }
2608                     }
2609                 }
2610               else if (arg_attr.pointer
2611                        && is_scalar_expr_ptr (args->expr) != SUCCESS)
2612                 {
2613                   /* Case 1c, section 15.1.2.5, J3/04-007: an associated
2614                      scalar pointer.  */
2615                   gfc_error_now ("Argument '%s' to '%s' at %L must be an "
2616                                  "associated scalar POINTER", args_sym->name,
2617                                  sym->name, &(args->expr->where));
2618                   retval = FAILURE;
2619                 }
2620             }
2621           else
2622             {
2623               /* The parameter is not required to be C interoperable.  If it
2624                  is not C interoperable, it must be a nonpolymorphic scalar
2625                  with no length type parameters.  It still must have either
2626                  the pointer or target attribute, and it can be
2627                  allocatable (but must be allocated when c_loc is called).  */
2628               if (args->expr->rank != 0 
2629                   && is_scalar_expr_ptr (args->expr) != SUCCESS)
2630                 {
2631                   gfc_error_now ("Parameter '%s' to '%s' at %L must be a "
2632                                  "scalar", args_sym->name, sym->name,
2633                                  &(args->expr->where));
2634                   retval = FAILURE;
2635                 }
2636               else if (arg_ts->type == BT_CHARACTER 
2637                        && is_scalar_expr_ptr (args->expr) != SUCCESS)
2638                 {
2639                   gfc_error_now ("CHARACTER argument '%s' to '%s' at "
2640                                  "%L must have a length of 1",
2641                                  args_sym->name, sym->name,
2642                                  &(args->expr->where));
2643                   retval = FAILURE;
2644                 }
2645               else if (arg_ts->type == BT_CLASS)
2646                 {
2647                   gfc_error_now ("Parameter '%s' to '%s' at %L must not be "
2648                                  "polymorphic", args_sym->name, sym->name,
2649                                  &(args->expr->where));
2650                   retval = FAILURE;
2651                 }
2652             }
2653         }
2654       else if (sym->intmod_sym_id == ISOCBINDING_FUNLOC)
2655         {
2656           if (args_sym->attr.flavor != FL_PROCEDURE)
2657             {
2658               /* TODO: Update this error message to allow for procedure
2659                  pointers once they are implemented.  */
2660               gfc_error_now ("Parameter '%s' to '%s' at %L must be a "
2661                              "procedure",
2662                              args_sym->name, sym->name,
2663                              &(args->expr->where));
2664               retval = FAILURE;
2665             }
2666           else if (args_sym->attr.is_bind_c != 1)
2667             {
2668               gfc_error_now ("Parameter '%s' to '%s' at %L must be "
2669                              "BIND(C)",
2670                              args_sym->name, sym->name,
2671                              &(args->expr->where));
2672               retval = FAILURE;
2673             }
2674         }
2675       
2676       /* for c_loc/c_funloc, the new symbol is the same as the old one */
2677       *new_sym = sym;
2678     }
2679   else
2680     {
2681       gfc_internal_error ("gfc_iso_c_func_interface(): Unhandled "
2682                           "iso_c_binding function: '%s'!\n", sym->name);
2683     }
2684
2685   return retval;
2686 }
2687
2688
2689 /* Resolve a function call, which means resolving the arguments, then figuring
2690    out which entity the name refers to.  */
2691 /* TODO: Check procedure arguments so that an INTENT(IN) isn't passed
2692    to INTENT(OUT) or INTENT(INOUT).  */
2693
2694 static gfc_try
2695 resolve_function (gfc_expr *expr)
2696 {
2697   gfc_actual_arglist *arg;
2698   gfc_symbol *sym;
2699   const char *name;
2700   gfc_try t;
2701   int temp;
2702   procedure_type p = PROC_INTRINSIC;
2703   bool no_formal_args;
2704
2705   sym = NULL;
2706   if (expr->symtree)
2707     sym = expr->symtree->n.sym;
2708
2709   /* If this is a procedure pointer component, it has already been resolved.  */
2710   if (gfc_is_proc_ptr_comp (expr, NULL))
2711     return SUCCESS;
2712   
2713   if (sym && sym->attr.intrinsic
2714       && resolve_intrinsic (sym, &expr->where) == FAILURE)
2715     return FAILURE;
2716
2717   if (sym && (sym->attr.flavor == FL_VARIABLE || sym->attr.subroutine))
2718     {
2719       gfc_error ("'%s' at %L is not a function", sym->name, &expr->where);
2720       return FAILURE;
2721     }
2722
2723   /* If this ia a deferred TBP with an abstract interface (which may
2724      of course be referenced), expr->value.function.esym will be set.  */
2725   if (sym && sym->attr.abstract && !expr->value.function.esym)
2726     {
2727       gfc_error ("ABSTRACT INTERFACE '%s' must not be referenced at %L",
2728                  sym->name, &expr->where);
2729       return FAILURE;
2730     }
2731
2732   /* Switch off assumed size checking and do this again for certain kinds
2733      of procedure, once the procedure itself is resolved.  */
2734   need_full_assumed_size++;
2735
2736   if (expr->symtree && expr->symtree->n.sym)
2737     p = expr->symtree->n.sym->attr.proc;
2738
2739   if (expr->value.function.isym && expr->value.function.isym->inquiry)
2740     inquiry_argument = true;
2741   no_formal_args = sym && is_external_proc (sym) && sym->formal == NULL;
2742
2743   if (resolve_actual_arglist (expr->value.function.actual,
2744                               p, no_formal_args) == FAILURE)
2745     {
2746       inquiry_argument = false;
2747       return FAILURE;
2748     }
2749
2750   inquiry_argument = false;
2751  
2752   /* Need to setup the call to the correct c_associated, depending on
2753      the number of cptrs to user gives to compare.  */
2754   if (sym && sym->attr.is_iso_c == 1)
2755     {
2756       if (gfc_iso_c_func_interface (sym, expr->value.function.actual, &sym)
2757           == FAILURE)
2758         return FAILURE;
2759       
2760       /* Get the symtree for the new symbol (resolved func).
2761          the old one will be freed later, when it's no longer used.  */
2762       gfc_find_sym_tree (sym->name, sym->ns, 1, &(expr->symtree));
2763     }
2764   
2765   /* Resume assumed_size checking.  */
2766   need_full_assumed_size--;
2767
2768   /* If the procedure is external, check for usage.  */
2769   if (sym && is_external_proc (sym))
2770     resolve_global_procedure (sym, &expr->where,
2771                               &expr->value.function.actual, 0);
2772
2773   if (sym && sym->ts.type == BT_CHARACTER
2774       && sym->ts.u.cl
2775       && sym->ts.u.cl->length == NULL
2776       && !sym->attr.dummy
2777       && expr->value.function.esym == NULL
2778       && !sym->attr.contained)
2779     {
2780       /* Internal procedures are taken care of in resolve_contained_fntype.  */
2781       gfc_error ("Function '%s' is declared CHARACTER(*) and cannot "
2782                  "be used at %L since it is not a dummy argument",
2783                  sym->name, &expr->where);
2784       return FAILURE;
2785     }
2786
2787   /* See if function is already resolved.  */
2788
2789   if (expr->value.function.name != NULL)
2790     {
2791       if (expr->ts.type == BT_UNKNOWN)
2792         expr->ts = sym->ts;
2793       t = SUCCESS;
2794     }
2795   else
2796     {
2797       /* Apply the rules of section 14.1.2.  */
2798
2799       switch (procedure_kind (sym))
2800         {
2801         case PTYPE_GENERIC:
2802           t = resolve_generic_f (expr);
2803           break;
2804
2805         case PTYPE_SPECIFIC:
2806           t = resolve_specific_f (expr);
2807           break;
2808
2809         case PTYPE_UNKNOWN:
2810           t = resolve_unknown_f (expr);
2811           break;
2812
2813         default:
2814           gfc_internal_error ("resolve_function(): bad function type");
2815         }
2816     }
2817
2818   /* If the expression is still a function (it might have simplified),
2819      then we check to see if we are calling an elemental function.  */
2820
2821   if (expr->expr_type != EXPR_FUNCTION)
2822     return t;
2823
2824   temp = need_full_assumed_size;
2825   need_full_assumed_size = 0;
2826
2827   if (resolve_elemental_actual (expr, NULL) == FAILURE)
2828     return FAILURE;
2829
2830   if (omp_workshare_flag
2831       && expr->value.function.esym
2832       && ! gfc_elemental (expr->value.function.esym))
2833     {
2834       gfc_error ("User defined non-ELEMENTAL function '%s' at %L not allowed "
2835                  "in WORKSHARE construct", expr->value.function.esym->name,
2836                  &expr->where);
2837       t = FAILURE;
2838     }
2839
2840 #define GENERIC_ID expr->value.function.isym->id
2841   else if (expr->value.function.actual != NULL
2842            && expr->value.function.isym != NULL
2843            && GENERIC_ID != GFC_ISYM_LBOUND
2844            && GENERIC_ID != GFC_ISYM_LEN
2845            && GENERIC_ID != GFC_ISYM_LOC
2846            && GENERIC_ID != GFC_ISYM_PRESENT)
2847     {
2848       /* Array intrinsics must also have the last upper bound of an
2849          assumed size array argument.  UBOUND and SIZE have to be
2850          excluded from the check if the second argument is anything
2851          than a constant.  */
2852
2853       for (arg = expr->value.function.actual; arg; arg = arg->next)
2854         {
2855           if ((GENERIC_ID == GFC_ISYM_UBOUND || GENERIC_ID == GFC_ISYM_SIZE)
2856               && arg->next != NULL && arg->next->expr)
2857             {
2858               if (arg->next->expr->expr_type != EXPR_CONSTANT)
2859                 break;
2860
2861               if (arg->next->name && strncmp(arg->next->name, "kind", 4) == 0)
2862                 break;
2863
2864               if ((int)mpz_get_si (arg->next->expr->value.integer)
2865                         < arg->expr->rank)
2866                 break;
2867             }
2868
2869           if (arg->expr != NULL
2870               && arg->expr->rank > 0
2871               && resolve_assumed_size_actual (arg->expr))
2872             return FAILURE;
2873         }
2874     }
2875 #undef GENERIC_ID
2876
2877   need_full_assumed_size = temp;
2878   name = NULL;
2879
2880   if (!pure_function (expr, &name) && name)
2881     {
2882       if (forall_flag)
2883         {
2884           gfc_error ("reference to non-PURE function '%s' at %L inside a "
2885                      "FORALL %s", name, &expr->where,
2886                      forall_flag == 2 ? "mask" : "block");
2887           t = FAILURE;
2888         }
2889       else if (gfc_pure (NULL))
2890         {
2891           gfc_error ("Function reference to '%s' at %L is to a non-PURE "
2892                      "procedure within a PURE procedure", name, &expr->where);
2893           t = FAILURE;
2894         }
2895     }
2896
2897   /* Functions without the RECURSIVE attribution are not allowed to
2898    * call themselves.  */
2899   if (expr->value.function.esym && !expr->value.function.esym->attr.recursive)
2900     {
2901       gfc_symbol *esym;
2902       esym = expr->value.function.esym;
2903
2904       if (is_illegal_recursion (esym, gfc_current_ns))
2905       {
2906         if (esym->attr.entry && esym->ns->entries)
2907           gfc_error ("ENTRY '%s' at %L cannot be called recursively, as"
2908                      " function '%s' is not RECURSIVE",
2909                      esym->name, &expr->where, esym->ns->entries->sym->name);
2910         else
2911           gfc_error ("Function '%s' at %L cannot be called recursively, as it"
2912                      " is not RECURSIVE", esym->name, &expr->where);
2913
2914         t = FAILURE;
2915       }
2916     }
2917
2918   /* Character lengths of use associated functions may contains references to
2919      symbols not referenced from the current program unit otherwise.  Make sure
2920      those symbols are marked as referenced.  */
2921
2922   if (expr->ts.type == BT_CHARACTER && expr->value.function.esym
2923       && expr->value.function.esym->attr.use_assoc)
2924     {
2925       gfc_expr_set_symbols_referenced (expr->ts.u.cl->length);
2926     }
2927
2928   if (t == SUCCESS
2929         && !((expr->value.function.esym
2930                 && expr->value.function.esym->attr.elemental)
2931                         ||
2932              (expr->value.function.isym
2933                 && expr->value.function.isym->elemental)))
2934     find_noncopying_intrinsics (expr->value.function.esym,
2935                                 expr->value.function.actual);
2936
2937   /* Make sure that the expression has a typespec that works.  */
2938   if (expr->ts.type == BT_UNKNOWN)
2939     {
2940       if (expr->symtree->n.sym->result
2941             && expr->symtree->n.sym->result->ts.type != BT_UNKNOWN
2942             && !expr->symtree->n.sym->result->attr.proc_pointer)
2943         expr->ts = expr->symtree->n.sym->result->ts;
2944     }
2945
2946   return t;
2947 }
2948
2949
2950 /************* Subroutine resolution *************/
2951
2952 static void
2953 pure_subroutine (gfc_code *c, gfc_symbol *sym)
2954 {
2955   if (gfc_pure (sym))
2956     return;
2957
2958   if (forall_flag)
2959     gfc_error ("Subroutine call to '%s' in FORALL block at %L is not PURE",
2960                sym->name, &c->loc);
2961   else if (gfc_pure (NULL))
2962     gfc_error ("Subroutine call to '%s' at %L is not PURE", sym->name,
2963                &c->loc);
2964 }
2965
2966
2967 static match
2968 resolve_generic_s0 (gfc_code *c, gfc_symbol *sym)
2969 {
2970   gfc_symbol *s;
2971
2972   if (sym->attr.generic)
2973     {
2974       s = gfc_search_interface (sym->generic, 1, &c->ext.actual);
2975       if (s != NULL)
2976         {
2977           c->resolved_sym = s;
2978           pure_subroutine (c, s);
2979           return MATCH_YES;
2980         }
2981
2982       /* TODO: Need to search for elemental references in generic interface.  */
2983     }
2984
2985   if (sym->attr.intrinsic)
2986     return gfc_intrinsic_sub_interface (c, 0);
2987
2988   return MATCH_NO;
2989 }
2990
2991
2992 static gfc_try
2993 resolve_generic_s (gfc_code *c)
2994 {
2995   gfc_symbol *sym;
2996   match m;
2997
2998   sym = c->symtree->n.sym;
2999
3000   for (;;)
3001     {
3002       m = resolve_generic_s0 (c, sym);
3003       if (m == MATCH_YES)
3004         return SUCCESS;
3005       else if (m == MATCH_ERROR)
3006         return FAILURE;
3007
3008 generic:
3009       if (sym->ns->parent == NULL)
3010         break;
3011       gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
3012
3013       if (sym == NULL)
3014         break;
3015       if (!generic_sym (sym))
3016         goto generic;
3017     }
3018
3019   /* Last ditch attempt.  See if the reference is to an intrinsic
3020      that possesses a matching interface.  14.1.2.4  */
3021   sym = c->symtree->n.sym;
3022
3023   if (!gfc_is_intrinsic (sym, 1, c->loc))
3024     {
3025       gfc_error ("There is no specific subroutine for the generic '%s' at %L",
3026                  sym->name, &c->loc);
3027       return FAILURE;
3028     }
3029
3030   m = gfc_intrinsic_sub_interface (c, 0);
3031   if (m == MATCH_YES)
3032     return SUCCESS;
3033   if (m == MATCH_NO)
3034     gfc_error ("Generic subroutine '%s' at %L is not consistent with an "
3035                "intrinsic subroutine interface", sym->name, &c->loc);
3036
3037   return FAILURE;
3038 }
3039
3040
3041 /* Set the name and binding label of the subroutine symbol in the call
3042    expression represented by 'c' to include the type and kind of the
3043    second parameter.  This function is for resolving the appropriate
3044    version of c_f_pointer() and c_f_procpointer().  For example, a
3045    call to c_f_pointer() for a default integer pointer could have a
3046    name of c_f_pointer_i4.  If no second arg exists, which is an error
3047    for these two functions, it defaults to the generic symbol's name
3048    and binding label.  */
3049
3050 static void
3051 set_name_and_label (gfc_code *c, gfc_symbol *sym,
3052                     char *name, char *binding_label)
3053 {
3054   gfc_expr *arg = NULL;
3055   char type;
3056   int kind;
3057
3058   /* The second arg of c_f_pointer and c_f_procpointer determines
3059      the type and kind for the procedure name.  */
3060   arg = c->ext.actual->next->expr;
3061
3062   if (arg != NULL)
3063     {
3064       /* Set up the name to have the given symbol's name,
3065          plus the type and kind.  */
3066       /* a derived type is marked with the type letter 'u' */
3067       if (arg->ts.type == BT_DERIVED)
3068         {
3069           type = 'd';
3070           kind = 0; /* set the kind as 0 for now */
3071         }
3072       else
3073         {
3074           type = gfc_type_letter (arg->ts.type);
3075           kind = arg->ts.kind;
3076         }
3077
3078       if (arg->ts.type == BT_CHARACTER)
3079         /* Kind info for character strings not needed.  */
3080         kind = 0;
3081
3082       sprintf (name, "%s_%c%d", sym->name, type, kind);
3083       /* Set up the binding label as the given symbol's label plus
3084          the type and kind.  */
3085       sprintf (binding_label, "%s_%c%d", sym->binding_label, type, kind);
3086     }
3087   else
3088     {
3089       /* If the second arg is missing, set the name and label as
3090          was, cause it should at least be found, and the missing
3091          arg error will be caught by compare_parameters().  */
3092       sprintf (name, "%s", sym->name);
3093       sprintf (binding_label, "%s", sym->binding_label);
3094     }
3095    
3096   return;
3097 }
3098
3099
3100 /* Resolve a generic version of the iso_c_binding procedure given
3101    (sym) to the specific one based on the type and kind of the
3102    argument(s).  Currently, this function resolves c_f_pointer() and
3103    c_f_procpointer based on the type and kind of the second argument
3104    (FPTR).  Other iso_c_binding procedures aren't specially handled.
3105    Upon successfully exiting, c->resolved_sym will hold the resolved
3106    symbol.  Returns MATCH_ERROR if an error occurred; MATCH_YES
3107    otherwise.  */
3108
3109 match
3110 gfc_iso_c_sub_interface (gfc_code *c, gfc_symbol *sym)
3111 {
3112   gfc_symbol *new_sym;
3113   /* this is fine, since we know the names won't use the max */
3114   char name[GFC_MAX_SYMBOL_LEN + 1];
3115   char binding_label[GFC_MAX_BINDING_LABEL_LEN + 1];
3116   /* default to success; will override if find error */
3117   match m = MATCH_YES;
3118
3119   /* Make sure the actual arguments are in the necessary order (based on the 
3120      formal args) before resolving.  */
3121   gfc_procedure_use (sym, &c->ext.actual, &(c->loc));
3122
3123   if ((sym->intmod_sym_id == ISOCBINDING_F_POINTER) ||
3124       (sym->intmod_sym_id == ISOCBINDING_F_PROCPOINTER))
3125     {
3126       set_name_and_label (c, sym, name, binding_label);
3127       
3128       if (sym->intmod_sym_id == ISOCBINDING_F_POINTER)
3129         {
3130           if (c->ext.actual != NULL && c->ext.actual->next != NULL)
3131             {
3132               /* Make sure we got a third arg if the second arg has non-zero
3133                  rank.  We must also check that the type and rank are
3134                  correct since we short-circuit this check in
3135                  gfc_procedure_use() (called above to sort actual args).  */
3136               if (c->ext.actual->next->expr->rank != 0)
3137                 {
3138                   if(c->ext.actual->next->next == NULL 
3139                      || c->ext.actual->next->next->expr == NULL)
3140                     {
3141                       m = MATCH_ERROR;
3142                       gfc_error ("Missing SHAPE parameter for call to %s "
3143                                  "at %L", sym->name, &(c->loc));
3144                     }
3145                   else if (c->ext.actual->next->next->expr->ts.type
3146                            != BT_INTEGER
3147                            || c->ext.actual->next->next->expr->rank != 1)
3148                     {
3149                       m = MATCH_ERROR;
3150                       gfc_error ("SHAPE parameter for call to %s at %L must "
3151                                  "be a rank 1 INTEGER array", sym->name,
3152                                  &(c->loc));
3153                     }
3154                 }
3155             }
3156         }
3157       
3158       if (m != MATCH_ERROR)
3159         {
3160           /* the 1 means to add the optional arg to formal list */
3161           new_sym = get_iso_c_sym (sym, name, binding_label, 1);
3162          
3163           /* for error reporting, say it's declared where the original was */
3164           new_sym->declared_at = sym->declared_at;
3165         }
3166     }
3167   else
3168     {
3169       /* no differences for c_loc or c_funloc */
3170       new_sym = sym;
3171     }
3172
3173   /* set the resolved symbol */
3174   if (m != MATCH_ERROR)
3175     c->resolved_sym = new_sym;
3176   else
3177     c->resolved_sym = sym;
3178   
3179   return m;
3180 }
3181
3182
3183 /* Resolve a subroutine call known to be specific.  */
3184
3185 static match
3186 resolve_specific_s0 (gfc_code *c, gfc_symbol *sym)
3187 {
3188   match m;
3189
3190   if(sym->attr.is_iso_c)
3191     {
3192       m = gfc_iso_c_sub_interface (c,sym);
3193       return m;
3194     }
3195   
3196   if (sym->attr.external || sym->attr.if_source == IFSRC_IFBODY)
3197     {
3198       if (sym->attr.dummy)
3199         {
3200           sym->attr.proc = PROC_DUMMY;
3201           goto found;
3202         }
3203
3204       sym->attr.proc = PROC_EXTERNAL;
3205       goto found;
3206     }
3207
3208   if (sym->attr.proc == PROC_MODULE || sym->attr.proc == PROC_INTERNAL)
3209     goto found;
3210
3211   if (sym->attr.intrinsic)
3212     {
3213       m = gfc_intrinsic_sub_interface (c, 1);
3214       if (m == MATCH_YES)
3215         return MATCH_YES;
3216       if (m == MATCH_NO)
3217         gfc_error ("Subroutine '%s' at %L is INTRINSIC but is not compatible "
3218                    "with an intrinsic", sym->name, &c->loc);
3219
3220       return MATCH_ERROR;
3221     }
3222
3223   return MATCH_NO;
3224
3225 found:
3226   gfc_procedure_use (sym, &c->ext.actual, &c->loc);
3227
3228   c->resolved_sym = sym;
3229   pure_subroutine (c, sym);
3230
3231   return MATCH_YES;
3232 }
3233
3234
3235 static gfc_try
3236 resolve_specific_s (gfc_code *c)
3237 {
3238   gfc_symbol *sym;
3239   match m;
3240
3241   sym = c->symtree->n.sym;
3242
3243   for (;;)
3244     {
3245       m = resolve_specific_s0 (c, sym);
3246       if (m == MATCH_YES)
3247         return SUCCESS;
3248       if (m == MATCH_ERROR)
3249         return FAILURE;
3250
3251       if (sym->ns->parent == NULL)
3252         break;
3253
3254       gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
3255
3256       if (sym == NULL)
3257         break;
3258     }
3259
3260   sym = c->symtree->n.sym;
3261   gfc_error ("Unable to resolve the specific subroutine '%s' at %L",
3262              sym->name, &c->loc);
3263
3264   return FAILURE;
3265 }
3266
3267
3268 /* Resolve a subroutine call not known to be generic nor specific.  */
3269
3270 static gfc_try
3271 resolve_unknown_s (gfc_code *c)
3272 {
3273   gfc_symbol *sym;
3274
3275   sym = c->symtree->n.sym;
3276
3277   if (sym->attr.dummy)
3278     {
3279       sym->attr.proc = PROC_DUMMY;
3280       goto found;
3281     }
3282
3283   /* See if we have an intrinsic function reference.  */
3284
3285   if (gfc_is_intrinsic (sym, 1, c->loc))
3286     {
3287       if (gfc_intrinsic_sub_interface (c, 1) == MATCH_YES)
3288         return SUCCESS;
3289       return FAILURE;
3290     }
3291
3292   /* The reference is to an external name.  */
3293
3294 found:
3295   gfc_procedure_use (sym, &c->ext.actual, &c->loc);
3296
3297   c->resolved_sym = sym;
3298
3299   pure_subroutine (c, sym);
3300
3301   return SUCCESS;
3302 }
3303
3304
3305 /* Resolve a subroutine call.  Although it was tempting to use the same code
3306    for functions, subroutines and functions are stored differently and this
3307    makes things awkward.  */
3308
3309 static gfc_try
3310 resolve_call (gfc_code *c)
3311 {
3312   gfc_try t;
3313   procedure_type ptype = PROC_INTRINSIC;
3314   gfc_symbol *csym, *sym;
3315   bool no_formal_args;
3316
3317   csym = c->symtree ? c->symtree->n.sym : NULL;
3318
3319   if (csym && csym->ts.type != BT_UNKNOWN)
3320     {
3321       gfc_error ("'%s' at %L has a type, which is not consistent with "
3322                  "the CALL at %L", csym->name, &csym->declared_at, &c->loc);
3323       return FAILURE;
3324     }
3325
3326   if (csym && gfc_current_ns->parent && csym->ns != gfc_current_ns)
3327     {
3328       gfc_symtree *st;
3329       gfc_find_sym_tree (csym->name, gfc_current_ns, 1, &st);
3330       sym = st ? st->n.sym : NULL;
3331       if (sym && csym != sym
3332               && sym->ns == gfc_current_ns
3333               && sym->attr.flavor == FL_PROCEDURE
3334               && sym->attr.contained)
3335         {
3336           sym->refs++;
3337           if (csym->attr.generic)
3338             c->symtree->n.sym = sym;
3339           else
3340             c->symtree = st;
3341           csym = c->symtree->n.sym;
3342         }
3343     }
3344
3345   /* If this ia a deferred TBP with an abstract interface
3346      (which may of course be referenced), c->expr1 will be set.  */
3347   if (csym && csym->attr.abstract && !c->expr1)
3348     {
3349       gfc_error ("ABSTRACT INTERFACE '%s' must not be referenced at %L",
3350                  csym->name, &c->loc);
3351       return FAILURE;
3352     }
3353
3354   /* Subroutines without the RECURSIVE attribution are not allowed to
3355    * call themselves.  */
3356   if (csym && is_illegal_recursion (csym, gfc_current_ns))
3357     {
3358       if (csym->attr.entry && csym->ns->entries)
3359         gfc_error ("ENTRY '%s' at %L cannot be called recursively, as"
3360                    " subroutine '%s' is not RECURSIVE",