OSDN Git Service

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