OSDN Git Service

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