OSDN Git Service

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