OSDN Git Service

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