OSDN Git Service

gcc/fortran:
[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                       /* Make sure it's not a character string.  Arrays of
1811                          any type should be ok if the variable is of a C
1812                          interoperable type.  */
1813                       if (args_sym->ts.type == BT_CHARACTER 
1814                           && is_scalar_expr_ptr (args->expr) != SUCCESS)
1815                         {
1816                           gfc_error_now ("CHARACTER argument '%s' to '%s' at "
1817                                          "%L must have a length of 1",
1818                                          args_sym->name, sym->name,
1819                                          &(args->expr->where));
1820                           retval = FAILURE;
1821                         }
1822                     }
1823                 }
1824               else if (args_sym->attr.pointer == 1
1825                        && is_scalar_expr_ptr (args->expr) != SUCCESS)
1826                 {
1827                   /* Case 1c, section 15.1.2.5, J3/04-007: an associated
1828                      scalar pointer.  */
1829                   gfc_error_now ("Argument '%s' to '%s' at %L must be an "
1830                                  "associated scalar POINTER", args_sym->name,
1831                                  sym->name, &(args->expr->where));
1832                   retval = FAILURE;
1833                 }
1834             }
1835           else
1836             {
1837               /* The parameter is not required to be C interoperable.  If it
1838                  is not C interoperable, it must be a nonpolymorphic scalar
1839                  with no length type parameters.  It still must have either
1840                  the pointer or target attribute, and it can be
1841                  allocatable (but must be allocated when c_loc is called).  */
1842               if (args_sym->attr.dimension != 0
1843                   && is_scalar_expr_ptr (args->expr) != SUCCESS)
1844                 {
1845                   gfc_error_now ("Parameter '%s' to '%s' at %L must be a "
1846                                  "scalar", args_sym->name, sym->name,
1847                                  &(args->expr->where));
1848                   retval = FAILURE;
1849                 }
1850               else if (args_sym->ts.type == BT_CHARACTER 
1851                        && args_sym->ts.cl != NULL)
1852                 {
1853                   gfc_error_now ("CHARACTER parameter '%s' to '%s' at %L "
1854                                  "cannot have a length type parameter",
1855                                  args_sym->name, sym->name,
1856                                  &(args->expr->where));
1857                   retval = FAILURE;
1858                 }
1859             }
1860         }
1861       else if (sym->intmod_sym_id == ISOCBINDING_FUNLOC)
1862         {
1863           if (args->expr->symtree->n.sym->attr.flavor != FL_PROCEDURE)
1864             {
1865               /* TODO: Update this error message to allow for procedure
1866                  pointers once they are implemented.  */
1867               gfc_error_now ("Parameter '%s' to '%s' at %L must be a "
1868                              "procedure",
1869                              args->expr->symtree->n.sym->name, sym->name,
1870                              &(args->expr->where));
1871               retval = FAILURE;
1872             }
1873           else if (args->expr->symtree->n.sym->attr.is_c_interop != 1)
1874             {
1875               gfc_error_now ("Parameter '%s' to '%s' at %L must be C "
1876                              "interoperable",
1877                              args->expr->symtree->n.sym->name, sym->name,
1878                              &(args->expr->where));
1879               retval = FAILURE;
1880             }
1881         }
1882       
1883       /* for c_loc/c_funloc, the new symbol is the same as the old one */
1884       *new_sym = sym;
1885     }
1886   else
1887     {
1888       gfc_internal_error ("gfc_iso_c_func_interface(): Unhandled "
1889                           "iso_c_binding function: '%s'!\n", sym->name);
1890     }
1891
1892   return retval;
1893 }
1894
1895
1896 /* Resolve a function call, which means resolving the arguments, then figuring
1897    out which entity the name refers to.  */
1898 /* TODO: Check procedure arguments so that an INTENT(IN) isn't passed
1899    to INTENT(OUT) or INTENT(INOUT).  */
1900
1901 static try
1902 resolve_function (gfc_expr *expr)
1903 {
1904   gfc_actual_arglist *arg;
1905   gfc_symbol *sym;
1906   const char *name;
1907   try t;
1908   int temp;
1909   procedure_type p = PROC_INTRINSIC;
1910
1911   sym = NULL;
1912   if (expr->symtree)
1913     sym = expr->symtree->n.sym;
1914
1915   if (sym && sym->attr.flavor == FL_VARIABLE)
1916     {
1917       gfc_error ("'%s' at %L is not a function", sym->name, &expr->where);
1918       return FAILURE;
1919     }
1920
1921   /* If the procedure is external, check for usage.  */
1922   if (sym && is_external_proc (sym))
1923     resolve_global_procedure (sym, &expr->where, 0);
1924
1925   /* Switch off assumed size checking and do this again for certain kinds
1926      of procedure, once the procedure itself is resolved.  */
1927   need_full_assumed_size++;
1928
1929   if (expr->symtree && expr->symtree->n.sym)
1930     p = expr->symtree->n.sym->attr.proc;
1931
1932   if (resolve_actual_arglist (expr->value.function.actual, p) == FAILURE)
1933       return FAILURE;
1934
1935   /* Need to setup the call to the correct c_associated, depending on
1936      the number of cptrs to user gives to compare.  */
1937   if (sym && sym->attr.is_iso_c == 1)
1938     {
1939       if (gfc_iso_c_func_interface (sym, expr->value.function.actual, &sym)
1940           == FAILURE)
1941         return FAILURE;
1942       
1943       /* Get the symtree for the new symbol (resolved func).
1944          the old one will be freed later, when it's no longer used.  */
1945       gfc_find_sym_tree (sym->name, sym->ns, 1, &(expr->symtree));
1946     }
1947   
1948   /* Resume assumed_size checking.  */
1949   need_full_assumed_size--;
1950
1951   if (sym && sym->ts.type == BT_CHARACTER
1952       && sym->ts.cl
1953       && sym->ts.cl->length == NULL
1954       && !sym->attr.dummy
1955       && expr->value.function.esym == NULL
1956       && !sym->attr.contained)
1957     {
1958       /* Internal procedures are taken care of in resolve_contained_fntype.  */
1959       gfc_error ("Function '%s' is declared CHARACTER(*) and cannot "
1960                  "be used at %L since it is not a dummy argument",
1961                  sym->name, &expr->where);
1962       return FAILURE;
1963     }
1964
1965   /* See if function is already resolved.  */
1966
1967   if (expr->value.function.name != NULL)
1968     {
1969       if (expr->ts.type == BT_UNKNOWN)
1970         expr->ts = sym->ts;
1971       t = SUCCESS;
1972     }
1973   else
1974     {
1975       /* Apply the rules of section 14.1.2.  */
1976
1977       switch (procedure_kind (sym))
1978         {
1979         case PTYPE_GENERIC:
1980           t = resolve_generic_f (expr);
1981           break;
1982
1983         case PTYPE_SPECIFIC:
1984           t = resolve_specific_f (expr);
1985           break;
1986
1987         case PTYPE_UNKNOWN:
1988           t = resolve_unknown_f (expr);
1989           break;
1990
1991         default:
1992           gfc_internal_error ("resolve_function(): bad function type");
1993         }
1994     }
1995
1996   /* If the expression is still a function (it might have simplified),
1997      then we check to see if we are calling an elemental function.  */
1998
1999   if (expr->expr_type != EXPR_FUNCTION)
2000     return t;
2001
2002   temp = need_full_assumed_size;
2003   need_full_assumed_size = 0;
2004
2005   if (resolve_elemental_actual (expr, NULL) == FAILURE)
2006     return FAILURE;
2007
2008   if (omp_workshare_flag
2009       && expr->value.function.esym
2010       && ! gfc_elemental (expr->value.function.esym))
2011     {
2012       gfc_error ("User defined non-ELEMENTAL function '%s' at %L not allowed "
2013                  "in WORKSHARE construct", expr->value.function.esym->name,
2014                  &expr->where);
2015       t = FAILURE;
2016     }
2017
2018 #define GENERIC_ID expr->value.function.isym->id
2019   else if (expr->value.function.actual != NULL
2020            && expr->value.function.isym != NULL
2021            && GENERIC_ID != GFC_ISYM_LBOUND
2022            && GENERIC_ID != GFC_ISYM_LEN
2023            && GENERIC_ID != GFC_ISYM_LOC
2024            && GENERIC_ID != GFC_ISYM_PRESENT)
2025     {
2026       /* Array intrinsics must also have the last upper bound of an
2027          assumed size array argument.  UBOUND and SIZE have to be
2028          excluded from the check if the second argument is anything
2029          than a constant.  */
2030       int inquiry;
2031       inquiry = GENERIC_ID == GFC_ISYM_UBOUND
2032                   || GENERIC_ID == GFC_ISYM_SIZE;
2033
2034       for (arg = expr->value.function.actual; arg; arg = arg->next)
2035         {
2036           if (inquiry && arg->next != NULL && arg->next->expr)
2037             {
2038               if (arg->next->expr->expr_type != EXPR_CONSTANT)
2039                 break;
2040
2041               if ((int)mpz_get_si (arg->next->expr->value.integer)
2042                         < arg->expr->rank)
2043                 break;
2044             }
2045
2046           if (arg->expr != NULL
2047               && arg->expr->rank > 0
2048               && resolve_assumed_size_actual (arg->expr))
2049             return FAILURE;
2050         }
2051     }
2052 #undef GENERIC_ID
2053
2054   need_full_assumed_size = temp;
2055   name = NULL;
2056
2057   if (!pure_function (expr, &name) && name)
2058     {
2059       if (forall_flag)
2060         {
2061           gfc_error ("reference to non-PURE function '%s' at %L inside a "
2062                      "FORALL %s", name, &expr->where,
2063                      forall_flag == 2 ? "mask" : "block");
2064           t = FAILURE;
2065         }
2066       else if (gfc_pure (NULL))
2067         {
2068           gfc_error ("Function reference to '%s' at %L is to a non-PURE "
2069                      "procedure within a PURE procedure", name, &expr->where);
2070           t = FAILURE;
2071         }
2072     }
2073
2074   /* Functions without the RECURSIVE attribution are not allowed to
2075    * call themselves.  */
2076   if (expr->value.function.esym && !expr->value.function.esym->attr.recursive)
2077     {
2078       gfc_symbol *esym, *proc;
2079       esym = expr->value.function.esym;
2080       proc = gfc_current_ns->proc_name;
2081       if (esym == proc)
2082       {
2083         gfc_error ("Function '%s' at %L cannot call itself, as it is not "
2084                    "RECURSIVE", name, &expr->where);
2085         t = FAILURE;
2086       }
2087
2088       if (esym->attr.entry && esym->ns->entries && proc->ns->entries
2089           && esym->ns->entries->sym == proc->ns->entries->sym)
2090       {
2091         gfc_error ("Call to ENTRY '%s' at %L is recursive, but function "
2092                    "'%s' is not declared as RECURSIVE",
2093                    esym->name, &expr->where, esym->ns->entries->sym->name);
2094         t = FAILURE;
2095       }
2096     }
2097
2098   /* Character lengths of use associated functions may contains references to
2099      symbols not referenced from the current program unit otherwise.  Make sure
2100      those symbols are marked as referenced.  */
2101
2102   if (expr->ts.type == BT_CHARACTER && expr->value.function.esym
2103       && expr->value.function.esym->attr.use_assoc)
2104     {
2105       gfc_expr_set_symbols_referenced (expr->ts.cl->length);
2106     }
2107
2108   if (t == SUCCESS)
2109     find_noncopying_intrinsics (expr->value.function.esym,
2110                                 expr->value.function.actual);
2111
2112   /* Make sure that the expression has a typespec that works.  */
2113   if (expr->ts.type == BT_UNKNOWN)
2114     {
2115       if (expr->symtree->n.sym->result
2116             && expr->symtree->n.sym->result->ts.type != BT_UNKNOWN)
2117         expr->ts = expr->symtree->n.sym->result->ts;
2118     }
2119
2120   return t;
2121 }
2122
2123
2124 /************* Subroutine resolution *************/
2125
2126 static void
2127 pure_subroutine (gfc_code *c, gfc_symbol *sym)
2128 {
2129   if (gfc_pure (sym))
2130     return;
2131
2132   if (forall_flag)
2133     gfc_error ("Subroutine call to '%s' in FORALL block at %L is not PURE",
2134                sym->name, &c->loc);
2135   else if (gfc_pure (NULL))
2136     gfc_error ("Subroutine call to '%s' at %L is not PURE", sym->name,
2137                &c->loc);
2138 }
2139
2140
2141 static match
2142 resolve_generic_s0 (gfc_code *c, gfc_symbol *sym)
2143 {
2144   gfc_symbol *s;
2145
2146   if (sym->attr.generic)
2147     {
2148       s = gfc_search_interface (sym->generic, 1, &c->ext.actual);
2149       if (s != NULL)
2150         {
2151           c->resolved_sym = s;
2152           pure_subroutine (c, s);
2153           return MATCH_YES;
2154         }
2155
2156       /* TODO: Need to search for elemental references in generic interface.  */
2157     }
2158
2159   if (sym->attr.intrinsic)
2160     return gfc_intrinsic_sub_interface (c, 0);
2161
2162   return MATCH_NO;
2163 }
2164
2165
2166 static try
2167 resolve_generic_s (gfc_code *c)
2168 {
2169   gfc_symbol *sym;
2170   match m;
2171
2172   sym = c->symtree->n.sym;
2173
2174   for (;;)
2175     {
2176       m = resolve_generic_s0 (c, sym);
2177       if (m == MATCH_YES)
2178         return SUCCESS;
2179       else if (m == MATCH_ERROR)
2180         return FAILURE;
2181
2182 generic:
2183       if (sym->ns->parent == NULL)
2184         break;
2185       gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
2186
2187       if (sym == NULL)
2188         break;
2189       if (!generic_sym (sym))
2190         goto generic;
2191     }
2192
2193   /* Last ditch attempt.  See if the reference is to an intrinsic
2194      that possesses a matching interface.  14.1.2.4  */
2195   sym = c->symtree->n.sym;
2196
2197   if (!gfc_intrinsic_name (sym->name, 1))
2198     {
2199       gfc_error ("There is no specific subroutine for the generic '%s' at %L",
2200                  sym->name, &c->loc);
2201       return FAILURE;
2202     }
2203
2204   m = gfc_intrinsic_sub_interface (c, 0);
2205   if (m == MATCH_YES)
2206     return SUCCESS;
2207   if (m == MATCH_NO)
2208     gfc_error ("Generic subroutine '%s' at %L is not consistent with an "
2209                "intrinsic subroutine interface", sym->name, &c->loc);
2210
2211   return FAILURE;
2212 }
2213
2214
2215 /* Set the name and binding label of the subroutine symbol in the call
2216    expression represented by 'c' to include the type and kind of the
2217    second parameter.  This function is for resolving the appropriate
2218    version of c_f_pointer() and c_f_procpointer().  For example, a
2219    call to c_f_pointer() for a default integer pointer could have a
2220    name of c_f_pointer_i4.  If no second arg exists, which is an error
2221    for these two functions, it defaults to the generic symbol's name
2222    and binding label.  */
2223
2224 static void
2225 set_name_and_label (gfc_code *c, gfc_symbol *sym,
2226                     char *name, char *binding_label)
2227 {
2228   gfc_expr *arg = NULL;
2229   char type;
2230   int kind;
2231
2232   /* The second arg of c_f_pointer and c_f_procpointer determines
2233      the type and kind for the procedure name.  */
2234   arg = c->ext.actual->next->expr;
2235
2236   if (arg != NULL)
2237     {
2238       /* Set up the name to have the given symbol's name,
2239          plus the type and kind.  */
2240       /* a derived type is marked with the type letter 'u' */
2241       if (arg->ts.type == BT_DERIVED)
2242         {
2243           type = 'd';
2244           kind = 0; /* set the kind as 0 for now */
2245         }
2246       else
2247         {
2248           type = gfc_type_letter (arg->ts.type);
2249           kind = arg->ts.kind;
2250         }
2251       sprintf (name, "%s_%c%d", sym->name, type, kind);
2252       /* Set up the binding label as the given symbol's label plus
2253          the type and kind.  */
2254       sprintf (binding_label, "%s_%c%d", sym->binding_label, type, kind);
2255     }
2256   else
2257     {
2258       /* If the second arg is missing, set the name and label as
2259          was, cause it should at least be found, and the missing
2260          arg error will be caught by compare_parameters().  */
2261       sprintf (name, "%s", sym->name);
2262       sprintf (binding_label, "%s", sym->binding_label);
2263     }
2264    
2265   return;
2266 }
2267
2268
2269 /* Resolve a generic version of the iso_c_binding procedure given
2270    (sym) to the specific one based on the type and kind of the
2271    argument(s).  Currently, this function resolves c_f_pointer() and
2272    c_f_procpointer based on the type and kind of the second argument
2273    (FPTR).  Other iso_c_binding procedures aren't specially handled.
2274    Upon successfully exiting, c->resolved_sym will hold the resolved
2275    symbol.  Returns MATCH_ERROR if an error occurred; MATCH_YES
2276    otherwise.  */
2277
2278 match
2279 gfc_iso_c_sub_interface (gfc_code *c, gfc_symbol *sym)
2280 {
2281   gfc_symbol *new_sym;
2282   /* this is fine, since we know the names won't use the max */
2283   char name[GFC_MAX_SYMBOL_LEN + 1];
2284   char binding_label[GFC_MAX_BINDING_LABEL_LEN + 1];
2285   /* default to success; will override if find error */
2286   match m = MATCH_YES;
2287   gfc_symbol *tmp_sym;
2288
2289   if ((sym->intmod_sym_id == ISOCBINDING_F_POINTER) ||
2290       (sym->intmod_sym_id == ISOCBINDING_F_PROCPOINTER))
2291     {
2292       set_name_and_label (c, sym, name, binding_label);
2293       
2294       if (sym->intmod_sym_id == ISOCBINDING_F_POINTER)
2295         {
2296           if (c->ext.actual != NULL && c->ext.actual->next != NULL)
2297             {
2298               /* Make sure we got a third arg.  The type/rank of it will
2299                  be checked later if it's there (gfc_procedure_use()).  */
2300               if (c->ext.actual->next->expr->rank != 0 &&
2301                   c->ext.actual->next->next == NULL)
2302                 {
2303                   m = MATCH_ERROR;
2304                   gfc_error ("Missing SHAPE parameter for call to %s "
2305                              "at %L", sym->name, &(c->loc));
2306                 }
2307               /* Make sure the param is a POINTER.  No need to make sure
2308                  it does not have INTENT(IN) since it is a POINTER.  */
2309               tmp_sym = c->ext.actual->next->expr->symtree->n.sym;
2310               if (tmp_sym != NULL && tmp_sym->attr.pointer != 1)
2311                 {
2312                   gfc_error ("Argument '%s' to '%s' at %L "
2313                              "must have the POINTER attribute",
2314                              tmp_sym->name, sym->name, &(c->loc));
2315                   m = MATCH_ERROR;
2316                 }
2317             }
2318         }
2319       
2320       if (m != MATCH_ERROR)
2321         {
2322           /* the 1 means to add the optional arg to formal list */
2323           new_sym = get_iso_c_sym (sym, name, binding_label, 1);
2324          
2325           /* for error reporting, say it's declared where the original was */
2326           new_sym->declared_at = sym->declared_at;
2327         }
2328     }
2329   else if (sym->intmod_sym_id == ISOCBINDING_ASSOCIATED)
2330     {
2331       /* TODO: Figure out if this is even reacable; this part of the
2332          conditional may not be necessary.  */
2333       int num_args = 0;
2334       if (c->ext.actual->next == NULL)
2335         {
2336           /* The user did not give two args, so resolve to the version
2337              of c_associated expecting one arg.  */
2338           num_args = 1;
2339           /* get rid of the second arg */
2340           /* TODO!! Should free up the memory here!  */
2341           sym->formal->next = NULL;
2342         }
2343       else
2344         {
2345           num_args = 2;
2346         }
2347
2348       new_sym = sym;
2349       sprintf (name, "%s_%d", sym->name, num_args);
2350       sprintf (binding_label, "%s_%d", sym->binding_label, num_args);
2351       sym->name = gfc_get_string (name);
2352       strcpy (sym->binding_label, binding_label);
2353     }
2354   else
2355     {
2356       /* no differences for c_loc or c_funloc */
2357       new_sym = sym;
2358     }
2359
2360   /* set the resolved symbol */
2361   if (m != MATCH_ERROR)
2362     {
2363       gfc_procedure_use (new_sym, &c->ext.actual, &c->loc);
2364       c->resolved_sym = new_sym;
2365     }
2366   else
2367     c->resolved_sym = sym;
2368   
2369   return m;
2370 }
2371
2372
2373 /* Resolve a subroutine call known to be specific.  */
2374
2375 static match
2376 resolve_specific_s0 (gfc_code *c, gfc_symbol *sym)
2377 {
2378   match m;
2379
2380   if(sym->attr.is_iso_c)
2381     {
2382       m = gfc_iso_c_sub_interface (c,sym);
2383       return m;
2384     }
2385   
2386   if (sym->attr.external || sym->attr.if_source == IFSRC_IFBODY)
2387     {
2388       if (sym->attr.dummy)
2389         {
2390           sym->attr.proc = PROC_DUMMY;
2391           goto found;
2392         }
2393
2394       sym->attr.proc = PROC_EXTERNAL;
2395       goto found;
2396     }
2397
2398   if (sym->attr.proc == PROC_MODULE || sym->attr.proc == PROC_INTERNAL)
2399     goto found;
2400
2401   if (sym->attr.intrinsic)
2402     {
2403       m = gfc_intrinsic_sub_interface (c, 1);
2404       if (m == MATCH_YES)
2405         return MATCH_YES;
2406       if (m == MATCH_NO)
2407         gfc_error ("Subroutine '%s' at %L is INTRINSIC but is not compatible "
2408                    "with an intrinsic", sym->name, &c->loc);
2409
2410       return MATCH_ERROR;
2411     }
2412
2413   return MATCH_NO;
2414
2415 found:
2416   gfc_procedure_use (sym, &c->ext.actual, &c->loc);
2417
2418   c->resolved_sym = sym;
2419   pure_subroutine (c, sym);
2420
2421   return MATCH_YES;
2422 }
2423
2424
2425 static try
2426 resolve_specific_s (gfc_code *c)
2427 {
2428   gfc_symbol *sym;
2429   match m;
2430
2431   sym = c->symtree->n.sym;
2432
2433   for (;;)
2434     {
2435       m = resolve_specific_s0 (c, sym);
2436       if (m == MATCH_YES)
2437         return SUCCESS;
2438       if (m == MATCH_ERROR)
2439         return FAILURE;
2440
2441       if (sym->ns->parent == NULL)
2442         break;
2443
2444       gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
2445
2446       if (sym == NULL)
2447         break;
2448     }
2449
2450   sym = c->symtree->n.sym;
2451   gfc_error ("Unable to resolve the specific subroutine '%s' at %L",
2452              sym->name, &c->loc);
2453
2454   return FAILURE;
2455 }
2456
2457
2458 /* Resolve a subroutine call not known to be generic nor specific.  */
2459
2460 static try
2461 resolve_unknown_s (gfc_code *c)
2462 {
2463   gfc_symbol *sym;
2464
2465   sym = c->symtree->n.sym;
2466
2467   if (sym->attr.dummy)
2468     {
2469       sym->attr.proc = PROC_DUMMY;
2470       goto found;
2471     }
2472
2473   /* See if we have an intrinsic function reference.  */
2474
2475   if (gfc_intrinsic_name (sym->name, 1))
2476     {
2477       if (gfc_intrinsic_sub_interface (c, 1) == MATCH_YES)
2478         return SUCCESS;
2479       return FAILURE;
2480     }
2481
2482   /* The reference is to an external name.  */
2483
2484 found:
2485   gfc_procedure_use (sym, &c->ext.actual, &c->loc);
2486
2487   c->resolved_sym = sym;
2488
2489   pure_subroutine (c, sym);
2490
2491   return SUCCESS;
2492 }
2493
2494
2495 /* Resolve a subroutine call.  Although it was tempting to use the same code
2496    for functions, subroutines and functions are stored differently and this
2497    makes things awkward.  */
2498
2499 static try
2500 resolve_call (gfc_code *c)
2501 {
2502   try t;
2503   procedure_type ptype = PROC_INTRINSIC;
2504
2505   if (c->symtree && c->symtree->n.sym
2506       && c->symtree->n.sym->ts.type != BT_UNKNOWN)
2507     {
2508       gfc_error ("'%s' at %L has a type, which is not consistent with "
2509                  "the CALL at %L", c->symtree->n.sym->name,
2510                  &c->symtree->n.sym->declared_at, &c->loc);
2511       return FAILURE;
2512     }
2513
2514   /* If external, check for usage.  */
2515   if (c->symtree && is_external_proc (c->symtree->n.sym))
2516     resolve_global_procedure (c->symtree->n.sym, &c->loc, 1);
2517
2518   /* Subroutines without the RECURSIVE attribution are not allowed to
2519    * call themselves.  */
2520   if (c->symtree && c->symtree->n.sym && !c->symtree->n.sym->attr.recursive)
2521     {
2522       gfc_symbol *csym, *proc;
2523       csym = c->symtree->n.sym;
2524       proc = gfc_current_ns->proc_name;
2525       if (csym == proc)
2526       {
2527         gfc_error ("SUBROUTINE '%s' at %L cannot call itself, as it is not "
2528                    "RECURSIVE", csym->name, &c->loc);
2529         t = FAILURE;
2530       }
2531
2532       if (csym->attr.entry && csym->ns->entries && proc->ns->entries
2533           && csym->ns->entries->sym == proc->ns->entries->sym)
2534       {
2535         gfc_error ("Call to ENTRY '%s' at %L is recursive, but subroutine "
2536                    "'%s' is not declared as RECURSIVE",
2537                    csym->name, &c->loc, csym->ns->entries->sym->name);
2538         t = FAILURE;
2539       }
2540     }
2541
2542   /* Switch off assumed size checking and do this again for certain kinds
2543      of procedure, once the procedure itself is resolved.  */
2544   need_full_assumed_size++;
2545
2546   if (c->symtree && c->symtree->n.sym)
2547     ptype = c->symtree->n.sym->attr.proc;
2548
2549   if (resolve_actual_arglist (c->ext.actual, ptype) == FAILURE)
2550     return FAILURE;
2551
2552   /* Resume assumed_size checking.  */
2553   need_full_assumed_size--;
2554
2555   t = SUCCESS;
2556   if (c->resolved_sym == NULL)
2557     switch (procedure_kind (c->symtree->n.sym))
2558       {
2559       case PTYPE_GENERIC:
2560         t = resolve_generic_s (c);
2561         break;
2562
2563       case PTYPE_SPECIFIC:
2564         t = resolve_specific_s (c);
2565         break;
2566
2567       case PTYPE_UNKNOWN:
2568         t = resolve_unknown_s (c);
2569         break;
2570
2571       default:
2572         gfc_internal_error ("resolve_subroutine(): bad function type");
2573       }
2574
2575   /* Some checks of elemental subroutine actual arguments.  */
2576   if (resolve_elemental_actual (NULL, c) == FAILURE)
2577     return FAILURE;
2578
2579   if (t == SUCCESS)
2580     find_noncopying_intrinsics (c->resolved_sym, c->ext.actual);
2581   return t;
2582 }
2583
2584
2585 /* Compare the shapes of two arrays that have non-NULL shapes.  If both
2586    op1->shape and op2->shape are non-NULL return SUCCESS if their shapes
2587    match.  If both op1->shape and op2->shape are non-NULL return FAILURE
2588    if their shapes do not match.  If either op1->shape or op2->shape is
2589    NULL, return SUCCESS.  */
2590
2591 static try
2592 compare_shapes (gfc_expr *op1, gfc_expr *op2)
2593 {
2594   try t;
2595   int i;
2596
2597   t = SUCCESS;
2598
2599   if (op1->shape != NULL && op2->shape != NULL)
2600     {
2601       for (i = 0; i < op1->rank; i++)
2602         {
2603           if (mpz_cmp (op1->shape[i], op2->shape[i]) != 0)
2604            {
2605              gfc_error ("Shapes for operands at %L and %L are not conformable",
2606                          &op1->where, &op2->where);
2607              t = FAILURE;
2608              break;
2609            }
2610         }
2611     }
2612
2613   return t;
2614 }
2615
2616
2617 /* Resolve an operator expression node.  This can involve replacing the
2618    operation with a user defined function call.  */
2619
2620 static try
2621 resolve_operator (gfc_expr *e)
2622 {
2623   gfc_expr *op1, *op2;
2624   char msg[200];
2625   bool dual_locus_error;
2626   try t;
2627
2628   /* Resolve all subnodes-- give them types.  */
2629
2630   switch (e->value.op.operator)
2631     {
2632     default:
2633       if (gfc_resolve_expr (e->value.op.op2) == FAILURE)
2634         return FAILURE;
2635
2636     /* Fall through...  */
2637
2638     case INTRINSIC_NOT:
2639     case INTRINSIC_UPLUS:
2640     case INTRINSIC_UMINUS:
2641     case INTRINSIC_PARENTHESES:
2642       if (gfc_resolve_expr (e->value.op.op1) == FAILURE)
2643         return FAILURE;
2644       break;
2645     }
2646
2647   /* Typecheck the new node.  */
2648
2649   op1 = e->value.op.op1;
2650   op2 = e->value.op.op2;
2651   dual_locus_error = false;
2652
2653   if ((op1 && op1->expr_type == EXPR_NULL)
2654       || (op2 && op2->expr_type == EXPR_NULL))
2655     {
2656       sprintf (msg, _("Invalid context for NULL() pointer at %%L"));
2657       goto bad_op;
2658     }
2659
2660   switch (e->value.op.operator)
2661     {
2662     case INTRINSIC_UPLUS:
2663     case INTRINSIC_UMINUS:
2664       if (op1->ts.type == BT_INTEGER
2665           || op1->ts.type == BT_REAL
2666           || op1->ts.type == BT_COMPLEX)
2667         {
2668           e->ts = op1->ts;
2669           break;
2670         }
2671
2672       sprintf (msg, _("Operand of unary numeric operator '%s' at %%L is %s"),
2673                gfc_op2string (e->value.op.operator), gfc_typename (&e->ts));
2674       goto bad_op;
2675
2676     case INTRINSIC_PLUS:
2677     case INTRINSIC_MINUS:
2678     case INTRINSIC_TIMES:
2679     case INTRINSIC_DIVIDE:
2680     case INTRINSIC_POWER:
2681       if (gfc_numeric_ts (&op1->ts) && gfc_numeric_ts (&op2->ts))
2682         {
2683           gfc_type_convert_binary (e);
2684           break;
2685         }
2686
2687       sprintf (msg,
2688                _("Operands of binary numeric operator '%s' at %%L are %s/%s"),
2689                gfc_op2string (e->value.op.operator), gfc_typename (&op1->ts),
2690                gfc_typename (&op2->ts));
2691       goto bad_op;
2692
2693     case INTRINSIC_CONCAT:
2694       if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER)
2695         {
2696           e->ts.type = BT_CHARACTER;
2697           e->ts.kind = op1->ts.kind;
2698           break;
2699         }
2700
2701       sprintf (msg,
2702                _("Operands of string concatenation operator at %%L are %s/%s"),
2703                gfc_typename (&op1->ts), gfc_typename (&op2->ts));
2704       goto bad_op;
2705
2706     case INTRINSIC_AND:
2707     case INTRINSIC_OR:
2708     case INTRINSIC_EQV:
2709     case INTRINSIC_NEQV:
2710       if (op1->ts.type == BT_LOGICAL && op2->ts.type == BT_LOGICAL)
2711         {
2712           e->ts.type = BT_LOGICAL;
2713           e->ts.kind = gfc_kind_max (op1, op2);
2714           if (op1->ts.kind < e->ts.kind)
2715             gfc_convert_type (op1, &e->ts, 2);
2716           else if (op2->ts.kind < e->ts.kind)
2717             gfc_convert_type (op2, &e->ts, 2);
2718           break;
2719         }
2720
2721       sprintf (msg, _("Operands of logical operator '%s' at %%L are %s/%s"),
2722                gfc_op2string (e->value.op.operator), gfc_typename (&op1->ts),
2723                gfc_typename (&op2->ts));
2724
2725       goto bad_op;
2726
2727     case INTRINSIC_NOT:
2728       if (op1->ts.type == BT_LOGICAL)
2729         {
2730           e->ts.type = BT_LOGICAL;
2731           e->ts.kind = op1->ts.kind;
2732           break;
2733         }
2734
2735       sprintf (msg, _("Operand of .not. operator at %%L is %s"),
2736                gfc_typename (&op1->ts));
2737       goto bad_op;
2738
2739     case INTRINSIC_GT:
2740     case INTRINSIC_GT_OS:
2741     case INTRINSIC_GE:
2742     case INTRINSIC_GE_OS:
2743     case INTRINSIC_LT:
2744     case INTRINSIC_LT_OS:
2745     case INTRINSIC_LE:
2746     case INTRINSIC_LE_OS:
2747       if (op1->ts.type == BT_COMPLEX || op2->ts.type == BT_COMPLEX)
2748         {
2749           strcpy (msg, _("COMPLEX quantities cannot be compared at %L"));
2750           goto bad_op;
2751         }
2752
2753       /* Fall through...  */
2754
2755     case INTRINSIC_EQ:
2756     case INTRINSIC_EQ_OS:
2757     case INTRINSIC_NE:
2758     case INTRINSIC_NE_OS:
2759       if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER)
2760         {
2761           e->ts.type = BT_LOGICAL;
2762           e->ts.kind = gfc_default_logical_kind;
2763           break;
2764         }
2765
2766       if (gfc_numeric_ts (&op1->ts) && gfc_numeric_ts (&op2->ts))
2767         {
2768           gfc_type_convert_binary (e);
2769
2770           e->ts.type = BT_LOGICAL;
2771           e->ts.kind = gfc_default_logical_kind;
2772           break;
2773         }
2774
2775       if (op1->ts.type == BT_LOGICAL && op2->ts.type == BT_LOGICAL)
2776         sprintf (msg,
2777                  _("Logicals at %%L must be compared with %s instead of %s"),
2778                  e->value.op.operator == INTRINSIC_EQ ? ".eqv." : ".neqv.",
2779                  gfc_op2string (e->value.op.operator));
2780       else
2781         sprintf (msg,
2782                  _("Operands of comparison operator '%s' at %%L are %s/%s"),
2783                  gfc_op2string (e->value.op.operator), gfc_typename (&op1->ts),
2784                  gfc_typename (&op2->ts));
2785
2786       goto bad_op;
2787
2788     case INTRINSIC_USER:
2789       if (e->value.op.uop->operator == NULL)
2790         sprintf (msg, _("Unknown operator '%s' at %%L"), e->value.op.uop->name);
2791       else if (op2 == NULL)
2792         sprintf (msg, _("Operand of user operator '%s' at %%L is %s"),
2793                  e->value.op.uop->name, gfc_typename (&op1->ts));
2794       else
2795         sprintf (msg, _("Operands of user operator '%s' at %%L are %s/%s"),
2796                  e->value.op.uop->name, gfc_typename (&op1->ts),
2797                  gfc_typename (&op2->ts));
2798
2799       goto bad_op;
2800
2801     case INTRINSIC_PARENTHESES:
2802       break;
2803
2804     default:
2805       gfc_internal_error ("resolve_operator(): Bad intrinsic");
2806     }
2807
2808   /* Deal with arrayness of an operand through an operator.  */
2809
2810   t = SUCCESS;
2811
2812   switch (e->value.op.operator)
2813     {
2814     case INTRINSIC_PLUS:
2815     case INTRINSIC_MINUS:
2816     case INTRINSIC_TIMES:
2817     case INTRINSIC_DIVIDE:
2818     case INTRINSIC_POWER:
2819     case INTRINSIC_CONCAT:
2820     case INTRINSIC_AND:
2821     case INTRINSIC_OR:
2822     case INTRINSIC_EQV:
2823     case INTRINSIC_NEQV:
2824     case INTRINSIC_EQ:
2825     case INTRINSIC_EQ_OS:
2826     case INTRINSIC_NE:
2827     case INTRINSIC_NE_OS:
2828     case INTRINSIC_GT:
2829     case INTRINSIC_GT_OS:
2830     case INTRINSIC_GE:
2831     case INTRINSIC_GE_OS:
2832     case INTRINSIC_LT:
2833     case INTRINSIC_LT_OS:
2834     case INTRINSIC_LE:
2835     case INTRINSIC_LE_OS:
2836
2837       if (op1->rank == 0 && op2->rank == 0)
2838         e->rank = 0;
2839
2840       if (op1->rank == 0 && op2->rank != 0)
2841         {
2842           e->rank = op2->rank;
2843
2844           if (e->shape == NULL)
2845             e->shape = gfc_copy_shape (op2->shape, op2->rank);
2846         }
2847
2848       if (op1->rank != 0 && op2->rank == 0)
2849         {
2850           e->rank = op1->rank;
2851
2852           if (e->shape == NULL)
2853             e->shape = gfc_copy_shape (op1->shape, op1->rank);
2854         }
2855
2856       if (op1->rank != 0 && op2->rank != 0)
2857         {
2858           if (op1->rank == op2->rank)
2859             {
2860               e->rank = op1->rank;
2861               if (e->shape == NULL)
2862                 {
2863                   t = compare_shapes(op1, op2);
2864                   if (t == FAILURE)
2865                     e->shape = NULL;
2866                   else
2867                 e->shape = gfc_copy_shape (op1->shape, op1->rank);
2868                 }
2869             }
2870           else
2871             {
2872               /* Allow higher level expressions to work.  */
2873               e->rank = 0;
2874
2875               /* Try user-defined operators, and otherwise throw an error.  */
2876               dual_locus_error = true;
2877               sprintf (msg,
2878                        _("Inconsistent ranks for operator at %%L and %%L"));
2879               goto bad_op;
2880             }
2881         }
2882
2883       break;
2884
2885     case INTRINSIC_NOT:
2886     case INTRINSIC_UPLUS:
2887     case INTRINSIC_UMINUS:
2888     case INTRINSIC_PARENTHESES:
2889       e->rank = op1->rank;
2890
2891       if (e->shape == NULL)
2892         e->shape = gfc_copy_shape (op1->shape, op1->rank);
2893
2894       /* Simply copy arrayness attribute */
2895       break;
2896
2897     default:
2898       break;
2899     }
2900
2901   /* Attempt to simplify the expression.  */
2902   if (t == SUCCESS)
2903     {
2904       t = gfc_simplify_expr (e, 0);
2905       /* Some calls do not succeed in simplification and return FAILURE
2906          even though there is no error; eg. variable references to
2907          PARAMETER arrays.  */
2908       if (!gfc_is_constant_expr (e))
2909         t = SUCCESS;
2910     }
2911   return t;
2912
2913 bad_op:
2914
2915   if (gfc_extend_expr (e) == SUCCESS)
2916     return SUCCESS;
2917
2918   if (dual_locus_error)
2919     gfc_error (msg, &op1->where, &op2->where);
2920   else
2921     gfc_error (msg, &e->where);
2922
2923   return FAILURE;
2924 }
2925
2926
2927 /************** Array resolution subroutines **************/
2928
2929 typedef enum
2930 { CMP_LT, CMP_EQ, CMP_GT, CMP_UNKNOWN }
2931 comparison;
2932
2933 /* Compare two integer expressions.  */
2934
2935 static comparison
2936 compare_bound (gfc_expr *a, gfc_expr *b)
2937 {
2938   int i;
2939
2940   if (a == NULL || a->expr_type != EXPR_CONSTANT
2941       || b == NULL || b->expr_type != EXPR_CONSTANT)
2942     return CMP_UNKNOWN;
2943
2944   if (a->ts.type != BT_INTEGER || b->ts.type != BT_INTEGER)
2945     gfc_internal_error ("compare_bound(): Bad expression");
2946
2947   i = mpz_cmp (a->value.integer, b->value.integer);
2948
2949   if (i < 0)
2950     return CMP_LT;
2951   if (i > 0)
2952     return CMP_GT;
2953   return CMP_EQ;
2954 }
2955
2956
2957 /* Compare an integer expression with an integer.  */
2958
2959 static comparison
2960 compare_bound_int (gfc_expr *a, int b)
2961 {
2962   int i;
2963
2964   if (a == NULL || a->expr_type != EXPR_CONSTANT)
2965     return CMP_UNKNOWN;
2966
2967   if (a->ts.type != BT_INTEGER)
2968     gfc_internal_error ("compare_bound_int(): Bad expression");
2969
2970   i = mpz_cmp_si (a->value.integer, b);
2971
2972   if (i < 0)
2973     return CMP_LT;
2974   if (i > 0)
2975     return CMP_GT;
2976   return CMP_EQ;
2977 }
2978
2979
2980 /* Compare an integer expression with a mpz_t.  */
2981
2982 static comparison
2983 compare_bound_mpz_t (gfc_expr *a, mpz_t b)
2984 {
2985   int i;
2986
2987   if (a == NULL || a->expr_type != EXPR_CONSTANT)
2988     return CMP_UNKNOWN;
2989
2990   if (a->ts.type != BT_INTEGER)
2991     gfc_internal_error ("compare_bound_int(): Bad expression");
2992
2993   i = mpz_cmp (a->value.integer, b);
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 /* Compute the last value of a sequence given by a triplet.  
3004    Return 0 if it wasn't able to compute the last value, or if the
3005    sequence if empty, and 1 otherwise.  */
3006
3007 static int
3008 compute_last_value_for_triplet (gfc_expr *start, gfc_expr *end,
3009                                 gfc_expr *stride, mpz_t last)
3010 {
3011   mpz_t rem;
3012
3013   if (start == NULL || start->expr_type != EXPR_CONSTANT
3014       || end == NULL || end->expr_type != EXPR_CONSTANT
3015       || (stride != NULL && stride->expr_type != EXPR_CONSTANT))
3016     return 0;
3017
3018   if (start->ts.type != BT_INTEGER || end->ts.type != BT_INTEGER
3019       || (stride != NULL && stride->ts.type != BT_INTEGER))
3020     return 0;
3021
3022   if (stride == NULL || compare_bound_int(stride, 1) == CMP_EQ)
3023     {
3024       if (compare_bound (start, end) == CMP_GT)
3025         return 0;
3026       mpz_set (last, end->value.integer);
3027       return 1;
3028     }
3029
3030   if (compare_bound_int (stride, 0) == CMP_GT)
3031     {
3032       /* Stride is positive */
3033       if (mpz_cmp (start->value.integer, end->value.integer) > 0)
3034         return 0;
3035     }
3036   else
3037     {
3038       /* Stride is negative */
3039       if (mpz_cmp (start->value.integer, end->value.integer) < 0)
3040         return 0;
3041     }
3042
3043   mpz_init (rem);
3044   mpz_sub (rem, end->value.integer, start->value.integer);
3045   mpz_tdiv_r (rem, rem, stride->value.integer);
3046   mpz_sub (last, end->value.integer, rem);
3047   mpz_clear (rem);
3048
3049   return 1;
3050 }
3051
3052
3053 /* Compare a single dimension of an array reference to the array
3054    specification.  */
3055
3056 static try
3057 check_dimension (int i, gfc_array_ref *ar, gfc_array_spec *as)
3058 {
3059   mpz_t last_value;
3060
3061 /* Given start, end and stride values, calculate the minimum and
3062    maximum referenced indexes.  */
3063
3064   switch (ar->type)
3065     {
3066     case AR_FULL:
3067       break;
3068
3069     case AR_ELEMENT:
3070       if (compare_bound (ar->start[i], as->lower[i]) == CMP_LT)
3071         goto bound;
3072       if (compare_bound (ar->start[i], as->upper[i]) == CMP_GT)
3073         goto bound;
3074
3075       break;
3076
3077     case AR_SECTION:
3078       {
3079 #define AR_START (ar->start[i] ? ar->start[i] : as->lower[i])
3080 #define AR_END (ar->end[i] ? ar->end[i] : as->upper[i])
3081
3082         comparison comp_start_end = compare_bound (AR_START, AR_END);
3083
3084         /* Check for zero stride, which is not allowed.  */
3085         if (compare_bound_int (ar->stride[i], 0) == CMP_EQ)
3086           {
3087             gfc_error ("Illegal stride of zero at %L", &ar->c_where[i]);
3088             return FAILURE;
3089           }
3090
3091         /* if start == len || (stride > 0 && start < len)
3092                            || (stride < 0 && start > len),
3093            then the array section contains at least one element.  In this
3094            case, there is an out-of-bounds access if
3095            (start < lower || start > upper).  */
3096         if (compare_bound (AR_START, AR_END) == CMP_EQ
3097             || ((compare_bound_int (ar->stride[i], 0) == CMP_GT
3098                  || ar->stride[i] == NULL) && comp_start_end == CMP_LT)
3099             || (compare_bound_int (ar->stride[i], 0) == CMP_LT
3100                 && comp_start_end == CMP_GT))
3101           {
3102             if (compare_bound (AR_START, as->lower[i]) == CMP_LT
3103                 || compare_bound (AR_START, as->upper[i]) == CMP_GT)
3104               goto bound;
3105           }
3106
3107         /* If we can compute the highest index of the array section,
3108            then it also has to be between lower and upper.  */
3109         mpz_init (last_value);
3110         if (compute_last_value_for_triplet (AR_START, AR_END, ar->stride[i],
3111                                             last_value))
3112           {
3113             if (compare_bound_mpz_t (as->lower[i], last_value) == CMP_GT
3114                 || compare_bound_mpz_t (as->upper[i], last_value) == CMP_LT)
3115               {
3116                 mpz_clear (last_value);
3117                 goto bound;
3118               }
3119           }
3120         mpz_clear (last_value);
3121
3122 #undef AR_START
3123 #undef AR_END
3124       }
3125       break;
3126
3127     default:
3128       gfc_internal_error ("check_dimension(): Bad array reference");
3129     }
3130
3131   return SUCCESS;
3132
3133 bound:
3134   gfc_warning ("Array reference at %L is out of bounds", &ar->c_where[i]);
3135   return SUCCESS;
3136 }
3137
3138
3139 /* Compare an array reference with an array specification.  */
3140
3141 static try
3142 compare_spec_to_ref (gfc_array_ref *ar)
3143 {
3144   gfc_array_spec *as;
3145   int i;
3146
3147   as = ar->as;
3148   i = as->rank - 1;
3149   /* TODO: Full array sections are only allowed as actual parameters.  */
3150   if (as->type == AS_ASSUMED_SIZE
3151       && (/*ar->type == AR_FULL
3152           ||*/ (ar->type == AR_SECTION
3153               && ar->dimen_type[i] == DIMEN_RANGE && ar->end[i] == NULL)))
3154     {
3155       gfc_error ("Rightmost upper bound of assumed size array section "
3156                  "not specified at %L", &ar->where);
3157       return FAILURE;
3158     }
3159
3160   if (ar->type == AR_FULL)
3161     return SUCCESS;
3162
3163   if (as->rank != ar->dimen)
3164     {
3165       gfc_error ("Rank mismatch in array reference at %L (%d/%d)",
3166                  &ar->where, ar->dimen, as->rank);
3167       return FAILURE;
3168     }
3169
3170   for (i = 0; i < as->rank; i++)
3171     if (check_dimension (i, ar, as) == FAILURE)
3172       return FAILURE;
3173
3174   return SUCCESS;
3175 }
3176
3177
3178 /* Resolve one part of an array index.  */
3179
3180 try
3181 gfc_resolve_index (gfc_expr *index, int check_scalar)
3182 {
3183   gfc_typespec ts;
3184
3185   if (index == NULL)
3186     return SUCCESS;
3187
3188   if (gfc_resolve_expr (index) == FAILURE)
3189     return FAILURE;
3190
3191   if (check_scalar && index->rank != 0)
3192     {
3193       gfc_error ("Array index at %L must be scalar", &index->where);
3194       return FAILURE;
3195     }
3196
3197   if (index->ts.type != BT_INTEGER && index->ts.type != BT_REAL)
3198     {
3199       gfc_error ("Array index at %L must be of INTEGER type",
3200                  &index->where);
3201       return FAILURE;
3202     }
3203
3204   if (index->ts.type == BT_REAL)
3205     if (gfc_notify_std (GFC_STD_LEGACY, "Extension: REAL array index at %L",
3206                         &index->where) == FAILURE)
3207       return FAILURE;
3208
3209   if (index->ts.kind != gfc_index_integer_kind
3210       || index->ts.type != BT_INTEGER)
3211     {
3212       gfc_clear_ts (&ts);
3213       ts.type = BT_INTEGER;
3214       ts.kind = gfc_index_integer_kind;
3215
3216       gfc_convert_type_warn (index, &ts, 2, 0);
3217     }
3218
3219   return SUCCESS;
3220 }
3221
3222 /* Resolve a dim argument to an intrinsic function.  */
3223
3224 try
3225 gfc_resolve_dim_arg (gfc_expr *dim)
3226 {
3227   if (dim == NULL)
3228     return SUCCESS;
3229
3230   if (gfc_resolve_expr (dim) == FAILURE)
3231     return FAILURE;
3232
3233   if (dim->rank != 0)
3234     {
3235       gfc_error ("Argument dim at %L must be scalar", &dim->where);
3236       return FAILURE;
3237
3238     }
3239   if (dim->ts.type != BT_INTEGER)
3240     {
3241       gfc_error ("Argument dim at %L must be of INTEGER type", &dim->where);
3242       return FAILURE;
3243     }
3244   if (dim->ts.kind != gfc_index_integer_kind)
3245     {
3246       gfc_typespec ts;
3247
3248       ts.type = BT_INTEGER;
3249       ts.kind = gfc_index_integer_kind;
3250
3251       gfc_convert_type_warn (dim, &ts, 2, 0);
3252     }
3253
3254   return SUCCESS;
3255 }
3256
3257 /* Given an expression that contains array references, update those array
3258    references to point to the right array specifications.  While this is
3259    filled in during matching, this information is difficult to save and load
3260    in a module, so we take care of it here.
3261
3262    The idea here is that the original array reference comes from the
3263    base symbol.  We traverse the list of reference structures, setting
3264    the stored reference to references.  Component references can
3265    provide an additional array specification.  */
3266
3267 static void
3268 find_array_spec (gfc_expr *e)
3269 {
3270   gfc_array_spec *as;
3271   gfc_component *c;
3272   gfc_symbol *derived;
3273   gfc_ref *ref;
3274
3275   as = e->symtree->n.sym->as;
3276   derived = NULL;
3277
3278   for (ref = e->ref; ref; ref = ref->next)
3279     switch (ref->type)
3280       {
3281       case REF_ARRAY:
3282         if (as == NULL)
3283           gfc_internal_error ("find_array_spec(): Missing spec");
3284
3285         ref->u.ar.as = as;
3286         as = NULL;
3287         break;
3288
3289       case REF_COMPONENT:
3290         if (derived == NULL)
3291           derived = e->symtree->n.sym->ts.derived;
3292
3293         c = derived->components;
3294
3295         for (; c; c = c->next)
3296           if (c == ref->u.c.component)
3297             {
3298               /* Track the sequence of component references.  */
3299               if (c->ts.type == BT_DERIVED)
3300                 derived = c->ts.derived;
3301               break;
3302             }
3303
3304         if (c == NULL)
3305           gfc_internal_error ("find_array_spec(): Component not found");
3306
3307         if (c->dimension)
3308           {
3309             if (as != NULL)
3310               gfc_internal_error ("find_array_spec(): unused as(1)");
3311             as = c->as;
3312           }
3313
3314         break;
3315
3316       case REF_SUBSTRING:
3317         break;
3318       }
3319
3320   if (as != NULL)
3321     gfc_internal_error ("find_array_spec(): unused as(2)");
3322 }
3323
3324
3325 /* Resolve an array reference.  */
3326
3327 static try
3328 resolve_array_ref (gfc_array_ref *ar)
3329 {
3330   int i, check_scalar;
3331   gfc_expr *e;
3332
3333   for (i = 0; i < ar->dimen; i++)
3334     {
3335       check_scalar = ar->dimen_type[i] == DIMEN_RANGE;
3336
3337       if (gfc_resolve_index (ar->start[i], check_scalar) == FAILURE)
3338         return FAILURE;
3339       if (gfc_resolve_index (ar->end[i], check_scalar) == FAILURE)
3340         return FAILURE;
3341       if (gfc_resolve_index (ar->stride[i], check_scalar) == FAILURE)
3342         return FAILURE;
3343
3344       e = ar->start[i];
3345
3346       if (ar->dimen_type[i] == DIMEN_UNKNOWN)
3347         switch (e->rank)
3348           {
3349           case 0:
3350             ar->dimen_type[i] = DIMEN_ELEMENT;
3351             break;
3352
3353           case 1:
3354             ar->dimen_type[i] = DIMEN_VECTOR;
3355             if (e->expr_type == EXPR_VARIABLE
3356                 && e->symtree->n.sym->ts.type == BT_DERIVED)
3357               ar->start[i] = gfc_get_parentheses (e);
3358             break;
3359
3360           default:
3361             gfc_error ("Array index at %L is an array of rank %d",
3362                        &ar->c_where[i], e->rank);
3363             return FAILURE;
3364           }
3365     }
3366
3367   /* If the reference type is unknown, figure out what kind it is.  */
3368
3369   if (ar->type == AR_UNKNOWN)
3370     {
3371       ar->type = AR_ELEMENT;
3372       for (i = 0; i < ar->dimen; i++)
3373         if (ar->dimen_type[i] == DIMEN_RANGE
3374             || ar->dimen_type[i] == DIMEN_VECTOR)
3375           {
3376             ar->type = AR_SECTION;
3377             break;
3378           }
3379     }
3380
3381   if (!ar->as->cray_pointee && compare_spec_to_ref (ar) == FAILURE)
3382     return FAILURE;
3383
3384   return SUCCESS;
3385 }
3386
3387
3388 static try
3389 resolve_substring (gfc_ref *ref)
3390 {
3391   if (ref->u.ss.start != NULL)
3392     {
3393       if (gfc_resolve_expr (ref->u.ss.start) == FAILURE)
3394         return FAILURE;
3395
3396       if (ref->u.ss.start->ts.type != BT_INTEGER)
3397         {
3398           gfc_error ("Substring start index at %L must be of type INTEGER",
3399                      &ref->u.ss.start->where);
3400           return FAILURE;
3401         }
3402
3403       if (ref->u.ss.start->rank != 0)
3404         {
3405           gfc_error ("Substring start index at %L must be scalar",
3406                      &ref->u.ss.start->where);
3407           return FAILURE;
3408         }
3409
3410       if (compare_bound_int (ref->u.ss.start, 1) == CMP_LT
3411           && (compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_EQ
3412               || compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_GT))
3413         {
3414           gfc_error ("Substring start index at %L is less than one",
3415                      &ref->u.ss.start->where);
3416           return FAILURE;
3417         }
3418     }
3419
3420   if (ref->u.ss.end != NULL)
3421     {
3422       if (gfc_resolve_expr (ref->u.ss.end) == FAILURE)
3423         return FAILURE;
3424
3425       if (ref->u.ss.end->ts.type != BT_INTEGER)
3426         {
3427           gfc_error ("Substring end index at %L must be of type INTEGER",
3428                      &ref->u.ss.end->where);
3429           return FAILURE;
3430         }
3431
3432       if (ref->u.ss.end->rank != 0)
3433         {
3434           gfc_error ("Substring end index at %L must be scalar",
3435                      &ref->u.ss.end->where);
3436           return FAILURE;
3437         }
3438
3439       if (ref->u.ss.length != NULL
3440           && compare_bound (ref->u.ss.end, ref->u.ss.length->length) == CMP_GT
3441           && (compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_EQ
3442               || compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_GT))
3443         {
3444           gfc_error ("Substring end index at %L exceeds the string length",
3445                      &ref->u.ss.start->where);
3446           return FAILURE;
3447         }
3448     }
3449
3450   return SUCCESS;
3451 }
3452
3453
3454 /* Resolve subtype references.  */
3455
3456 static try
3457 resolve_ref (gfc_expr *expr)
3458 {
3459   int current_part_dimension, n_components, seen_part_dimension;
3460   gfc_ref *ref;
3461
3462   for (ref = expr->ref; ref; ref = ref->next)
3463     if (ref->type == REF_ARRAY && ref->u.ar.as == NULL)
3464       {
3465         find_array_spec (expr);
3466