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