OSDN Git Service

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