OSDN Git Service

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