OSDN Git Service

2007-07-21 Christopher D. Rickett <crickett@lanl.gov>
[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
2286       if (arg->ts.type == BT_CHARACTER)
2287         /* Kind info for character strings not needed.  */
2288         kind = 0;
2289
2290       sprintf (name, "%s_%c%d", sym->name, type, kind);
2291       /* Set up the binding label as the given symbol's label plus
2292          the type and kind.  */
2293       sprintf (binding_label, "%s_%c%d", sym->binding_label, type, kind);
2294     }
2295   else
2296     {
2297       /* If the second arg is missing, set the name and label as
2298          was, cause it should at least be found, and the missing
2299          arg error will be caught by compare_parameters().  */
2300       sprintf (name, "%s", sym->name);
2301       sprintf (binding_label, "%s", sym->binding_label);
2302     }
2303    
2304   return;
2305 }
2306
2307
2308 /* Resolve a generic version of the iso_c_binding procedure given
2309    (sym) to the specific one based on the type and kind of the
2310    argument(s).  Currently, this function resolves c_f_pointer() and
2311    c_f_procpointer based on the type and kind of the second argument
2312    (FPTR).  Other iso_c_binding procedures aren't specially handled.
2313    Upon successfully exiting, c->resolved_sym will hold the resolved
2314    symbol.  Returns MATCH_ERROR if an error occurred; MATCH_YES
2315    otherwise.  */
2316
2317 match
2318 gfc_iso_c_sub_interface (gfc_code *c, gfc_symbol *sym)
2319 {
2320   gfc_symbol *new_sym;
2321   /* this is fine, since we know the names won't use the max */
2322   char name[GFC_MAX_SYMBOL_LEN + 1];
2323   char binding_label[GFC_MAX_BINDING_LABEL_LEN + 1];
2324   /* default to success; will override if find error */
2325   match m = MATCH_YES;
2326   gfc_symbol *tmp_sym;
2327
2328   if ((sym->intmod_sym_id == ISOCBINDING_F_POINTER) ||
2329       (sym->intmod_sym_id == ISOCBINDING_F_PROCPOINTER))
2330     {
2331       set_name_and_label (c, sym, name, binding_label);
2332       
2333       if (sym->intmod_sym_id == ISOCBINDING_F_POINTER)
2334         {
2335           if (c->ext.actual != NULL && c->ext.actual->next != NULL)
2336             {
2337               /* Make sure we got a third arg.  The type/rank of it will
2338                  be checked later if it's there (gfc_procedure_use()).  */
2339               if (c->ext.actual->next->expr->rank != 0 &&
2340                   c->ext.actual->next->next == NULL)
2341                 {
2342                   m = MATCH_ERROR;
2343                   gfc_error ("Missing SHAPE parameter for call to %s "
2344                              "at %L", sym->name, &(c->loc));
2345                 }
2346               /* Make sure the param is a POINTER.  No need to make sure
2347                  it does not have INTENT(IN) since it is a POINTER.  */
2348               tmp_sym = c->ext.actual->next->expr->symtree->n.sym;
2349               if (tmp_sym != NULL && tmp_sym->attr.pointer != 1)
2350                 {
2351                   gfc_error ("Argument '%s' to '%s' at %L "
2352                              "must have the POINTER attribute",
2353                              tmp_sym->name, sym->name, &(c->loc));
2354                   m = MATCH_ERROR;
2355                 }
2356             }
2357         }
2358       
2359       if (m != MATCH_ERROR)
2360         {
2361           /* the 1 means to add the optional arg to formal list */
2362           new_sym = get_iso_c_sym (sym, name, binding_label, 1);
2363          
2364           /* Set the kind for the SHAPE array to that of the actual
2365              (if given).  */
2366           if (c->ext.actual != NULL && c->ext.actual->next != NULL
2367               && c->ext.actual->next->expr->rank != 0)
2368             new_sym->formal->next->next->sym->ts.kind =
2369               c->ext.actual->next->next->expr->ts.kind;
2370          
2371           /* for error reporting, say it's declared where the original was */
2372           new_sym->declared_at = sym->declared_at;
2373         }
2374     }
2375   else if (sym->intmod_sym_id == ISOCBINDING_ASSOCIATED)
2376     {
2377       /* TODO: Figure out if this is even reacable; this part of the
2378          conditional may not be necessary.  */
2379       int num_args = 0;
2380       if (c->ext.actual->next == NULL)
2381         {
2382           /* The user did not give two args, so resolve to the version
2383              of c_associated expecting one arg.  */
2384           num_args = 1;
2385           /* get rid of the second arg */
2386           /* TODO!! Should free up the memory here!  */
2387           sym->formal->next = NULL;
2388         }
2389       else
2390         {
2391           num_args = 2;
2392         }
2393
2394       new_sym = sym;
2395       sprintf (name, "%s_%d", sym->name, num_args);
2396       sprintf (binding_label, "%s_%d", sym->binding_label, num_args);
2397       sym->name = gfc_get_string (name);
2398       strcpy (sym->binding_label, binding_label);
2399     }
2400   else
2401     {
2402       /* no differences for c_loc or c_funloc */
2403       new_sym = sym;
2404     }
2405
2406   /* set the resolved symbol */
2407   if (m != MATCH_ERROR)
2408     {
2409       gfc_procedure_use (new_sym, &c->ext.actual, &c->loc);
2410       c->resolved_sym = new_sym;
2411     }
2412   else
2413     c->resolved_sym = sym;
2414   
2415   return m;
2416 }
2417
2418
2419 /* Resolve a subroutine call known to be specific.  */
2420
2421 static match
2422 resolve_specific_s0 (gfc_code *c, gfc_symbol *sym)
2423 {
2424   match m;
2425
2426   if(sym->attr.is_iso_c)
2427     {
2428       m = gfc_iso_c_sub_interface (c,sym);
2429       return m;
2430     }
2431   
2432   if (sym->attr.external || sym->attr.if_source == IFSRC_IFBODY)
2433     {
2434       if (sym->attr.dummy)
2435         {
2436           sym->attr.proc = PROC_DUMMY;
2437           goto found;
2438         }
2439
2440       sym->attr.proc = PROC_EXTERNAL;
2441       goto found;
2442     }
2443
2444   if (sym->attr.proc == PROC_MODULE || sym->attr.proc == PROC_INTERNAL)
2445     goto found;
2446
2447   if (sym->attr.intrinsic)
2448     {
2449       m = gfc_intrinsic_sub_interface (c, 1);
2450       if (m == MATCH_YES)
2451         return MATCH_YES;
2452       if (m == MATCH_NO)
2453         gfc_error ("Subroutine '%s' at %L is INTRINSIC but is not compatible "
2454                    "with an intrinsic", sym->name, &c->loc);
2455
2456       return MATCH_ERROR;
2457     }
2458
2459   return MATCH_NO;
2460
2461 found:
2462   gfc_procedure_use (sym, &c->ext.actual, &c->loc);
2463
2464   c->resolved_sym = sym;
2465   pure_subroutine (c, sym);
2466
2467   return MATCH_YES;
2468 }
2469
2470
2471 static try
2472 resolve_specific_s (gfc_code *c)
2473 {
2474   gfc_symbol *sym;
2475   match m;
2476
2477   sym = c->symtree->n.sym;
2478
2479   for (;;)
2480     {
2481       m = resolve_specific_s0 (c, sym);
2482       if (m == MATCH_YES)
2483         return SUCCESS;
2484       if (m == MATCH_ERROR)
2485         return FAILURE;
2486
2487       if (sym->ns->parent == NULL)
2488         break;
2489
2490       gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
2491
2492       if (sym == NULL)
2493         break;
2494     }
2495
2496   sym = c->symtree->n.sym;
2497   gfc_error ("Unable to resolve the specific subroutine '%s' at %L",
2498              sym->name, &c->loc);
2499
2500   return FAILURE;
2501 }
2502
2503
2504 /* Resolve a subroutine call not known to be generic nor specific.  */
2505
2506 static try
2507 resolve_unknown_s (gfc_code *c)
2508 {
2509   gfc_symbol *sym;
2510
2511   sym = c->symtree->n.sym;
2512
2513   if (sym->attr.dummy)
2514     {
2515       sym->attr.proc = PROC_DUMMY;
2516       goto found;
2517     }
2518
2519   /* See if we have an intrinsic function reference.  */
2520
2521   if (gfc_intrinsic_name (sym->name, 1))
2522     {
2523       if (gfc_intrinsic_sub_interface (c, 1) == MATCH_YES)
2524         return SUCCESS;
2525       return FAILURE;
2526     }
2527
2528   /* The reference is to an external name.  */
2529
2530 found:
2531   gfc_procedure_use (sym, &c->ext.actual, &c->loc);
2532
2533   c->resolved_sym = sym;
2534
2535   pure_subroutine (c, sym);
2536
2537   return SUCCESS;
2538 }
2539
2540
2541 /* Resolve a subroutine call.  Although it was tempting to use the same code
2542    for functions, subroutines and functions are stored differently and this
2543    makes things awkward.  */
2544
2545 static try
2546 resolve_call (gfc_code *c)
2547 {
2548   try t;
2549   procedure_type ptype = PROC_INTRINSIC;
2550
2551   if (c->symtree && c->symtree->n.sym
2552       && c->symtree->n.sym->ts.type != BT_UNKNOWN)
2553     {
2554       gfc_error ("'%s' at %L has a type, which is not consistent with "
2555                  "the CALL at %L", c->symtree->n.sym->name,
2556                  &c->symtree->n.sym->declared_at, &c->loc);
2557       return FAILURE;
2558     }
2559
2560   /* If external, check for usage.  */
2561   if (c->symtree && is_external_proc (c->symtree->n.sym))
2562     resolve_global_procedure (c->symtree->n.sym, &c->loc, 1);
2563
2564   /* Subroutines without the RECURSIVE attribution are not allowed to
2565    * call themselves.  */
2566   if (c->symtree && c->symtree->n.sym && !c->symtree->n.sym->attr.recursive)
2567     {
2568       gfc_symbol *csym, *proc;
2569       csym = c->symtree->n.sym;
2570       proc = gfc_current_ns->proc_name;
2571       if (csym == proc)
2572       {
2573         gfc_error ("SUBROUTINE '%s' at %L cannot call itself, as it is not "
2574                    "RECURSIVE", csym->name, &c->loc);
2575         t = FAILURE;
2576       }
2577
2578       if (csym->attr.entry && csym->ns->entries && proc->ns->entries
2579           && csym->ns->entries->sym == proc->ns->entries->sym)
2580       {
2581         gfc_error ("Call to ENTRY '%s' at %L is recursive, but subroutine "
2582                    "'%s' is not declared as RECURSIVE",
2583                    csym->name, &c->loc, csym->ns->entries->sym->name);
2584         t = FAILURE;
2585       }
2586     }
2587
2588   /* Switch off assumed size checking and do this again for certain kinds
2589      of procedure, once the procedure itself is resolved.  */
2590   need_full_assumed_size++;
2591
2592   if (c->symtree && c->symtree->n.sym)
2593     ptype = c->symtree->n.sym->attr.proc;
2594
2595   if (resolve_actual_arglist (c->ext.actual, ptype) == FAILURE)
2596     return FAILURE;
2597
2598   /* Resume assumed_size checking.  */
2599   need_full_assumed_size--;
2600
2601   t = SUCCESS;
2602   if (c->resolved_sym == NULL)
2603     switch (procedure_kind (c->symtree->n.sym))
2604       {
2605       case PTYPE_GENERIC:
2606         t = resolve_generic_s (c);
2607         break;
2608
2609       case PTYPE_SPECIFIC:
2610         t = resolve_specific_s (c);
2611         break;
2612
2613       case PTYPE_UNKNOWN:
2614         t = resolve_unknown_s (c);
2615         break;
2616
2617       default:
2618         gfc_internal_error ("resolve_subroutine(): bad function type");
2619       }
2620
2621   /* Some checks of elemental subroutine actual arguments.  */
2622   if (resolve_elemental_actual (NULL, c) == FAILURE)
2623     return FAILURE;
2624
2625   if (t == SUCCESS)
2626     find_noncopying_intrinsics (c->resolved_sym, c->ext.actual);
2627   return t;
2628 }
2629
2630
2631 /* Compare the shapes of two arrays that have non-NULL shapes.  If both
2632    op1->shape and op2->shape are non-NULL return SUCCESS if their shapes
2633    match.  If both op1->shape and op2->shape are non-NULL return FAILURE
2634    if their shapes do not match.  If either op1->shape or op2->shape is
2635    NULL, return SUCCESS.  */
2636
2637 static try
2638 compare_shapes (gfc_expr *op1, gfc_expr *op2)
2639 {
2640   try t;
2641   int i;
2642
2643   t = SUCCESS;
2644
2645   if (op1->shape != NULL && op2->shape != NULL)
2646     {
2647       for (i = 0; i < op1->rank; i++)
2648         {
2649           if (mpz_cmp (op1->shape[i], op2->shape[i]) != 0)
2650            {
2651              gfc_error ("Shapes for operands at %L and %L are not conformable",
2652                          &op1->where, &op2->where);
2653              t = FAILURE;
2654              break;
2655            }
2656         }
2657     }
2658
2659   return t;
2660 }
2661
2662
2663 /* Resolve an operator expression node.  This can involve replacing the
2664    operation with a user defined function call.  */
2665
2666 static try
2667 resolve_operator (gfc_expr *e)
2668 {
2669   gfc_expr *op1, *op2;
2670   char msg[200];
2671   bool dual_locus_error;
2672   try t;
2673
2674   /* Resolve all subnodes-- give them types.  */
2675
2676   switch (e->value.op.operator)
2677     {
2678     default:
2679       if (gfc_resolve_expr (e->value.op.op2) == FAILURE)
2680         return FAILURE;
2681
2682     /* Fall through...  */
2683
2684     case INTRINSIC_NOT:
2685     case INTRINSIC_UPLUS:
2686     case INTRINSIC_UMINUS:
2687     case INTRINSIC_PARENTHESES:
2688       if (gfc_resolve_expr (e->value.op.op1) == FAILURE)
2689         return FAILURE;
2690       break;
2691     }
2692
2693   /* Typecheck the new node.  */
2694
2695   op1 = e->value.op.op1;
2696   op2 = e->value.op.op2;
2697   dual_locus_error = false;
2698
2699   if ((op1 && op1->expr_type == EXPR_NULL)
2700       || (op2 && op2->expr_type == EXPR_NULL))
2701     {
2702       sprintf (msg, _("Invalid context for NULL() pointer at %%L"));
2703       goto bad_op;
2704     }
2705
2706   switch (e->value.op.operator)
2707     {
2708     case INTRINSIC_UPLUS:
2709     case INTRINSIC_UMINUS:
2710       if (op1->ts.type == BT_INTEGER
2711           || op1->ts.type == BT_REAL
2712           || op1->ts.type == BT_COMPLEX)
2713         {
2714           e->ts = op1->ts;
2715           break;
2716         }
2717
2718       sprintf (msg, _("Operand of unary numeric operator '%s' at %%L is %s"),
2719                gfc_op2string (e->value.op.operator), gfc_typename (&e->ts));
2720       goto bad_op;
2721
2722     case INTRINSIC_PLUS:
2723     case INTRINSIC_MINUS:
2724     case INTRINSIC_TIMES:
2725     case INTRINSIC_DIVIDE:
2726     case INTRINSIC_POWER:
2727       if (gfc_numeric_ts (&op1->ts) && gfc_numeric_ts (&op2->ts))
2728         {
2729           gfc_type_convert_binary (e);
2730           break;
2731         }
2732
2733       sprintf (msg,
2734                _("Operands of binary numeric operator '%s' at %%L are %s/%s"),
2735                gfc_op2string (e->value.op.operator), gfc_typename (&op1->ts),
2736                gfc_typename (&op2->ts));
2737       goto bad_op;
2738
2739     case INTRINSIC_CONCAT:
2740       if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER)
2741         {
2742           e->ts.type = BT_CHARACTER;
2743           e->ts.kind = op1->ts.kind;
2744           break;
2745         }
2746
2747       sprintf (msg,
2748                _("Operands of string concatenation operator at %%L are %s/%s"),
2749                gfc_typename (&op1->ts), gfc_typename (&op2->ts));
2750       goto bad_op;
2751
2752     case INTRINSIC_AND:
2753     case INTRINSIC_OR:
2754     case INTRINSIC_EQV:
2755     case INTRINSIC_NEQV:
2756       if (op1->ts.type == BT_LOGICAL && op2->ts.type == BT_LOGICAL)
2757         {
2758           e->ts.type = BT_LOGICAL;
2759           e->ts.kind = gfc_kind_max (op1, op2);
2760           if (op1->ts.kind < e->ts.kind)
2761             gfc_convert_type (op1, &e->ts, 2);
2762           else if (op2->ts.kind < e->ts.kind)
2763             gfc_convert_type (op2, &e->ts, 2);
2764           break;
2765         }
2766
2767       sprintf (msg, _("Operands of logical operator '%s' at %%L are %s/%s"),
2768                gfc_op2string (e->value.op.operator), gfc_typename (&op1->ts),
2769                gfc_typename (&op2->ts));
2770
2771       goto bad_op;
2772
2773     case INTRINSIC_NOT:
2774       if (op1->ts.type == BT_LOGICAL)
2775         {
2776           e->ts.type = BT_LOGICAL;
2777           e->ts.kind = op1->ts.kind;
2778           break;
2779         }
2780
2781       sprintf (msg, _("Operand of .not. operator at %%L is %s"),
2782                gfc_typename (&op1->ts));
2783       goto bad_op;
2784
2785     case INTRINSIC_GT:
2786     case INTRINSIC_GT_OS:
2787     case INTRINSIC_GE:
2788     case INTRINSIC_GE_OS:
2789     case INTRINSIC_LT:
2790     case INTRINSIC_LT_OS:
2791     case INTRINSIC_LE:
2792     case INTRINSIC_LE_OS:
2793       if (op1->ts.type == BT_COMPLEX || op2->ts.type == BT_COMPLEX)
2794         {
2795           strcpy (msg, _("COMPLEX quantities cannot be compared at %L"));
2796           goto bad_op;
2797         }
2798
2799       /* Fall through...  */
2800
2801     case INTRINSIC_EQ:
2802     case INTRINSIC_EQ_OS:
2803     case INTRINSIC_NE:
2804     case INTRINSIC_NE_OS:
2805       if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER)
2806         {
2807           e->ts.type = BT_LOGICAL;
2808           e->ts.kind = gfc_default_logical_kind;
2809           break;
2810         }
2811
2812       if (gfc_numeric_ts (&op1->ts) && gfc_numeric_ts (&op2->ts))
2813         {
2814           gfc_type_convert_binary (e);
2815
2816           e->ts.type = BT_LOGICAL;
2817           e->ts.kind = gfc_default_logical_kind;
2818           break;
2819         }
2820
2821       if (op1->ts.type == BT_LOGICAL && op2->ts.type == BT_LOGICAL)
2822         sprintf (msg,
2823                  _("Logicals at %%L must be compared with %s instead of %s"),
2824                  e->value.op.operator == INTRINSIC_EQ ? ".eqv." : ".neqv.",
2825                  gfc_op2string (e->value.op.operator));
2826       else
2827         sprintf (msg,
2828                  _("Operands of comparison operator '%s' at %%L are %s/%s"),
2829                  gfc_op2string (e->value.op.operator), gfc_typename (&op1->ts),
2830                  gfc_typename (&op2->ts));
2831
2832       goto bad_op;
2833
2834     case INTRINSIC_USER:
2835       if (e->value.op.uop->operator == NULL)
2836         sprintf (msg, _("Unknown operator '%s' at %%L"), e->value.op.uop->name);
2837       else if (op2 == NULL)
2838         sprintf (msg, _("Operand of user operator '%s' at %%L is %s"),
2839                  e->value.op.uop->name, gfc_typename (&op1->ts));
2840       else
2841         sprintf (msg, _("Operands of user operator '%s' at %%L are %s/%s"),
2842                  e->value.op.uop->name, gfc_typename (&op1->ts),
2843                  gfc_typename (&op2->ts));
2844
2845       goto bad_op;
2846
2847     case INTRINSIC_PARENTHESES:
2848       break;
2849
2850     default:
2851       gfc_internal_error ("resolve_operator(): Bad intrinsic");
2852     }
2853
2854   /* Deal with arrayness of an operand through an operator.  */
2855
2856   t = SUCCESS;
2857
2858   switch (e->value.op.operator)
2859     {
2860     case INTRINSIC_PLUS:
2861     case INTRINSIC_MINUS:
2862     case INTRINSIC_TIMES:
2863     case INTRINSIC_DIVIDE:
2864     case INTRINSIC_POWER:
2865     case INTRINSIC_CONCAT:
2866     case INTRINSIC_AND:
2867     case INTRINSIC_OR:
2868     case INTRINSIC_EQV:
2869     case INTRINSIC_NEQV:
2870     case INTRINSIC_EQ:
2871     case INTRINSIC_EQ_OS:
2872     case INTRINSIC_NE:
2873     case INTRINSIC_NE_OS:
2874     case INTRINSIC_GT:
2875     case INTRINSIC_GT_OS:
2876     case INTRINSIC_GE:
2877     case INTRINSIC_GE_OS:
2878     case INTRINSIC_LT:
2879     case INTRINSIC_LT_OS:
2880     case INTRINSIC_LE:
2881     case INTRINSIC_LE_OS:
2882
2883       if (op1->rank == 0 && op2->rank == 0)
2884         e->rank = 0;
2885
2886       if (op1->rank == 0 && op2->rank != 0)
2887         {
2888           e->rank = op2->rank;
2889
2890           if (e->shape == NULL)
2891             e->shape = gfc_copy_shape (op2->shape, op2->rank);
2892         }
2893
2894       if (op1->rank != 0 && op2->rank == 0)
2895         {
2896           e->rank = op1->rank;
2897
2898           if (e->shape == NULL)
2899             e->shape = gfc_copy_shape (op1->shape, op1->rank);
2900         }
2901
2902       if (op1->rank != 0 && op2->rank != 0)
2903         {
2904           if (op1->rank == op2->rank)
2905             {
2906               e->rank = op1->rank;
2907               if (e->shape == NULL)
2908                 {
2909                   t = compare_shapes(op1, op2);
2910                   if (t == FAILURE)
2911                     e->shape = NULL;
2912                   else
2913                 e->shape = gfc_copy_shape (op1->shape, op1->rank);
2914                 }
2915             }
2916           else
2917             {
2918               /* Allow higher level expressions to work.  */
2919               e->rank = 0;
2920
2921               /* Try user-defined operators, and otherwise throw an error.  */
2922               dual_locus_error = true;
2923               sprintf (msg,
2924                        _("Inconsistent ranks for operator at %%L and %%L"));
2925               goto bad_op;
2926             }
2927         }
2928
2929       break;
2930
2931     case INTRINSIC_NOT:
2932     case INTRINSIC_UPLUS:
2933     case INTRINSIC_UMINUS:
2934     case INTRINSIC_PARENTHESES:
2935       e->rank = op1->rank;
2936
2937       if (e->shape == NULL)
2938         e->shape = gfc_copy_shape (op1->shape, op1->rank);
2939
2940       /* Simply copy arrayness attribute */
2941       break;
2942
2943     default:
2944       break;
2945     }
2946
2947   /* Attempt to simplify the expression.  */
2948   if (t == SUCCESS)
2949     {
2950       t = gfc_simplify_expr (e, 0);
2951       /* Some calls do not succeed in simplification and return FAILURE
2952          even though there is no error; eg. variable references to
2953          PARAMETER arrays.  */
2954       if (!gfc_is_constant_expr (e))
2955         t = SUCCESS;
2956     }
2957   return t;
2958
2959 bad_op:
2960
2961   if (gfc_extend_expr (e) == SUCCESS)
2962     return SUCCESS;
2963
2964   if (dual_locus_error)
2965     gfc_error (msg, &op1->where, &op2->where);
2966   else
2967     gfc_error (msg, &e->where);
2968
2969   return FAILURE;
2970 }
2971
2972
2973 /************** Array resolution subroutines **************/
2974
2975 typedef enum
2976 { CMP_LT, CMP_EQ, CMP_GT, CMP_UNKNOWN }
2977 comparison;
2978
2979 /* Compare two integer expressions.  */
2980
2981 static comparison
2982 compare_bound (gfc_expr *a, gfc_expr *b)
2983 {
2984   int i;
2985
2986   if (a == NULL || a->expr_type != EXPR_CONSTANT
2987       || b == NULL || b->expr_type != EXPR_CONSTANT)
2988     return CMP_UNKNOWN;
2989
2990   if (a->ts.type != BT_INTEGER || b->ts.type != BT_INTEGER)
2991     gfc_internal_error ("compare_bound(): Bad expression");
2992
2993   i = mpz_cmp (a->value.integer, b->value.integer);
2994
2995   if (i < 0)
2996     return CMP_LT;
2997   if (i > 0)
2998     return CMP_GT;
2999   return CMP_EQ;
3000 }
3001
3002
3003 /* Compare an integer expression with an integer.  */
3004
3005 static comparison
3006 compare_bound_int (gfc_expr *a, int b)
3007 {
3008   int i;
3009
3010   if (a == NULL || a->expr_type != EXPR_CONSTANT)
3011     return CMP_UNKNOWN;
3012
3013   if (a->ts.type != BT_INTEGER)
3014     gfc_internal_error ("compare_bound_int(): Bad expression");
3015
3016   i = mpz_cmp_si (a->value.integer, b);
3017
3018   if (i < 0)
3019     return CMP_LT;
3020   if (i > 0)
3021     return CMP_GT;
3022   return CMP_EQ;
3023 }
3024
3025
3026 /* Compare an integer expression with a mpz_t.  */
3027
3028 static comparison
3029 compare_bound_mpz_t (gfc_expr *a, mpz_t b)
3030 {
3031   int i;
3032
3033   if (a == NULL || a->expr_type != EXPR_CONSTANT)
3034     return CMP_UNKNOWN;
3035
3036   if (a->ts.type != BT_INTEGER)
3037     gfc_internal_error ("compare_bound_int(): Bad expression");
3038
3039   i = mpz_cmp (a->value.integer, b);
3040
3041   if (i < 0)
3042     return CMP_LT;
3043   if (i > 0)
3044     return CMP_GT;
3045   return CMP_EQ;
3046 }
3047
3048
3049 /* Compute the last value of a sequence given by a triplet.  
3050    Return 0 if it wasn't able to compute the last value, or if the
3051    sequence if empty, and 1 otherwise.  */
3052
3053 static int
3054 compute_last_value_for_triplet (gfc_expr *start, gfc_expr *end,
3055                                 gfc_expr *stride, mpz_t last)
3056 {
3057   mpz_t rem;
3058
3059   if (start == NULL || start->expr_type != EXPR_CONSTANT
3060       || end == NULL || end->expr_type != EXPR_CONSTANT
3061       || (stride != NULL && stride->expr_type != EXPR_CONSTANT))
3062     return 0;
3063
3064   if (start->ts.type != BT_INTEGER || end->ts.type != BT_INTEGER
3065       || (stride != NULL && stride->ts.type != BT_INTEGER))
3066     return 0;
3067
3068   if (stride == NULL || compare_bound_int(stride, 1) == CMP_EQ)
3069     {
3070       if (compare_bound (start, end) == CMP_GT)
3071         return 0;
3072       mpz_set (last, end->value.integer);
3073       return 1;
3074     }
3075
3076   if (compare_bound_int (stride, 0) == CMP_GT)
3077     {
3078       /* Stride is positive */
3079       if (mpz_cmp (start->value.integer, end->value.integer) > 0)
3080         return 0;
3081     }
3082   else
3083     {
3084       /* Stride is negative */
3085       if (mpz_cmp (start->value.integer, end->value.integer) < 0)
3086         return 0;
3087     }
3088
3089   mpz_init (rem);
3090   mpz_sub (rem, end->value.integer, start->value.integer);
3091   mpz_tdiv_r (rem, rem, stride->value.integer);
3092   mpz_sub (last, end->value.integer, rem);
3093   mpz_clear (rem);
3094
3095   return 1;
3096 }
3097
3098
3099 /* Compare a single dimension of an array reference to the array
3100    specification.  */
3101
3102 static try
3103 check_dimension (int i, gfc_array_ref *ar, gfc_array_spec *as)
3104 {
3105   mpz_t last_value;
3106
3107 /* Given start, end and stride values, calculate the minimum and
3108    maximum referenced indexes.  */
3109
3110   switch (ar->type)
3111     {
3112     case AR_FULL:
3113       break;
3114
3115     case AR_ELEMENT:
3116       if (compare_bound (ar->start[i], as->lower[i]) == CMP_LT)
3117         goto bound;
3118       if (compare_bound (ar->start[i], as->upper[i]) == CMP_GT)
3119         goto bound;
3120
3121       break;
3122
3123     case AR_SECTION:
3124       {
3125 #define AR_START (ar->start[i] ? ar->start[i] : as->lower[i])
3126 #define AR_END (ar->end[i] ? ar->end[i] : as->upper[i])
3127
3128         comparison comp_start_end = compare_bound (AR_START, AR_END);
3129
3130         /* Check for zero stride, which is not allowed.  */
3131         if (compare_bound_int (ar->stride[i], 0) == CMP_EQ)
3132           {
3133             gfc_error ("Illegal stride of zero at %L", &ar->c_where[i]);
3134             return FAILURE;
3135           }
3136
3137         /* if start == len || (stride > 0 && start < len)
3138                            || (stride < 0 && start > len),
3139            then the array section contains at least one element.  In this
3140            case, there is an out-of-bounds access if
3141            (start < lower || start > upper).  */
3142         if (compare_bound (AR_START, AR_END) == CMP_EQ
3143             || ((compare_bound_int (ar->stride[i], 0) == CMP_GT
3144                  || ar->stride[i] == NULL) && comp_start_end == CMP_LT)
3145             || (compare_bound_int (ar->stride[i], 0) == CMP_LT
3146                 && comp_start_end == CMP_GT))
3147           {
3148             if (compare_bound (AR_START, as->lower[i]) == CMP_LT
3149                 || compare_bound (AR_START, as->upper[i]) == CMP_GT)
3150               goto bound;
3151           }
3152
3153         /* If we can compute the highest index of the array section,
3154            then it also has to be between lower and upper.  */
3155         mpz_init (last_value);
3156         if (compute_last_value_for_triplet (AR_START, AR_END, ar->stride[i],
3157                                             last_value))
3158           {
3159             if (compare_bound_mpz_t (as->lower[i], last_value) == CMP_GT
3160                 || compare_bound_mpz_t (as->upper[i], last_value) == CMP_LT)
3161               {
3162                 mpz_clear (last_value);
3163                 goto bound;
3164               }
3165           }
3166         mpz_clear (last_value);
3167
3168 #undef AR_START
3169 #undef AR_END
3170       }
3171       break;
3172
3173     default:
3174       gfc_internal_error ("check_dimension(): Bad array reference");
3175     }
3176
3177   return SUCCESS;
3178
3179 bound:
3180   gfc_warning ("Array reference at %L is out of bounds", &ar->c_where[i]);
3181   return SUCCESS;
3182 }
3183
3184
3185 /* Compare an array reference with an array specification.  */
3186
3187 static try
3188 compare_spec_to_ref (gfc_array_ref *ar)
3189 {
3190   gfc_array_spec *as;
3191   int i;
3192
3193   as = ar->as;
3194   i = as->rank - 1;
3195   /* TODO: Full array sections are only allowed as actual parameters.  */
3196   if (as->type == AS_ASSUMED_SIZE
3197       && (/*ar->type == AR_FULL
3198           ||*/ (ar->type == AR_SECTION
3199               && ar->dimen_type[i] == DIMEN_RANGE && ar->end[i] == NULL)))
3200     {
3201       gfc_error ("Rightmost upper bound of assumed size array section "
3202                  "not specified at %L", &ar->where);
3203       return FAILURE;
3204     }
3205
3206   if (ar->type == AR_FULL)
3207     return SUCCESS;
3208
3209   if (as->rank != ar->dimen)
3210     {
3211       gfc_error ("Rank mismatch in array reference at %L (%d/%d)",
3212                  &ar->where, ar->dimen, as->rank);
3213       return FAILURE;
3214     }
3215
3216   for (i = 0; i < as->rank; i++)
3217     if (check_dimension (i, ar, as) == FAILURE)
3218       return FAILURE;
3219
3220   return SUCCESS;
3221 }
3222
3223
3224 /* Resolve one part of an array index.  */
3225
3226 try
3227 gfc_resolve_index (gfc_expr *index, int check_scalar)
3228 {
3229   gfc_typespec ts;
3230
3231   if (index == NULL)
3232     return SUCCESS;
3233
3234   if (gfc_resolve_expr (index) == FAILURE)
3235     return FAILURE;
3236
3237   if (check_scalar && index->rank != 0)
3238     {
3239       gfc_error ("Array index at %L must be scalar", &index->where);
3240       return FAILURE;
3241     }
3242
3243   if (index->ts.type != BT_INTEGER && index->ts.type != BT_REAL)
3244     {
3245       gfc_error ("Array index at %L must be of INTEGER type",
3246                  &index->where);
3247       return FAILURE;
3248     }
3249
3250   if (index->ts.type == BT_REAL)
3251     if (gfc_notify_std (GFC_STD_LEGACY, "Extension: REAL array index at %L",
3252                         &index->where) == FAILURE)
3253       return FAILURE;
3254
3255   if (index->ts.kind != gfc_index_integer_kind
3256       || index->ts.type != BT_INTEGER)
3257     {
3258       gfc_clear_ts (&ts);
3259       ts.type = BT_INTEGER;
3260       ts.kind = gfc_index_integer_kind;
3261
3262       gfc_convert_type_warn (index, &ts, 2, 0);
3263     }
3264
3265   return SUCCESS;
3266 }
3267
3268 /* Resolve a dim argument to an intrinsic function.  */
3269
3270 try
3271 gfc_resolve_dim_arg (gfc_expr *dim)
3272 {
3273   if (dim == NULL)
3274     return SUCCESS;
3275
3276   if (gfc_resolve_expr (dim) == FAILURE)
3277     return FAILURE;
3278
3279   if (dim->rank != 0)
3280     {
3281       gfc_error ("Argument dim at %L must be scalar", &dim->where);
3282       return FAILURE;
3283
3284     }
3285   if (dim->ts.type != BT_INTEGER)
3286     {
3287       gfc_error ("Argument dim at %L must be of INTEGER type", &dim->where);
3288       return FAILURE;
3289     }
3290   if (dim->ts.kind != gfc_index_integer_kind)
3291     {
3292       gfc_typespec ts;
3293
3294       ts.type = BT_INTEGER;
3295       ts.kind = gfc_index_integer_kind;
3296
3297       gfc_convert_type_warn (dim, &ts, 2, 0);
3298     }
3299
3300   return SUCCESS;
3301 }
3302
3303 /* Given an expression that contains array references, update those array
3304    references to point to the right array specifications.  While this is
3305    filled in during matching, this information is difficult to save and load
3306    in a module, so we take care of it here.
3307
3308    The idea here is that the original array reference comes from the
3309    base symbol.  We traverse the list of reference structures, setting
3310    the stored reference to references.  Component references can
3311    provide an additional array specification.  */
3312
3313 static void
3314 find_array_spec (gfc_expr *e)
3315 {
3316   gfc_array_spec *as;
3317   gfc_component *c;
3318   gfc_symbol *derived;
3319   gfc_ref *ref;
3320
3321   as = e->symtree->n.sym->as;
3322   derived = NULL;
3323
3324   for (ref = e->ref; ref; ref = ref->next)
3325     switch (ref->type)
3326       {
3327       case REF_ARRAY:
3328         if (as == NULL)
3329           gfc_internal_error ("find_array_spec(): Missing spec");
3330
3331         ref->u.ar.as = as;
3332         as = NULL;
3333         break;
3334
3335       case REF_COMPONENT:
3336         if (derived == NULL)
3337           derived = e->symtree->n.sym->ts.derived;
3338
3339         c = derived->components;
3340
3341         for (; c; c = c->next)
3342           if (c == ref->u.c.component)
3343             {
3344               /* Track the sequence of component references.  */
3345               if (c->ts.type == BT_DERIVED)
3346                 derived = c->ts.derived;
3347               break;
3348             }
3349
3350         if (c == NULL)
3351           gfc_internal_error ("find_array_spec(): Component not found");
3352
3353         if (c->dimension)
3354           {
3355             if (as != NULL)
3356               gfc_internal_error ("find_array_spec(): unused as(1)");
3357             as = c->as;
3358           }
3359
3360         break;
3361
3362       case REF_SUBSTRING:
3363         break;
3364       }
3365
3366   if (as != NULL)
3367     gfc_internal_error ("find_array_spec(): unused as(2)");
3368 }
3369
3370
3371 /* Resolve an array reference.  */
3372
3373 static try
3374 resolve_array_ref (gfc_array_ref *ar)
3375 {
3376   int i, check_scalar;
3377   gfc_expr *e;
3378
3379   for (i = 0; i < ar->dimen; i++)
3380     {
3381       check_scalar = ar->dimen_type[i] == DIMEN_RANGE;
3382
3383       if (gfc_resolve_index (ar->start[i], check_scalar) == FAILURE)
3384         return FAILURE;
3385       if (gfc_resolve_index (ar->end[i], check_scalar) == FAILURE)
3386         return FAILURE;
3387       if (gfc_resolve_index (ar->stride[i], check_scalar) == FAILURE)
3388         return FAILURE;
3389
3390       e = ar->start[i];
3391
3392       if (ar->dimen_type[i] == DIMEN_UNKNOWN)
3393         switch (e->rank)
3394           {
3395           case 0:
3396             ar->dimen_type[i] = DIMEN_ELEMENT;
3397             break;
3398
3399           case 1:
3400             ar->dimen_type[i] = DIMEN_VECTOR;
3401             if (e->expr_type == EXPR_VARIABLE
3402                 && e->symtree->n.sym->ts.type == BT_DERIVED)
3403               ar->start[i] = gfc_get_parentheses (e);
3404             break;
3405
3406           default:
3407             gfc_error ("Array index at %L is an array of rank %d",
3408                        &ar->c_where[i], e->rank);
3409             return FAILURE;
3410           }
3411     }
3412
3413   /* If the reference type is unknown, figure out what kind it is.  */
3414
3415   if (ar->type == AR_UNKNOWN)
3416     {
3417       ar->type = AR_ELEMENT;
3418       for (i = 0; i < ar->dimen; i++)
3419         if (ar->dimen_type[i] == DIMEN_RANGE
3420             || ar->dimen_type[i] == DIMEN_VECTOR)
3421           {
3422             ar->type = AR_SECTION;
3423             break;
3424           }
3425     }
3426
3427   if (!ar->as->cray_pointee && compare_spec_to_ref (ar) == FAILURE)
3428     return FAILURE;
3429
3430   return SUCCESS;
3431 }
3432
3433
3434 static try
3435 resolve_substring (gfc_ref *ref)
3436 {
3437   if (ref->u.ss.start != NULL)
3438     {
3439       if (gfc_resolve_expr (ref->u.ss.start) == FAILURE)
3440         return FAILURE;
3441
3442       if (ref->u.ss.start->ts.type != BT_INTEGER)
3443         {
3444           gfc_error ("Substring start index at %L must be of type INTEGER",
3445                      &ref->u.ss.start->where);
3446           return FAILURE;