OSDN Git Service

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