OSDN Git Service

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