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