OSDN Git Service

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