OSDN Git Service

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