OSDN Git Service

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