OSDN Git Service

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