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