OSDN Git Service

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