OSDN Git Service

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