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