OSDN Git Service

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