]> gcc.gnu.org Git - gcc.git/blame - gcc/fortran/resolve.c
git://gcc.gnu.org / gcc.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
Update FSF address.
[gcc.git] / gcc / fortran / resolve.c
CommitLineData
6de9cd9a 1/* Perform type resolution on the various stuctures.
35e4be35 2 Copyright (C) 2001, 2002, 2003, 2004, 2005 Free Software Foundation, Inc.
6de9cd9a
DN		 3 Contributed by Andy Vaught
4
9fc4d79b 5This file is part of GCC.
6de9cd9a 6
9fc4d79b
TS		 7GCC is free software; you can redistribute it and/or modify it under
8the terms of the GNU General Public License as published by the Free
9Software Foundation; either version 2, or (at your option) any later
10version.
6de9cd9a 11
9fc4d79b
TS		 12GCC is distributed in the hope that it will be useful, but WITHOUT ANY
13WARRANTY; without even the implied warranty of MERCHANTABILITY or
14FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
15for more details.
6de9cd9a
DN		 16
17You should have received a copy of the GNU General Public License
9fc4d79b 18along with GCC; see the file COPYING. If not, write to the Free
ab57747b
KC		 19Software Foundation, 51 Franklin Street, Fifth Floor,Boston, MA
2002110-1301, USA. */
6de9cd9a 21
d22e4895 22
6de9cd9a 23#include "config.h"
d22e4895 24#include "system.h"
6de9cd9a
DN		 25#include "gfortran.h"
26#include "arith.h" /* For gfc_compare_expr(). */
d22e4895 27
6de9cd9a
DN		 28
29/* Stack to push the current if we descend into a block during
30 resolution. See resolve_branch() and resolve_code(). */
31
32typedef struct code_stack
33{
34 struct gfc_code *head, *current;
35 struct code_stack *prev;
36}
37code_stack;
38
39static code_stack *cs_base = NULL;
40
41
42/* Nonzero if we're inside a FORALL block */
43
44static int forall_flag;
45
46/* Resolve types of formal argument lists. These have to be done early so that
47 the formal argument lists of module procedures can be copied to the
48 containing module before the individual procedures are resolved
49 individually. We also resolve argument lists of procedures in interface
50 blocks because they are self-contained scoping units.
51
52 Since a dummy argument cannot be a non-dummy procedure, the only
53 resort left for untyped names are the IMPLICIT types. */
54
55static void
56resolve_formal_arglist (gfc_symbol * proc)
57{
58 gfc_formal_arglist *f;
59 gfc_symbol *sym;
60 int i;
61
62 /* TODO: Procedures whose return character length parameter is not constant
63 or assumed must also have explicit interfaces. */
64 if (proc->result != NULL)
65 sym = proc->result;
66 else
67 sym = proc;
68
69 if (gfc_elemental (proc)
70 || sym->attr.pointer || sym->attr.allocatable
71 || (sym->as && sym->as->rank > 0))
72 proc->attr.always_explicit = 1;
73
74 for (f = proc->formal; f; f = f->next)
75 {
76 sym = f->sym;
77
78 if (sym == NULL)
79 {
80 /* Alternate return placeholder. */
81 if (gfc_elemental (proc))
82 gfc_error ("Alternate return specifier in elemental subroutine "
83 "'%s' at %L is not allowed", proc->name,
84 &proc->declared_at);
85 if (proc->attr.function)
86 gfc_error ("Alternate return specifier in function "
87 "'%s' at %L is not allowed", proc->name,
88 &proc->declared_at);
89 continue;
90 }
91
92 if (sym->attr.if_source != IFSRC_UNKNOWN)
93 resolve_formal_arglist (sym);
94
95 if (sym->attr.subroutine || sym->attr.external || sym->attr.intrinsic)
96 {
97 if (gfc_pure (proc) && !gfc_pure (sym))
98 {
99 gfc_error
100 ("Dummy procedure '%s' of PURE procedure at %L must also "
101 "be PURE", sym->name, &sym->declared_at);
102 continue;
103 }
104
105 if (gfc_elemental (proc))
106 {
107 gfc_error
108 ("Dummy procedure at %L not allowed in ELEMENTAL procedure",
109 &sym->declared_at);
110 continue;
111 }
112
113 continue;
114 }
115
116 if (sym->ts.type == BT_UNKNOWN)
117 {
118 if (!sym->attr.function || sym->result == sym)
119 gfc_set_default_type (sym, 1, sym->ns);
120 else
121 {
122 /* Set the type of the RESULT, then copy. */
123 if (sym->result->ts.type == BT_UNKNOWN)
124 gfc_set_default_type (sym->result, 1, sym->result->ns);
125
126 sym->ts = sym->result->ts;
127 if (sym->as == NULL)
128 sym->as = gfc_copy_array_spec (sym->result->as);
129 }
130 }
131
132 gfc_resolve_array_spec (sym->as, 0);
133
134 /* We can't tell if an array with dimension (:) is assumed or deferred
135 shape until we know if it has the pointer or allocatable attributes.
136 */
137 if (sym->as && sym->as->rank > 0 && sym->as->type == AS_DEFERRED
138 && !(sym->attr.pointer || sym->attr.allocatable))
139 {
140 sym->as->type = AS_ASSUMED_SHAPE;
141 for (i = 0; i < sym->as->rank; i++)
142 sym->as->lower[i] = gfc_int_expr (1);
143 }
144
145 if ((sym->as && sym->as->rank > 0 && sym->as->type == AS_ASSUMED_SHAPE)
146 || sym->attr.pointer || sym->attr.allocatable || sym->attr.target
147 || sym->attr.optional)
148 proc->attr.always_explicit = 1;
149
150 /* If the flavor is unknown at this point, it has to be a variable.
151 A procedure specification would have already set the type. */
152
153 if (sym->attr.flavor == FL_UNKNOWN)
231b2fcc 154 gfc_add_flavor (&sym->attr, FL_VARIABLE, sym->name, &sym->declared_at);
6de9cd9a
DN		 155
156 if (gfc_pure (proc))
157 {
158 if (proc->attr.function && !sym->attr.pointer
159 && sym->attr.flavor != FL_PROCEDURE
160 && sym->attr.intent != INTENT_IN)
161
162 gfc_error ("Argument '%s' of pure function '%s' at %L must be "
163 "INTENT(IN)", sym->name, proc->name,
164 &sym->declared_at);
165
166 if (proc->attr.subroutine && !sym->attr.pointer
167 && sym->attr.intent == INTENT_UNKNOWN)
168
169 gfc_error
170 ("Argument '%s' of pure subroutine '%s' at %L must have "
171 "its INTENT specified", sym->name, proc->name,
172 &sym->declared_at);
173 }
174
175
176 if (gfc_elemental (proc))
177 {
178 if (sym->as != NULL)
179 {
180 gfc_error
181 ("Argument '%s' of elemental procedure at %L must be scalar",
182 sym->name, &sym->declared_at);
183 continue;
184 }
185
186 if (sym->attr.pointer)
187 {
188 gfc_error
189 ("Argument '%s' of elemental procedure at %L cannot have "
190 "the POINTER attribute", sym->name, &sym->declared_at);
191 continue;
192 }
193 }
194
195 /* Each dummy shall be specified to be scalar. */
196 if (proc->attr.proc == PROC_ST_FUNCTION)
197 {
198 if (sym->as != NULL)
199 {
200 gfc_error
201 ("Argument '%s' of statement function at %L must be scalar",
202 sym->name, &sym->declared_at);
203 continue;
204 }
205
206 if (sym->ts.type == BT_CHARACTER)
207 {
208 gfc_charlen *cl = sym->ts.cl;
209 if (!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT)
210 {
211 gfc_error
212 ("Character-valued argument '%s' of statement function at "
213 "%L must has constant length",
214 sym->name, &sym->declared_at);
215 continue;
216 }
217 }
218 }
219 }
220}
221
222
223/* Work function called when searching for symbols that have argument lists
224 associated with them. */
225
226static void
227find_arglists (gfc_symbol * sym)
228{
229
230 if (sym->attr.if_source == IFSRC_UNKNOWN || sym->ns != gfc_current_ns)
231 return;
232
233 resolve_formal_arglist (sym);
234}
235
236
237/* Given a namespace, resolve all formal argument lists within the namespace.
238 */
239
240static void
241resolve_formal_arglists (gfc_namespace * ns)
242{
243
244 if (ns == NULL)
245 return;
246
247 gfc_traverse_ns (ns, find_arglists);
248}
249
250
3d79abbd
PB		 251static void
252resolve_contained_fntype (gfc_symbol * sym, gfc_namespace * ns)
253{
254 try t;
255
256 /* If this namespace is not a function, ignore it. */
257 if (! sym
258 || !(sym->attr.function
259 || sym->attr.flavor == FL_VARIABLE))
260 return;
261
0dd973dd 262 /* Try to find out of what the return type is. */
3d79abbd
PB		 263 if (sym->result != NULL)
264 sym = sym->result;
265
266 if (sym->ts.type == BT_UNKNOWN)
267 {
0dd973dd 268 t = gfc_set_default_type (sym, 0, ns);
3d79abbd 269
cf4d246b
JJ		 270 if (t == FAILURE && !sym->attr.untyped)
271 {
272 gfc_error ("Contained function '%s' at %L has no IMPLICIT type",
273 sym->name, &sym->declared_at); /* FIXME */
274 sym->attr.untyped = 1;
275 }
3d79abbd
PB		 276 }
277}
278
279
280/* Add NEW_ARGS to the formal argument list of PROC, taking care not to
f7b529fa 281 introduce duplicates. */
3d79abbd
PB		 282
283static void
284merge_argument_lists (gfc_symbol *proc, gfc_formal_arglist *new_args)
285{
286 gfc_formal_arglist *f, *new_arglist;
287 gfc_symbol *new_sym;
288
289 for (; new_args != NULL; new_args = new_args->next)
290 {
291 new_sym = new_args->sym;
292 /* See if ths arg is already in the formal argument list. */
293 for (f = proc->formal; f; f = f->next)
294 {
295 if (new_sym == f->sym)
296 break;
297 }
298
299 if (f)
300 continue;
301
302 /* Add a new argument. Argument order is not important. */
303 new_arglist = gfc_get_formal_arglist ();
304 new_arglist->sym = new_sym;
305 new_arglist->next = proc->formal;
306 proc->formal = new_arglist;
307 }
308}
309
310
311/* Resolve alternate entry points. If a symbol has multiple entry points we
312 create a new master symbol for the main routine, and turn the existing
313 symbol into an entry point. */
314
315static void
316resolve_entries (gfc_namespace * ns)
317{
318 gfc_namespace *old_ns;
319 gfc_code *c;
320 gfc_symbol *proc;
321 gfc_entry_list *el;
322 char name[GFC_MAX_SYMBOL_LEN + 1];
323 static int master_count = 0;
324
325 if (ns->proc_name == NULL)
326 return;
327
328 /* No need to do anything if this procedure doesn't have alternate entry
329 points. */
330 if (!ns->entries)
331 return;
332
333 /* We may already have resolved alternate entry points. */
334 if (ns->proc_name->attr.entry_master)
335 return;
336
f7b529fa 337 /* If this isn't a procedure something has gone horribly wrong. */
6e45f57b 338 gcc_assert (ns->proc_name->attr.flavor == FL_PROCEDURE);
3d79abbd
PB		 339
340 /* Remember the current namespace. */
341 old_ns = gfc_current_ns;
342
343 gfc_current_ns = ns;
344
345 /* Add the main entry point to the list of entry points. */
346 el = gfc_get_entry_list ();
347 el->sym = ns->proc_name;
348 el->id = 0;
349 el->next = ns->entries;
350 ns->entries = el;
351 ns->proc_name->attr.entry = 1;
352
353 /* Add an entry statement for it. */
354 c = gfc_get_code ();
355 c->op = EXEC_ENTRY;
356 c->ext.entry = el;
357 c->next = ns->code;
358 ns->code = c;
359
360 /* Create a new symbol for the master function. */
361 /* Give the internal function a unique name (within this file).
7be7d41b
TS		 362 Also include the function name so the user has some hope of figuring
363 out what is going on. */
3d79abbd
PB		 364 snprintf (name, GFC_MAX_SYMBOL_LEN, "master.%d.%s",
365 master_count++, ns->proc_name->name);
3d79abbd 366 gfc_get_ha_symbol (name, &proc);
6e45f57b 367 gcc_assert (proc != NULL);
3d79abbd 368
231b2fcc 369 gfc_add_procedure (&proc->attr, PROC_INTERNAL, proc->name, NULL);
3d79abbd 370 if (ns->proc_name->attr.subroutine)
231b2fcc 371 gfc_add_subroutine (&proc->attr, proc->name, NULL);
3d79abbd
PB		 372 else
373 {
d198b59a
JJ		 374 gfc_symbol *sym;
375 gfc_typespec *ts, *fts;
376
231b2fcc 377 gfc_add_function (&proc->attr, proc->name, NULL);
d198b59a
JJ		 378 proc->result = proc;
379 fts = &ns->entries->sym->result->ts;
380 if (fts->type == BT_UNKNOWN)
381 fts = gfc_get_default_type (ns->entries->sym->result, NULL);
382 for (el = ns->entries->next; el; el = el->next)
383 {
384 ts = &el->sym->result->ts;
385 if (ts->type == BT_UNKNOWN)
386 ts = gfc_get_default_type (el->sym->result, NULL);
387 if (! gfc_compare_types (ts, fts)
388 || (el->sym->result->attr.dimension
389 != ns->entries->sym->result->attr.dimension)
390 || (el->sym->result->attr.pointer
391 != ns->entries->sym->result->attr.pointer))
392 break;
393 }
394
395 if (el == NULL)
396 {
397 sym = ns->entries->sym->result;
398 /* All result types the same. */
399 proc->ts = *fts;
400 if (sym->attr.dimension)
401 gfc_set_array_spec (proc, gfc_copy_array_spec (sym->as), NULL);
402 if (sym->attr.pointer)
403 gfc_add_pointer (&proc->attr, NULL);
404 }
405 else
406 {
407 /* Otherwise the result will be passed through an union by
408 reference. */
409 proc->attr.mixed_entry_master = 1;
410 for (el = ns->entries; el; el = el->next)
411 {
412 sym = el->sym->result;
413 if (sym->attr.dimension)
414 gfc_error ("%s result %s can't be an array in FUNCTION %s at %L",
415 el == ns->entries ? "FUNCTION" : "ENTRY", sym->name,
416 ns->entries->sym->name, &sym->declared_at);
417 else if (sym->attr.pointer)
418 gfc_error ("%s result %s can't be a POINTER in FUNCTION %s at %L",
419 el == ns->entries ? "FUNCTION" : "ENTRY", sym->name,
420 ns->entries->sym->name, &sym->declared_at);
421 else
422 {
423 ts = &sym->ts;
424 if (ts->type == BT_UNKNOWN)
425 ts = gfc_get_default_type (sym, NULL);
426 switch (ts->type)
427 {
428 case BT_INTEGER:
429 if (ts->kind == gfc_default_integer_kind)
430 sym = NULL;
431 break;
432 case BT_REAL:
433 if (ts->kind == gfc_default_real_kind
434 || ts->kind == gfc_default_double_kind)
435 sym = NULL;
436 break;
437 case BT_COMPLEX:
438 if (ts->kind == gfc_default_complex_kind)
439 sym = NULL;
440 break;
441 case BT_LOGICAL:
442 if (ts->kind == gfc_default_logical_kind)
443 sym = NULL;
444 break;
cf4d246b
JJ		 445 case BT_UNKNOWN:
446 /* We will issue error elsewhere. */
447 sym = NULL;
448 break;
d198b59a
JJ		 449 default:
450 break;
451 }
452 if (sym)
453 gfc_error ("%s result %s can't be of type %s in FUNCTION %s at %L",
454 el == ns->entries ? "FUNCTION" : "ENTRY", sym->name,
455 gfc_typename (ts), ns->entries->sym->name,
456 &sym->declared_at);
457 }
458 }
459 }
3d79abbd
PB		 460 }
461 proc->attr.access = ACCESS_PRIVATE;
462 proc->attr.entry_master = 1;
463
464 /* Merge all the entry point arguments. */
465 for (el = ns->entries; el; el = el->next)
466 merge_argument_lists (proc, el->sym->formal);
467
7be7d41b 468 /* Use the master function for the function body. */
3d79abbd
PB		 469 ns->proc_name = proc;
470
7be7d41b 471 /* Finalize the new symbols. */
3d79abbd
PB		 472 gfc_commit_symbols ();
473
474 /* Restore the original namespace. */
475 gfc_current_ns = old_ns;
476}
477
478
6de9cd9a
DN		 479/* Resolve contained function types. Because contained functions can call one
480 another, they have to be worked out before any of the contained procedures
481 can be resolved.
482
483 The good news is that if a function doesn't already have a type, the only
484 way it can get one is through an IMPLICIT type or a RESULT variable, because
485 by definition contained functions are contained namespace they're contained
486 in, not in a sibling or parent namespace. */
487
488static void
489resolve_contained_functions (gfc_namespace * ns)
490{
6de9cd9a 491 gfc_namespace *child;
3d79abbd 492 gfc_entry_list *el;
6de9cd9a
DN		 493
494 resolve_formal_arglists (ns);
495
496 for (child = ns->contained; child; child = child->sibling)
497 {
3d79abbd
PB		 498 /* Resolve alternate entry points first. */
499 resolve_entries (child);
6de9cd9a 500
3d79abbd
PB		 501 /* Then check function return types. */
502 resolve_contained_fntype (child->proc_name, child);
503 for (el = child->entries; el; el = el->next)
504 resolve_contained_fntype (el->sym, child);
6de9cd9a
DN		 505 }
506}
507
508
509/* Resolve all of the elements of a structure constructor and make sure that
f7b529fa 510 the types are correct. */
6de9cd9a
DN		 511
512static try
513resolve_structure_cons (gfc_expr * expr)
514{
515 gfc_constructor *cons;
516 gfc_component *comp;
517 try t;
518
519 t = SUCCESS;
520 cons = expr->value.constructor;
521 /* A constructor may have references if it is the result of substituting a
522 parameter variable. In this case we just pull out the component we
523 want. */
524 if (expr->ref)
525 comp = expr->ref->u.c.sym->components;
526 else
527 comp = expr->ts.derived->components;
528
529 for (; comp; comp = comp->next, cons = cons->next)
530 {
531 if (! cons->expr)
532 {
533 t = FAILURE;
534 continue;
535 }
536
537 if (gfc_resolve_expr (cons->expr) == FAILURE)
538 {
539 t = FAILURE;
540 continue;
541 }
542
543 /* If we don't have the right type, try to convert it. */
544
545 if (!gfc_compare_types (&cons->expr->ts, &comp->ts)
546 && gfc_convert_type (cons->expr, &comp->ts, 1) == FAILURE)
547 t = FAILURE;
548 }
549
550 return t;
551}
552
553
554
555/****************** Expression name resolution ******************/
556
557/* Returns 0 if a symbol was not declared with a type or
4f613946 558 attribute declaration statement, nonzero otherwise. */
6de9cd9a
DN		 559
560static int
561was_declared (gfc_symbol * sym)
562{
563 symbol_attribute a;
564
565 a = sym->attr;
566
567 if (!a.implicit_type && sym->ts.type != BT_UNKNOWN)
568 return 1;
569
9439ae41 570 if (a.allocatable || a.dimension || a.dummy || a.external || a.intrinsic
6de9cd9a
DN		 571 || a.optional || a.pointer || a.save || a.target
572 || a.access != ACCESS_UNKNOWN || a.intent != INTENT_UNKNOWN)
573 return 1;
574
575 return 0;
576}
577
578
579/* Determine if a symbol is generic or not. */
580
581static int
582generic_sym (gfc_symbol * sym)
583{
584 gfc_symbol *s;
585
586 if (sym->attr.generic ||
587 (sym->attr.intrinsic && gfc_generic_intrinsic (sym->name)))
588 return 1;
589
590 if (was_declared (sym) || sym->ns->parent == NULL)
591 return 0;
592
593 gfc_find_symbol (sym->name, sym->ns->parent, 1, &s);
594
595 return (s == NULL) ? 0 : generic_sym (s);
596}
597
598
599/* Determine if a symbol is specific or not. */
600
601static int
602specific_sym (gfc_symbol * sym)
603{
604 gfc_symbol *s;
605
606 if (sym->attr.if_source == IFSRC_IFBODY
607 || sym->attr.proc == PROC_MODULE
608 || sym->attr.proc == PROC_INTERNAL
609 || sym->attr.proc == PROC_ST_FUNCTION
610 || (sym->attr.intrinsic &&
611 gfc_specific_intrinsic (sym->name))
612 || sym->attr.external)
613 return 1;
614
615 if (was_declared (sym) || sym->ns->parent == NULL)
616 return 0;
617
618 gfc_find_symbol (sym->name, sym->ns->parent, 1, &s);
619
620 return (s == NULL) ? 0 : specific_sym (s);
621}
622
623
624/* Figure out if the procedure is specific, generic or unknown. */
625
626typedef enum
627{ PTYPE_GENERIC = 1, PTYPE_SPECIFIC, PTYPE_UNKNOWN }
628proc_type;
629
630static proc_type
631procedure_kind (gfc_symbol * sym)
632{
633
634 if (generic_sym (sym))
635 return PTYPE_GENERIC;
636
637 if (specific_sym (sym))
638 return PTYPE_SPECIFIC;
639
640 return PTYPE_UNKNOWN;
641}
642
643
644/* Resolve an actual argument list. Most of the time, this is just
645 resolving the expressions in the list.
646 The exception is that we sometimes have to decide whether arguments
647 that look like procedure arguments are really simple variable
648 references. */
649
650static try
651resolve_actual_arglist (gfc_actual_arglist * arg)
652{
653 gfc_symbol *sym;
654 gfc_symtree *parent_st;
655 gfc_expr *e;
656
657 for (; arg; arg = arg->next)
658 {
659
660 e = arg->expr;
661 if (e == NULL)
662 {
663 /* Check the label is a valid branching target. */
664 if (arg->label)
665 {
666 if (arg->label->defined == ST_LABEL_UNKNOWN)
667 {
668 gfc_error ("Label %d referenced at %L is never defined",
669 arg->label->value, &arg->label->where);
670 return FAILURE;
671 }
672 }
673 continue;
674 }
675
676 if (e->ts.type != BT_PROCEDURE)
677 {
678 if (gfc_resolve_expr (e) != SUCCESS)
679 return FAILURE;
680 continue;
681 }
682
683 /* See if the expression node should really be a variable
684 reference. */
685
686 sym = e->symtree->n.sym;
687
688 if (sym->attr.flavor == FL_PROCEDURE
689 || sym->attr.intrinsic
690 || sym->attr.external)
691 {
692
781e1004
FXC		 693 if (sym->attr.proc == PROC_ST_FUNCTION)
694 {
695 gfc_error ("Statement function '%s' at %L is not allowed as an "
696 "actual argument", sym->name, &e->where);
697 }
698
6de9cd9a
DN		 699 /* If the symbol is the function that names the current (or
700 parent) scope, then we really have a variable reference. */
701
702 if (sym->attr.function && sym->result == sym
703 && (sym->ns->proc_name == sym
704 || (sym->ns->parent != NULL
705 && sym->ns->parent->proc_name == sym)))
706 goto got_variable;
707
708 continue;
709 }
710
711 /* See if the name is a module procedure in a parent unit. */
712
713 if (was_declared (sym) || sym->ns->parent == NULL)
714 goto got_variable;
715
716 if (gfc_find_sym_tree (sym->name, sym->ns->parent, 1, &parent_st))
717 {
718 gfc_error ("Symbol '%s' at %L is ambiguous", sym->name, &e->where);
719 return FAILURE;
720 }
721
722 if (parent_st == NULL)
723 goto got_variable;
724
725 sym = parent_st->n.sym;
726 e->symtree = parent_st; /* Point to the right thing. */
727
728 if (sym->attr.flavor == FL_PROCEDURE
729 || sym->attr.intrinsic
730 || sym->attr.external)
731 {
732 continue;
733 }
734
735 got_variable:
736 e->expr_type = EXPR_VARIABLE;
737 e->ts = sym->ts;
738 if (sym->as != NULL)
739 {
740 e->rank = sym->as->rank;
741 e->ref = gfc_get_ref ();
742 e->ref->type = REF_ARRAY;
743 e->ref->u.ar.type = AR_FULL;
744 e->ref->u.ar.as = sym->as;
745 }
746 }
747
748 return SUCCESS;
749}
750
751
752/************* Function resolution *************/
753
754/* Resolve a function call known to be generic.
755 Section 14.1.2.4.1. */
756
757static match
758resolve_generic_f0 (gfc_expr * expr, gfc_symbol * sym)
759{
760 gfc_symbol *s;
761
762 if (sym->attr.generic)
763 {
764 s =
765 gfc_search_interface (sym->generic, 0, &expr->value.function.actual);
766 if (s != NULL)
767 {
768 expr->value.function.name = s->name;
769 expr->value.function.esym = s;
770 expr->ts = s->ts;
771 if (s->as != NULL)
772 expr->rank = s->as->rank;
773 return MATCH_YES;
774 }
775
776 /* TODO: Need to search for elemental references in generic interface */
777 }
778
779 if (sym->attr.intrinsic)
780 return gfc_intrinsic_func_interface (expr, 0);
781
782 return MATCH_NO;
783}
784
785
786static try
787resolve_generic_f (gfc_expr * expr)
788{
789 gfc_symbol *sym;
790 match m;
791
792 sym = expr->symtree->n.sym;
793
794 for (;;)
795 {
796 m = resolve_generic_f0 (expr, sym);
797 if (m == MATCH_YES)
798 return SUCCESS;
799 else if (m == MATCH_ERROR)
800 return FAILURE;
801
802generic:
803 if (sym->ns->parent == NULL)
804 break;
805 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
806
807 if (sym == NULL)
808 break;
809 if (!generic_sym (sym))
810 goto generic;
811 }
812
813 /* Last ditch attempt. */
814
815 if (!gfc_generic_intrinsic (expr->symtree->n.sym->name))
816 {
817 gfc_error ("Generic function '%s' at %L is not an intrinsic function",
818 expr->symtree->n.sym->name, &expr->where);
819 return FAILURE;
820 }
821
822 m = gfc_intrinsic_func_interface (expr, 0);
823 if (m == MATCH_YES)
824 return SUCCESS;
825 if (m == MATCH_NO)
826 gfc_error
827 ("Generic function '%s' at %L is not consistent with a specific "
828 "intrinsic interface", expr->symtree->n.sym->name, &expr->where);
829
830 return FAILURE;
831}
832
833
834/* Resolve a function call known to be specific. */
835
836static match
837resolve_specific_f0 (gfc_symbol * sym, gfc_expr * expr)
838{
839 match m;
840
841 if (sym->attr.external || sym->attr.if_source == IFSRC_IFBODY)
842 {
843 if (sym->attr.dummy)
844 {
845 sym->attr.proc = PROC_DUMMY;
846 goto found;
847 }
848
849 sym->attr.proc = PROC_EXTERNAL;
850 goto found;
851 }
852
853 if (sym->attr.proc == PROC_MODULE
854 || sym->attr.proc == PROC_ST_FUNCTION
855 || sym->attr.proc == PROC_INTERNAL)
856 goto found;
857
858 if (sym->attr.intrinsic)
859 {
860 m = gfc_intrinsic_func_interface (expr, 1);
861 if (m == MATCH_YES)
862 return MATCH_YES;
863 if (m == MATCH_NO)
864 gfc_error
865 ("Function '%s' at %L is INTRINSIC but is not compatible with "
866 "an intrinsic", sym->name, &expr->where);
867
868 return MATCH_ERROR;
869 }
870
871 return MATCH_NO;
872
873found:
874 gfc_procedure_use (sym, &expr->value.function.actual, &expr->where);
875
876 expr->ts = sym->ts;
877 expr->value.function.name = sym->name;
878 expr->value.function.esym = sym;
879 if (sym->as != NULL)
880 expr->rank = sym->as->rank;
881
882 return MATCH_YES;
883}
884
885
886static try
887resolve_specific_f (gfc_expr * expr)
888{
889 gfc_symbol *sym;
890 match m;
891
892 sym = expr->symtree->n.sym;
893
894 for (;;)
895 {
896 m = resolve_specific_f0 (sym, expr);
897 if (m == MATCH_YES)
898 return SUCCESS;
899 if (m == MATCH_ERROR)
900 return FAILURE;
901
902 if (sym->ns->parent == NULL)
903 break;
904
905 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
906
907 if (sym == NULL)
908 break;
909 }
910
911 gfc_error ("Unable to resolve the specific function '%s' at %L",
912 expr->symtree->n.sym->name, &expr->where);
913
914 return SUCCESS;
915}
916
917
918/* Resolve a procedure call not known to be generic nor specific. */
919
920static try
921resolve_unknown_f (gfc_expr * expr)
922{
923 gfc_symbol *sym;
924 gfc_typespec *ts;
925
926 sym = expr->symtree->n.sym;
927
928 if (sym->attr.dummy)
929 {
930 sym->attr.proc = PROC_DUMMY;
931 expr->value.function.name = sym->name;
932 goto set_type;
933 }
934
935 /* See if we have an intrinsic function reference. */
936
937 if (gfc_intrinsic_name (sym->name, 0))
938 {
939 if (gfc_intrinsic_func_interface (expr, 1) == MATCH_YES)
940 return SUCCESS;
941 return FAILURE;
942 }
943
944 /* The reference is to an external name. */
945
946 sym->attr.proc = PROC_EXTERNAL;
947 expr->value.function.name = sym->name;
948 expr->value.function.esym = expr->symtree->n.sym;
949
950 if (sym->as != NULL)
951 expr->rank = sym->as->rank;
952
953 /* Type of the expression is either the type of the symbol or the
954 default type of the symbol. */
955
956set_type:
957 gfc_procedure_use (sym, &expr->value.function.actual, &expr->where);
958
959 if (sym->ts.type != BT_UNKNOWN)
960 expr->ts = sym->ts;
961 else
962 {
963 ts = gfc_get_default_type (sym, sym->ns);
964
965 if (ts->type == BT_UNKNOWN)
966 {
cf4d246b 967 gfc_error ("Function '%s' at %L has no IMPLICIT type",
6de9cd9a
DN		 968 sym->name, &expr->where);
969 return FAILURE;
970 }
971 else
972 expr->ts = *ts;
973 }
974
975 return SUCCESS;
976}
977
978
2054fc29
VR		 979/* Figure out if a function reference is pure or not. Also set the name
980 of the function for a potential error message. Return nonzero if the
6de9cd9a
DN		 981 function is PURE, zero if not. */
982
983static int
6b25a558 984pure_function (gfc_expr * e, const char **name)
6de9cd9a
DN		 985{
986 int pure;
987
988 if (e->value.function.esym)
989 {
990 pure = gfc_pure (e->value.function.esym);
991 *name = e->value.function.esym->name;
992 }
993 else if (e->value.function.isym)
994 {
995 pure = e->value.function.isym->pure
996 || e->value.function.isym->elemental;
997 *name = e->value.function.isym->name;
998 }
999 else
1000 {
1001 /* Implicit functions are not pure. */
1002 pure = 0;
1003 *name = e->value.function.name;
1004 }
1005
1006 return pure;
1007}
1008
1009
1010/* Resolve a function call, which means resolving the arguments, then figuring
1011 out which entity the name refers to. */
1012/* TODO: Check procedure arguments so that an INTENT(IN) isn't passed
1013 to INTENT(OUT) or INTENT(INOUT). */
1014
1015static try
1016resolve_function (gfc_expr * expr)
1017{
1018 gfc_actual_arglist *arg;
6b25a558 1019 const char *name;
6de9cd9a
DN		 1020 try t;
1021
1022 if (resolve_actual_arglist (expr->value.function.actual) == FAILURE)
1023 return FAILURE;
1024
1025/* See if function is already resolved. */
1026
1027 if (expr->value.function.name != NULL)
1028 {
1029 if (expr->ts.type == BT_UNKNOWN)
1030 expr->ts = expr->symtree->n.sym->ts;
1031 t = SUCCESS;
1032 }
1033 else
1034 {
1035 /* Apply the rules of section 14.1.2. */
1036
1037 switch (procedure_kind (expr->symtree->n.sym))
1038 {
1039 case PTYPE_GENERIC:
1040 t = resolve_generic_f (expr);
1041 break;
1042
1043 case PTYPE_SPECIFIC:
1044 t = resolve_specific_f (expr);
1045 break;
1046
1047 case PTYPE_UNKNOWN:
1048 t = resolve_unknown_f (expr);
1049 break;
1050
1051 default:
1052 gfc_internal_error ("resolve_function(): bad function type");
1053 }
1054 }
1055
1056 /* If the expression is still a function (it might have simplified),
1057 then we check to see if we are calling an elemental function. */
1058
1059 if (expr->expr_type != EXPR_FUNCTION)
1060 return t;
1061
1062 if (expr->value.function.actual != NULL
1063 && ((expr->value.function.esym != NULL
1064 && expr->value.function.esym->attr.elemental)
1065 || (expr->value.function.isym != NULL
1066 && expr->value.function.isym->elemental)))
1067 {
1068
1069 /* The rank of an elemental is the rank of its array argument(s). */
1070
1071 for (arg = expr->value.function.actual; arg; arg = arg->next)
1072 {
1073 if (arg->expr != NULL && arg->expr->rank > 0)
1074 {
1075 expr->rank = arg->expr->rank;
1076 break;
1077 }
1078 }
1079 }
1080
1081 if (!pure_function (expr, &name))
1082 {
1083 if (forall_flag)
1084 {
1085 gfc_error
1086 ("Function reference to '%s' at %L is inside a FORALL block",
1087 name, &expr->where);
1088 t = FAILURE;
1089 }
1090 else if (gfc_pure (NULL))
1091 {
1092 gfc_error ("Function reference to '%s' at %L is to a non-PURE "
1093 "procedure within a PURE procedure", name, &expr->where);
1094 t = FAILURE;
1095 }
1096 }
1097
1098 return t;
1099}
1100
1101
1102/************* Subroutine resolution *************/
1103
1104static void
1105pure_subroutine (gfc_code * c, gfc_symbol * sym)
1106{
1107
1108 if (gfc_pure (sym))
1109 return;
1110
1111 if (forall_flag)
1112 gfc_error ("Subroutine call to '%s' in FORALL block at %L is not PURE",
1113 sym->name, &c->loc);
1114 else if (gfc_pure (NULL))
1115 gfc_error ("Subroutine call to '%s' at %L is not PURE", sym->name,
1116 &c->loc);
1117}
1118
1119
1120static match
1121resolve_generic_s0 (gfc_code * c, gfc_symbol * sym)
1122{
1123 gfc_symbol *s;
1124
1125 if (sym->attr.generic)
1126 {
1127 s = gfc_search_interface (sym->generic, 1, &c->ext.actual);
1128 if (s != NULL)
1129 {
1130 c->resolved_sym = s;
1131 pure_subroutine (c, s);
1132 return MATCH_YES;
1133 }
1134
1135 /* TODO: Need to search for elemental references in generic interface. */
1136 }
1137
1138 if (sym->attr.intrinsic)
1139 return gfc_intrinsic_sub_interface (c, 0);
1140
1141 return MATCH_NO;
1142}
1143
1144
1145static try
1146resolve_generic_s (gfc_code * c)
1147{
1148 gfc_symbol *sym;
1149 match m;
1150
1151 sym = c->symtree->n.sym;
1152
1153 m = resolve_generic_s0 (c, sym);
1154 if (m == MATCH_YES)
1155 return SUCCESS;
1156 if (m == MATCH_ERROR)
1157 return FAILURE;
1158
1159 if (sym->ns->parent != NULL)
1160 {
1161 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
1162 if (sym != NULL)
1163 {
1164 m = resolve_generic_s0 (c, sym);
1165 if (m == MATCH_YES)
1166 return SUCCESS;
1167 if (m == MATCH_ERROR)
1168 return FAILURE;
1169 }
1170 }
1171
1172 /* Last ditch attempt. */
1173
1174 if (!gfc_generic_intrinsic (sym->name))
1175 {
1176 gfc_error
1177 ("Generic subroutine '%s' at %L is not an intrinsic subroutine",
1178 sym->name, &c->loc);
1179 return FAILURE;
1180 }
1181
1182 m = gfc_intrinsic_sub_interface (c, 0);
1183 if (m == MATCH_YES)
1184 return SUCCESS;
1185 if (m == MATCH_NO)
1186 gfc_error ("Generic subroutine '%s' at %L is not consistent with an "
1187 "intrinsic subroutine interface", sym->name, &c->loc);
1188
1189 return FAILURE;
1190}
1191
1192
1193/* Resolve a subroutine call known to be specific. */
1194
1195static match
1196resolve_specific_s0 (gfc_code * c, gfc_symbol * sym)
1197{
1198 match m;
1199
1200 if (sym->attr.external || sym->attr.if_source == IFSRC_IFBODY)
1201 {
1202 if (sym->attr.dummy)
1203 {
1204 sym->attr.proc = PROC_DUMMY;
1205 goto found;
1206 }
1207
1208 sym->attr.proc = PROC_EXTERNAL;
1209 goto found;
1210 }
1211
1212 if (sym->attr.proc == PROC_MODULE || sym->attr.proc == PROC_INTERNAL)
1213 goto found;
1214
1215 if (sym->attr.intrinsic)
1216 {
1217 m = gfc_intrinsic_sub_interface (c, 1);
1218 if (m == MATCH_YES)
1219 return MATCH_YES;
1220 if (m == MATCH_NO)
1221 gfc_error ("Subroutine '%s' at %L is INTRINSIC but is not compatible "
1222 "with an intrinsic", sym->name, &c->loc);
1223
1224 return MATCH_ERROR;
1225 }
1226
1227 return MATCH_NO;
1228
1229found:
1230 gfc_procedure_use (sym, &c->ext.actual, &c->loc);
1231
1232 c->resolved_sym = sym;
1233 pure_subroutine (c, sym);
1234
1235 return MATCH_YES;
1236}
1237
1238
1239static try
1240resolve_specific_s (gfc_code * c)
1241{
1242 gfc_symbol *sym;
1243 match m;
1244
1245 sym = c->symtree->n.sym;
1246
1247 m = resolve_specific_s0 (c, sym);
1248 if (m == MATCH_YES)
1249 return SUCCESS;
1250 if (m == MATCH_ERROR)
1251 return FAILURE;
1252
1253 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
1254
1255 if (sym != NULL)
1256 {
1257 m = resolve_specific_s0 (c, sym);
1258 if (m == MATCH_YES)
1259 return SUCCESS;
1260 if (m == MATCH_ERROR)
1261 return FAILURE;
1262 }
1263
1264 gfc_error ("Unable to resolve the specific subroutine '%s' at %L",
1265 sym->name, &c->loc);
1266
1267 return FAILURE;
1268}
1269
1270
1271/* Resolve a subroutine call not known to be generic nor specific. */
1272
1273static try
1274resolve_unknown_s (gfc_code * c)
1275{
1276 gfc_symbol *sym;
1277
1278 sym = c->symtree->n.sym;
1279
1280 if (sym->attr.dummy)
1281 {
1282 sym->attr.proc = PROC_DUMMY;
1283 goto found;
1284 }
1285
1286 /* See if we have an intrinsic function reference. */
1287
1288 if (gfc_intrinsic_name (sym->name, 1))
1289 {
1290 if (gfc_intrinsic_sub_interface (c, 1) == MATCH_YES)
1291 return SUCCESS;
1292 return FAILURE;
1293 }
1294
1295 /* The reference is to an external name. */
1296
1297found:
1298 gfc_procedure_use (sym, &c->ext.actual, &c->loc);
1299
1300 c->resolved_sym = sym;
1301
1302 pure_subroutine (c, sym);
1303
1304 return SUCCESS;
1305}
1306
1307
1308/* Resolve a subroutine call. Although it was tempting to use the same code
1309 for functions, subroutines and functions are stored differently and this
1310 makes things awkward. */
1311
1312static try
1313resolve_call (gfc_code * c)
1314{
1315 try t;
1316
1317 if (resolve_actual_arglist (c->ext.actual) == FAILURE)
1318 return FAILURE;
1319
1320 if (c->resolved_sym != NULL)
1321 return SUCCESS;
1322
1323 switch (procedure_kind (c->symtree->n.sym))
1324 {
1325 case PTYPE_GENERIC:
1326 t = resolve_generic_s (c);
1327 break;
1328
1329 case PTYPE_SPECIFIC:
1330 t = resolve_specific_s (c);
1331 break;
1332
1333 case PTYPE_UNKNOWN:
1334 t = resolve_unknown_s (c);
1335 break;
1336
1337 default:
1338 gfc_internal_error ("resolve_subroutine(): bad function type");
1339 }
1340
1341 return t;
1342}
1343
2c5ed587
SK		 1344/* Compare the shapes of two arrays that have non-NULL shapes. If both
1345 op1->shape and op2->shape are non-NULL return SUCCESS if their shapes
1346 match. If both op1->shape and op2->shape are non-NULL return FAILURE
1347 if their shapes do not match. If either op1->shape or op2->shape is
1348 NULL, return SUCCESS. */
1349
1350static try
1351compare_shapes (gfc_expr * op1, gfc_expr * op2)
1352{
1353 try t;
1354 int i;
1355
1356 t = SUCCESS;
1357
1358 if (op1->shape != NULL && op2->shape != NULL)
1359 {
1360 for (i = 0; i < op1->rank; i++)
1361 {
1362 if (mpz_cmp (op1->shape[i], op2->shape[i]) != 0)
1363 {
1364 gfc_error ("Shapes for operands at %L and %L are not conformable",
1365 &op1->where, &op2->where);
1366 t = FAILURE;
1367 break;
1368 }
1369 }
1370 }
1371
1372 return t;
1373}
6de9cd9a
DN		 1374
1375/* Resolve an operator expression node. This can involve replacing the
1376 operation with a user defined function call. */
1377
1378static try
1379resolve_operator (gfc_expr * e)
1380{
1381 gfc_expr *op1, *op2;
1382 char msg[200];
1383 try t;
1384
1385 /* Resolve all subnodes-- give them types. */
1386
58b03ab2 1387 switch (e->value.op.operator)
6de9cd9a
DN		 1388 {
1389 default:
58b03ab2 1390 if (gfc_resolve_expr (e->value.op.op2) == FAILURE)
6de9cd9a
DN		 1391 return FAILURE;
1392
1393 /* Fall through... */
1394
1395 case INTRINSIC_NOT:
1396 case INTRINSIC_UPLUS:
1397 case INTRINSIC_UMINUS:
58b03ab2 1398 if (gfc_resolve_expr (e->value.op.op1) == FAILURE)
6de9cd9a
DN		 1399 return FAILURE;
1400 break;
1401 }
1402
1403 /* Typecheck the new node. */
1404
58b03ab2
TS		 1405 op1 = e->value.op.op1;
1406 op2 = e->value.op.op2;
6de9cd9a 1407
58b03ab2 1408 switch (e->value.op.operator)
6de9cd9a
DN		 1409 {
1410 case INTRINSIC_UPLUS:
1411 case INTRINSIC_UMINUS:
1412 if (op1->ts.type == BT_INTEGER
1413 || op1->ts.type == BT_REAL
1414 || op1->ts.type == BT_COMPLEX)
1415 {
1416 e->ts = op1->ts;
1417 break;
1418 }
1419
1420 sprintf (msg, "Operand of unary numeric operator '%s' at %%L is %s",
58b03ab2 1421 gfc_op2string (e->value.op.operator), gfc_typename (&e->ts));
6de9cd9a
DN		 1422 goto bad_op;
1423
1424 case INTRINSIC_PLUS:
1425 case INTRINSIC_MINUS:
1426 case INTRINSIC_TIMES:
1427 case INTRINSIC_DIVIDE:
1428 case INTRINSIC_POWER:
1429 if (gfc_numeric_ts (&op1->ts) && gfc_numeric_ts (&op2->ts))
1430 {
1431 gfc_type_convert_binary (e);
1432 break;
1433 }
1434
1435 sprintf (msg,
1436 "Operands of binary numeric operator '%s' at %%L are %s/%s",
58b03ab2 1437 gfc_op2string (e->value.op.operator), gfc_typename (&op1->ts),
6de9cd9a
DN		 1438 gfc_typename (&op2->ts));
1439 goto bad_op;
1440
1441 case INTRINSIC_CONCAT:
1442 if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER)
1443 {
1444 e->ts.type = BT_CHARACTER;
1445 e->ts.kind = op1->ts.kind;
1446 break;
1447 }
1448
1449 sprintf (msg,
1450 "Operands of string concatenation operator at %%L are %s/%s",
1451 gfc_typename (&op1->ts), gfc_typename (&op2->ts));
1452 goto bad_op;
1453
1454 case INTRINSIC_AND:
1455 case INTRINSIC_OR:
1456 case INTRINSIC_EQV:
1457 case INTRINSIC_NEQV:
1458 if (op1->ts.type == BT_LOGICAL && op2->ts.type == BT_LOGICAL)
1459 {
1460 e->ts.type = BT_LOGICAL;
1461 e->ts.kind = gfc_kind_max (op1, op2);
1462 if (op1->ts.kind < e->ts.kind)
1463 gfc_convert_type (op1, &e->ts, 2);
1464 else if (op2->ts.kind < e->ts.kind)
1465 gfc_convert_type (op2, &e->ts, 2);
1466 break;
1467 }
1468
1469 sprintf (msg, "Operands of logical operator '%s' at %%L are %s/%s",
58b03ab2 1470 gfc_op2string (e->value.op.operator), gfc_typename (&op1->ts),
6de9cd9a
DN		 1471 gfc_typename (&op2->ts));
1472
1473 goto bad_op;
1474
1475 case INTRINSIC_NOT:
1476 if (op1->ts.type == BT_LOGICAL)
1477 {
1478 e->ts.type = BT_LOGICAL;
1479 e->ts.kind = op1->ts.kind;
1480 break;
1481 }
1482
1483 sprintf (msg, "Operand of .NOT. operator at %%L is %s",
1484 gfc_typename (&op1->ts));
1485 goto bad_op;
1486
1487 case INTRINSIC_GT:
1488 case INTRINSIC_GE:
1489 case INTRINSIC_LT:
1490 case INTRINSIC_LE:
1491 if (op1->ts.type == BT_COMPLEX || op2->ts.type == BT_COMPLEX)
1492 {
1493 strcpy (msg, "COMPLEX quantities cannot be compared at %L");
1494 goto bad_op;
1495 }
1496
1497 /* Fall through... */
1498
1499 case INTRINSIC_EQ:
1500 case INTRINSIC_NE:
1501 if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER)
1502 {
1503 e->ts.type = BT_LOGICAL;
9d64df18 1504 e->ts.kind = gfc_default_logical_kind;
6de9cd9a
DN		 1505 break;
1506 }
1507
1508 if (gfc_numeric_ts (&op1->ts) && gfc_numeric_ts (&op2->ts))
1509 {
1510 gfc_type_convert_binary (e);
1511
1512 e->ts.type = BT_LOGICAL;
9d64df18 1513 e->ts.kind = gfc_default_logical_kind;
6de9cd9a
DN		 1514 break;
1515 }
1516
1517 sprintf (msg, "Operands of comparison operator '%s' at %%L are %s/%s",
58b03ab2 1518 gfc_op2string (e->value.op.operator), gfc_typename (&op1->ts),
6de9cd9a
DN		 1519 gfc_typename (&op2->ts));
1520
1521 goto bad_op;
1522
1523 case INTRINSIC_USER:
1524 if (op2 == NULL)
1525 sprintf (msg, "Operand of user operator '%s' at %%L is %s",
58b03ab2 1526 e->value.op.uop->name, gfc_typename (&op1->ts));
6de9cd9a
DN		 1527 else
1528 sprintf (msg, "Operands of user operator '%s' at %%L are %s/%s",
58b03ab2 1529 e->value.op.uop->name, gfc_typename (&op1->ts),
6de9cd9a
DN		 1530 gfc_typename (&op2->ts));
1531
1532 goto bad_op;
1533
1534 default:
1535 gfc_internal_error ("resolve_operator(): Bad intrinsic");
1536 }
1537
1538 /* Deal with arrayness of an operand through an operator. */
1539
1540 t = SUCCESS;
1541
58b03ab2 1542 switch (e->value.op.operator)
6de9cd9a
DN		 1543 {
1544 case INTRINSIC_PLUS:
1545 case INTRINSIC_MINUS:
1546 case INTRINSIC_TIMES:
1547 case INTRINSIC_DIVIDE:
1548 case INTRINSIC_POWER:
1549 case INTRINSIC_CONCAT:
1550 case INTRINSIC_AND:
1551 case INTRINSIC_OR:
1552 case INTRINSIC_EQV:
1553 case INTRINSIC_NEQV:
1554 case INTRINSIC_EQ:
1555 case INTRINSIC_NE:
1556 case INTRINSIC_GT:
1557 case INTRINSIC_GE:
1558 case INTRINSIC_LT:
1559 case INTRINSIC_LE:
1560
1561 if (op1->rank == 0 && op2->rank == 0)
1562 e->rank = 0;
1563
1564 if (op1->rank == 0 && op2->rank != 0)
1565 {
1566 e->rank = op2->rank;
1567
1568 if (e->shape == NULL)
1569 e->shape = gfc_copy_shape (op2->shape, op2->rank);
1570 }
1571
1572 if (op1->rank != 0 && op2->rank == 0)
1573 {
1574 e->rank = op1->rank;
1575
1576 if (e->shape == NULL)
1577 e->shape = gfc_copy_shape (op1->shape, op1->rank);
1578 }
1579
1580 if (op1->rank != 0 && op2->rank != 0)
1581 {
1582 if (op1->rank == op2->rank)
1583 {
1584 e->rank = op1->rank;
6de9cd9a 1585 if (e->shape == NULL)
2c5ed587
SK		 1586 {
1587 t = compare_shapes(op1, op2);
1588 if (t == FAILURE)
1589 e->shape = NULL;
1590 else
6de9cd9a 1591 e->shape = gfc_copy_shape (op1->shape, op1->rank);
2c5ed587 1592 }
6de9cd9a
DN		 1593 }
1594 else
1595 {
1596 gfc_error ("Inconsistent ranks for operator at %L and %L",
1597 &op1->where, &op2->where);
1598 t = FAILURE;
1599
1600 /* Allow higher level expressions to work. */
1601 e->rank = 0;
1602 }
1603 }
1604
1605 break;
1606
1607 case INTRINSIC_NOT:
1608 case INTRINSIC_UPLUS:
1609 case INTRINSIC_UMINUS:
1610 e->rank = op1->rank;
1611
1612 if (e->shape == NULL)
1613 e->shape = gfc_copy_shape (op1->shape, op1->rank);
1614
1615 /* Simply copy arrayness attribute */
1616 break;
1617
1618 default:
1619 break;
1620 }
1621
1622 /* Attempt to simplify the expression. */
1623 if (t == SUCCESS)
1624 t = gfc_simplify_expr (e, 0);
1625 return t;
1626
1627bad_op:
2c5ed587 1628
6de9cd9a
DN		 1629 if (gfc_extend_expr (e) == SUCCESS)
1630 return SUCCESS;
1631
1632 gfc_error (msg, &e->where);
2c5ed587 1633
6de9cd9a
DN		 1634 return FAILURE;
1635}
1636
1637
1638/************** Array resolution subroutines **************/
1639
1640
1641typedef enum
1642{ CMP_LT, CMP_EQ, CMP_GT, CMP_UNKNOWN }
1643comparison;
1644
1645/* Compare two integer expressions. */
1646
1647static comparison
1648compare_bound (gfc_expr * a, gfc_expr * b)
1649{
1650 int i;
1651
1652 if (a == NULL || a->expr_type != EXPR_CONSTANT
1653 || b == NULL || b->expr_type != EXPR_CONSTANT)
1654 return CMP_UNKNOWN;
1655
1656 if (a->ts.type != BT_INTEGER || b->ts.type != BT_INTEGER)
1657 gfc_internal_error ("compare_bound(): Bad expression");
1658
1659 i = mpz_cmp (a->value.integer, b->value.integer);
1660
1661 if (i < 0)
1662 return CMP_LT;
1663 if (i > 0)
1664 return CMP_GT;
1665 return CMP_EQ;
1666}
1667
1668
1669/* Compare an integer expression with an integer. */
1670
1671static comparison
1672compare_bound_int (gfc_expr * a, int b)
1673{
1674 int i;
1675
1676 if (a == NULL || a->expr_type != EXPR_CONSTANT)
1677 return CMP_UNKNOWN;
1678
1679 if (a->ts.type != BT_INTEGER)
1680 gfc_internal_error ("compare_bound_int(): Bad expression");
1681
1682 i = mpz_cmp_si (a->value.integer, b);
1683
1684 if (i < 0)
1685 return CMP_LT;
1686 if (i > 0)
1687 return CMP_GT;
1688 return CMP_EQ;
1689}
1690
1691
1692/* Compare a single dimension of an array reference to the array
1693 specification. */
1694
1695static try
1696check_dimension (int i, gfc_array_ref * ar, gfc_array_spec * as)
1697{
1698
1699/* Given start, end and stride values, calculate the minimum and
f7b529fa 1700 maximum referenced indexes. */
6de9cd9a
DN		 1701
1702 switch (ar->type)
1703 {
1704 case AR_FULL:
1705 break;
1706
1707 case AR_ELEMENT:
1708 if (compare_bound (ar->start[i], as->lower[i]) == CMP_LT)
1709 goto bound;
1710 if (compare_bound (ar->start[i], as->upper[i]) == CMP_GT)
1711 goto bound;
1712
1713 break;
1714
1715 case AR_SECTION:
1716 if (compare_bound_int (ar->stride[i], 0) == CMP_EQ)
1717 {
1718 gfc_error ("Illegal stride of zero at %L", &ar->c_where[i]);
1719 return FAILURE;
1720 }
1721
1722 if (compare_bound (ar->start[i], as->lower[i]) == CMP_LT)
1723 goto bound;
1724 if (compare_bound (ar->start[i], as->upper[i]) == CMP_GT)
1725 goto bound;
1726
1727 /* TODO: Possibly, we could warn about end[i] being out-of-bound although
f7b529fa 1728 it is legal (see 6.2.2.3.1). */
6de9cd9a
DN		 1729
1730 break;
1731
1732 default:
1733 gfc_internal_error ("check_dimension(): Bad array reference");
1734 }
1735
1736 return SUCCESS;
1737
1738bound:
1739 gfc_warning ("Array reference at %L is out of bounds", &ar->c_where[i]);
1740 return SUCCESS;
1741}
1742
1743
1744/* Compare an array reference with an array specification. */
1745
1746static try
1747compare_spec_to_ref (gfc_array_ref * ar)
1748{
1749 gfc_array_spec *as;
1750 int i;
1751
1752 as = ar->as;
1753 i = as->rank - 1;
1754 /* TODO: Full array sections are only allowed as actual parameters. */
1755 if (as->type == AS_ASSUMED_SIZE
1756 && (/*ar->type == AR_FULL
1757 ||*/ (ar->type == AR_SECTION
1758 && ar->dimen_type[i] == DIMEN_RANGE && ar->end[i] == NULL)))
1759 {
1760 gfc_error ("Rightmost upper bound of assumed size array section"
1761 " not specified at %L", &ar->where);
1762 return FAILURE;
1763 }
1764
1765 if (ar->type == AR_FULL)
1766 return SUCCESS;
1767
1768 if (as->rank != ar->dimen)
1769 {
1770 gfc_error ("Rank mismatch in array reference at %L (%d/%d)",
1771 &ar->where, ar->dimen, as->rank);
1772 return FAILURE;
1773 }
1774
1775 for (i = 0; i < as->rank; i++)
1776 if (check_dimension (i, ar, as) == FAILURE)
1777 return FAILURE;
1778
1779 return SUCCESS;
1780}
1781
1782
1783/* Resolve one part of an array index. */
1784
1785try
1786gfc_resolve_index (gfc_expr * index, int check_scalar)
1787{
1788 gfc_typespec ts;
1789
1790 if (index == NULL)
1791 return SUCCESS;
1792
1793 if (gfc_resolve_expr (index) == FAILURE)
1794 return FAILURE;
1795
ee943062 1796 if (check_scalar && index->rank != 0)
6de9cd9a 1797 {
ee943062 1798 gfc_error ("Array index at %L must be scalar", &index->where);
6de9cd9a
DN		 1799 return FAILURE;
1800 }
1801
ee943062 1802 if (index->ts.type != BT_INTEGER && index->ts.type != BT_REAL)
6de9cd9a 1803 {
ee943062
TS		 1804 gfc_error ("Array index at %L must be of INTEGER type",
1805 &index->where);
6de9cd9a
DN		 1806 return FAILURE;
1807 }
1808
ee943062
TS		 1809 if (index->ts.type == BT_REAL)
1810 if (gfc_notify_std (GFC_STD_GNU, "Extension: REAL array index at %L",
1811 &index->where) == FAILURE)
1812 return FAILURE;
1813
1814 if (index->ts.kind != gfc_index_integer_kind
1815 || index->ts.type != BT_INTEGER)
6de9cd9a
DN		 1816 {
1817 ts.type = BT_INTEGER;
1818 ts.kind = gfc_index_integer_kind;
1819
1820 gfc_convert_type_warn (index, &ts, 2, 0);
1821 }
1822
1823 return SUCCESS;
1824}
1825
1826
1827/* Given an expression that contains array references, update those array
1828 references to point to the right array specifications. While this is
1829 filled in during matching, this information is difficult to save and load
1830 in a module, so we take care of it here.
1831
1832 The idea here is that the original array reference comes from the
1833 base symbol. We traverse the list of reference structures, setting
1834 the stored reference to references. Component references can
1835 provide an additional array specification. */
1836
1837static void
1838find_array_spec (gfc_expr * e)
1839{
1840 gfc_array_spec *as;
1841 gfc_component *c;
1842 gfc_ref *ref;
1843
1844 as = e->symtree->n.sym->as;
1845 c = e->symtree->n.sym->components;
1846
1847 for (ref = e->ref; ref; ref = ref->next)
1848 switch (ref->type)
1849 {
1850 case REF_ARRAY:
1851 if (as == NULL)
1852 gfc_internal_error ("find_array_spec(): Missing spec");
1853
1854 ref->u.ar.as = as;
1855 as = NULL;
1856 break;
1857
1858 case REF_COMPONENT:
1859 for (; c; c = c->next)
1860 if (c == ref->u.c.component)
1861 break;
1862
1863 if (c == NULL)
1864 gfc_internal_error ("find_array_spec(): Component not found");
1865
1866 if (c->dimension)
1867 {
1868 if (as != NULL)
1869 gfc_internal_error ("find_array_spec(): unused as(1)");
1870 as = c->as;
1871 }
1872
1873 c = c->ts.derived->components;
1874 break;
1875
1876 case REF_SUBSTRING:
1877 break;
1878 }
1879
1880 if (as != NULL)
1881 gfc_internal_error ("find_array_spec(): unused as(2)");
1882}
1883
1884
1885/* Resolve an array reference. */
1886
1887static try
1888resolve_array_ref (gfc_array_ref * ar)
1889{
1890 int i, check_scalar;
1891
1892 for (i = 0; i < ar->dimen; i++)
1893 {
1894 check_scalar = ar->dimen_type[i] == DIMEN_RANGE;
1895
1896 if (gfc_resolve_index (ar->start[i], check_scalar) == FAILURE)
1897 return FAILURE;
1898 if (gfc_resolve_index (ar->end[i], check_scalar) == FAILURE)
1899 return FAILURE;
1900 if (gfc_resolve_index (ar->stride[i], check_scalar) == FAILURE)
1901 return FAILURE;
1902
1903 if (ar->dimen_type[i] == DIMEN_UNKNOWN)
1904 switch (ar->start[i]->rank)
1905 {
1906 case 0:
1907 ar->dimen_type[i] = DIMEN_ELEMENT;
1908 break;
1909
1910 case 1:
1911 ar->dimen_type[i] = DIMEN_VECTOR;
1912 break;
1913
1914 default:
1915 gfc_error ("Array index at %L is an array of rank %d",
1916 &ar->c_where[i], ar->start[i]->rank);
1917 return FAILURE;
1918 }
1919 }
1920
1921 /* If the reference type is unknown, figure out what kind it is. */
1922
1923 if (ar->type == AR_UNKNOWN)
1924 {
1925 ar->type = AR_ELEMENT;
1926 for (i = 0; i < ar->dimen; i++)
1927 if (ar->dimen_type[i] == DIMEN_RANGE
1928 || ar->dimen_type[i] == DIMEN_VECTOR)
1929 {
1930 ar->type = AR_SECTION;
1931 break;
1932 }
1933 }
1934
1935 if (compare_spec_to_ref (ar) == FAILURE)
1936 return FAILURE;
1937
1938 return SUCCESS;
1939}
1940
1941
1942static try
1943resolve_substring (gfc_ref * ref)
1944{
1945
1946 if (ref->u.ss.start != NULL)
1947 {
1948 if (gfc_resolve_expr (ref->u.ss.start) == FAILURE)
1949 return FAILURE;
1950
1951 if (ref->u.ss.start->ts.type != BT_INTEGER)
1952 {
1953 gfc_error ("Substring start index at %L must be of type INTEGER",
1954 &ref->u.ss.start->where);
1955 return FAILURE;
1956 }
1957
1958 if (ref->u.ss.start->rank != 0)
1959 {
1960 gfc_error ("Substring start index at %L must be scalar",
1961 &ref->u.ss.start->where);
1962 return FAILURE;
1963 }
1964
1965 if (compare_bound_int (ref->u.ss.start, 1) == CMP_LT)
1966 {
1967 gfc_error ("Substring start index at %L is less than one",
1968 &ref->u.ss.start->where);
1969 return FAILURE;
1970 }
1971 }
1972
1973 if (ref->u.ss.end != NULL)
1974 {
1975 if (gfc_resolve_expr (ref->u.ss.end) == FAILURE)
1976 return FAILURE;
1977
1978 if (ref->u.ss.end->ts.type != BT_INTEGER)
1979 {
1980 gfc_error ("Substring end index at %L must be of type INTEGER",
1981 &ref->u.ss.end->where);
1982 return FAILURE;
1983 }
1984
1985 if (ref->u.ss.end->rank != 0)
1986 {
1987 gfc_error ("Substring end index at %L must be scalar",
1988 &ref->u.ss.end->where);
1989 return FAILURE;
1990 }
1991
1992 if (ref->u.ss.length != NULL
1993 && compare_bound (ref->u.ss.end, ref->u.ss.length->length) == CMP_GT)
1994 {
1995 gfc_error ("Substring end index at %L is out of bounds",
1996 &ref->u.ss.start->where);
1997 return FAILURE;
1998 }
1999 }
2000
2001 return SUCCESS;
2002}
2003
2004
2005/* Resolve subtype references. */
2006
2007static try
2008resolve_ref (gfc_expr * expr)
2009{
2010 int current_part_dimension, n_components, seen_part_dimension;
2011 gfc_ref *ref;
2012
2013 for (ref = expr->ref; ref; ref = ref->next)
2014 if (ref->type == REF_ARRAY && ref->u.ar.as == NULL)
2015 {
2016 find_array_spec (expr);
2017 break;
2018 }
2019
2020 for (ref = expr->ref; ref; ref = ref->next)
2021 switch (ref->type)
2022 {
2023 case REF_ARRAY:
2024 if (resolve_array_ref (&ref->u.ar) == FAILURE)
2025 return FAILURE;
2026 break;
2027
2028 case REF_COMPONENT:
2029 break;
2030
2031 case REF_SUBSTRING:
2032 resolve_substring (ref);
2033 break;
2034 }
2035
2036 /* Check constraints on part references. */
2037
2038 current_part_dimension = 0;
2039 seen_part_dimension = 0;
2040 n_components = 0;
2041
2042 for (ref = expr->ref; ref; ref = ref->next)
2043 {
2044 switch (ref->type)
2045 {
2046 case REF_ARRAY:
2047 switch (ref->u.ar.type)
2048 {
2049 case AR_FULL:
2050 case AR_SECTION:
2051 current_part_dimension = 1;
2052 break;
2053
2054 case AR_ELEMENT:
2055 current_part_dimension = 0;
2056 break;
2057
2058 case AR_UNKNOWN:
2059 gfc_internal_error ("resolve_ref(): Bad array reference");
2060 }
2061
2062 break;
2063
2064 case REF_COMPONENT:
2065 if ((current_part_dimension || seen_part_dimension)
2066 && ref->u.c.component->pointer)
2067 {
2068 gfc_error
2069 ("Component to the right of a part reference with nonzero "
2070 "rank must not have the POINTER attribute at %L",
2071 &expr->where);
2072 return FAILURE;
2073 }
2074
2075 n_components++;
2076 break;
2077
2078 case REF_SUBSTRING:
2079 break;
2080 }
2081
2082 if (((ref->type == REF_COMPONENT && n_components > 1)
2083 || ref->next == NULL)
2084 && current_part_dimension
2085 && seen_part_dimension)
2086 {
2087
2088 gfc_error ("Two or more part references with nonzero rank must "
2089 "not be specified at %L", &expr->where);
2090 return FAILURE;
2091 }
2092
2093 if (ref->type == REF_COMPONENT)
2094 {
2095 if (current_part_dimension)
2096 seen_part_dimension = 1;
2097
2098 /* reset to make sure */
2099 current_part_dimension = 0;
2100 }
2101 }
2102
2103 return SUCCESS;
2104}
2105
2106
2107/* Given an expression, determine its shape. This is easier than it sounds.
f7b529fa 2108 Leaves the shape array NULL if it is not possible to determine the shape. */
6de9cd9a
DN		 2109
2110static void
2111expression_shape (gfc_expr * e)
2112{
2113 mpz_t array[GFC_MAX_DIMENSIONS];
2114 int i;
2115
2116 if (e->rank == 0 || e->shape != NULL)
2117 return;
2118
2119 for (i = 0; i < e->rank; i++)
2120 if (gfc_array_dimen_size (e, i, &array[i]) == FAILURE)
2121 goto fail;
2122
2123 e->shape = gfc_get_shape (e->rank);
2124
2125 memcpy (e->shape, array, e->rank * sizeof (mpz_t));
2126
2127 return;
2128
2129fail:
2130 for (i--; i >= 0; i--)
2131 mpz_clear (array[i]);
2132}
2133
2134
2135/* Given a variable expression node, compute the rank of the expression by
2136 examining the base symbol and any reference structures it may have. */
2137
2138static void
2139expression_rank (gfc_expr * e)
2140{
2141 gfc_ref *ref;
2142 int i, rank;
2143
2144 if (e->ref == NULL)
2145 {
2146 if (e->expr_type == EXPR_ARRAY)
2147 goto done;
f7b529fa 2148 /* Constructors can have a rank different from one via RESHAPE(). */
6de9cd9a
DN		 2149
2150 if (e->symtree == NULL)
2151 {
2152 e->rank = 0;
2153 goto done;
2154 }
2155
2156 e->rank = (e->symtree->n.sym->as == NULL)
2157 ? 0 : e->symtree->n.sym->as->rank;
2158 goto done;
2159 }
2160
2161 rank = 0;
2162
2163 for (ref = e->ref; ref; ref = ref->next)
2164 {
2165 if (ref->type != REF_ARRAY)
2166 continue;
2167
2168 if (ref->u.ar.type == AR_FULL)
2169 {
2170 rank = ref->u.ar.as->rank;
2171 break;
2172 }
2173
2174 if (ref->u.ar.type == AR_SECTION)
2175 {
2176 /* Figure out the rank of the section. */
2177 if (rank != 0)
2178 gfc_internal_error ("expression_rank(): Two array specs");
2179
2180 for (i = 0; i < ref->u.ar.dimen; i++)
2181 if (ref->u.ar.dimen_type[i] == DIMEN_RANGE
2182 || ref->u.ar.dimen_type[i] == DIMEN_VECTOR)
2183 rank++;
2184
2185 break;
2186 }
2187 }
2188
2189 e->rank = rank;
2190
2191done:
2192 expression_shape (e);
2193}
2194
2195
2196/* Resolve a variable expression. */
2197
2198static try
2199resolve_variable (gfc_expr * e)
2200{
2201 gfc_symbol *sym;
2202
2203 if (e->ref && resolve_ref (e) == FAILURE)
2204 return FAILURE;
2205
009e94d4
FXC		 2206 if (e->symtree == NULL)
2207 return FAILURE;
2208
6de9cd9a
DN		 2209 sym = e->symtree->n.sym;
2210 if (sym->attr.flavor == FL_PROCEDURE && !sym->attr.function)
2211 {
2212 e->ts.type = BT_PROCEDURE;
2213 return SUCCESS;
2214 }
2215
2216 if (sym->ts.type != BT_UNKNOWN)
2217 gfc_variable_attr (e, &e->ts);
2218 else
2219 {
2220 /* Must be a simple variable reference. */
2221 if (gfc_set_default_type (sym, 1, NULL) == FAILURE)
2222 return FAILURE;
2223 e->ts = sym->ts;
2224 }
2225
2226 return SUCCESS;
2227}
2228
2229
2230/* Resolve an expression. That is, make sure that types of operands agree
2231 with their operators, intrinsic operators are converted to function calls
2232 for overloaded types and unresolved function references are resolved. */
2233
2234try
2235gfc_resolve_expr (gfc_expr * e)
2236{
2237 try t;
2238
2239 if (e == NULL)
2240 return SUCCESS;
2241
2242 switch (e->expr_type)
2243 {
2244 case EXPR_OP:
2245 t = resolve_operator (e);
2246 break;
2247
2248 case EXPR_FUNCTION:
2249 t = resolve_function (e);
2250 break;
2251
2252 case EXPR_VARIABLE:
2253 t = resolve_variable (e);
2254 if (t == SUCCESS)
2255 expression_rank (e);
2256 break;
2257
2258 case EXPR_SUBSTRING:
2259 t = resolve_ref (e);
2260 break;
2261
2262 case EXPR_CONSTANT:
2263 case EXPR_NULL:
2264 t = SUCCESS;
2265 break;
2266
2267 case EXPR_ARRAY:
2268 t = FAILURE;
2269 if (resolve_ref (e) == FAILURE)
2270 break;
2271
2272 t = gfc_resolve_array_constructor (e);
2273 /* Also try to expand a constructor. */
2274 if (t == SUCCESS)
2275 {
2276 expression_rank (e);
2277 gfc_expand_constructor (e);
2278 }
2279
2280 break;
2281
2282 case EXPR_STRUCTURE:
2283 t = resolve_ref (e);
2284 if (t == FAILURE)
2285 break;
2286
2287 t = resolve_structure_cons (e);
2288 if (t == FAILURE)
2289 break;
2290
2291 t = gfc_simplify_expr (e, 0);
2292 break;
2293
2294 default:
2295 gfc_internal_error ("gfc_resolve_expr(): Bad expression type");
2296 }
2297
2298 return t;
2299}
2300
2301
8d5cfa27
SK		 2302/* Resolve an expression from an iterator. They must be scalar and have
2303 INTEGER or (optionally) REAL type. */
6de9cd9a 2304
8d5cfa27
SK		 2305static try
2306gfc_resolve_iterator_expr (gfc_expr * expr, bool real_ok, const char * name)
6de9cd9a 2307{
8d5cfa27 2308 if (gfc_resolve_expr (expr) == FAILURE)
6de9cd9a
DN		 2309 return FAILURE;
2310
8d5cfa27 2311 if (expr->rank != 0)
6de9cd9a 2312 {
8d5cfa27 2313 gfc_error ("%s at %L must be a scalar", name, &expr->where);
6de9cd9a
DN		 2314 return FAILURE;
2315 }
2316
8d5cfa27
SK		 2317 if (!(expr->ts.type == BT_INTEGER
2318 || (expr->ts.type == BT_REAL && real_ok)))
6de9cd9a 2319 {
8d5cfa27
SK		 2320 gfc_error ("%s at %L must be INTEGER%s",
2321 name,
2322 &expr->where,
2323 real_ok ? " or REAL" : "");
6de9cd9a
DN		 2324 return FAILURE;
2325 }
8d5cfa27
SK		 2326 return SUCCESS;
2327}
2328
2329
2330/* Resolve the expressions in an iterator structure. If REAL_OK is
2331 false allow only INTEGER type iterators, otherwise allow REAL types. */
2332
2333try
2334gfc_resolve_iterator (gfc_iterator * iter, bool real_ok)
2335{
6de9cd9a 2336
8d5cfa27
SK		 2337 if (iter->var->ts.type == BT_REAL)
2338 gfc_notify_std (GFC_STD_F95_DEL,
2339 "Obsolete: REAL DO loop iterator at %L",
2340 &iter->var->where);
2341
2342 if (gfc_resolve_iterator_expr (iter->var, real_ok, "Loop variable")
2343 == FAILURE)
6de9cd9a
DN		 2344 return FAILURE;
2345
8d5cfa27 2346 if (gfc_pure (NULL) && gfc_impure_variable (iter->var->symtree->n.sym))
6de9cd9a 2347 {
8d5cfa27
SK		 2348 gfc_error ("Cannot assign to loop variable in PURE procedure at %L",
2349 &iter->var->where);
6de9cd9a
DN		 2350 return FAILURE;
2351 }
2352
8d5cfa27
SK		 2353 if (gfc_resolve_iterator_expr (iter->start, real_ok,
2354 "Start expression in DO loop") == FAILURE)
6de9cd9a
DN		 2355 return FAILURE;
2356
8d5cfa27
SK		 2357 if (gfc_resolve_iterator_expr (iter->end, real_ok,
2358 "End expression in DO loop") == FAILURE)
2359 return FAILURE;
6de9cd9a 2360
8d5cfa27
SK		 2361 if (gfc_resolve_iterator_expr (iter->step, real_ok,
2362 "Step expression in DO loop") == FAILURE)
6de9cd9a
DN		 2363 return FAILURE;
2364
8d5cfa27 2365 if (iter->step->expr_type == EXPR_CONSTANT)
6de9cd9a 2366 {
8d5cfa27
SK		 2367 if ((iter->step->ts.type == BT_INTEGER
2368 && mpz_cmp_ui (iter->step->value.integer, 0) == 0)
2369 || (iter->step->ts.type == BT_REAL
2370 && mpfr_sgn (iter->step->value.real) == 0))
2371 {
2372 gfc_error ("Step expression in DO loop at %L cannot be zero",
2373 &iter->step->where);
2374 return FAILURE;
2375 }
6de9cd9a
DN		 2376 }
2377
8d5cfa27
SK		 2378 /* Convert start, end, and step to the same type as var. */
2379 if (iter->start->ts.kind != iter->var->ts.kind
2380 || iter->start->ts.type != iter->var->ts.type)
2381 gfc_convert_type (iter->start, &iter->var->ts, 2);
2382
2383 if (iter->end->ts.kind != iter->var->ts.kind
2384 || iter->end->ts.type != iter->var->ts.type)
2385 gfc_convert_type (iter->end, &iter->var->ts, 2);
2386
2387 if (iter->step->ts.kind != iter->var->ts.kind
2388 || iter->step->ts.type != iter->var->ts.type)
2389 gfc_convert_type (iter->step, &iter->var->ts, 2);
6de9cd9a
DN		 2390
2391 return SUCCESS;
2392}
2393
2394
2395/* Resolve a list of FORALL iterators. */
2396
2397static void
2398resolve_forall_iterators (gfc_forall_iterator * iter)
2399{
2400
2401 while (iter)
2402 {
2403 if (gfc_resolve_expr (iter->var) == SUCCESS
2404 && iter->var->ts.type != BT_INTEGER)
2405 gfc_error ("FORALL Iteration variable at %L must be INTEGER",
2406 &iter->var->where);
2407
2408 if (gfc_resolve_expr (iter->start) == SUCCESS
2409 && iter->start->ts.type != BT_INTEGER)
2410 gfc_error ("FORALL start expression at %L must be INTEGER",
2411 &iter->start->where);
2412 if (iter->var->ts.kind != iter->start->ts.kind)
2413 gfc_convert_type (iter->start, &iter->var->ts, 2);
2414
2415 if (gfc_resolve_expr (iter->end) == SUCCESS
2416 && iter->end->ts.type != BT_INTEGER)
2417 gfc_error ("FORALL end expression at %L must be INTEGER",
2418 &iter->end->where);
2419 if (iter->var->ts.kind != iter->end->ts.kind)
2420 gfc_convert_type (iter->end, &iter->var->ts, 2);
2421
2422 if (gfc_resolve_expr (iter->stride) == SUCCESS
2423 && iter->stride->ts.type != BT_INTEGER)
2424 gfc_error ("FORALL Stride expression at %L must be INTEGER",
2425 &iter->stride->where);
2426 if (iter->var->ts.kind != iter->stride->ts.kind)
2427 gfc_convert_type (iter->stride, &iter->var->ts, 2);
2428
2429 iter = iter->next;
2430 }
2431}
2432
2433
2434/* Given a pointer to a symbol that is a derived type, see if any components
2435 have the POINTER attribute. The search is recursive if necessary.
2436 Returns zero if no pointer components are found, nonzero otherwise. */
2437
2438static int
2439derived_pointer (gfc_symbol * sym)
2440{
2441 gfc_component *c;
2442
2443 for (c = sym->components; c; c = c->next)
2444 {
2445 if (c->pointer)
2446 return 1;
2447
2448 if (c->ts.type == BT_DERIVED && derived_pointer (c->ts.derived))
2449 return 1;
2450 }
2451
2452 return 0;
2453}
2454
2455
2456/* Resolve the argument of a deallocate expression. The expression must be
2457 a pointer or a full array. */
2458
2459static try
2460resolve_deallocate_expr (gfc_expr * e)
2461{
2462 symbol_attribute attr;
2463 int allocatable;
2464 gfc_ref *ref;
2465
2466 if (gfc_resolve_expr (e) == FAILURE)
2467 return FAILURE;
2468
2469 attr = gfc_expr_attr (e);
2470 if (attr.pointer)
2471 return SUCCESS;
2472
2473 if (e->expr_type != EXPR_VARIABLE)
2474 goto bad;
2475
2476 allocatable = e->symtree->n.sym->attr.allocatable;
2477 for (ref = e->ref; ref; ref = ref->next)
2478 switch (ref->type)
2479 {
2480 case REF_ARRAY:
2481 if (ref->u.ar.type != AR_FULL)
2482 allocatable = 0;
2483 break;
2484
2485 case REF_COMPONENT:
2486 allocatable = (ref->u.c.component->as != NULL
2487 && ref->u.c.component->as->type == AS_DEFERRED);
2488 break;
2489
2490 case REF_SUBSTRING:
2491 allocatable = 0;
2492 break;
2493 }
2494
2495 if (allocatable == 0)
2496 {
2497 bad:
2498 gfc_error ("Expression in DEALLOCATE statement at %L must be "
2499 "ALLOCATABLE or a POINTER", &e->where);
2500 }
2501
2502 return SUCCESS;
2503}
2504
2505
2506/* Resolve the expression in an ALLOCATE statement, doing the additional
2507 checks to see whether the expression is OK or not. The expression must
2508 have a trailing array reference that gives the size of the array. */
2509
2510static try
2511resolve_allocate_expr (gfc_expr * e)
2512{
2513 int i, pointer, allocatable, dimension;
2514 symbol_attribute attr;
2515 gfc_ref *ref, *ref2;
2516 gfc_array_ref *ar;
2517
2518 if (gfc_resolve_expr (e) == FAILURE)
2519 return FAILURE;
2520
2521 /* Make sure the expression is allocatable or a pointer. If it is
2522 pointer, the next-to-last reference must be a pointer. */
2523
2524 ref2 = NULL;
2525
2526 if (e->expr_type != EXPR_VARIABLE)
2527 {
2528 allocatable = 0;
2529
2530 attr = gfc_expr_attr (e);
2531 pointer = attr.pointer;
2532 dimension = attr.dimension;
2533
2534 }
2535 else
2536 {
2537 allocatable = e->symtree->n.sym->attr.allocatable;
2538 pointer = e->symtree->n.sym->attr.pointer;
2539 dimension = e->symtree->n.sym->attr.dimension;
2540
2541 for (ref = e->ref; ref; ref2 = ref, ref = ref->next)
2542 switch (ref->type)
2543 {
2544 case REF_ARRAY:
2545 if (ref->next != NULL)
2546 pointer = 0;
2547 break;
2548
2549 case REF_COMPONENT:
2550 allocatable = (ref->u.c.component->as != NULL
2551 && ref->u.c.component->as->type == AS_DEFERRED);
2552
2553 pointer = ref->u.c.component->pointer;
2554 dimension = ref->u.c.component->dimension;
2555 break;
2556
2557 case REF_SUBSTRING:
2558 allocatable = 0;
2559 pointer = 0;
2560 break;
2561 }
2562 }
2563
2564 if (allocatable == 0 && pointer == 0)
2565 {
2566 gfc_error ("Expression in ALLOCATE statement at %L must be "
2567 "ALLOCATABLE or a POINTER", &e->where);
2568 return FAILURE;
2569 }
2570
2571 if (pointer && dimension == 0)
2572 return SUCCESS;
2573
2574 /* Make sure the next-to-last reference node is an array specification. */
2575
2576 if (ref2 == NULL || ref2->type != REF_ARRAY || ref2->u.ar.type == AR_FULL)
2577 {
2578 gfc_error ("Array specification required in ALLOCATE statement "
2579 "at %L", &e->where);
2580 return FAILURE;
2581 }
2582
2583 if (ref2->u.ar.type == AR_ELEMENT)
2584 return SUCCESS;
2585
2586 /* Make sure that the array section reference makes sense in the
2587 context of an ALLOCATE specification. */
2588
2589 ar = &ref2->u.ar;
2590
2591 for (i = 0; i < ar->dimen; i++)
2592 switch (ar->dimen_type[i])
2593 {
2594 case DIMEN_ELEMENT:
2595 break;
2596
2597 case DIMEN_RANGE:
2598 if (ar->start[i] != NULL
2599 && ar->end[i] != NULL
2600 && ar->stride[i] == NULL)
2601 break;
2602
2603 /* Fall Through... */
2604
2605 case DIMEN_UNKNOWN:
2606 case DIMEN_VECTOR:
2607 gfc_error ("Bad array specification in ALLOCATE statement at %L",
2608 &e->where);
2609 return FAILURE;
2610 }
2611
2612 return SUCCESS;
2613}
2614
2615
2616/************ SELECT CASE resolution subroutines ************/
2617
2618/* Callback function for our mergesort variant. Determines interval
2619 overlaps for CASEs. Return <0 if op1 < op2, 0 for overlap, >0 for
c224550f
SK		 2620 op1 > op2. Assumes we're not dealing with the default case.
2621 We have op1 = (:L), (K:L) or (K:) and op2 = (:N), (M:N) or (M:).
2622 There are nine situations to check. */
6de9cd9a
DN		 2623
2624static int
6e06dac5 2625compare_cases (const gfc_case * op1, const gfc_case * op2)
6de9cd9a 2626{
c224550f 2627 int retval;
6de9cd9a 2628
c224550f 2629 if (op1->low == NULL) /* op1 = (:L) */
6de9cd9a 2630 {
c224550f
SK		 2631 /* op2 = (:N), so overlap. */
2632 retval = 0;
2633 /* op2 = (M:) or (M:N), L < M */
2634 if (op2->low != NULL
2635 && gfc_compare_expr (op1->high, op2->low) < 0)
2636 retval = -1;
6de9cd9a 2637 }
c224550f 2638 else if (op1->high == NULL) /* op1 = (K:) */
6de9cd9a 2639 {
c224550f
SK		 2640 /* op2 = (M:), so overlap. */
2641 retval = 0;
2642 /* op2 = (:N) or (M:N), K > N */
2643 if (op2->high != NULL
2644 && gfc_compare_expr (op1->low, op2->high) > 0)
2645 retval = 1;
6de9cd9a 2646 }
c224550f 2647 else /* op1 = (K:L) */
6de9cd9a 2648 {
c224550f
SK		 2649 if (op2->low == NULL) /* op2 = (:N), K > N */
2650 retval = (gfc_compare_expr (op1->low, op2->high) > 0) ? 1 : 0;
2651 else if (op2->high == NULL) /* op2 = (M:), L < M */
2652 retval = (gfc_compare_expr (op1->high, op2->low) < 0) ? -1 : 0;
2653 else /* op2 = (M:N) */
6de9cd9a 2654 {
c224550f
SK		 2655 retval = 0;
2656 /* L < M */
6de9cd9a 2657 if (gfc_compare_expr (op1->high, op2->low) < 0)
c224550f
SK		 2658 retval = -1;
2659 /* K > N */
2660 else if (gfc_compare_expr (op1->low, op2->high) > 0)
2661 retval = 1;
6de9cd9a
DN		 2662 }
2663 }
c224550f
SK		 2664
2665 return retval;
6de9cd9a
DN		 2666}
2667
2668
2669/* Merge-sort a double linked case list, detecting overlap in the
2670 process. LIST is the head of the double linked case list before it
2671 is sorted. Returns the head of the sorted list if we don't see any
2672 overlap, or NULL otherwise. */
2673
2674static gfc_case *
2675check_case_overlap (gfc_case * list)
2676{
2677 gfc_case *p, *q, *e, *tail;
2678 int insize, nmerges, psize, qsize, cmp, overlap_seen;
2679
2680 /* If the passed list was empty, return immediately. */
2681 if (!list)
2682 return NULL;
2683
2684 overlap_seen = 0;
2685 insize = 1;
2686
2687 /* Loop unconditionally. The only exit from this loop is a return
2688 statement, when we've finished sorting the case list. */
2689 for (;;)
2690 {
2691 p = list;
2692 list = NULL;
2693 tail = NULL;
2694
2695 /* Count the number of merges we do in this pass. */
2696 nmerges = 0;
2697
2698 /* Loop while there exists a merge to be done. */
2699 while (p)
2700 {
2701 int i;
2702
2703 /* Count this merge. */
2704 nmerges++;
2705
5352b89f 2706 /* Cut the list in two pieces by stepping INSIZE places
6de9cd9a
DN		 2707 forward in the list, starting from P. */
2708 psize = 0;
2709 q = p;
2710 for (i = 0; i < insize; i++)
2711 {
2712 psize++;
2713 q = q->right;
2714 if (!q)
2715 break;
2716 }
2717 qsize = insize;
2718
2719 /* Now we have two lists. Merge them! */
2720 while (psize > 0 || (qsize > 0 && q != NULL))
2721 {
2722
2723 /* See from which the next case to merge comes from. */
2724 if (psize == 0)
2725 {
2726 /* P is empty so the next case must come from Q. */
2727 e = q;
2728 q = q->right;
2729 qsize--;
2730 }
2731 else if (qsize == 0 || q == NULL)
2732 {
2733 /* Q is empty. */
2734 e = p;
2735 p = p->right;
2736 psize--;
2737 }
2738 else
2739 {
2740 cmp = compare_cases (p, q);
2741 if (cmp < 0)
2742 {
2743 /* The whole case range for P is less than the
2744 one for Q. */
2745 e = p;
2746 p = p->right;
2747 psize--;
2748 }
2749 else if (cmp > 0)
2750 {
2751 /* The whole case range for Q is greater than
2752 the case range for P. */
2753 e = q;
2754 q = q->right;
2755 qsize--;
2756 }
2757 else
2758 {
2759 /* The cases overlap, or they are the same
2760 element in the list. Either way, we must
2761 issue an error and get the next case from P. */
2762 /* FIXME: Sort P and Q by line number. */
2763 gfc_error ("CASE label at %L overlaps with CASE "
2764 "label at %L", &p->where, &q->where);
2765 overlap_seen = 1;
2766 e = p;
2767 p = p->right;
2768 psize--;
2769 }
2770 }
2771
2772 /* Add the next element to the merged list. */
2773 if (tail)
2774 tail->right = e;
2775 else
2776 list = e;
2777 e->left = tail;
2778 tail = e;
2779 }
2780
2781 /* P has now stepped INSIZE places along, and so has Q. So
2782 they're the same. */
2783 p = q;
2784 }
2785 tail->right = NULL;
2786
2787 /* If we have done only one merge or none at all, we've
2788 finished sorting the cases. */
2789 if (nmerges <= 1)
2790 {
2791 if (!overlap_seen)
2792 return list;
2793 else
2794 return NULL;
2795 }
2796
2797 /* Otherwise repeat, merging lists twice the size. */
2798 insize *= 2;
2799 }
2800}
2801
2802
5352b89f
SK		 2803/* Check to see if an expression is suitable for use in a CASE statement.
2804 Makes sure that all case expressions are scalar constants of the same
2805 type. Return FAILURE if anything is wrong. */
6de9cd9a
DN		 2806
2807static try
2808validate_case_label_expr (gfc_expr * e, gfc_expr * case_expr)
2809{
6de9cd9a
DN		 2810 if (e == NULL) return SUCCESS;
2811
5352b89f 2812 if (e->ts.type != case_expr->ts.type)
6de9cd9a
DN		 2813 {
2814 gfc_error ("Expression in CASE statement at %L must be of type %s",
5352b89f 2815 &e->where, gfc_basic_typename (case_expr->ts.type));
6de9cd9a
DN		 2816 return FAILURE;
2817 }
2818
5352b89f
SK		 2819 /* C805 (R808) For a given case-construct, each case-value shall be of
2820 the same type as case-expr. For character type, length differences
2821 are allowed, but the kind type parameters shall be the same. */
2822
2823 if (case_expr->ts.type == BT_CHARACTER && e->ts.kind != case_expr->ts.kind)
6de9cd9a
DN		 2824 {
2825 gfc_error("Expression in CASE statement at %L must be kind %d",
5352b89f 2826 &e->where, case_expr->ts.kind);
6de9cd9a
DN		 2827 return FAILURE;
2828 }
2829
5352b89f
SK		 2830 /* Convert the case value kind to that of case expression kind, if needed.
2831 FIXME: Should a warning be issued? */
2832 if (e->ts.kind != case_expr->ts.kind)
2833 gfc_convert_type_warn (e, &case_expr->ts, 2, 0);
2834
6de9cd9a
DN		 2835 if (e->rank != 0)
2836 {
2837 gfc_error ("Expression in CASE statement at %L must be scalar",
2838 &e->where);
2839 return FAILURE;
2840 }
2841
2842 return SUCCESS;
2843}
2844
2845
2846/* Given a completely parsed select statement, we:
2847
2848 - Validate all expressions and code within the SELECT.
2849 - Make sure that the selection expression is not of the wrong type.
2850 - Make sure that no case ranges overlap.
2851 - Eliminate unreachable cases and unreachable code resulting from
2852 removing case labels.
2853
2854 The standard does allow unreachable cases, e.g. CASE (5:3). But
2855 they are a hassle for code generation, and to prevent that, we just
2856 cut them out here. This is not necessary for overlapping cases
2857 because they are illegal and we never even try to generate code.
2858
2859 We have the additional caveat that a SELECT construct could have
1f2959f0 2860 been a computed GOTO in the source code. Fortunately we can fairly
6de9cd9a
DN		 2861 easily work around that here: The case_expr for a "real" SELECT CASE
2862 is in code->expr1, but for a computed GOTO it is in code->expr2. All
2863 we have to do is make sure that the case_expr is a scalar integer
2864 expression. */
2865
2866static void
2867resolve_select (gfc_code * code)
2868{
2869 gfc_code *body;
2870 gfc_expr *case_expr;
2871 gfc_case *cp, *default_case, *tail, *head;
2872 int seen_unreachable;
2873 int ncases;
2874 bt type;
2875 try t;
2876
2877 if (code->expr == NULL)
2878 {
2879 /* This was actually a computed GOTO statement. */
2880 case_expr = code->expr2;
2881 if (case_expr->ts.type != BT_INTEGER
2882 || case_expr->rank != 0)
2883 gfc_error ("Selection expression in computed GOTO statement "
2884 "at %L must be a scalar integer expression",
2885 &case_expr->where);
2886
2887 /* Further checking is not necessary because this SELECT was built
2888 by the compiler, so it should always be OK. Just move the
2889 case_expr from expr2 to expr so that we can handle computed
2890 GOTOs as normal SELECTs from here on. */
2891 code->expr = code->expr2;
2892 code->expr2 = NULL;
2893 return;
2894 }
2895
2896 case_expr = code->expr;
2897
2898 type = case_expr->ts.type;
2899 if (type != BT_LOGICAL && type != BT_INTEGER && type != BT_CHARACTER)
2900 {
2901 gfc_error ("Argument of SELECT statement at %L cannot be %s",
2902 &case_expr->where, gfc_typename (&case_expr->ts));
2903
2904 /* Punt. Going on here just produce more garbage error messages. */
2905 return;
2906 }
2907
2908 if (case_expr->rank != 0)
2909 {
2910 gfc_error ("Argument of SELECT statement at %L must be a scalar "
2911 "expression", &case_expr->where);
2912
2913 /* Punt. */
2914 return;
2915 }
2916
5352b89f
SK		 2917 /* PR 19168 has a long discussion concerning a mismatch of the kinds
2918 of the SELECT CASE expression and its CASE values. Walk the lists
2919 of case values, and if we find a mismatch, promote case_expr to
2920 the appropriate kind. */
2921
2922 if (type == BT_LOGICAL || type == BT_INTEGER)
2923 {
2924 for (body = code->block; body; body = body->block)
2925 {
2926 /* Walk the case label list. */
2927 for (cp = body->ext.case_list; cp; cp = cp->next)
2928 {
2929 /* Intercept the DEFAULT case. It does not have a kind. */
2930 if (cp->low == NULL && cp->high == NULL)
2931 continue;
2932
2933 /* Unreachable case ranges are discarded, so ignore. */
2934 if (cp->low != NULL && cp->high != NULL
2935 && cp->low != cp->high
2936 && gfc_compare_expr (cp->low, cp->high) > 0)
2937 continue;
2938
2939 /* FIXME: Should a warning be issued? */
2940 if (cp->low != NULL
2941 && case_expr->ts.kind != gfc_kind_max(case_expr, cp->low))
2942 gfc_convert_type_warn (case_expr, &cp->low->ts, 2, 0);
2943
2944 if (cp->high != NULL
2945 && case_expr->ts.kind != gfc_kind_max(case_expr, cp->high))
2946 gfc_convert_type_warn (case_expr, &cp->high->ts, 2, 0);
2947 }
2948 }
2949 }
2950
6de9cd9a
DN		 2951 /* Assume there is no DEFAULT case. */
2952 default_case = NULL;
2953 head = tail = NULL;
2954 ncases = 0;
2955
2956 for (body = code->block; body; body = body->block)
2957 {
2958 /* Assume the CASE list is OK, and all CASE labels can be matched. */
2959 t = SUCCESS;
2960 seen_unreachable = 0;
2961
2962 /* Walk the case label list, making sure that all case labels
2963 are legal. */
2964 for (cp = body->ext.case_list; cp; cp = cp->next)
2965 {
2966 /* Count the number of cases in the whole construct. */
2967 ncases++;
2968
2969 /* Intercept the DEFAULT case. */
2970 if (cp->low == NULL && cp->high == NULL)
2971 {
2972 if (default_case != NULL)
2973 {
2974 gfc_error ("The DEFAULT CASE at %L cannot be followed "
2975 "by a second DEFAULT CASE at %L",
2976 &default_case->where, &cp->where);
2977 t = FAILURE;
2978 break;
2979 }
2980 else
2981 {
2982 default_case = cp;
2983 continue;
2984 }
2985 }
2986
2987 /* Deal with single value cases and case ranges. Errors are
2988 issued from the validation function. */
2989 if(validate_case_label_expr (cp->low, case_expr) != SUCCESS
2990 || validate_case_label_expr (cp->high, case_expr) != SUCCESS)
2991 {
2992 t = FAILURE;
2993 break;
2994 }
2995
2996 if (type == BT_LOGICAL
2997 && ((cp->low == NULL || cp->high == NULL)
2998 || cp->low != cp->high))
2999 {
3000 gfc_error
3001 ("Logical range in CASE statement at %L is not allowed",
3002 &cp->low->where);
3003 t = FAILURE;
3004 break;
3005 }
3006
3007 if (cp->low != NULL && cp->high != NULL
3008 && cp->low != cp->high
3009 && gfc_compare_expr (cp->low, cp->high) > 0)
3010 {
3011 if (gfc_option.warn_surprising)
3012 gfc_warning ("Range specification at %L can never "
3013 "be matched", &cp->where);
3014
3015 cp->unreachable = 1;
3016 seen_unreachable = 1;
3017 }
3018 else
3019 {
3020 /* If the case range can be matched, it can also overlap with
3021 other cases. To make sure it does not, we put it in a
3022 double linked list here. We sort that with a merge sort
3023 later on to detect any overlapping cases. */
3024 if (!head)
3025 {
3026 head = tail = cp;
3027 head->right = head->left = NULL;
3028 }
3029 else
3030 {
3031 tail->right = cp;
3032 tail->right->left = tail;
3033 tail = tail->right;
3034 tail->right = NULL;
3035 }
3036 }
3037 }
3038
3039 /* It there was a failure in the previous case label, give up
3040 for this case label list. Continue with the next block. */
3041 if (t == FAILURE)
3042 continue;
3043
3044 /* See if any case labels that are unreachable have been seen.
3045 If so, we eliminate them. This is a bit of a kludge because
3046 the case lists for a single case statement (label) is a
3047 single forward linked lists. */
3048 if (seen_unreachable)
3049 {
3050 /* Advance until the first case in the list is reachable. */
3051 while (body->ext.case_list != NULL
3052 && body->ext.case_list->unreachable)
3053 {
3054 gfc_case *n = body->ext.case_list;
3055 body->ext.case_list = body->ext.case_list->next;
3056 n->next = NULL;
3057 gfc_free_case_list (n);
3058 }
3059
3060 /* Strip all other unreachable cases. */
3061 if (body->ext.case_list)
3062 {
3063 for (cp = body->ext.case_list; cp->next; cp = cp->next)
3064 {
3065 if (cp->next->unreachable)
3066 {
3067 gfc_case *n = cp->next;
3068 cp->next = cp->next->next;
3069 n->next = NULL;
3070 gfc_free_case_list (n);
3071 }
3072 }
3073 }
3074 }
3075 }
3076
3077 /* See if there were overlapping cases. If the check returns NULL,
3078 there was overlap. In that case we don't do anything. If head
3079 is non-NULL, we prepend the DEFAULT case. The sorted list can
3080 then used during code generation for SELECT CASE constructs with
3081 a case expression of a CHARACTER type. */
3082 if (head)
3083 {
3084 head = check_case_overlap (head);
3085
3086 /* Prepend the default_case if it is there. */
3087 if (head != NULL && default_case)
3088 {
3089 default_case->left = NULL;
3090 default_case->right = head;
3091 head->left = default_case;
3092 }
3093 }
3094
3095 /* Eliminate dead blocks that may be the result if we've seen
3096 unreachable case labels for a block. */
3097 for (body = code; body && body->block; body = body->block)
3098 {
3099 if (body->block->ext.case_list == NULL)
3100 {
3101 /* Cut the unreachable block from the code chain. */
3102 gfc_code *c = body->block;
3103 body->block = c->block;
3104
3105 /* Kill the dead block, but not the blocks below it. */
3106 c->block = NULL;
3107 gfc_free_statements (c);
3108 }
3109 }
3110
3111 /* More than two cases is legal but insane for logical selects.
3112 Issue a warning for it. */
3113 if (gfc_option.warn_surprising && type == BT_LOGICAL
3114 && ncases > 2)
3115 gfc_warning ("Logical SELECT CASE block at %L has more that two cases",
3116 &code->loc);
3117}
3118
3119
0e6928d8
TS		 3120/* Resolve a transfer statement. This is making sure that:
3121 -- a derived type being transferred has only non-pointer components
3122 -- a derived type being transferred doesn't have private components
3123 -- we're not trying to transfer a whole assumed size array. */
3124
3125static void
3126resolve_transfer (gfc_code * code)
3127{
3128 gfc_typespec *ts;
3129 gfc_symbol *sym;
3130 gfc_ref *ref;
3131 gfc_expr *exp;
3132
3133 exp = code->expr;
3134
3135 if (exp->expr_type != EXPR_VARIABLE)
3136 return;
3137
3138 sym = exp->symtree->n.sym;
3139 ts = &sym->ts;
3140
3141 /* Go to actual component transferred. */
3142 for (ref = code->expr->ref; ref; ref = ref->next)
3143 if (ref->type == REF_COMPONENT)
3144 ts = &ref->u.c.component->ts;
3145
3146 if (ts->type == BT_DERIVED)
3147 {
3148 /* Check that transferred derived type doesn't contain POINTER
3149 components. */
3150 if (derived_pointer (ts->derived))
3151 {
3152 gfc_error ("Data transfer element at %L cannot have "
3153 "POINTER components", &code->loc);
3154 return;
3155 }
3156
3157 if (ts->derived->component_access == ACCESS_PRIVATE)
3158 {
3159 gfc_error ("Data transfer element at %L cannot have "
3160 "PRIVATE components",&code->loc);
3161 return;
3162 }
3163 }
3164
3165 if (sym->as != NULL && sym->as->type == AS_ASSUMED_SIZE
3166 && exp->ref->type == REF_ARRAY && exp->ref->u.ar.type == AR_FULL)
3167 {
3168 gfc_error ("Data transfer element at %L cannot be a full reference to "
3169 "an assumed-size array", &code->loc);
3170 return;
3171 }
3172}
3173
3174
6de9cd9a
DN		 3175/*********** Toplevel code resolution subroutines ***********/
3176
3177/* Given a branch to a label and a namespace, if the branch is conforming.
3178 The code node described where the branch is located. */
3179
3180static void
3181resolve_branch (gfc_st_label * label, gfc_code * code)
3182{
3183 gfc_code *block, *found;
3184 code_stack *stack;
3185 gfc_st_label *lp;
3186
3187 if (label == NULL)
3188 return;
3189 lp = label;
3190
3191 /* Step one: is this a valid branching target? */
3192
3193 if (lp->defined == ST_LABEL_UNKNOWN)
3194 {
3195 gfc_error ("Label %d referenced at %L is never defined", lp->value,
3196 &lp->where);
3197 return;
3198 }
3199
3200 if (lp->defined != ST_LABEL_TARGET)
3201 {
3202 gfc_error ("Statement at %L is not a valid branch target statement "
3203 "for the branch statement at %L", &lp->where, &code->loc);
3204 return;
3205 }
3206
3207 /* Step two: make sure this branch is not a branch to itself ;-) */
3208
3209 if (code->here == label)
3210 {
3211 gfc_warning ("Branch at %L causes an infinite loop", &code->loc);
3212 return;
3213 }
3214
3215 /* Step three: Try to find the label in the parse tree. To do this,
3216 we traverse the tree block-by-block: first the block that
3217 contains this GOTO, then the block that it is nested in, etc. We
3218 can ignore other blocks because branching into another block is
3219 not allowed. */
3220
3221 found = NULL;
3222
3223 for (stack = cs_base; stack; stack = stack->prev)
3224 {
3225 for (block = stack->head; block; block = block->next)
3226 {
3227 if (block->here == label)
3228 {
3229 found = block;
3230 break;
3231 }
3232 }
3233
3234 if (found)
3235 break;
3236 }
3237
3238 if (found == NULL)
3239 {
3240 /* still nothing, so illegal. */
3241 gfc_error_now ("Label at %L is not in the same block as the "
3242 "GOTO statement at %L", &lp->where, &code->loc);
3243 return;
3244 }
3245
3246 /* Step four: Make sure that the branching target is legal if
3247 the statement is an END {SELECT,DO,IF}. */
3248
3249 if (found->op == EXEC_NOP)
3250 {
3251 for (stack = cs_base; stack; stack = stack->prev)
3252 if (stack->current->next == found)
3253 break;
3254
3255 if (stack == NULL)
3256 gfc_notify_std (GFC_STD_F95_DEL,
3257 "Obsolete: GOTO at %L jumps to END of construct at %L",
3258 &code->loc, &found->loc);
3259 }
3260}
3261
3262
3263/* Check whether EXPR1 has the same shape as EXPR2. */
3264
3265static try
3266resolve_where_shape (gfc_expr *expr1, gfc_expr *expr2)
3267{
3268 mpz_t shape[GFC_MAX_DIMENSIONS];
3269 mpz_t shape2[GFC_MAX_DIMENSIONS];
3270 try result = FAILURE;
3271 int i;
3272
3273 /* Compare the rank. */
3274 if (expr1->rank != expr2->rank)
3275 return result;
3276
3277 /* Compare the size of each dimension. */
3278 for (i=0; i<expr1->rank; i++)
3279 {
3280 if (gfc_array_dimen_size (expr1, i, &shape[i]) == FAILURE)
3281 goto ignore;
3282
3283 if (gfc_array_dimen_size (expr2, i, &shape2[i]) == FAILURE)
3284 goto ignore;
3285
3286 if (mpz_cmp (shape[i], shape2[i]))
3287 goto over;
3288 }
3289
3290 /* When either of the two expression is an assumed size array, we
3291 ignore the comparison of dimension sizes. */
3292ignore:
3293 result = SUCCESS;
3294
3295over:
3296 for (i--; i>=0; i--)
3297 {
3298 mpz_clear (shape[i]);
3299 mpz_clear (shape2[i]);
3300 }
3301 return result;
3302}
3303
3304
3305/* Check whether a WHERE assignment target or a WHERE mask expression
3306 has the same shape as the outmost WHERE mask expression. */
3307
3308static void
3309resolve_where (gfc_code *code, gfc_expr *mask)
3310{
3311 gfc_code *cblock;
3312 gfc_code *cnext;
3313 gfc_expr *e = NULL;
3314
3315 cblock = code->block;
3316
3317 /* Store the first WHERE mask-expr of the WHERE statement or construct.
3318 In case of nested WHERE, only the outmost one is stored. */
3319 if (mask == NULL) /* outmost WHERE */
3320 e = cblock->expr;
3321 else /* inner WHERE */
3322 e = mask;
3323
3324 while (cblock)
3325 {
3326 if (cblock->expr)
3327 {
3328 /* Check if the mask-expr has a consistent shape with the
3329 outmost WHERE mask-expr. */
3330 if (resolve_where_shape (cblock->expr, e) == FAILURE)
3331 gfc_error ("WHERE mask at %L has inconsistent shape",
3332 &cblock->expr->where);
3333 }
3334
3335 /* the assignment statement of a WHERE statement, or the first
3336 statement in where-body-construct of a WHERE construct */
3337 cnext = cblock->next;
3338 while (cnext)
3339 {
3340 switch (cnext->op)
3341 {
3342 /* WHERE assignment statement */
3343 case EXEC_ASSIGN:
3344
3345 /* Check shape consistent for WHERE assignment target. */
3346 if (e && resolve_where_shape (cnext->expr, e) == FAILURE)
3347 gfc_error ("WHERE assignment target at %L has "
3348 "inconsistent shape", &cnext->expr->where);
3349 break;
3350
3351 /* WHERE or WHERE construct is part of a where-body-construct */
3352 case EXEC_WHERE:
3353 resolve_where (cnext, e);
3354 break;
3355
3356 default:
3357 gfc_error ("Unsupported statement inside WHERE at %L",
3358 &cnext->loc);
3359 }
3360 /* the next statement within the same where-body-construct */
3361 cnext = cnext->next;
3362 }
3363 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
3364 cblock = cblock->block;
3365 }
3366}
3367
3368
3369/* Check whether the FORALL index appears in the expression or not. */
3370
3371static try
3372gfc_find_forall_index (gfc_expr *expr, gfc_symbol *symbol)
3373{
3374 gfc_array_ref ar;
3375 gfc_ref *tmp;
3376 gfc_actual_arglist *args;
3377 int i;
3378
3379 switch (expr->expr_type)
3380 {
3381 case EXPR_VARIABLE:
6e45f57b 3382 gcc_assert (expr->symtree->n.sym);
6de9cd9a
DN		 3383
3384 /* A scalar assignment */
3385 if (!expr->ref)
3386 {
3387 if (expr->symtree->n.sym == symbol)
3388 return SUCCESS;
3389 else
3390 return FAILURE;
3391 }
3392
3393 /* the expr is array ref, substring or struct component. */
3394 tmp = expr->ref;
3395 while (tmp != NULL)
3396 {
3397 switch (tmp->type)
3398 {
3399 case REF_ARRAY:
3400 /* Check if the symbol appears in the array subscript. */
3401 ar = tmp->u.ar;
3402 for (i = 0; i < GFC_MAX_DIMENSIONS; i++)
3403 {
3404 if (ar.start[i])
3405 if (gfc_find_forall_index (ar.start[i], symbol) == SUCCESS)
3406 return SUCCESS;
3407
3408 if (ar.end[i])
3409 if (gfc_find_forall_index (ar.end[i], symbol) == SUCCESS)
3410 return SUCCESS;
3411
3412 if (ar.stride[i])
3413 if (gfc_find_forall_index (ar.stride[i], symbol) == SUCCESS)
3414 return SUCCESS;
3415 } /* end for */
3416 break;
3417
3418 case REF_SUBSTRING:
3419 if (expr->symtree->n.sym == symbol)
3420 return SUCCESS;
3421 tmp = expr->ref;
3422 /* Check if the symbol appears in the substring section. */
3423 if (gfc_find_forall_index (tmp->u.ss.start, symbol) == SUCCESS)
3424 return SUCCESS;
3425 if (gfc_find_forall_index (tmp->u.ss.end, symbol) == SUCCESS)
3426 return SUCCESS;
3427 break;
3428
3429 case REF_COMPONENT:
3430 break;
3431
3432 default:
3433 gfc_error("expresion reference type error at %L", &expr->where);
3434 }
3435 tmp = tmp->next;
3436 }
3437 break;
3438
3439 /* If the expression is a function call, then check if the symbol
3440 appears in the actual arglist of the function. */
3441 case EXPR_FUNCTION:
3442 for (args = expr->value.function.actual; args; args = args->next)
3443 {
3444 if (gfc_find_forall_index(args->expr,symbol) == SUCCESS)
3445 return SUCCESS;
3446 }
3447 break;
3448
3449 /* It seems not to happen. */
3450 case EXPR_SUBSTRING:
3451 if (expr->ref)
3452 {
3453 tmp = expr->ref;
6e45f57b 3454 gcc_assert (expr->ref->type == REF_SUBSTRING);
6de9cd9a
DN		 3455 if (gfc_find_forall_index (tmp->u.ss.start, symbol) == SUCCESS)
3456 return SUCCESS;
3457 if (gfc_find_forall_index (tmp->u.ss.end, symbol) == SUCCESS)
3458 return SUCCESS;
3459 }
3460 break;
3461
3462 /* It seems not to happen. */
3463 case EXPR_STRUCTURE:
3464 case EXPR_ARRAY:
3465 gfc_error ("Unsupported statement while finding forall index in "
3466 "expression");
3467 break;
58b03ab2
TS		 3468
3469 case EXPR_OP:
3470 /* Find the FORALL index in the first operand. */
3471 if (expr->value.op.op1)
3472 {
3473 if (gfc_find_forall_index (expr->value.op.op1, symbol) == SUCCESS)
3474 return SUCCESS;
3475 }
3476
3477 /* Find the FORALL index in the second operand. */
3478 if (expr->value.op.op2)
3479 {
3480 if (gfc_find_forall_index (expr->value.op.op2, symbol) == SUCCESS)
3481 return SUCCESS;
3482 }
6de9cd9a 3483 break;
6de9cd9a 3484
58b03ab2
TS		 3485 default:
3486 break;
6de9cd9a
DN		 3487 }
3488
6de9cd9a
DN		 3489 return FAILURE;
3490}
3491
3492
3493/* Resolve assignment in FORALL construct.
3494 NVAR is the number of FORALL index variables, and VAR_EXPR records the
3495 FORALL index variables. */
3496
3497static void
3498gfc_resolve_assign_in_forall (gfc_code *code, int nvar, gfc_expr **var_expr)
3499{
3500 int n;
3501
3502 for (n = 0; n < nvar; n++)
3503 {
3504 gfc_symbol *forall_index;
3505
3506 forall_index = var_expr[n]->symtree->n.sym;
3507
3508 /* Check whether the assignment target is one of the FORALL index
f7b529fa 3509 variable. */
6de9cd9a
DN		 3510 if ((code->expr->expr_type == EXPR_VARIABLE)
3511 && (code->expr->symtree->n.sym == forall_index))
3512 gfc_error ("Assignment to a FORALL index variable at %L",
3513 &code->expr->where);
3514 else
3515 {
3516 /* If one of the FORALL index variables doesn't appear in the
3517 assignment target, then there will be a many-to-one
3518 assignment. */
3519 if (gfc_find_forall_index (code->expr, forall_index) == FAILURE)
3520 gfc_error ("The FORALL with index '%s' cause more than one "
3521 "assignment to this object at %L",
3522 var_expr[n]->symtree->name, &code->expr->where);
3523 }
3524 }
3525}
3526
3527
3528/* Resolve WHERE statement in FORALL construct. */
3529
3530static void
3531gfc_resolve_where_code_in_forall (gfc_code *code, int nvar, gfc_expr **var_expr){
3532 gfc_code *cblock;
3533 gfc_code *cnext;
3534
3535 cblock = code->block;
3536 while (cblock)
3537 {
3538 /* the assignment statement of a WHERE statement, or the first
3539 statement in where-body-construct of a WHERE construct */
3540 cnext = cblock->next;
3541 while (cnext)
3542 {
3543 switch (cnext->op)
3544 {
3545 /* WHERE assignment statement */
3546 case EXEC_ASSIGN:
3547 gfc_resolve_assign_in_forall (cnext, nvar, var_expr);
3548 break;
3549
3550 /* WHERE or WHERE construct is part of a where-body-construct */
3551 case EXEC_WHERE:
3552 gfc_resolve_where_code_in_forall (cnext, nvar, var_expr);
3553 break;
3554
3555 default:
3556 gfc_error ("Unsupported statement inside WHERE at %L",
3557 &cnext->loc);
3558 }
3559 /* the next statement within the same where-body-construct */
3560 cnext = cnext->next;
3561 }
3562 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
3563 cblock = cblock->block;
3564 }
3565}
3566
3567
3568/* Traverse the FORALL body to check whether the following errors exist:
3569 1. For assignment, check if a many-to-one assignment happens.
3570 2. For WHERE statement, check the WHERE body to see if there is any
3571 many-to-one assignment. */
3572
3573static void
3574gfc_resolve_forall_body (gfc_code *code, int nvar, gfc_expr **var_expr)
3575{
3576 gfc_code *c;
3577
3578 c = code->block->next;
3579 while (c)
3580 {
3581 switch (c->op)
3582 {
3583 case EXEC_ASSIGN:
3584 case EXEC_POINTER_ASSIGN:
3585 gfc_resolve_assign_in_forall (c, nvar, var_expr);
3586 break;
3587
3588 /* Because the resolve_blocks() will handle the nested FORALL,
3589 there is no need to handle it here. */
3590 case EXEC_FORALL:
3591 break;
3592 case EXEC_WHERE:
3593 gfc_resolve_where_code_in_forall(c, nvar, var_expr);
3594 break;
3595 default:
3596 break;
3597 }
3598 /* The next statement in the FORALL body. */
3599 c = c->next;
3600 }
3601}
3602
3603
3604/* Given a FORALL construct, first resolve the FORALL iterator, then call
3605 gfc_resolve_forall_body to resolve the FORALL body. */
3606
3607static void resolve_blocks (gfc_code *, gfc_namespace *);
3608
3609static void
3610gfc_resolve_forall (gfc_code *code, gfc_namespace *ns, int forall_save)
3611{
3612 static gfc_expr **var_expr;
3613 static int total_var = 0;
3614 static int nvar = 0;
3615 gfc_forall_iterator *fa;
3616 gfc_symbol *forall_index;
3617 gfc_code *next;
3618 int i;
3619
3620 /* Start to resolve a FORALL construct */
3621 if (forall_save == 0)
3622 {
3623 /* Count the total number of FORALL index in the nested FORALL
f7b529fa 3624 construct in order to allocate the VAR_EXPR with proper size. */
6de9cd9a
DN		 3625 next = code;
3626 while ((next != NULL) && (next->op == EXEC_FORALL))
3627 {
3628 for (fa = next->ext.forall_iterator; fa; fa = fa->next)
3629 total_var ++;
3630 next = next->block->next;
3631 }
3632
f7b529fa 3633 /* Allocate VAR_EXPR with NUMBER_OF_FORALL_INDEX elements. */
6de9cd9a
DN		 3634 var_expr = (gfc_expr **) gfc_getmem (total_var * sizeof (gfc_expr *));
3635 }
3636
3637 /* The information about FORALL iterator, including FORALL index start, end
3638 and stride. The FORALL index can not appear in start, end or stride. */
3639 for (fa = code->ext.forall_iterator; fa; fa = fa->next)
3640 {
3641 /* Check if any outer FORALL index name is the same as the current
3642 one. */
3643 for (i = 0; i < nvar; i++)
3644 {
3645 if (fa->var->symtree->n.sym == var_expr[i]->symtree->n.sym)
3646 {
3647 gfc_error ("An outer FORALL construct already has an index "
3648 "with this name %L", &fa->var->where);
3649 }
3650 }
3651
3652 /* Record the current FORALL index. */
3653 var_expr[nvar] = gfc_copy_expr (fa->var);
3654
3655 forall_index = fa->var->symtree->n.sym;
3656
3657 /* Check if the FORALL index appears in start, end or stride. */
3658 if (gfc_find_forall_index (fa->start, forall_index) == SUCCESS)
3659 gfc_error ("A FORALL index must not appear in a limit or stride "
3660 "expression in the same FORALL at %L", &fa->start->where);
3661 if (gfc_find_forall_index (fa->end, forall_index) == SUCCESS)
3662 gfc_error ("A FORALL index must not appear in a limit or stride "
3663 "expression in the same FORALL at %L", &fa->end->where);
3664 if (gfc_find_forall_index (fa->stride, forall_index) == SUCCESS)
3665 gfc_error ("A FORALL index must not appear in a limit or stride "
3666 "expression in the same FORALL at %L", &fa->stride->where);
3667 nvar++;
3668 }
3669
3670 /* Resolve the FORALL body. */
3671 gfc_resolve_forall_body (code, nvar, var_expr);
3672
3673 /* May call gfc_resolve_forall to resolve the inner FORALL loop. */
3674 resolve_blocks (code->block, ns);
3675
3676 /* Free VAR_EXPR after the whole FORALL construct resolved. */
3677 for (i = 0; i < total_var; i++)
3678 gfc_free_expr (var_expr[i]);
3679
3680 /* Reset the counters. */
3681 total_var = 0;
3682 nvar = 0;
3683}
3684
3685
3686/* Resolve lists of blocks found in IF, SELECT CASE, WHERE, FORALL ,GOTO and
3687 DO code nodes. */
3688
3689static void resolve_code (gfc_code *, gfc_namespace *);
3690
3691static void
3692resolve_blocks (gfc_code * b, gfc_namespace * ns)
3693{
3694 try t;
3695
3696 for (; b; b = b->block)
3697 {
3698 t = gfc_resolve_expr (b->expr);
3699 if (gfc_resolve_expr (b->expr2) == FAILURE)
3700 t = FAILURE;
3701
3702 switch (b->op)
3703 {
3704 case EXEC_IF:
3705 if (t == SUCCESS && b->expr != NULL
3706 && (b->expr->ts.type != BT_LOGICAL || b->expr->rank != 0))
3707 gfc_error
3708 ("ELSE IF clause at %L requires a scalar LOGICAL expression",
3709 &b->expr->where);
3710 break;
3711
3712 case EXEC_WHERE:
3713 if (t == SUCCESS
3714 && b->expr != NULL
3715 && (b->expr->ts.type != BT_LOGICAL
3716 || b->expr->rank == 0))
3717 gfc_error
3718 ("WHERE/ELSEWHERE clause at %L requires a LOGICAL array",
3719 &b->expr->where);
3720 break;
3721
3722 case EXEC_GOTO:
3723 resolve_branch (b->label, b);
3724 break;
3725
3726 case EXEC_SELECT:
3727 case EXEC_FORALL:
3728 case EXEC_DO:
3729 case EXEC_DO_WHILE:
3730 break;
3731
3732 default:
3733 gfc_internal_error ("resolve_block(): Bad block type");
3734 }
3735
3736 resolve_code (b->next, ns);
3737 }
3738}
3739
3740
3741/* Given a block of code, recursively resolve everything pointed to by this
3742 code block. */
3743
3744static void
3745resolve_code (gfc_code * code, gfc_namespace * ns)
3746{
3747 int forall_save = 0;
3748 code_stack frame;
3749 gfc_alloc *a;
3750 try t;
3751
3752 frame.prev = cs_base;
3753 frame.head = code;
3754 cs_base = &frame;
3755
3756 for (; code; code = code->next)
3757 {
3758 frame.current = code;
3759
3760 if (code->op == EXEC_FORALL)
3761 {
3762 forall_save = forall_flag;
3763 forall_flag = 1;
3764 gfc_resolve_forall (code, ns, forall_save);
3765 }
3766 else
3767 resolve_blocks (code->block, ns);
3768
3769 if (code->op == EXEC_FORALL)
3770 forall_flag = forall_save;
3771
3772 t = gfc_resolve_expr (code->expr);
3773 if (gfc_resolve_expr (code->expr2) == FAILURE)
3774 t = FAILURE;
3775
3776 switch (code->op)
3777 {
3778 case EXEC_NOP:
3779 case EXEC_CYCLE:
6de9cd9a
DN		 3780 case EXEC_PAUSE:
3781 case EXEC_STOP:
3782 case EXEC_EXIT:
3783 case EXEC_CONTINUE:
3784 case EXEC_DT_END:
3d79abbd 3785 case EXEC_ENTRY:
6de9cd9a
DN		 3786 break;
3787
3788 case EXEC_WHERE:
3789 resolve_where (code, NULL);
3790 break;
3791
3792 case EXEC_GOTO:
ce2df7c6
FW		 3793 if (code->expr != NULL)
3794 {
3795 if (code->expr->ts.type != BT_INTEGER)
3796 gfc_error ("ASSIGNED GOTO statement at %L requires an INTEGER "
6de9cd9a 3797 "variable", &code->expr->where);
ce2df7c6
FW		 3798 else if (code->expr->symtree->n.sym->attr.assign != 1)
3799 gfc_error ("Variable '%s' has not been assigned a target label "
3800 "at %L", code->expr->symtree->n.sym->name,
3801 &code->expr->where);
3802 }
3803 else
6de9cd9a
DN		 3804 resolve_branch (code->label, code);
3805 break;
3806
3807 case EXEC_RETURN:
3808 if (code->expr != NULL && code->expr->ts.type != BT_INTEGER)
3809 gfc_error ("Alternate RETURN statement at %L requires an INTEGER "
3810 "return specifier", &code->expr->where);
3811 break;
3812
3813 case EXEC_ASSIGN:
3814 if (t == FAILURE)
3815 break;
3816
3817 if (gfc_extend_assign (code, ns) == SUCCESS)
3818 goto call;
3819
3820 if (gfc_pure (NULL))
3821 {
3822 if (gfc_impure_variable (code->expr->symtree->n.sym))
3823 {
3824 gfc_error
3825 ("Cannot assign to variable '%s' in PURE procedure at %L",
3826 code->expr->symtree->n.sym->name, &code->expr->where);
3827 break;
3828 }
3829
3830 if (code->expr2->ts.type == BT_DERIVED
3831 && derived_pointer (code->expr2->ts.derived))
3832 {
3833 gfc_error
3834 ("Right side of assignment at %L is a derived type "
3835 "containing a POINTER in a PURE procedure",
3836 &code->expr2->where);
3837 break;
3838 }
3839 }
3840
3841 gfc_check_assign (code->expr, code->expr2, 1);
3842 break;
3843
3844 case EXEC_LABEL_ASSIGN:
3845 if (code->label->defined == ST_LABEL_UNKNOWN)
3846 gfc_error ("Label %d referenced at %L is never defined",
3847 code->label->value, &code->label->where);
40f2165e
TS		 3848 if (t == SUCCESS
3849 && (code->expr->expr_type != EXPR_VARIABLE
3850 || code->expr->symtree->n.sym->ts.type != BT_INTEGER
3851 || code->expr->symtree->n.sym->ts.kind
3852 != gfc_default_integer_kind
3853 || code->expr->symtree->n.sym->as != NULL))
3854 gfc_error ("ASSIGN statement at %L requires a scalar "
3855 "default INTEGER variable", &code->expr->where);
6de9cd9a
DN		 3856 break;
3857
3858 case EXEC_POINTER_ASSIGN:
3859 if (t == FAILURE)
3860 break;
3861
3862 gfc_check_pointer_assign (code->expr, code->expr2);
3863 break;
3864
3865 case EXEC_ARITHMETIC_IF:
3866 if (t == SUCCESS
3867 && code->expr->ts.type != BT_INTEGER
3868 && code->expr->ts.type != BT_REAL)
3869 gfc_error ("Arithmetic IF statement at %L requires a numeric "
3870 "expression", &code->expr->where);
3871
3872 resolve_branch (code->label, code);
3873 resolve_branch (code->label2, code);
3874 resolve_branch (code->label3, code);
3875 break;
3876
3877 case EXEC_IF:
3878 if (t == SUCCESS && code->expr != NULL
3879 && (code->expr->ts.type != BT_LOGICAL
3880 || code->expr->rank != 0))
3881 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
3882 &code->expr->where);
3883 break;
3884
3885 case EXEC_CALL:
3886 call:
3887 resolve_call (code);
3888 break;
3889
3890 case EXEC_SELECT:
3891 /* Select is complicated. Also, a SELECT construct could be
3892 a transformed computed GOTO. */
3893 resolve_select (code);
3894 break;
3895
3896 case EXEC_DO:
3897 if (code->ext.iterator != NULL)
8d5cfa27 3898 gfc_resolve_iterator (code->ext.iterator, true);
6de9cd9a
DN		 3899 break;
3900
3901 case EXEC_DO_WHILE:
3902 if (code->expr == NULL)
3903 gfc_internal_error ("resolve_code(): No expression on DO WHILE");
3904 if (t == SUCCESS
3905 && (code->expr->rank != 0
3906 || code->expr->ts.type != BT_LOGICAL))
3907 gfc_error ("Exit condition of DO WHILE loop at %L must be "
3908 "a scalar LOGICAL expression", &code->expr->where);
3909 break;
3910
3911 case EXEC_ALLOCATE:
3912 if (t == SUCCESS && code->expr != NULL
3913 && code->expr->ts.type != BT_INTEGER)
3914 gfc_error ("STAT tag in ALLOCATE statement at %L must be "
3915 "of type INTEGER", &code->expr->where);
3916
3917 for (a = code->ext.alloc_list; a; a = a->next)
3918 resolve_allocate_expr (a->expr);
3919
3920 break;
3921
3922 case EXEC_DEALLOCATE:
3923 if (t == SUCCESS && code->expr != NULL
3924 && code->expr->ts.type != BT_INTEGER)
3925 gfc_error
3926 ("STAT tag in DEALLOCATE statement at %L must be of type "
3927 "INTEGER", &code->expr->where);
3928
3929 for (a = code->ext.alloc_list; a; a = a->next)
3930 resolve_deallocate_expr (a->expr);
3931
3932 break;
3933
3934 case EXEC_OPEN:
3935 if (gfc_resolve_open (code->ext.open) == FAILURE)
3936 break;
3937
3938 resolve_branch (code->ext.open->err, code);
3939 break;
3940
3941 case EXEC_CLOSE:
3942 if (gfc_resolve_close (code->ext.close) == FAILURE)
3943 break;
3944
3945 resolve_branch (code->ext.close->err, code);
3946 break;
3947
3948 case EXEC_BACKSPACE:
3949 case EXEC_ENDFILE:
3950 case EXEC_REWIND:
3951 if (gfc_resolve_filepos (code->ext.filepos) == FAILURE)
3952 break;
3953
3954 resolve_branch (code->ext.filepos->err, code);
3955 break;
3956
3957 case EXEC_INQUIRE:
8750f9cd
JB		 3958 if (gfc_resolve_inquire (code->ext.inquire) == FAILURE)
3959 break;
3960
3961 resolve_branch (code->ext.inquire->err, code);
3962 break;
3963
3964 case EXEC_IOLENGTH:
6e45f57b 3965 gcc_assert (code->ext.inquire != NULL);
6de9cd9a
DN		 3966 if (gfc_resolve_inquire (code->ext.inquire) == FAILURE)
3967 break;
3968
3969 resolve_branch (code->ext.inquire->err, code);
3970 break;
3971
3972 case EXEC_READ:
3973 case EXEC_WRITE:
3974 if (gfc_resolve_dt (code->ext.dt) == FAILURE)
3975 break;
3976
3977 resolve_branch (code->ext.dt->err, code);
3978 resolve_branch (code->ext.dt->end, code);
3979 resolve_branch (code->ext.dt->eor, code);
3980 break;
3981
0e6928d8
TS		 3982 case EXEC_TRANSFER:
3983 resolve_transfer (code);
3984 break;
3985
6de9cd9a
DN		 3986 case EXEC_FORALL:
3987 resolve_forall_iterators (code->ext.forall_iterator);
3988
3989 if (code->expr != NULL && code->expr->ts.type != BT_LOGICAL)
3990 gfc_error
3991 ("FORALL mask clause at %L requires a LOGICAL expression",
3992 &code->expr->where);
3993 break;
3994
3995 default:
3996 gfc_internal_error ("resolve_code(): Bad statement code");
3997 }
3998 }
3999
4000 cs_base = frame.prev;
4001}
4002
4003
4004/* Resolve initial values and make sure they are compatible with
4005 the variable. */
4006
4007static void
4008resolve_values (gfc_symbol * sym)
4009{
4010
4011 if (sym->value == NULL)
4012 return;
4013
4014 if (gfc_resolve_expr (sym->value) == FAILURE)
4015 return;
4016
4017 gfc_check_assign_symbol (sym, sym->value);
4018}
4019
4020
4021/* Do anything necessary to resolve a symbol. Right now, we just
4022 assume that an otherwise unknown symbol is a variable. This sort
4023 of thing commonly happens for symbols in module. */
4024
4025static void
4026resolve_symbol (gfc_symbol * sym)
4027{
4028 /* Zero if we are checking a formal namespace. */
4029 static int formal_ns_flag = 1;
4030 int formal_ns_save, check_constant, mp_flag;
54b4ba60
PB		 4031 int i;
4032 const char *whynot;
af30f793 4033 gfc_namelist *nl;
6de9cd9a
DN		 4034
4035 if (sym->attr.flavor == FL_UNKNOWN)
4036 {
4037 if (sym->attr.external == 0 && sym->attr.intrinsic == 0)
4038 sym->attr.flavor = FL_VARIABLE;
4039 else
4040 {
4041 sym->attr.flavor = FL_PROCEDURE;
4042 if (sym->attr.dimension)
4043 sym->attr.function = 1;
4044 }
4045 }
4046
4047 /* Symbols that are module procedures with results (functions) have
4048 the types and array specification copied for type checking in
4049 procedures that call them, as well as for saving to a module
4050 file. These symbols can't stand the scrutiny that their results
4051 can. */
4052 mp_flag = (sym->result != NULL && sym->result != sym);
4053
4054 /* Assign default type to symbols that need one and don't have one. */
4055 if (sym->ts.type == BT_UNKNOWN)
4056 {
4057 if (sym->attr.flavor == FL_VARIABLE || sym->attr.flavor == FL_PARAMETER)
d3fcc995 4058 gfc_set_default_type (sym, 1, NULL);
6de9cd9a
DN		 4059
4060 if (sym->attr.flavor == FL_PROCEDURE && sym->attr.function)
4061 {
4062 if (!mp_flag)
4063 gfc_set_default_type (sym, 0, NULL);
4064 else
4065 {
4066 /* Result may be in another namespace. */
4067 resolve_symbol (sym->result);
4068
4069 sym->ts = sym->result->ts;
4070 sym->as = gfc_copy_array_spec (sym->result->as);
09e7f686
TS		 4071 sym->attr.dimension = sym->result->attr.dimension;
4072 sym->attr.pointer = sym->result->attr.pointer;
6de9cd9a
DN		 4073 }
4074 }
4075 }
4076
f5e440e1
TS		 4077 /* Assumed size arrays and assumed shape arrays must be dummy
4078 arguments. */
4079
6de9cd9a
DN		 4080 if (sym->as != NULL
4081 && (sym->as->type == AS_ASSUMED_SIZE
4082 || sym->as->type == AS_ASSUMED_SHAPE)
4083 && sym->attr.dummy == 0)
4084 {
a4ac5dd3
TS		 4085 gfc_error ("Assumed %s array at %L must be a dummy argument",
4086 sym->as->type == AS_ASSUMED_SIZE ? "size" : "shape",
4087 &sym->declared_at);
4088 return;
4089 }
4090
4077d207
TS		 4091 /* A parameter array's shape needs to be constant. */
4092
4093 if (sym->attr.flavor == FL_PARAMETER && sym->as != NULL
4094 && !gfc_is_compile_time_shape (sym->as))
a4ac5dd3 4095 {
4077d207
TS		 4096 gfc_error ("Parameter array '%s' at %L cannot be automatic "
4097 "or assumed shape", sym->name, &sym->declared_at);
4098 return;
6de9cd9a
DN		 4099 }
4100
4101 /* Make sure that character string variables with assumed length are
a4ac5dd3 4102 dummy arguments. */
6de9cd9a
DN		 4103
4104 if (sym->attr.flavor == FL_VARIABLE && !sym->attr.result
4105 && sym->ts.type == BT_CHARACTER
4106 && sym->ts.cl->length == NULL && sym->attr.dummy == 0)
4107 {
4108 gfc_error ("Entity with assumed character length at %L must be a "
4109 "dummy argument or a PARAMETER", &sym->declared_at);
4110 return;
4111 }
4112
4113 /* Make sure a parameter that has been implicitly typed still
4114 matches the implicit type, since PARAMETER statements can precede
4115 IMPLICIT statements. */
4116
4117 if (sym->attr.flavor == FL_PARAMETER
4118 && sym->attr.implicit_type
4119 && !gfc_compare_types (&sym->ts, gfc_get_default_type (sym, sym->ns)))
4120 gfc_error ("Implicitly typed PARAMETER '%s' at %L doesn't match a "
4121 "later IMPLICIT type", sym->name, &sym->declared_at);
4122
4123 /* Make sure the types of derived parameters are consistent. This
4124 type checking is deferred until resolution because the type may
4125 refer to a derived type from the host. */
4126
4127 if (sym->attr.flavor == FL_PARAMETER
4128 && sym->ts.type == BT_DERIVED
4129 && !gfc_compare_types (&sym->ts, &sym->value->ts))
4130 gfc_error ("Incompatible derived type in PARAMETER at %L",
4131 &sym->value->where);
4132
4133 /* Make sure symbols with known intent or optional are really dummy
4134 variable. Because of ENTRY statement, this has to be deferred
4135 until resolution time. */
4136
4137 if (! sym->attr.dummy
4138 && (sym->attr.optional
4139 || sym->attr.intent != INTENT_UNKNOWN))
4140 {
4141 gfc_error ("Symbol at %L is not a DUMMY variable", &sym->declared_at);
4142 return;
4143 }
4144
4145 if (sym->attr.proc == PROC_ST_FUNCTION)
4146 {
4147 if (sym->ts.type == BT_CHARACTER)
4148 {
4149 gfc_charlen *cl = sym->ts.cl;
4150 if (!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT)
4151 {
4152 gfc_error ("Character-valued statement function '%s' at %L must "
4153 "have constant length", sym->name, &sym->declared_at);
4154 return;
4155 }
4156 }
4157 }
4158
4159 /* Constraints on deferred shape variable. */
4160 if (sym->attr.flavor == FL_VARIABLE
4161 || (sym->attr.flavor == FL_PROCEDURE
4162 && sym->attr.function))
4163 {
4164 if (sym->as == NULL || sym->as->type != AS_DEFERRED)
4165 {
4166 if (sym->attr.allocatable)
4167 {
4168 if (sym->attr.dimension)
4169 gfc_error ("Allocatable array at %L must have a deferred shape",
4170 &sym->declared_at);
4171 else
4172 gfc_error ("Object at %L may not be ALLOCATABLE",
4173 &sym->declared_at);
4174 return;
4175 }
4176
4177 if (sym->attr.pointer && sym->attr.dimension)
4178 {
4179 gfc_error ("Pointer to array at %L must have a deferred shape",
4180 &sym->declared_at);
4181 return;
4182 }
4183
4184 }
4185 else
4186 {
4187 if (!mp_flag && !sym->attr.allocatable
4188 && !sym->attr.pointer && !sym->attr.dummy)
4189 {
4190 gfc_error ("Array at %L cannot have a deferred shape",
4191 &sym->declared_at);
4192 return;
4193 }
4194 }
4195 }
4196
af30f793 4197 switch (sym->attr.flavor)
54b4ba60 4198 {
af30f793 4199 case FL_VARIABLE:
54b4ba60
PB		 4200 /* Can the sybol have an initializer? */
4201 whynot = NULL;
4202 if (sym->attr.allocatable)
4203 whynot = "Allocatable";
4204 else if (sym->attr.external)
4205 whynot = "External";
4206 else if (sym->attr.dummy)
4207 whynot = "Dummy";
4208 else if (sym->attr.intrinsic)
4209 whynot = "Intrinsic";
4210 else if (sym->attr.result)
4211 whynot = "Function Result";
4212 else if (sym->attr.dimension && !sym->attr.pointer)
4213 {
4214 /* Don't allow initialization of automatic arrays. */
4215 for (i = 0; i < sym->as->rank; i++)
4216 {
4217 if (sym->as->lower[i] == NULL
4218 || sym->as->lower[i]->expr_type != EXPR_CONSTANT
4219 || sym->as->upper[i] == NULL
4220 || sym->as->upper[i]->expr_type != EXPR_CONSTANT)
4221 {
4222 whynot = "Automatic array";
4223 break;
4224 }
4225 }
4226 }
4227
4228 /* Reject illegal initializers. */
4229 if (sym->value && whynot)
4230 {
4231 gfc_error ("%s '%s' at %L cannot have an initializer",
4232 whynot, sym->name, &sym->declared_at);
4233 return;
4234 }
4235
4236 /* Assign default initializer. */
4237 if (sym->ts.type == BT_DERIVED && !(sym->value || whynot))
4238 sym->value = gfc_default_initializer (&sym->ts);
af30f793
PB		 4239 break;
4240
4241 case FL_NAMELIST:
4242 /* Reject PRIVATE objects in a PUBLIC namelist. */
4243 if (gfc_check_access(sym->attr.access, sym->ns->default_access))
4244 {
4245 for (nl = sym->namelist; nl; nl = nl->next)
4246 {
4247 if (!gfc_check_access(nl->sym->attr.access,
4248 nl->sym->ns->default_access))
4249 gfc_error ("PRIVATE symbol '%s' cannot be member of "
4250 "PUBLIC namelist at %L", nl->sym->name,
4251 &sym->declared_at);
4252 }
4253 }
4254 break;
4255
4256 default:
4257 break;
54b4ba60
PB		 4258 }
4259
4260
6de9cd9a
DN		 4261 /* Make sure that intrinsic exist */
4262 if (sym->attr.intrinsic
4263 && ! gfc_intrinsic_name(sym->name, 0)
4264 && ! gfc_intrinsic_name(sym->name, 1))
4265 gfc_error("Intrinsic at %L does not exist", &sym->declared_at);
4266
4267 /* Resolve array specifier. Check as well some constraints
f7b529fa 4268 on COMMON blocks. */
6de9cd9a
DN		 4269
4270 check_constant = sym->attr.in_common && !sym->attr.pointer;
4271 gfc_resolve_array_spec (sym->as, check_constant);
4272
4273 /* Resolve formal namespaces. */
4274
4275 if (formal_ns_flag && sym != NULL && sym->formal_ns != NULL)
4276 {
4277 formal_ns_save = formal_ns_flag;
4278 formal_ns_flag = 0;
4279 gfc_resolve (sym->formal_ns);
4280 formal_ns_flag = formal_ns_save;
4281 }
4282}
4283
4284
4285
4286/************* Resolve DATA statements *************/
4287
4288static struct
4289{
4290 gfc_data_value *vnode;
b8502435 4291 unsigned int left;
6de9cd9a
DN		 4292}
4293values;
4294
4295
4296/* Advance the values structure to point to the next value in the data list. */
4297
4298static try
4299next_data_value (void)
4300{
6de9cd9a
DN		 4301 while (values.left == 0)
4302 {
4303 if (values.vnode->next == NULL)
4304 return FAILURE;
4305
4306 values.vnode = values.vnode->next;
4307 values.left = values.vnode->repeat;
4308 }
4309
6de9cd9a
DN		 4310 return SUCCESS;
4311}
4312
4313
4314static try
4315check_data_variable (gfc_data_variable * var, locus * where)
4316{
4317 gfc_expr *e;
4318 mpz_t size;
4319 mpz_t offset;
4320 try t;
f5e440e1 4321 ar_type mark = AR_UNKNOWN;
6de9cd9a
DN		 4322 int i;
4323 mpz_t section_index[GFC_MAX_DIMENSIONS];
4324 gfc_ref *ref;
4325 gfc_array_ref *ar;
4326
4327 if (gfc_resolve_expr (var->expr) == FAILURE)
4328 return FAILURE;
4329
4330 ar = NULL;
4331 mpz_init_set_si (offset, 0);
4332 e = var->expr;
4333
4334 if (e->expr_type != EXPR_VARIABLE)
4335 gfc_internal_error ("check_data_variable(): Bad expression");
4336
4337 if (e->rank == 0)
b8502435
RH		 4338 {
4339 mpz_init_set_ui (size, 1);
4340 ref = NULL;
4341 }
6de9cd9a
DN		 4342 else
4343 {
4344 ref = e->ref;
4345
4346 /* Find the array section reference. */
4347 for (ref = e->ref; ref; ref = ref->next)
4348 {
4349 if (ref->type != REF_ARRAY)
4350 continue;
4351 if (ref->u.ar.type == AR_ELEMENT)
4352 continue;
4353 break;
4354 }
6e45f57b 4355 gcc_assert (ref);
6de9cd9a 4356
1f2959f0 4357 /* Set marks according to the reference pattern. */
6de9cd9a
DN		 4358 switch (ref->u.ar.type)
4359 {
4360 case AR_FULL:
f5e440e1 4361 mark = AR_FULL;
6de9cd9a
DN		 4362 break;
4363
4364 case AR_SECTION:
4365 ar = &ref->u.ar;
4366 /* Get the start position of array section. */
4367 gfc_get_section_index (ar, section_index, &offset);
f5e440e1 4368 mark = AR_SECTION;
6de9cd9a
DN		 4369 break;
4370
4371 default:
6e45f57b 4372 gcc_unreachable ();
6de9cd9a
DN		 4373 }
4374
4375 if (gfc_array_size (e, &size) == FAILURE)
4376 {
4377 gfc_error ("Nonconstant array section at %L in DATA statement",
4378 &e->where);
4379 mpz_clear (offset);
4380 return FAILURE;
4381 }
4382 }
4383
4384 t = SUCCESS;
4385
4386 while (mpz_cmp_ui (size, 0) > 0)
4387 {
4388 if (next_data_value () == FAILURE)
4389 {
4390 gfc_error ("DATA statement at %L has more variables than values",
4391 where);
4392 t = FAILURE;
4393 break;
4394 }
4395
4396 t = gfc_check_assign (var->expr, values.vnode->expr, 0);
4397 if (t == FAILURE)
4398 break;
4399
b8502435
RH		 4400 /* If we have more than one element left in the repeat count,
4401 and we have more than one element left in the target variable,
4402 then create a range assignment. */
4403 /* ??? Only done for full arrays for now, since array sections
4404 seem tricky. */
4405 if (mark == AR_FULL && ref && ref->next == NULL
4406 && values.left > 1 && mpz_cmp_ui (size, 1) > 0)
4407 {
4408 mpz_t range;
4409
4410 if (mpz_cmp_ui (size, values.left) >= 0)
4411 {
4412 mpz_init_set_ui (range, values.left);
4413 mpz_sub_ui (size, size, values.left);
4414 values.left = 0;
4415 }
4416 else
4417 {
4418 mpz_init_set (range, size);
4419 values.left -= mpz_get_ui (size);
4420 mpz_set_ui (size, 0);
4421 }
4422
4423 gfc_assign_data_value_range (var->expr, values.vnode->expr,
4424 offset, range);
4425
4426 mpz_add (offset, offset, range);
4427 mpz_clear (range);
4428 }
4429
6de9cd9a 4430 /* Assign initial value to symbol. */
b8502435
RH		 4431 else
4432 {
4433 values.left -= 1;
4434 mpz_sub_ui (size, size, 1);
6de9cd9a 4435
b8502435 4436 gfc_assign_data_value (var->expr, values.vnode->expr, offset);
6de9cd9a 4437
b8502435
RH		 4438 if (mark == AR_FULL)
4439 mpz_add_ui (offset, offset, 1);
6de9cd9a 4440
b8502435
RH		 4441 /* Modify the array section indexes and recalculate the offset
4442 for next element. */
4443 else if (mark == AR_SECTION)
4444 gfc_advance_section (section_index, ar, &offset);
4445 }
6de9cd9a 4446 }
b8502435 4447
f5e440e1 4448 if (mark == AR_SECTION)
6de9cd9a
DN		 4449 {
4450 for (i = 0; i < ar->dimen; i++)
4451 mpz_clear (section_index[i]);
4452 }
4453
4454 mpz_clear (size);
4455 mpz_clear (offset);
4456
4457 return t;
4458}
4459
4460
4461static try traverse_data_var (gfc_data_variable *, locus *);
4462
4463/* Iterate over a list of elements in a DATA statement. */
4464
4465static try
4466traverse_data_list (gfc_data_variable * var, locus * where)
4467{
4468 mpz_t trip;
4469 iterator_stack frame;
4470 gfc_expr *e;
4471
4472 mpz_init (frame.value);
4473
4474 mpz_init_set (trip, var->iter.end->value.integer);
4475 mpz_sub (trip, trip, var->iter.start->value.integer);
4476 mpz_add (trip, trip, var->iter.step->value.integer);
4477
4478 mpz_div (trip, trip, var->iter.step->value.integer);
4479
4480 mpz_set (frame.value, var->iter.start->value.integer);
4481
4482 frame.prev = iter_stack;
4483 frame.variable = var->iter.var->symtree;
4484 iter_stack = &frame;
4485
4486 while (mpz_cmp_ui (trip, 0) > 0)
4487 {
4488 if (traverse_data_var (var->list, where) == FAILURE)
4489 {
4490 mpz_clear (trip);
4491 return FAILURE;
4492 }
4493
4494 e = gfc_copy_expr (var->expr);
4495 if (gfc_simplify_expr (e, 1) == FAILURE)
4496 {
4497 gfc_free_expr (e);
4498 return FAILURE;
4499 }
4500
4501 mpz_add (frame.value, frame.value, var->iter.step->value.integer);
4502
4503 mpz_sub_ui (trip, trip, 1);
4504 }
4505
4506 mpz_clear (trip);
4507 mpz_clear (frame.value);
4508
4509 iter_stack = frame.prev;
4510 return SUCCESS;
4511}
4512
4513
4514/* Type resolve variables in the variable list of a DATA statement. */
4515
4516static try
4517traverse_data_var (gfc_data_variable * var, locus * where)
4518{
4519 try t;
4520
4521 for (; var; var = var->next)
4522 {
4523 if (var->expr == NULL)
4524 t = traverse_data_list (var, where);
4525 else
4526 t = check_data_variable (var, where);
4527
4528 if (t == FAILURE)
4529 return FAILURE;
4530 }
4531
4532 return SUCCESS;
4533}
4534
4535
4536/* Resolve the expressions and iterators associated with a data statement.
4537 This is separate from the assignment checking because data lists should
4538 only be resolved once. */
4539
4540static try
4541resolve_data_variables (gfc_data_variable * d)
4542{
6de9cd9a
DN		 4543 for (; d; d = d->next)
4544 {
4545 if (d->list == NULL)
4546 {
4547 if (gfc_resolve_expr (d->expr) == FAILURE)
4548 return FAILURE;
4549 }
4550 else
4551 {
8d5cfa27 4552 if (gfc_resolve_iterator (&d->iter, false) == FAILURE)
6de9cd9a
DN		 4553 return FAILURE;
4554
4555 if (d->iter.start->expr_type != EXPR_CONSTANT
4556 || d->iter.end->expr_type != EXPR_CONSTANT
4557 || d->iter.step->expr_type != EXPR_CONSTANT)
4558 gfc_internal_error ("resolve_data_variables(): Bad iterator");
4559
4560 if (resolve_data_variables (d->list) == FAILURE)
4561 return FAILURE;
4562 }
4563 }
4564
4565 return SUCCESS;
4566}
4567
4568
4569/* Resolve a single DATA statement. We implement this by storing a pointer to
4570 the value list into static variables, and then recursively traversing the
4571 variables list, expanding iterators and such. */
4572
4573static void
4574resolve_data (gfc_data * d)
4575{
6de9cd9a
DN		 4576 if (resolve_data_variables (d->var) == FAILURE)
4577 return;
4578
4579 values.vnode = d->value;
4580 values.left = (d->value == NULL) ? 0 : d->value->repeat;
4581
4582 if (traverse_data_var (d->var, &d->where) == FAILURE)
4583 return;
4584
4585 /* At this point, we better not have any values left. */
4586
4587 if (next_data_value () == SUCCESS)
4588 gfc_error ("DATA statement at %L has more values than variables",
4589 &d->where);
4590}
4591
4592
4593/* Determines if a variable is not 'pure', ie not assignable within a pure
4594 procedure. Returns zero if assignment is OK, nonzero if there is a problem.
4595 */
4596
4597int
4598gfc_impure_variable (gfc_symbol * sym)
4599{
6de9cd9a
DN		 4600 if (sym->attr.use_assoc || sym->attr.in_common)
4601 return 1;
4602
4603 if (sym->ns != gfc_current_ns)
4604 return !sym->attr.function;
4605
4606 /* TODO: Check storage association through EQUIVALENCE statements */
4607
4608 return 0;
4609}
4610
4611
4612/* Test whether a symbol is pure or not. For a NULL pointer, checks the
4613 symbol of the current procedure. */
4614
4615int
4616gfc_pure (gfc_symbol * sym)
4617{
4618 symbol_attribute attr;
4619
4620 if (sym == NULL)
4621 sym = gfc_current_ns->proc_name;
4622 if (sym == NULL)
4623 return 0;
4624
4625 attr = sym->attr;
4626
4627 return attr.flavor == FL_PROCEDURE && (attr.pure || attr.elemental);
4628}
4629
4630
4631/* Test whether the current procedure is elemental or not. */
4632
4633int
4634gfc_elemental (gfc_symbol * sym)
4635{
4636 symbol_attribute attr;
4637
4638 if (sym == NULL)
4639 sym = gfc_current_ns->proc_name;
4640 if (sym == NULL)
4641 return 0;
4642 attr = sym->attr;
4643
4644 return attr.flavor == FL_PROCEDURE && attr.elemental;
4645}
4646
4647
4648/* Warn about unused labels. */
4649
4650static void
4651warn_unused_label (gfc_namespace * ns)
4652{
4653 gfc_st_label *l;
4654
4655 l = ns->st_labels;
4656 if (l == NULL)
4657 return;
4658
4659 while (l->next)
4660 l = l->next;
4661
4662 for (; l; l = l->prev)
4663 {
4664 if (l->defined == ST_LABEL_UNKNOWN)
4665 continue;
4666
4667 switch (l->referenced)
4668 {
4669 case ST_LABEL_UNKNOWN:
4670 gfc_warning ("Label %d at %L defined but not used", l->value,
4671 &l->where);
4672 break;
4673
4674 case ST_LABEL_BAD_TARGET:
4675 gfc_warning ("Label %d at %L defined but cannot be used", l->value,
4676 &l->where);
4677 break;
4678
4679 default:
4680 break;
4681 }
4682 }
4683}
4684
4685
4686/* Resolve derived type EQUIVALENCE object. */
4687
4688static try
4689resolve_equivalence_derived (gfc_symbol *derived, gfc_symbol *sym, gfc_expr *e)
4690{
4691 gfc_symbol *d;
4692 gfc_component *c = derived->components;
4693
4694 if (!derived)
4695 return SUCCESS;
4696
4697 /* Shall not be an object of nonsequence derived type. */
4698 if (!derived->attr.sequence)
4699 {
4700 gfc_error ("Derived type variable '%s' at %L must have SEQUENCE "
4701 "attribute to be an EQUIVALENCE object", sym->name, &e->where);
4702 return FAILURE;
4703 }
4704
4705 for (; c ; c = c->next)
4706 {
4707 d = c->ts.derived;
4708 if (d && (resolve_equivalence_derived (c->ts.derived, sym, e) == FAILURE))
4709 return FAILURE;
4710
4711 /* Shall not be an object of sequence derived type containing a pointer
4712 in the structure. */
4713 if (c->pointer)
4714 {
4715 gfc_error ("Derived type variable '%s' at %L has pointer componet(s) "
4716 "cannot be an EQUIVALENCE object", sym->name, &e->where);
4717 return FAILURE;
4718 }
4719 }
4720 return SUCCESS;
4721}
4722
4723
4724/* Resolve equivalence object.
4725 An EQUIVALENCE object shall not be a dummy argument, a pointer, an
4726 allocatable array, an object of nonsequence derived type, an object of
4727 sequence derived type containing a pointer at any level of component
4728 selection, an automatic object, a function name, an entry name, a result
4729 name, a named constant, a structure component, or a subobject of any of
4730 the preceding objects. */
4731
4732static void
4733resolve_equivalence (gfc_equiv *eq)
4734{
4735 gfc_symbol *sym;
4736 gfc_symbol *derived;
4737 gfc_expr *e;
4738 gfc_ref *r;
4739
4740 for (; eq; eq = eq->eq)
4741 {
4742 e = eq->expr;
4743 if (gfc_resolve_expr (e) == FAILURE)
4744 continue;
4745
4746 sym = e->symtree->n.sym;
4747
4748 /* Shall not be a dummy argument. */
4749 if (sym->attr.dummy)
4750 {
4751 gfc_error ("Dummy argument '%s' at %L cannot be an EQUIVALENCE "
4752 "object", sym->name, &e->where);
4753 continue;
4754 }
4755
4756 /* Shall not be an allocatable array. */
4757 if (sym->attr.allocatable)
4758 {
4759 gfc_error ("Allocatable array '%s' at %L cannot be an EQUIVALENCE "
4760 "object", sym->name, &e->where);
4761 continue;
4762 }
4763
4764 /* Shall not be a pointer. */
4765 if (sym->attr.pointer)
4766 {
4767 gfc_error ("Pointer '%s' at %L cannot be an EQUIVALENCE object",
4768 sym->name, &e->where);
4769 continue;
4770 }
4771
4772 /* Shall not be a function name, ... */
4773 if (sym->attr.function || sym->attr.result || sym->attr.entry
4774 || sym->attr.subroutine)
4775 {
4776 gfc_error ("Entity '%s' at %L cannot be an EQUIVALENCE object",
4777 sym->name, &e->where);
4778 continue;
4779 }
4780
4781 /* Shall not be a named constant. */
4782 if (e->expr_type == EXPR_CONSTANT)
4783 {
4784 gfc_error ("Named constant '%s' at %L cannot be an EQUIVALENCE "
4785 "object", sym->name, &e->where);
4786 continue;
4787 }
4788
4789 derived = e->ts.derived;
4790 if (derived && resolve_equivalence_derived (derived, sym, e) == FAILURE)
4791 continue;
4792
4793 if (!e->ref)
4794 continue;
4795
4796 /* Shall not be an automatic array. */
4797 if (e->ref->type == REF_ARRAY
4798 && gfc_resolve_array_spec (e->ref->u.ar.as, 1) == FAILURE)
4799 {
4800 gfc_error ("Array '%s' at %L with non-constant bounds cannot be "
4801 "an EQUIVALENCE object", sym->name, &e->where);
4802 continue;
4803 }
4804
4805 /* Shall not be a structure component. */
4806 r = e->ref;
4807 while (r)
4808 {
4809 if (r->type == REF_COMPONENT)
4810 {
4811 gfc_error ("Structure component '%s' at %L cannot be an "
4812 "EQUIVALENCE object",
4813 r->u.c.component->name, &e->where);
4814 break;
4815 }
4816 r = r->next;
4817 }
4818 }
4819}
cf4d246b
JJ		 4820
4821
4822/* Resolve function and ENTRY types, issue diagnostics if needed. */
4823
4824static void
4825resolve_fntype (gfc_namespace * ns)
4826{
4827 gfc_entry_list *el;
4828 gfc_symbol *sym;
4829
4830 if (ns->proc_name == NULL || !ns->proc_name->attr.function)
4831 return;
4832
4833 /* If there are any entries, ns->proc_name is the entry master
4834 synthetic symbol and ns->entries->sym actual FUNCTION symbol. */
4835 if (ns->entries)
4836 sym = ns->entries->sym;
4837 else
4838 sym = ns->proc_name;
4839 if (sym->result == sym
4840 && sym->ts.type == BT_UNKNOWN
4841 && gfc_set_default_type (sym, 0, NULL) == FAILURE
4842 && !sym->attr.untyped)
4843 {
4844 gfc_error ("Function '%s' at %L has no IMPLICIT type",
4845 sym->name, &sym->declared_at);
4846 sym->attr.untyped = 1;
4847 }
4848
4849 if (ns->entries)
4850 for (el = ns->entries->next; el; el = el->next)
4851 {
4852 if (el->sym->result == el->sym
4853 && el->sym->ts.type == BT_UNKNOWN
4854 && gfc_set_default_type (el->sym, 0, NULL) == FAILURE
4855 && !el->sym->attr.untyped)
4856 {
4857 gfc_error ("ENTRY '%s' at %L has no IMPLICIT type",
4858 el->sym->name, &el->sym->declared_at);
4859 el->sym->attr.untyped = 1;
4860 }
4861 }
4862}
4863
4864
6de9cd9a
DN		 4865/* This function is called after a complete program unit has been compiled.
4866 Its purpose is to examine all of the expressions associated with a program
4867 unit, assign types to all intermediate expressions, make sure that all
4868 assignments are to compatible types and figure out which names refer to
4869 which functions or subroutines. */
4870
4871void
4872gfc_resolve (gfc_namespace * ns)
4873{
4874 gfc_namespace *old_ns, *n;
4875 gfc_charlen *cl;
4876 gfc_data *d;
4877 gfc_equiv *eq;
4878
4879 old_ns = gfc_current_ns;
4880 gfc_current_ns = ns;
4881
3d79abbd
PB		 4882 resolve_entries (ns);
4883
6de9cd9a
DN		 4884 resolve_contained_functions (ns);
4885
4886 gfc_traverse_ns (ns, resolve_symbol);
4887
cf4d246b
JJ		 4888 resolve_fntype (ns);
4889
6de9cd9a
DN		 4890 for (n = ns->contained; n; n = n->sibling)
4891 {
4892 if (gfc_pure (ns->proc_name) && !gfc_pure (n->proc_name))
4893 gfc_error ("Contained procedure '%s' at %L of a PURE procedure must "
4894 "also be PURE", n->proc_name->name,
4895 &n->proc_name->declared_at);
4896
4897 gfc_resolve (n);
4898 }
4899
4900 forall_flag = 0;
4901 gfc_check_interfaces (ns);
4902
4903 for (cl = ns->cl_list; cl; cl = cl->next)
4904 {
4905 if (cl->length == NULL || gfc_resolve_expr (cl->length) == FAILURE)
4906 continue;
4907
8f9c06ca
TS		 4908 if (gfc_simplify_expr (cl->length, 0) == FAILURE)
4909 continue;
4910
4911 if (gfc_specification_expr (cl->length) == FAILURE)
4912 continue;
6de9cd9a
DN		 4913 }
4914
4915 gfc_traverse_ns (ns, resolve_values);
4916
4917 if (ns->save_all)
4918 gfc_save_all (ns);
4919
4920 iter_stack = NULL;
4921 for (d = ns->data; d; d = d->next)
4922 resolve_data (d);
4923
4924 iter_stack = NULL;
4925 gfc_traverse_ns (ns, gfc_formalize_init_value);
4926
4927 for (eq = ns->equiv; eq; eq = eq->next)
4928 resolve_equivalence (eq);
4929
4930 cs_base = NULL;
4931 resolve_code (ns->code, ns);
4932
4933 /* Warn about unused labels. */
4934 if (gfc_option.warn_unused_labels)
4935 warn_unused_label (ns);
4936
4937 gfc_current_ns = old_ns;
4938}
GNU Compiler Collection
This page took 1.016158 seconds and 5 git commands to generate.