OSDN Git Service

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