1 /* Perform type resolution on the various stuctures.
2 Copyright (C) 2001, 2002, 2003, 2004, 2005 Free Software Foundation, Inc.
3 Contributed by Andy Vaught
5 This file is part of GCC.
7 GCC is free software; you can redistribute it and/or modify it under
8 the terms of the GNU General Public License as published by the Free
9 Software Foundation; either version 2, or (at your option) any later
12 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
13 WARRANTY; without even the implied warranty of MERCHANTABILITY or
14 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
17 You should have received a copy of the GNU General Public License
18 along with GCC; see the file COPYING. If not, write to the Free
19 Software Foundation, 51 Franklin Street, Fifth Floor,Boston, MA
26 #include "arith.h" /* For gfc_compare_expr(). */
28 /* Types used in equivalence statements. */
32 SEQ_NONDEFAULT, SEQ_NUMERIC, SEQ_CHARACTER, SEQ_MIXED
36 /* Stack to push the current if we descend into a block during
37 resolution. See resolve_branch() and resolve_code(). */
39 typedef struct code_stack
41 struct gfc_code *head, *current;
42 struct code_stack *prev;
46 static code_stack *cs_base = NULL;
49 /* Nonzero if we're inside a FORALL block */
51 static int forall_flag;
53 /* Nonzero if we are processing a formal arglist. The corresponding function
54 resets the flag each time that it is read. */
55 static int formal_arg_flag = 0;
58 gfc_is_formal_arg (void)
60 return formal_arg_flag;
63 /* Resolve types of formal argument lists. These have to be done early so that
64 the formal argument lists of module procedures can be copied to the
65 containing module before the individual procedures are resolved
66 individually. We also resolve argument lists of procedures in interface
67 blocks because they are self-contained scoping units.
69 Since a dummy argument cannot be a non-dummy procedure, the only
70 resort left for untyped names are the IMPLICIT types. */
73 resolve_formal_arglist (gfc_symbol * proc)
75 gfc_formal_arglist *f;
79 /* TODO: Procedures whose return character length parameter is not constant
80 or assumed must also have explicit interfaces. */
81 if (proc->result != NULL)
86 if (gfc_elemental (proc)
87 || sym->attr.pointer || sym->attr.allocatable
88 || (sym->as && sym->as->rank > 0))
89 proc->attr.always_explicit = 1;
93 for (f = proc->formal; f; f = f->next)
99 /* Alternate return placeholder. */
100 if (gfc_elemental (proc))
101 gfc_error ("Alternate return specifier in elemental subroutine "
102 "'%s' at %L is not allowed", proc->name,
104 if (proc->attr.function)
105 gfc_error ("Alternate return specifier in function "
106 "'%s' at %L is not allowed", proc->name,
111 if (sym->attr.if_source != IFSRC_UNKNOWN)
112 resolve_formal_arglist (sym);
114 if (sym->attr.subroutine || sym->attr.external || sym->attr.intrinsic)
116 if (gfc_pure (proc) && !gfc_pure (sym))
119 ("Dummy procedure '%s' of PURE procedure at %L must also "
120 "be PURE", sym->name, &sym->declared_at);
124 if (gfc_elemental (proc))
127 ("Dummy procedure at %L not allowed in ELEMENTAL procedure",
135 if (sym->ts.type == BT_UNKNOWN)
137 if (!sym->attr.function || sym->result == sym)
138 gfc_set_default_type (sym, 1, sym->ns);
141 /* Set the type of the RESULT, then copy. */
142 if (sym->result->ts.type == BT_UNKNOWN)
143 gfc_set_default_type (sym->result, 1, sym->result->ns);
145 sym->ts = sym->result->ts;
147 sym->as = gfc_copy_array_spec (sym->result->as);
151 gfc_resolve_array_spec (sym->as, 0);
153 /* We can't tell if an array with dimension (:) is assumed or deferred
154 shape until we know if it has the pointer or allocatable attributes.
156 if (sym->as && sym->as->rank > 0 && sym->as->type == AS_DEFERRED
157 && !(sym->attr.pointer || sym->attr.allocatable))
159 sym->as->type = AS_ASSUMED_SHAPE;
160 for (i = 0; i < sym->as->rank; i++)
161 sym->as->lower[i] = gfc_int_expr (1);
164 if ((sym->as && sym->as->rank > 0 && sym->as->type == AS_ASSUMED_SHAPE)
165 || sym->attr.pointer || sym->attr.allocatable || sym->attr.target
166 || sym->attr.optional)
167 proc->attr.always_explicit = 1;
169 /* If the flavor is unknown at this point, it has to be a variable.
170 A procedure specification would have already set the type. */
172 if (sym->attr.flavor == FL_UNKNOWN)
173 gfc_add_flavor (&sym->attr, FL_VARIABLE, sym->name, &sym->declared_at);
177 if (proc->attr.function && !sym->attr.pointer
178 && sym->attr.flavor != FL_PROCEDURE
179 && sym->attr.intent != INTENT_IN)
181 gfc_error ("Argument '%s' of pure function '%s' at %L must be "
182 "INTENT(IN)", sym->name, proc->name,
185 if (proc->attr.subroutine && !sym->attr.pointer
186 && sym->attr.intent == INTENT_UNKNOWN)
189 ("Argument '%s' of pure subroutine '%s' at %L must have "
190 "its INTENT specified", sym->name, proc->name,
195 if (gfc_elemental (proc))
200 ("Argument '%s' of elemental procedure at %L must be scalar",
201 sym->name, &sym->declared_at);
205 if (sym->attr.pointer)
208 ("Argument '%s' of elemental procedure at %L cannot have "
209 "the POINTER attribute", sym->name, &sym->declared_at);
214 /* Each dummy shall be specified to be scalar. */
215 if (proc->attr.proc == PROC_ST_FUNCTION)
220 ("Argument '%s' of statement function at %L must be scalar",
221 sym->name, &sym->declared_at);
225 if (sym->ts.type == BT_CHARACTER)
227 gfc_charlen *cl = sym->ts.cl;
228 if (!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT)
231 ("Character-valued argument '%s' of statement function at "
232 "%L must has constant length",
233 sym->name, &sym->declared_at);
243 /* Work function called when searching for symbols that have argument lists
244 associated with them. */
247 find_arglists (gfc_symbol * sym)
250 if (sym->attr.if_source == IFSRC_UNKNOWN || sym->ns != gfc_current_ns)
253 resolve_formal_arglist (sym);
257 /* Given a namespace, resolve all formal argument lists within the namespace.
261 resolve_formal_arglists (gfc_namespace * ns)
267 gfc_traverse_ns (ns, find_arglists);
272 resolve_contained_fntype (gfc_symbol * sym, gfc_namespace * ns)
276 /* If this namespace is not a function, ignore it. */
278 || !(sym->attr.function
279 || sym->attr.flavor == FL_VARIABLE))
282 /* Try to find out of what the return type is. */
283 if (sym->result != NULL)
286 if (sym->ts.type == BT_UNKNOWN)
288 t = gfc_set_default_type (sym, 0, ns);
290 if (t == FAILURE && !sym->attr.untyped)
292 gfc_error ("Contained function '%s' at %L has no IMPLICIT type",
293 sym->name, &sym->declared_at); /* FIXME */
294 sym->attr.untyped = 1;
300 /* Add NEW_ARGS to the formal argument list of PROC, taking care not to
301 introduce duplicates. */
304 merge_argument_lists (gfc_symbol *proc, gfc_formal_arglist *new_args)
306 gfc_formal_arglist *f, *new_arglist;
309 for (; new_args != NULL; new_args = new_args->next)
311 new_sym = new_args->sym;
312 /* See if ths arg is already in the formal argument list. */
313 for (f = proc->formal; f; f = f->next)
315 if (new_sym == f->sym)
322 /* Add a new argument. Argument order is not important. */
323 new_arglist = gfc_get_formal_arglist ();
324 new_arglist->sym = new_sym;
325 new_arglist->next = proc->formal;
326 proc->formal = new_arglist;
331 /* Resolve alternate entry points. If a symbol has multiple entry points we
332 create a new master symbol for the main routine, and turn the existing
333 symbol into an entry point. */
336 resolve_entries (gfc_namespace * ns)
338 gfc_namespace *old_ns;
342 char name[GFC_MAX_SYMBOL_LEN + 1];
343 static int master_count = 0;
345 if (ns->proc_name == NULL)
348 /* No need to do anything if this procedure doesn't have alternate entry
353 /* We may already have resolved alternate entry points. */
354 if (ns->proc_name->attr.entry_master)
357 /* If this isn't a procedure something has gone horribly wrong. */
358 gcc_assert (ns->proc_name->attr.flavor == FL_PROCEDURE);
360 /* Remember the current namespace. */
361 old_ns = gfc_current_ns;
365 /* Add the main entry point to the list of entry points. */
366 el = gfc_get_entry_list ();
367 el->sym = ns->proc_name;
369 el->next = ns->entries;
371 ns->proc_name->attr.entry = 1;
373 /* Add an entry statement for it. */
380 /* Create a new symbol for the master function. */
381 /* Give the internal function a unique name (within this file).
382 Also include the function name so the user has some hope of figuring
383 out what is going on. */
384 snprintf (name, GFC_MAX_SYMBOL_LEN, "master.%d.%s",
385 master_count++, ns->proc_name->name);
386 gfc_get_ha_symbol (name, &proc);
387 gcc_assert (proc != NULL);
389 gfc_add_procedure (&proc->attr, PROC_INTERNAL, proc->name, NULL);
390 if (ns->proc_name->attr.subroutine)
391 gfc_add_subroutine (&proc->attr, proc->name, NULL);
395 gfc_typespec *ts, *fts;
397 gfc_add_function (&proc->attr, proc->name, NULL);
399 fts = &ns->entries->sym->result->ts;
400 if (fts->type == BT_UNKNOWN)
401 fts = gfc_get_default_type (ns->entries->sym->result, NULL);
402 for (el = ns->entries->next; el; el = el->next)
404 ts = &el->sym->result->ts;
405 if (ts->type == BT_UNKNOWN)
406 ts = gfc_get_default_type (el->sym->result, NULL);
407 if (! gfc_compare_types (ts, fts)
408 || (el->sym->result->attr.dimension
409 != ns->entries->sym->result->attr.dimension)
410 || (el->sym->result->attr.pointer
411 != ns->entries->sym->result->attr.pointer))
417 sym = ns->entries->sym->result;
418 /* All result types the same. */
420 if (sym->attr.dimension)
421 gfc_set_array_spec (proc, gfc_copy_array_spec (sym->as), NULL);
422 if (sym->attr.pointer)
423 gfc_add_pointer (&proc->attr, NULL);
427 /* Otherwise the result will be passed through a union by
429 proc->attr.mixed_entry_master = 1;
430 for (el = ns->entries; el; el = el->next)
432 sym = el->sym->result;
433 if (sym->attr.dimension)
435 if (el == ns->entries)
437 ("FUNCTION result %s can't be an array in FUNCTION %s at %L",
438 sym->name, ns->entries->sym->name, &sym->declared_at);
441 ("ENTRY result %s can't be an array in FUNCTION %s at %L",
442 sym->name, ns->entries->sym->name, &sym->declared_at);
444 else if (sym->attr.pointer)
446 if (el == ns->entries)
448 ("FUNCTION result %s can't be a POINTER in FUNCTION %s at %L",
449 sym->name, ns->entries->sym->name, &sym->declared_at);
452 ("ENTRY result %s can't be a POINTER in FUNCTION %s at %L",
453 sym->name, ns->entries->sym->name, &sym->declared_at);
458 if (ts->type == BT_UNKNOWN)
459 ts = gfc_get_default_type (sym, NULL);
463 if (ts->kind == gfc_default_integer_kind)
467 if (ts->kind == gfc_default_real_kind
468 || ts->kind == gfc_default_double_kind)
472 if (ts->kind == gfc_default_complex_kind)
476 if (ts->kind == gfc_default_logical_kind)
480 /* We will issue error elsewhere. */
488 if (el == ns->entries)
490 ("FUNCTION result %s can't be of type %s in FUNCTION %s at %L",
491 sym->name, gfc_typename (ts), ns->entries->sym->name,
495 ("ENTRY result %s can't be of type %s in FUNCTION %s at %L",
496 sym->name, gfc_typename (ts), ns->entries->sym->name,
503 proc->attr.access = ACCESS_PRIVATE;
504 proc->attr.entry_master = 1;
506 /* Merge all the entry point arguments. */
507 for (el = ns->entries; el; el = el->next)
508 merge_argument_lists (proc, el->sym->formal);
510 /* Use the master function for the function body. */
511 ns->proc_name = proc;
513 /* Finalize the new symbols. */
514 gfc_commit_symbols ();
516 /* Restore the original namespace. */
517 gfc_current_ns = old_ns;
521 /* Resolve contained function types. Because contained functions can call one
522 another, they have to be worked out before any of the contained procedures
525 The good news is that if a function doesn't already have a type, the only
526 way it can get one is through an IMPLICIT type or a RESULT variable, because
527 by definition contained functions are contained namespace they're contained
528 in, not in a sibling or parent namespace. */
531 resolve_contained_functions (gfc_namespace * ns)
533 gfc_namespace *child;
536 resolve_formal_arglists (ns);
538 for (child = ns->contained; child; child = child->sibling)
540 /* Resolve alternate entry points first. */
541 resolve_entries (child);
543 /* Then check function return types. */
544 resolve_contained_fntype (child->proc_name, child);
545 for (el = child->entries; el; el = el->next)
546 resolve_contained_fntype (el->sym, child);
551 /* Resolve all of the elements of a structure constructor and make sure that
552 the types are correct. */
555 resolve_structure_cons (gfc_expr * expr)
557 gfc_constructor *cons;
562 cons = expr->value.constructor;
563 /* A constructor may have references if it is the result of substituting a
564 parameter variable. In this case we just pull out the component we
567 comp = expr->ref->u.c.sym->components;
569 comp = expr->ts.derived->components;
571 for (; comp; comp = comp->next, cons = cons->next)
579 if (gfc_resolve_expr (cons->expr) == FAILURE)
585 /* If we don't have the right type, try to convert it. */
587 if (!gfc_compare_types (&cons->expr->ts, &comp->ts)
588 && gfc_convert_type (cons->expr, &comp->ts, 1) == FAILURE)
597 /****************** Expression name resolution ******************/
599 /* Returns 0 if a symbol was not declared with a type or
600 attribute declaration statement, nonzero otherwise. */
603 was_declared (gfc_symbol * sym)
609 if (!a.implicit_type && sym->ts.type != BT_UNKNOWN)
612 if (a.allocatable || a.dimension || a.dummy || a.external || a.intrinsic
613 || a.optional || a.pointer || a.save || a.target
614 || a.access != ACCESS_UNKNOWN || a.intent != INTENT_UNKNOWN)
621 /* Determine if a symbol is generic or not. */
624 generic_sym (gfc_symbol * sym)
628 if (sym->attr.generic ||
629 (sym->attr.intrinsic && gfc_generic_intrinsic (sym->name)))
632 if (was_declared (sym) || sym->ns->parent == NULL)
635 gfc_find_symbol (sym->name, sym->ns->parent, 1, &s);
637 return (s == NULL) ? 0 : generic_sym (s);
641 /* Determine if a symbol is specific or not. */
644 specific_sym (gfc_symbol * sym)
648 if (sym->attr.if_source == IFSRC_IFBODY
649 || sym->attr.proc == PROC_MODULE
650 || sym->attr.proc == PROC_INTERNAL
651 || sym->attr.proc == PROC_ST_FUNCTION
652 || (sym->attr.intrinsic &&
653 gfc_specific_intrinsic (sym->name))
654 || sym->attr.external)
657 if (was_declared (sym) || sym->ns->parent == NULL)
660 gfc_find_symbol (sym->name, sym->ns->parent, 1, &s);
662 return (s == NULL) ? 0 : specific_sym (s);
666 /* Figure out if the procedure is specific, generic or unknown. */
669 { PTYPE_GENERIC = 1, PTYPE_SPECIFIC, PTYPE_UNKNOWN }
673 procedure_kind (gfc_symbol * sym)
676 if (generic_sym (sym))
677 return PTYPE_GENERIC;
679 if (specific_sym (sym))
680 return PTYPE_SPECIFIC;
682 return PTYPE_UNKNOWN;
686 /* Resolve an actual argument list. Most of the time, this is just
687 resolving the expressions in the list.
688 The exception is that we sometimes have to decide whether arguments
689 that look like procedure arguments are really simple variable
693 resolve_actual_arglist (gfc_actual_arglist * arg)
696 gfc_symtree *parent_st;
699 for (; arg; arg = arg->next)
705 /* Check the label is a valid branching target. */
708 if (arg->label->defined == ST_LABEL_UNKNOWN)
710 gfc_error ("Label %d referenced at %L is never defined",
711 arg->label->value, &arg->label->where);
718 if (e->ts.type != BT_PROCEDURE)
720 if (gfc_resolve_expr (e) != SUCCESS)
725 /* See if the expression node should really be a variable
728 sym = e->symtree->n.sym;
730 if (sym->attr.flavor == FL_PROCEDURE
731 || sym->attr.intrinsic
732 || sym->attr.external)
735 if (sym->attr.proc == PROC_ST_FUNCTION)
737 gfc_error ("Statement function '%s' at %L is not allowed as an "
738 "actual argument", sym->name, &e->where);
741 /* If the symbol is the function that names the current (or
742 parent) scope, then we really have a variable reference. */
744 if (sym->attr.function && sym->result == sym
745 && (sym->ns->proc_name == sym
746 || (sym->ns->parent != NULL
747 && sym->ns->parent->proc_name == sym)))
753 /* See if the name is a module procedure in a parent unit. */
755 if (was_declared (sym) || sym->ns->parent == NULL)
758 if (gfc_find_sym_tree (sym->name, sym->ns->parent, 1, &parent_st))
760 gfc_error ("Symbol '%s' at %L is ambiguous", sym->name, &e->where);
764 if (parent_st == NULL)
767 sym = parent_st->n.sym;
768 e->symtree = parent_st; /* Point to the right thing. */
770 if (sym->attr.flavor == FL_PROCEDURE
771 || sym->attr.intrinsic
772 || sym->attr.external)
778 e->expr_type = EXPR_VARIABLE;
782 e->rank = sym->as->rank;
783 e->ref = gfc_get_ref ();
784 e->ref->type = REF_ARRAY;
785 e->ref->u.ar.type = AR_FULL;
786 e->ref->u.ar.as = sym->as;
794 /************* Function resolution *************/
796 /* Resolve a function call known to be generic.
797 Section 14.1.2.4.1. */
800 resolve_generic_f0 (gfc_expr * expr, gfc_symbol * sym)
804 if (sym->attr.generic)
807 gfc_search_interface (sym->generic, 0, &expr->value.function.actual);
810 expr->value.function.name = s->name;
811 expr->value.function.esym = s;
814 expr->rank = s->as->rank;
818 /* TODO: Need to search for elemental references in generic interface */
821 if (sym->attr.intrinsic)
822 return gfc_intrinsic_func_interface (expr, 0);
829 resolve_generic_f (gfc_expr * expr)
834 sym = expr->symtree->n.sym;
838 m = resolve_generic_f0 (expr, sym);
841 else if (m == MATCH_ERROR)
845 if (sym->ns->parent == NULL)
847 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
851 if (!generic_sym (sym))
855 /* Last ditch attempt. */
857 if (!gfc_generic_intrinsic (expr->symtree->n.sym->name))
859 gfc_error ("Generic function '%s' at %L is not an intrinsic function",
860 expr->symtree->n.sym->name, &expr->where);
864 m = gfc_intrinsic_func_interface (expr, 0);
869 ("Generic function '%s' at %L is not consistent with a specific "
870 "intrinsic interface", expr->symtree->n.sym->name, &expr->where);
876 /* Resolve a function call known to be specific. */
879 resolve_specific_f0 (gfc_symbol * sym, gfc_expr * expr)
883 if (sym->attr.external || sym->attr.if_source == IFSRC_IFBODY)
887 sym->attr.proc = PROC_DUMMY;
891 sym->attr.proc = PROC_EXTERNAL;
895 if (sym->attr.proc == PROC_MODULE
896 || sym->attr.proc == PROC_ST_FUNCTION
897 || sym->attr.proc == PROC_INTERNAL)
900 if (sym->attr.intrinsic)
902 m = gfc_intrinsic_func_interface (expr, 1);
907 ("Function '%s' at %L is INTRINSIC but is not compatible with "
908 "an intrinsic", sym->name, &expr->where);
916 gfc_procedure_use (sym, &expr->value.function.actual, &expr->where);
919 expr->value.function.name = sym->name;
920 expr->value.function.esym = sym;
922 expr->rank = sym->as->rank;
929 resolve_specific_f (gfc_expr * expr)
934 sym = expr->symtree->n.sym;
938 m = resolve_specific_f0 (sym, expr);
941 if (m == MATCH_ERROR)
944 if (sym->ns->parent == NULL)
947 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
953 gfc_error ("Unable to resolve the specific function '%s' at %L",
954 expr->symtree->n.sym->name, &expr->where);
960 /* Resolve a procedure call not known to be generic nor specific. */
963 resolve_unknown_f (gfc_expr * expr)
968 sym = expr->symtree->n.sym;
972 sym->attr.proc = PROC_DUMMY;
973 expr->value.function.name = sym->name;
977 /* See if we have an intrinsic function reference. */
979 if (gfc_intrinsic_name (sym->name, 0))
981 if (gfc_intrinsic_func_interface (expr, 1) == MATCH_YES)
986 /* The reference is to an external name. */
988 sym->attr.proc = PROC_EXTERNAL;
989 expr->value.function.name = sym->name;
990 expr->value.function.esym = expr->symtree->n.sym;
993 expr->rank = sym->as->rank;
995 /* Type of the expression is either the type of the symbol or the
996 default type of the symbol. */
999 gfc_procedure_use (sym, &expr->value.function.actual, &expr->where);
1001 if (sym->ts.type != BT_UNKNOWN)
1005 ts = gfc_get_default_type (sym, sym->ns);
1007 if (ts->type == BT_UNKNOWN)
1009 gfc_error ("Function '%s' at %L has no IMPLICIT type",
1010 sym->name, &expr->where);
1021 /* Figure out if a function reference is pure or not. Also set the name
1022 of the function for a potential error message. Return nonzero if the
1023 function is PURE, zero if not. */
1026 pure_function (gfc_expr * e, const char **name)
1030 if (e->value.function.esym)
1032 pure = gfc_pure (e->value.function.esym);
1033 *name = e->value.function.esym->name;
1035 else if (e->value.function.isym)
1037 pure = e->value.function.isym->pure
1038 || e->value.function.isym->elemental;
1039 *name = e->value.function.isym->name;
1043 /* Implicit functions are not pure. */
1045 *name = e->value.function.name;
1052 /* Resolve a function call, which means resolving the arguments, then figuring
1053 out which entity the name refers to. */
1054 /* TODO: Check procedure arguments so that an INTENT(IN) isn't passed
1055 to INTENT(OUT) or INTENT(INOUT). */
1058 resolve_function (gfc_expr * expr)
1060 gfc_actual_arglist *arg;
1064 if (resolve_actual_arglist (expr->value.function.actual) == FAILURE)
1067 /* See if function is already resolved. */
1069 if (expr->value.function.name != NULL)
1071 if (expr->ts.type == BT_UNKNOWN)
1072 expr->ts = expr->symtree->n.sym->ts;
1077 /* Apply the rules of section 14.1.2. */
1079 switch (procedure_kind (expr->symtree->n.sym))
1082 t = resolve_generic_f (expr);
1085 case PTYPE_SPECIFIC:
1086 t = resolve_specific_f (expr);
1090 t = resolve_unknown_f (expr);
1094 gfc_internal_error ("resolve_function(): bad function type");
1098 /* If the expression is still a function (it might have simplified),
1099 then we check to see if we are calling an elemental function. */
1101 if (expr->expr_type != EXPR_FUNCTION)
1104 if (expr->value.function.actual != NULL
1105 && ((expr->value.function.esym != NULL
1106 && expr->value.function.esym->attr.elemental)
1107 || (expr->value.function.isym != NULL
1108 && expr->value.function.isym->elemental)))
1111 /* The rank of an elemental is the rank of its array argument(s). */
1113 for (arg = expr->value.function.actual; arg; arg = arg->next)
1115 if (arg->expr != NULL && arg->expr->rank > 0)
1117 expr->rank = arg->expr->rank;
1123 if (!pure_function (expr, &name))
1128 ("Function reference to '%s' at %L is inside a FORALL block",
1129 name, &expr->where);
1132 else if (gfc_pure (NULL))
1134 gfc_error ("Function reference to '%s' at %L is to a non-PURE "
1135 "procedure within a PURE procedure", name, &expr->where);
1144 /************* Subroutine resolution *************/
1147 pure_subroutine (gfc_code * c, gfc_symbol * sym)
1154 gfc_error ("Subroutine call to '%s' in FORALL block at %L is not PURE",
1155 sym->name, &c->loc);
1156 else if (gfc_pure (NULL))
1157 gfc_error ("Subroutine call to '%s' at %L is not PURE", sym->name,
1163 resolve_generic_s0 (gfc_code * c, gfc_symbol * sym)
1167 if (sym->attr.generic)
1169 s = gfc_search_interface (sym->generic, 1, &c->ext.actual);
1172 c->resolved_sym = s;
1173 pure_subroutine (c, s);
1177 /* TODO: Need to search for elemental references in generic interface. */
1180 if (sym->attr.intrinsic)
1181 return gfc_intrinsic_sub_interface (c, 0);
1188 resolve_generic_s (gfc_code * c)
1193 sym = c->symtree->n.sym;
1195 m = resolve_generic_s0 (c, sym);
1198 if (m == MATCH_ERROR)
1201 if (sym->ns->parent != NULL)
1203 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
1206 m = resolve_generic_s0 (c, sym);
1209 if (m == MATCH_ERROR)
1214 /* Last ditch attempt. */
1216 if (!gfc_generic_intrinsic (sym->name))
1219 ("Generic subroutine '%s' at %L is not an intrinsic subroutine",
1220 sym->name, &c->loc);
1224 m = gfc_intrinsic_sub_interface (c, 0);
1228 gfc_error ("Generic subroutine '%s' at %L is not consistent with an "
1229 "intrinsic subroutine interface", sym->name, &c->loc);
1235 /* Resolve a subroutine call known to be specific. */
1238 resolve_specific_s0 (gfc_code * c, gfc_symbol * sym)
1242 if (sym->attr.external || sym->attr.if_source == IFSRC_IFBODY)
1244 if (sym->attr.dummy)
1246 sym->attr.proc = PROC_DUMMY;
1250 sym->attr.proc = PROC_EXTERNAL;
1254 if (sym->attr.proc == PROC_MODULE || sym->attr.proc == PROC_INTERNAL)
1257 if (sym->attr.intrinsic)
1259 m = gfc_intrinsic_sub_interface (c, 1);
1263 gfc_error ("Subroutine '%s' at %L is INTRINSIC but is not compatible "
1264 "with an intrinsic", sym->name, &c->loc);
1272 gfc_procedure_use (sym, &c->ext.actual, &c->loc);
1274 c->resolved_sym = sym;
1275 pure_subroutine (c, sym);
1282 resolve_specific_s (gfc_code * c)
1287 sym = c->symtree->n.sym;
1289 m = resolve_specific_s0 (c, sym);
1292 if (m == MATCH_ERROR)
1295 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
1299 m = resolve_specific_s0 (c, sym);
1302 if (m == MATCH_ERROR)
1306 gfc_error ("Unable to resolve the specific subroutine '%s' at %L",
1307 sym->name, &c->loc);
1313 /* Resolve a subroutine call not known to be generic nor specific. */
1316 resolve_unknown_s (gfc_code * c)
1320 sym = c->symtree->n.sym;
1322 if (sym->attr.dummy)
1324 sym->attr.proc = PROC_DUMMY;
1328 /* See if we have an intrinsic function reference. */
1330 if (gfc_intrinsic_name (sym->name, 1))
1332 if (gfc_intrinsic_sub_interface (c, 1) == MATCH_YES)
1337 /* The reference is to an external name. */
1340 gfc_procedure_use (sym, &c->ext.actual, &c->loc);
1342 c->resolved_sym = sym;
1344 pure_subroutine (c, sym);
1350 /* Resolve a subroutine call. Although it was tempting to use the same code
1351 for functions, subroutines and functions are stored differently and this
1352 makes things awkward. */
1355 resolve_call (gfc_code * c)
1359 if (resolve_actual_arglist (c->ext.actual) == FAILURE)
1362 if (c->resolved_sym != NULL)
1365 switch (procedure_kind (c->symtree->n.sym))
1368 t = resolve_generic_s (c);
1371 case PTYPE_SPECIFIC:
1372 t = resolve_specific_s (c);
1376 t = resolve_unknown_s (c);
1380 gfc_internal_error ("resolve_subroutine(): bad function type");
1386 /* Compare the shapes of two arrays that have non-NULL shapes. If both
1387 op1->shape and op2->shape are non-NULL return SUCCESS if their shapes
1388 match. If both op1->shape and op2->shape are non-NULL return FAILURE
1389 if their shapes do not match. If either op1->shape or op2->shape is
1390 NULL, return SUCCESS. */
1393 compare_shapes (gfc_expr * op1, gfc_expr * op2)
1400 if (op1->shape != NULL && op2->shape != NULL)
1402 for (i = 0; i < op1->rank; i++)
1404 if (mpz_cmp (op1->shape[i], op2->shape[i]) != 0)
1406 gfc_error ("Shapes for operands at %L and %L are not conformable",
1407 &op1->where, &op2->where);
1417 /* Resolve an operator expression node. This can involve replacing the
1418 operation with a user defined function call. */
1421 resolve_operator (gfc_expr * e)
1423 gfc_expr *op1, *op2;
1427 /* Resolve all subnodes-- give them types. */
1429 switch (e->value.op.operator)
1432 if (gfc_resolve_expr (e->value.op.op2) == FAILURE)
1435 /* Fall through... */
1438 case INTRINSIC_UPLUS:
1439 case INTRINSIC_UMINUS:
1440 if (gfc_resolve_expr (e->value.op.op1) == FAILURE)
1445 /* Typecheck the new node. */
1447 op1 = e->value.op.op1;
1448 op2 = e->value.op.op2;
1450 switch (e->value.op.operator)
1452 case INTRINSIC_UPLUS:
1453 case INTRINSIC_UMINUS:
1454 if (op1->ts.type == BT_INTEGER
1455 || op1->ts.type == BT_REAL
1456 || op1->ts.type == BT_COMPLEX)
1462 sprintf (msg, _("Operand of unary numeric operator '%s' at %%L is %s"),
1463 gfc_op2string (e->value.op.operator), gfc_typename (&e->ts));
1466 case INTRINSIC_PLUS:
1467 case INTRINSIC_MINUS:
1468 case INTRINSIC_TIMES:
1469 case INTRINSIC_DIVIDE:
1470 case INTRINSIC_POWER:
1471 if (gfc_numeric_ts (&op1->ts) && gfc_numeric_ts (&op2->ts))
1473 gfc_type_convert_binary (e);
1478 _("Operands of binary numeric operator '%s' at %%L are %s/%s"),
1479 gfc_op2string (e->value.op.operator), gfc_typename (&op1->ts),
1480 gfc_typename (&op2->ts));
1483 case INTRINSIC_CONCAT:
1484 if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER)
1486 e->ts.type = BT_CHARACTER;
1487 e->ts.kind = op1->ts.kind;
1492 _("Operands of string concatenation operator at %%L are %s/%s"),
1493 gfc_typename (&op1->ts), gfc_typename (&op2->ts));
1499 case INTRINSIC_NEQV:
1500 if (op1->ts.type == BT_LOGICAL && op2->ts.type == BT_LOGICAL)
1502 e->ts.type = BT_LOGICAL;
1503 e->ts.kind = gfc_kind_max (op1, op2);
1504 if (op1->ts.kind < e->ts.kind)
1505 gfc_convert_type (op1, &e->ts, 2);
1506 else if (op2->ts.kind < e->ts.kind)
1507 gfc_convert_type (op2, &e->ts, 2);
1511 sprintf (msg, _("Operands of logical operator '%s' at %%L are %s/%s"),
1512 gfc_op2string (e->value.op.operator), gfc_typename (&op1->ts),
1513 gfc_typename (&op2->ts));
1518 if (op1->ts.type == BT_LOGICAL)
1520 e->ts.type = BT_LOGICAL;
1521 e->ts.kind = op1->ts.kind;
1525 sprintf (msg, _("Operand of .NOT. operator at %%L is %s"),
1526 gfc_typename (&op1->ts));
1533 if (op1->ts.type == BT_COMPLEX || op2->ts.type == BT_COMPLEX)
1535 strcpy (msg, _("COMPLEX quantities cannot be compared at %L"));
1539 /* Fall through... */
1543 if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER)
1545 e->ts.type = BT_LOGICAL;
1546 e->ts.kind = gfc_default_logical_kind;
1550 if (gfc_numeric_ts (&op1->ts) && gfc_numeric_ts (&op2->ts))
1552 gfc_type_convert_binary (e);
1554 e->ts.type = BT_LOGICAL;
1555 e->ts.kind = gfc_default_logical_kind;
1559 if (op1->ts.type == BT_LOGICAL && op2->ts.type == BT_LOGICAL)
1561 _("Logicals at %%L must be compared with %s instead of %s"),
1562 e->value.op.operator == INTRINSIC_EQ ? ".EQV." : ".NEQV.",
1563 gfc_op2string (e->value.op.operator));
1566 _("Operands of comparison operator '%s' at %%L are %s/%s"),
1567 gfc_op2string (e->value.op.operator), gfc_typename (&op1->ts),
1568 gfc_typename (&op2->ts));
1572 case INTRINSIC_USER:
1574 sprintf (msg, _("Operand of user operator '%s' at %%L is %s"),
1575 e->value.op.uop->name, gfc_typename (&op1->ts));
1577 sprintf (msg, _("Operands of user operator '%s' at %%L are %s/%s"),
1578 e->value.op.uop->name, gfc_typename (&op1->ts),
1579 gfc_typename (&op2->ts));
1584 gfc_internal_error ("resolve_operator(): Bad intrinsic");
1587 /* Deal with arrayness of an operand through an operator. */
1591 switch (e->value.op.operator)
1593 case INTRINSIC_PLUS:
1594 case INTRINSIC_MINUS:
1595 case INTRINSIC_TIMES:
1596 case INTRINSIC_DIVIDE:
1597 case INTRINSIC_POWER:
1598 case INTRINSIC_CONCAT:
1602 case INTRINSIC_NEQV:
1610 if (op1->rank == 0 && op2->rank == 0)
1613 if (op1->rank == 0 && op2->rank != 0)
1615 e->rank = op2->rank;
1617 if (e->shape == NULL)
1618 e->shape = gfc_copy_shape (op2->shape, op2->rank);
1621 if (op1->rank != 0 && op2->rank == 0)
1623 e->rank = op1->rank;
1625 if (e->shape == NULL)
1626 e->shape = gfc_copy_shape (op1->shape, op1->rank);
1629 if (op1->rank != 0 && op2->rank != 0)
1631 if (op1->rank == op2->rank)
1633 e->rank = op1->rank;
1634 if (e->shape == NULL)
1636 t = compare_shapes(op1, op2);
1640 e->shape = gfc_copy_shape (op1->shape, op1->rank);
1645 gfc_error ("Inconsistent ranks for operator at %L and %L",
1646 &op1->where, &op2->where);
1649 /* Allow higher level expressions to work. */
1657 case INTRINSIC_UPLUS:
1658 case INTRINSIC_UMINUS:
1659 e->rank = op1->rank;
1661 if (e->shape == NULL)
1662 e->shape = gfc_copy_shape (op1->shape, op1->rank);
1664 /* Simply copy arrayness attribute */
1671 /* Attempt to simplify the expression. */
1673 t = gfc_simplify_expr (e, 0);
1678 if (gfc_extend_expr (e) == SUCCESS)
1681 gfc_error (msg, &e->where);
1687 /************** Array resolution subroutines **************/
1691 { CMP_LT, CMP_EQ, CMP_GT, CMP_UNKNOWN }
1694 /* Compare two integer expressions. */
1697 compare_bound (gfc_expr * a, gfc_expr * b)
1701 if (a == NULL || a->expr_type != EXPR_CONSTANT
1702 || b == NULL || b->expr_type != EXPR_CONSTANT)
1705 if (a->ts.type != BT_INTEGER || b->ts.type != BT_INTEGER)
1706 gfc_internal_error ("compare_bound(): Bad expression");
1708 i = mpz_cmp (a->value.integer, b->value.integer);
1718 /* Compare an integer expression with an integer. */
1721 compare_bound_int (gfc_expr * a, int b)
1725 if (a == NULL || a->expr_type != EXPR_CONSTANT)
1728 if (a->ts.type != BT_INTEGER)
1729 gfc_internal_error ("compare_bound_int(): Bad expression");
1731 i = mpz_cmp_si (a->value.integer, b);
1741 /* Compare a single dimension of an array reference to the array
1745 check_dimension (int i, gfc_array_ref * ar, gfc_array_spec * as)
1748 /* Given start, end and stride values, calculate the minimum and
1749 maximum referenced indexes. */
1757 if (compare_bound (ar->start[i], as->lower[i]) == CMP_LT)
1759 if (compare_bound (ar->start[i], as->upper[i]) == CMP_GT)
1765 if (compare_bound_int (ar->stride[i], 0) == CMP_EQ)
1767 gfc_error ("Illegal stride of zero at %L", &ar->c_where[i]);
1771 if (compare_bound (ar->start[i], as->lower[i]) == CMP_LT)
1773 if (compare_bound (ar->start[i], as->upper[i]) == CMP_GT)
1776 /* TODO: Possibly, we could warn about end[i] being out-of-bound although
1777 it is legal (see 6.2.2.3.1). */
1782 gfc_internal_error ("check_dimension(): Bad array reference");
1788 gfc_warning ("Array reference at %L is out of bounds", &ar->c_where[i]);
1793 /* Compare an array reference with an array specification. */
1796 compare_spec_to_ref (gfc_array_ref * ar)
1803 /* TODO: Full array sections are only allowed as actual parameters. */
1804 if (as->type == AS_ASSUMED_SIZE
1805 && (/*ar->type == AR_FULL
1806 ||*/ (ar->type == AR_SECTION
1807 && ar->dimen_type[i] == DIMEN_RANGE && ar->end[i] == NULL)))
1809 gfc_error ("Rightmost upper bound of assumed size array section"
1810 " not specified at %L", &ar->where);
1814 if (ar->type == AR_FULL)
1817 if (as->rank != ar->dimen)
1819 gfc_error ("Rank mismatch in array reference at %L (%d/%d)",
1820 &ar->where, ar->dimen, as->rank);
1824 for (i = 0; i < as->rank; i++)
1825 if (check_dimension (i, ar, as) == FAILURE)
1832 /* Resolve one part of an array index. */
1835 gfc_resolve_index (gfc_expr * index, int check_scalar)
1842 if (gfc_resolve_expr (index) == FAILURE)
1845 if (check_scalar && index->rank != 0)
1847 gfc_error ("Array index at %L must be scalar", &index->where);
1851 if (index->ts.type != BT_INTEGER && index->ts.type != BT_REAL)
1853 gfc_error ("Array index at %L must be of INTEGER type",
1858 if (index->ts.type == BT_REAL)
1859 if (gfc_notify_std (GFC_STD_GNU, "Extension: REAL array index at %L",
1860 &index->where) == FAILURE)
1863 if (index->ts.kind != gfc_index_integer_kind
1864 || index->ts.type != BT_INTEGER)
1866 ts.type = BT_INTEGER;
1867 ts.kind = gfc_index_integer_kind;
1869 gfc_convert_type_warn (index, &ts, 2, 0);
1875 /* Resolve a dim argument to an intrinsic function. */
1878 gfc_resolve_dim_arg (gfc_expr *dim)
1883 if (gfc_resolve_expr (dim) == FAILURE)
1888 gfc_error ("Argument dim at %L must be scalar", &dim->where);
1892 if (dim->ts.type != BT_INTEGER)
1894 gfc_error ("Argument dim at %L must be of INTEGER type", &dim->where);
1897 if (dim->ts.kind != gfc_index_integer_kind)
1901 ts.type = BT_INTEGER;
1902 ts.kind = gfc_index_integer_kind;
1904 gfc_convert_type_warn (dim, &ts, 2, 0);
1910 /* Given an expression that contains array references, update those array
1911 references to point to the right array specifications. While this is
1912 filled in during matching, this information is difficult to save and load
1913 in a module, so we take care of it here.
1915 The idea here is that the original array reference comes from the
1916 base symbol. We traverse the list of reference structures, setting
1917 the stored reference to references. Component references can
1918 provide an additional array specification. */
1921 find_array_spec (gfc_expr * e)
1927 as = e->symtree->n.sym->as;
1929 for (ref = e->ref; ref; ref = ref->next)
1934 gfc_internal_error ("find_array_spec(): Missing spec");
1941 for (c = e->symtree->n.sym->ts.derived->components; c; c = c->next)
1942 if (c == ref->u.c.component)
1946 gfc_internal_error ("find_array_spec(): Component not found");
1951 gfc_internal_error ("find_array_spec(): unused as(1)");
1962 gfc_internal_error ("find_array_spec(): unused as(2)");
1966 /* Resolve an array reference. */
1969 resolve_array_ref (gfc_array_ref * ar)
1971 int i, check_scalar;
1973 for (i = 0; i < ar->dimen; i++)
1975 check_scalar = ar->dimen_type[i] == DIMEN_RANGE;
1977 if (gfc_resolve_index (ar->start[i], check_scalar) == FAILURE)
1979 if (gfc_resolve_index (ar->end[i], check_scalar) == FAILURE)
1981 if (gfc_resolve_index (ar->stride[i], check_scalar) == FAILURE)
1984 if (ar->dimen_type[i] == DIMEN_UNKNOWN)
1985 switch (ar->start[i]->rank)
1988 ar->dimen_type[i] = DIMEN_ELEMENT;
1992 ar->dimen_type[i] = DIMEN_VECTOR;
1996 gfc_error ("Array index at %L is an array of rank %d",
1997 &ar->c_where[i], ar->start[i]->rank);
2002 /* If the reference type is unknown, figure out what kind it is. */
2004 if (ar->type == AR_UNKNOWN)
2006 ar->type = AR_ELEMENT;
2007 for (i = 0; i < ar->dimen; i++)
2008 if (ar->dimen_type[i] == DIMEN_RANGE
2009 || ar->dimen_type[i] == DIMEN_VECTOR)
2011 ar->type = AR_SECTION;
2016 if (compare_spec_to_ref (ar) == FAILURE)
2024 resolve_substring (gfc_ref * ref)
2027 if (ref->u.ss.start != NULL)
2029 if (gfc_resolve_expr (ref->u.ss.start) == FAILURE)
2032 if (ref->u.ss.start->ts.type != BT_INTEGER)
2034 gfc_error ("Substring start index at %L must be of type INTEGER",
2035 &ref->u.ss.start->where);
2039 if (ref->u.ss.start->rank != 0)
2041 gfc_error ("Substring start index at %L must be scalar",
2042 &ref->u.ss.start->where);
2046 if (compare_bound_int (ref->u.ss.start, 1) == CMP_LT)
2048 gfc_error ("Substring start index at %L is less than one",
2049 &ref->u.ss.start->where);
2054 if (ref->u.ss.end != NULL)
2056 if (gfc_resolve_expr (ref->u.ss.end) == FAILURE)
2059 if (ref->u.ss.end->ts.type != BT_INTEGER)
2061 gfc_error ("Substring end index at %L must be of type INTEGER",
2062 &ref->u.ss.end->where);
2066 if (ref->u.ss.end->rank != 0)
2068 gfc_error ("Substring end index at %L must be scalar",
2069 &ref->u.ss.end->where);
2073 if (ref->u.ss.length != NULL
2074 && compare_bound (ref->u.ss.end, ref->u.ss.length->length) == CMP_GT)
2076 gfc_error ("Substring end index at %L is out of bounds",
2077 &ref->u.ss.start->where);
2086 /* Resolve subtype references. */
2089 resolve_ref (gfc_expr * expr)
2091 int current_part_dimension, n_components, seen_part_dimension;
2094 for (ref = expr->ref; ref; ref = ref->next)
2095 if (ref->type == REF_ARRAY && ref->u.ar.as == NULL)
2097 find_array_spec (expr);
2101 for (ref = expr->ref; ref; ref = ref->next)
2105 if (resolve_array_ref (&ref->u.ar) == FAILURE)
2113 resolve_substring (ref);
2117 /* Check constraints on part references. */
2119 current_part_dimension = 0;
2120 seen_part_dimension = 0;
2123 for (ref = expr->ref; ref; ref = ref->next)
2128 switch (ref->u.ar.type)
2132 current_part_dimension = 1;
2136 current_part_dimension = 0;
2140 gfc_internal_error ("resolve_ref(): Bad array reference");
2146 if ((current_part_dimension || seen_part_dimension)
2147 && ref->u.c.component->pointer)
2150 ("Component to the right of a part reference with nonzero "
2151 "rank must not have the POINTER attribute at %L",
2163 if (((ref->type == REF_COMPONENT && n_components > 1)
2164 || ref->next == NULL)
2165 && current_part_dimension
2166 && seen_part_dimension)
2169 gfc_error ("Two or more part references with nonzero rank must "
2170 "not be specified at %L", &expr->where);
2174 if (ref->type == REF_COMPONENT)
2176 if (current_part_dimension)
2177 seen_part_dimension = 1;
2179 /* reset to make sure */
2180 current_part_dimension = 0;
2188 /* Given an expression, determine its shape. This is easier than it sounds.
2189 Leaves the shape array NULL if it is not possible to determine the shape. */
2192 expression_shape (gfc_expr * e)
2194 mpz_t array[GFC_MAX_DIMENSIONS];
2197 if (e->rank == 0 || e->shape != NULL)
2200 for (i = 0; i < e->rank; i++)
2201 if (gfc_array_dimen_size (e, i, &array[i]) == FAILURE)
2204 e->shape = gfc_get_shape (e->rank);
2206 memcpy (e->shape, array, e->rank * sizeof (mpz_t));
2211 for (i--; i >= 0; i--)
2212 mpz_clear (array[i]);
2216 /* Given a variable expression node, compute the rank of the expression by
2217 examining the base symbol and any reference structures it may have. */
2220 expression_rank (gfc_expr * e)
2227 if (e->expr_type == EXPR_ARRAY)
2229 /* Constructors can have a rank different from one via RESHAPE(). */
2231 if (e->symtree == NULL)
2237 e->rank = (e->symtree->n.sym->as == NULL)
2238 ? 0 : e->symtree->n.sym->as->rank;
2244 for (ref = e->ref; ref; ref = ref->next)
2246 if (ref->type != REF_ARRAY)
2249 if (ref->u.ar.type == AR_FULL)
2251 rank = ref->u.ar.as->rank;
2255 if (ref->u.ar.type == AR_SECTION)
2257 /* Figure out the rank of the section. */
2259 gfc_internal_error ("expression_rank(): Two array specs");
2261 for (i = 0; i < ref->u.ar.dimen; i++)
2262 if (ref->u.ar.dimen_type[i] == DIMEN_RANGE
2263 || ref->u.ar.dimen_type[i] == DIMEN_VECTOR)
2273 expression_shape (e);
2277 /* Resolve a variable expression. */
2280 resolve_variable (gfc_expr * e)
2284 if (e->ref && resolve_ref (e) == FAILURE)
2287 if (e->symtree == NULL)
2290 sym = e->symtree->n.sym;
2291 if (sym->attr.flavor == FL_PROCEDURE && !sym->attr.function)
2293 e->ts.type = BT_PROCEDURE;
2297 if (sym->ts.type != BT_UNKNOWN)
2298 gfc_variable_attr (e, &e->ts);
2301 /* Must be a simple variable reference. */
2302 if (gfc_set_default_type (sym, 1, NULL) == FAILURE)
2311 /* Resolve an expression. That is, make sure that types of operands agree
2312 with their operators, intrinsic operators are converted to function calls
2313 for overloaded types and unresolved function references are resolved. */
2316 gfc_resolve_expr (gfc_expr * e)
2323 switch (e->expr_type)
2326 t = resolve_operator (e);
2330 t = resolve_function (e);
2334 t = resolve_variable (e);
2336 expression_rank (e);
2339 case EXPR_SUBSTRING:
2340 t = resolve_ref (e);
2350 if (resolve_ref (e) == FAILURE)
2353 t = gfc_resolve_array_constructor (e);
2354 /* Also try to expand a constructor. */
2357 expression_rank (e);
2358 gfc_expand_constructor (e);
2363 case EXPR_STRUCTURE:
2364 t = resolve_ref (e);
2368 t = resolve_structure_cons (e);
2372 t = gfc_simplify_expr (e, 0);
2376 gfc_internal_error ("gfc_resolve_expr(): Bad expression type");
2383 /* Resolve an expression from an iterator. They must be scalar and have
2384 INTEGER or (optionally) REAL type. */
2387 gfc_resolve_iterator_expr (gfc_expr * expr, bool real_ok,
2388 const char * name_msgid)
2390 if (gfc_resolve_expr (expr) == FAILURE)
2393 if (expr->rank != 0)
2395 gfc_error ("%s at %L must be a scalar", _(name_msgid), &expr->where);
2399 if (!(expr->ts.type == BT_INTEGER
2400 || (expr->ts.type == BT_REAL && real_ok)))
2403 gfc_error ("%s at %L must be INTEGER or REAL", _(name_msgid),
2406 gfc_error ("%s at %L must be INTEGER", _(name_msgid), &expr->where);
2413 /* Resolve the expressions in an iterator structure. If REAL_OK is
2414 false allow only INTEGER type iterators, otherwise allow REAL types. */
2417 gfc_resolve_iterator (gfc_iterator * iter, bool real_ok)
2420 if (iter->var->ts.type == BT_REAL)
2421 gfc_notify_std (GFC_STD_F95_DEL,
2422 "Obsolete: REAL DO loop iterator at %L",
2425 if (gfc_resolve_iterator_expr (iter->var, real_ok, "Loop variable")
2429 if (gfc_pure (NULL) && gfc_impure_variable (iter->var->symtree->n.sym))
2431 gfc_error ("Cannot assign to loop variable in PURE procedure at %L",
2436 if (gfc_resolve_iterator_expr (iter->start, real_ok,
2437 "Start expression in DO loop") == FAILURE)
2440 if (gfc_resolve_iterator_expr (iter->end, real_ok,
2441 "End expression in DO loop") == FAILURE)
2444 if (gfc_resolve_iterator_expr (iter->step, real_ok,
2445 "Step expression in DO loop") == FAILURE)
2448 if (iter->step->expr_type == EXPR_CONSTANT)
2450 if ((iter->step->ts.type == BT_INTEGER
2451 && mpz_cmp_ui (iter->step->value.integer, 0) == 0)
2452 || (iter->step->ts.type == BT_REAL
2453 && mpfr_sgn (iter->step->value.real) == 0))
2455 gfc_error ("Step expression in DO loop at %L cannot be zero",
2456 &iter->step->where);
2461 /* Convert start, end, and step to the same type as var. */
2462 if (iter->start->ts.kind != iter->var->ts.kind
2463 || iter->start->ts.type != iter->var->ts.type)
2464 gfc_convert_type (iter->start, &iter->var->ts, 2);
2466 if (iter->end->ts.kind != iter->var->ts.kind
2467 || iter->end->ts.type != iter->var->ts.type)
2468 gfc_convert_type (iter->end, &iter->var->ts, 2);
2470 if (iter->step->ts.kind != iter->var->ts.kind
2471 || iter->step->ts.type != iter->var->ts.type)
2472 gfc_convert_type (iter->step, &iter->var->ts, 2);
2478 /* Resolve a list of FORALL iterators. */
2481 resolve_forall_iterators (gfc_forall_iterator * iter)
2486 if (gfc_resolve_expr (iter->var) == SUCCESS
2487 && iter->var->ts.type != BT_INTEGER)
2488 gfc_error ("FORALL Iteration variable at %L must be INTEGER",
2491 if (gfc_resolve_expr (iter->start) == SUCCESS
2492 && iter->start->ts.type != BT_INTEGER)
2493 gfc_error ("FORALL start expression at %L must be INTEGER",
2494 &iter->start->where);
2495 if (iter->var->ts.kind != iter->start->ts.kind)
2496 gfc_convert_type (iter->start, &iter->var->ts, 2);
2498 if (gfc_resolve_expr (iter->end) == SUCCESS
2499 && iter->end->ts.type != BT_INTEGER)
2500 gfc_error ("FORALL end expression at %L must be INTEGER",
2502 if (iter->var->ts.kind != iter->end->ts.kind)
2503 gfc_convert_type (iter->end, &iter->var->ts, 2);
2505 if (gfc_resolve_expr (iter->stride) == SUCCESS
2506 && iter->stride->ts.type != BT_INTEGER)
2507 gfc_error ("FORALL Stride expression at %L must be INTEGER",
2508 &iter->stride->where);
2509 if (iter->var->ts.kind != iter->stride->ts.kind)
2510 gfc_convert_type (iter->stride, &iter->var->ts, 2);
2517 /* Given a pointer to a symbol that is a derived type, see if any components
2518 have the POINTER attribute. The search is recursive if necessary.
2519 Returns zero if no pointer components are found, nonzero otherwise. */
2522 derived_pointer (gfc_symbol * sym)
2526 for (c = sym->components; c; c = c->next)
2531 if (c->ts.type == BT_DERIVED && derived_pointer (c->ts.derived))
2539 /* Given a pointer to a symbol that is a derived type, see if it's
2540 inaccessible, i.e. if it's defined in another module and the components are
2541 PRIVATE. The search is recursive if necessary. Returns zero if no
2542 inaccessible components are found, nonzero otherwise. */
2545 derived_inaccessible (gfc_symbol *sym)
2549 if (sym->attr.use_assoc && sym->component_access == ACCESS_PRIVATE)
2552 for (c = sym->components; c; c = c->next)
2554 if (c->ts.type == BT_DERIVED && derived_inaccessible (c->ts.derived))
2562 /* Resolve the argument of a deallocate expression. The expression must be
2563 a pointer or a full array. */
2566 resolve_deallocate_expr (gfc_expr * e)
2568 symbol_attribute attr;
2572 if (gfc_resolve_expr (e) == FAILURE)
2575 attr = gfc_expr_attr (e);
2579 if (e->expr_type != EXPR_VARIABLE)
2582 allocatable = e->symtree->n.sym->attr.allocatable;
2583 for (ref = e->ref; ref; ref = ref->next)
2587 if (ref->u.ar.type != AR_FULL)
2592 allocatable = (ref->u.c.component->as != NULL
2593 && ref->u.c.component->as->type == AS_DEFERRED);
2601 if (allocatable == 0)
2604 gfc_error ("Expression in DEALLOCATE statement at %L must be "
2605 "ALLOCATABLE or a POINTER", &e->where);
2612 /* Resolve the expression in an ALLOCATE statement, doing the additional
2613 checks to see whether the expression is OK or not. The expression must
2614 have a trailing array reference that gives the size of the array. */
2617 resolve_allocate_expr (gfc_expr * e)
2619 int i, pointer, allocatable, dimension;
2620 symbol_attribute attr;
2621 gfc_ref *ref, *ref2;
2624 if (gfc_resolve_expr (e) == FAILURE)
2627 /* Make sure the expression is allocatable or a pointer. If it is
2628 pointer, the next-to-last reference must be a pointer. */
2632 if (e->expr_type != EXPR_VARIABLE)
2636 attr = gfc_expr_attr (e);
2637 pointer = attr.pointer;
2638 dimension = attr.dimension;
2643 allocatable = e->symtree->n.sym->attr.allocatable;
2644 pointer = e->symtree->n.sym->attr.pointer;
2645 dimension = e->symtree->n.sym->attr.dimension;
2647 for (ref = e->ref; ref; ref2 = ref, ref = ref->next)
2651 if (ref->next != NULL)
2656 allocatable = (ref->u.c.component->as != NULL
2657 && ref->u.c.component->as->type == AS_DEFERRED);
2659 pointer = ref->u.c.component->pointer;
2660 dimension = ref->u.c.component->dimension;
2670 if (allocatable == 0 && pointer == 0)
2672 gfc_error ("Expression in ALLOCATE statement at %L must be "
2673 "ALLOCATABLE or a POINTER", &e->where);
2677 if (pointer && dimension == 0)
2680 /* Make sure the next-to-last reference node is an array specification. */
2682 if (ref2 == NULL || ref2->type != REF_ARRAY || ref2->u.ar.type == AR_FULL)
2684 gfc_error ("Array specification required in ALLOCATE statement "
2685 "at %L", &e->where);
2689 if (ref2->u.ar.type == AR_ELEMENT)
2692 /* Make sure that the array section reference makes sense in the
2693 context of an ALLOCATE specification. */
2697 for (i = 0; i < ar->dimen; i++)
2698 switch (ar->dimen_type[i])
2704 if (ar->start[i] != NULL
2705 && ar->end[i] != NULL
2706 && ar->stride[i] == NULL)
2709 /* Fall Through... */
2713 gfc_error ("Bad array specification in ALLOCATE statement at %L",
2722 /************ SELECT CASE resolution subroutines ************/
2724 /* Callback function for our mergesort variant. Determines interval
2725 overlaps for CASEs. Return <0 if op1 < op2, 0 for overlap, >0 for
2726 op1 > op2. Assumes we're not dealing with the default case.
2727 We have op1 = (:L), (K:L) or (K:) and op2 = (:N), (M:N) or (M:).
2728 There are nine situations to check. */
2731 compare_cases (const gfc_case * op1, const gfc_case * op2)
2735 if (op1->low == NULL) /* op1 = (:L) */
2737 /* op2 = (:N), so overlap. */
2739 /* op2 = (M:) or (M:N), L < M */
2740 if (op2->low != NULL
2741 && gfc_compare_expr (op1->high, op2->low) < 0)
2744 else if (op1->high == NULL) /* op1 = (K:) */
2746 /* op2 = (M:), so overlap. */
2748 /* op2 = (:N) or (M:N), K > N */
2749 if (op2->high != NULL
2750 && gfc_compare_expr (op1->low, op2->high) > 0)
2753 else /* op1 = (K:L) */
2755 if (op2->low == NULL) /* op2 = (:N), K > N */
2756 retval = (gfc_compare_expr (op1->low, op2->high) > 0) ? 1 : 0;
2757 else if (op2->high == NULL) /* op2 = (M:), L < M */
2758 retval = (gfc_compare_expr (op1->high, op2->low) < 0) ? -1 : 0;
2759 else /* op2 = (M:N) */
2763 if (gfc_compare_expr (op1->high, op2->low) < 0)
2766 else if (gfc_compare_expr (op1->low, op2->high) > 0)
2775 /* Merge-sort a double linked case list, detecting overlap in the
2776 process. LIST is the head of the double linked case list before it
2777 is sorted. Returns the head of the sorted list if we don't see any
2778 overlap, or NULL otherwise. */
2781 check_case_overlap (gfc_case * list)
2783 gfc_case *p, *q, *e, *tail;
2784 int insize, nmerges, psize, qsize, cmp, overlap_seen;
2786 /* If the passed list was empty, return immediately. */
2793 /* Loop unconditionally. The only exit from this loop is a return
2794 statement, when we've finished sorting the case list. */
2801 /* Count the number of merges we do in this pass. */
2804 /* Loop while there exists a merge to be done. */
2809 /* Count this merge. */
2812 /* Cut the list in two pieces by stepping INSIZE places
2813 forward in the list, starting from P. */
2816 for (i = 0; i < insize; i++)
2825 /* Now we have two lists. Merge them! */
2826 while (psize > 0 || (qsize > 0 && q != NULL))
2829 /* See from which the next case to merge comes from. */
2832 /* P is empty so the next case must come from Q. */
2837 else if (qsize == 0 || q == NULL)
2846 cmp = compare_cases (p, q);
2849 /* The whole case range for P is less than the
2857 /* The whole case range for Q is greater than
2858 the case range for P. */
2865 /* The cases overlap, or they are the same
2866 element in the list. Either way, we must
2867 issue an error and get the next case from P. */
2868 /* FIXME: Sort P and Q by line number. */
2869 gfc_error ("CASE label at %L overlaps with CASE "
2870 "label at %L", &p->where, &q->where);
2878 /* Add the next element to the merged list. */
2887 /* P has now stepped INSIZE places along, and so has Q. So
2888 they're the same. */
2893 /* If we have done only one merge or none at all, we've
2894 finished sorting the cases. */
2903 /* Otherwise repeat, merging lists twice the size. */
2909 /* Check to see if an expression is suitable for use in a CASE statement.
2910 Makes sure that all case expressions are scalar constants of the same
2911 type. Return FAILURE if anything is wrong. */
2914 validate_case_label_expr (gfc_expr * e, gfc_expr * case_expr)
2916 if (e == NULL) return SUCCESS;
2918 if (e->ts.type != case_expr->ts.type)
2920 gfc_error ("Expression in CASE statement at %L must be of type %s",
2921 &e->where, gfc_basic_typename (case_expr->ts.type));
2925 /* C805 (R808) For a given case-construct, each case-value shall be of
2926 the same type as case-expr. For character type, length differences
2927 are allowed, but the kind type parameters shall be the same. */
2929 if (case_expr->ts.type == BT_CHARACTER && e->ts.kind != case_expr->ts.kind)
2931 gfc_error("Expression in CASE statement at %L must be kind %d",
2932 &e->where, case_expr->ts.kind);
2936 /* Convert the case value kind to that of case expression kind, if needed.
2937 FIXME: Should a warning be issued? */
2938 if (e->ts.kind != case_expr->ts.kind)
2939 gfc_convert_type_warn (e, &case_expr->ts, 2, 0);
2943 gfc_error ("Expression in CASE statement at %L must be scalar",
2952 /* Given a completely parsed select statement, we:
2954 - Validate all expressions and code within the SELECT.
2955 - Make sure that the selection expression is not of the wrong type.
2956 - Make sure that no case ranges overlap.
2957 - Eliminate unreachable cases and unreachable code resulting from
2958 removing case labels.
2960 The standard does allow unreachable cases, e.g. CASE (5:3). But
2961 they are a hassle for code generation, and to prevent that, we just
2962 cut them out here. This is not necessary for overlapping cases
2963 because they are illegal and we never even try to generate code.
2965 We have the additional caveat that a SELECT construct could have
2966 been a computed GOTO in the source code. Fortunately we can fairly
2967 easily work around that here: The case_expr for a "real" SELECT CASE
2968 is in code->expr1, but for a computed GOTO it is in code->expr2. All
2969 we have to do is make sure that the case_expr is a scalar integer
2973 resolve_select (gfc_code * code)
2976 gfc_expr *case_expr;
2977 gfc_case *cp, *default_case, *tail, *head;
2978 int seen_unreachable;
2983 if (code->expr == NULL)
2985 /* This was actually a computed GOTO statement. */
2986 case_expr = code->expr2;
2987 if (case_expr->ts.type != BT_INTEGER
2988 || case_expr->rank != 0)
2989 gfc_error ("Selection expression in computed GOTO statement "
2990 "at %L must be a scalar integer expression",
2993 /* Further checking is not necessary because this SELECT was built
2994 by the compiler, so it should always be OK. Just move the
2995 case_expr from expr2 to expr so that we can handle computed
2996 GOTOs as normal SELECTs from here on. */
2997 code->expr = code->expr2;
3002 case_expr = code->expr;
3004 type = case_expr->ts.type;
3005 if (type != BT_LOGICAL && type != BT_INTEGER && type != BT_CHARACTER)
3007 gfc_error ("Argument of SELECT statement at %L cannot be %s",
3008 &case_expr->where, gfc_typename (&case_expr->ts));
3010 /* Punt. Going on here just produce more garbage error messages. */
3014 if (case_expr->rank != 0)
3016 gfc_error ("Argument of SELECT statement at %L must be a scalar "
3017 "expression", &case_expr->where);
3023 /* PR 19168 has a long discussion concerning a mismatch of the kinds
3024 of the SELECT CASE expression and its CASE values. Walk the lists
3025 of case values, and if we find a mismatch, promote case_expr to
3026 the appropriate kind. */
3028 if (type == BT_LOGICAL || type == BT_INTEGER)
3030 for (body = code->block; body; body = body->block)
3032 /* Walk the case label list. */
3033 for (cp = body->ext.case_list; cp; cp = cp->next)
3035 /* Intercept the DEFAULT case. It does not have a kind. */
3036 if (cp->low == NULL && cp->high == NULL)
3039 /* Unreachable case ranges are discarded, so ignore. */
3040 if (cp->low != NULL && cp->high != NULL
3041 && cp->low != cp->high
3042 && gfc_compare_expr (cp->low, cp->high) > 0)
3045 /* FIXME: Should a warning be issued? */
3047 && case_expr->ts.kind != gfc_kind_max(case_expr, cp->low))
3048 gfc_convert_type_warn (case_expr, &cp->low->ts, 2, 0);
3050 if (cp->high != NULL
3051 && case_expr->ts.kind != gfc_kind_max(case_expr, cp->high))
3052 gfc_convert_type_warn (case_expr, &cp->high->ts, 2, 0);
3057 /* Assume there is no DEFAULT case. */
3058 default_case = NULL;
3062 for (body = code->block; body; body = body->block)
3064 /* Assume the CASE list is OK, and all CASE labels can be matched. */
3066 seen_unreachable = 0;
3068 /* Walk the case label list, making sure that all case labels
3070 for (cp = body->ext.case_list; cp; cp = cp->next)
3072 /* Count the number of cases in the whole construct. */
3075 /* Intercept the DEFAULT case. */
3076 if (cp->low == NULL && cp->high == NULL)
3078 if (default_case != NULL)
3080 gfc_error ("The DEFAULT CASE at %L cannot be followed "
3081 "by a second DEFAULT CASE at %L",
3082 &default_case->where, &cp->where);
3093 /* Deal with single value cases and case ranges. Errors are
3094 issued from the validation function. */
3095 if(validate_case_label_expr (cp->low, case_expr) != SUCCESS
3096 || validate_case_label_expr (cp->high, case_expr) != SUCCESS)
3102 if (type == BT_LOGICAL
3103 && ((cp->low == NULL || cp->high == NULL)
3104 || cp->low != cp->high))
3107 ("Logical range in CASE statement at %L is not allowed",
3113 if (cp->low != NULL && cp->high != NULL
3114 && cp->low != cp->high
3115 && gfc_compare_expr (cp->low, cp->high) > 0)
3117 if (gfc_option.warn_surprising)
3118 gfc_warning ("Range specification at %L can never "
3119 "be matched", &cp->where);
3121 cp->unreachable = 1;
3122 seen_unreachable = 1;
3126 /* If the case range can be matched, it can also overlap with
3127 other cases. To make sure it does not, we put it in a
3128 double linked list here. We sort that with a merge sort
3129 later on to detect any overlapping cases. */
3133 head->right = head->left = NULL;
3138 tail->right->left = tail;
3145 /* It there was a failure in the previous case label, give up
3146 for this case label list. Continue with the next block. */
3150 /* See if any case labels that are unreachable have been seen.
3151 If so, we eliminate them. This is a bit of a kludge because
3152 the case lists for a single case statement (label) is a
3153 single forward linked lists. */
3154 if (seen_unreachable)
3156 /* Advance until the first case in the list is reachable. */
3157 while (body->ext.case_list != NULL
3158 && body->ext.case_list->unreachable)
3160 gfc_case *n = body->ext.case_list;
3161 body->ext.case_list = body->ext.case_list->next;
3163 gfc_free_case_list (n);
3166 /* Strip all other unreachable cases. */
3167 if (body->ext.case_list)
3169 for (cp = body->ext.case_list; cp->next; cp = cp->next)
3171 if (cp->next->unreachable)
3173 gfc_case *n = cp->next;
3174 cp->next = cp->next->next;
3176 gfc_free_case_list (n);
3183 /* See if there were overlapping cases. If the check returns NULL,
3184 there was overlap. In that case we don't do anything. If head
3185 is non-NULL, we prepend the DEFAULT case. The sorted list can
3186 then used during code generation for SELECT CASE constructs with
3187 a case expression of a CHARACTER type. */
3190 head = check_case_overlap (head);
3192 /* Prepend the default_case if it is there. */
3193 if (head != NULL && default_case)
3195 default_case->left = NULL;
3196 default_case->right = head;
3197 head->left = default_case;
3201 /* Eliminate dead blocks that may be the result if we've seen
3202 unreachable case labels for a block. */
3203 for (body = code; body && body->block; body = body->block)
3205 if (body->block->ext.case_list == NULL)
3207 /* Cut the unreachable block from the code chain. */
3208 gfc_code *c = body->block;
3209 body->block = c->block;
3211 /* Kill the dead block, but not the blocks below it. */
3213 gfc_free_statements (c);
3217 /* More than two cases is legal but insane for logical selects.
3218 Issue a warning for it. */
3219 if (gfc_option.warn_surprising && type == BT_LOGICAL
3221 gfc_warning ("Logical SELECT CASE block at %L has more that two cases",
3226 /* Resolve a transfer statement. This is making sure that:
3227 -- a derived type being transferred has only non-pointer components
3228 -- a derived type being transferred doesn't have private components, unless
3229 it's being transferred from the module where the type was defined
3230 -- we're not trying to transfer a whole assumed size array. */
3233 resolve_transfer (gfc_code * code)
3242 if (exp->expr_type != EXPR_VARIABLE)
3245 sym = exp->symtree->n.sym;
3248 /* Go to actual component transferred. */
3249 for (ref = code->expr->ref; ref; ref = ref->next)
3250 if (ref->type == REF_COMPONENT)
3251 ts = &ref->u.c.component->ts;
3253 if (ts->type == BT_DERIVED)
3255 /* Check that transferred derived type doesn't contain POINTER
3257 if (derived_pointer (ts->derived))
3259 gfc_error ("Data transfer element at %L cannot have "
3260 "POINTER components", &code->loc);
3264 if (derived_inaccessible (ts->derived))
3266 gfc_error ("Data transfer element at %L cannot have "
3267 "PRIVATE components",&code->loc);
3272 if (sym->as != NULL && sym->as->type == AS_ASSUMED_SIZE
3273 && exp->ref->type == REF_ARRAY && exp->ref->u.ar.type == AR_FULL)
3275 gfc_error ("Data transfer element at %L cannot be a full reference to "
3276 "an assumed-size array", &code->loc);
3282 /*********** Toplevel code resolution subroutines ***********/
3284 /* Given a branch to a label and a namespace, if the branch is conforming.
3285 The code node described where the branch is located. */
3288 resolve_branch (gfc_st_label * label, gfc_code * code)
3290 gfc_code *block, *found;
3298 /* Step one: is this a valid branching target? */
3300 if (lp->defined == ST_LABEL_UNKNOWN)
3302 gfc_error ("Label %d referenced at %L is never defined", lp->value,
3307 if (lp->defined != ST_LABEL_TARGET)
3309 gfc_error ("Statement at %L is not a valid branch target statement "
3310 "for the branch statement at %L", &lp->where, &code->loc);
3314 /* Step two: make sure this branch is not a branch to itself ;-) */
3316 if (code->here == label)
3318 gfc_warning ("Branch at %L causes an infinite loop", &code->loc);
3322 /* Step three: Try to find the label in the parse tree. To do this,
3323 we traverse the tree block-by-block: first the block that
3324 contains this GOTO, then the block that it is nested in, etc. We
3325 can ignore other blocks because branching into another block is
3330 for (stack = cs_base; stack; stack = stack->prev)
3332 for (block = stack->head; block; block = block->next)
3334 if (block->here == label)
3347 /* still nothing, so illegal. */
3348 gfc_error_now ("Label at %L is not in the same block as the "
3349 "GOTO statement at %L", &lp->where, &code->loc);
3353 /* Step four: Make sure that the branching target is legal if
3354 the statement is an END {SELECT,DO,IF}. */
3356 if (found->op == EXEC_NOP)
3358 for (stack = cs_base; stack; stack = stack->prev)
3359 if (stack->current->next == found)
3363 gfc_notify_std (GFC_STD_F95_DEL,
3364 "Obsolete: GOTO at %L jumps to END of construct at %L",
3365 &code->loc, &found->loc);
3370 /* Check whether EXPR1 has the same shape as EXPR2. */
3373 resolve_where_shape (gfc_expr *expr1, gfc_expr *expr2)
3375 mpz_t shape[GFC_MAX_DIMENSIONS];
3376 mpz_t shape2[GFC_MAX_DIMENSIONS];
3377 try result = FAILURE;
3380 /* Compare the rank. */
3381 if (expr1->rank != expr2->rank)
3384 /* Compare the size of each dimension. */
3385 for (i=0; i<expr1->rank; i++)
3387 if (gfc_array_dimen_size (expr1, i, &shape[i]) == FAILURE)
3390 if (gfc_array_dimen_size (expr2, i, &shape2[i]) == FAILURE)
3393 if (mpz_cmp (shape[i], shape2[i]))
3397 /* When either of the two expression is an assumed size array, we
3398 ignore the comparison of dimension sizes. */
3403 for (i--; i>=0; i--)
3405 mpz_clear (shape[i]);
3406 mpz_clear (shape2[i]);
3412 /* Check whether a WHERE assignment target or a WHERE mask expression
3413 has the same shape as the outmost WHERE mask expression. */
3416 resolve_where (gfc_code *code, gfc_expr *mask)
3422 cblock = code->block;
3424 /* Store the first WHERE mask-expr of the WHERE statement or construct.
3425 In case of nested WHERE, only the outmost one is stored. */
3426 if (mask == NULL) /* outmost WHERE */
3428 else /* inner WHERE */
3435 /* Check if the mask-expr has a consistent shape with the
3436 outmost WHERE mask-expr. */
3437 if (resolve_where_shape (cblock->expr, e) == FAILURE)
3438 gfc_error ("WHERE mask at %L has inconsistent shape",
3439 &cblock->expr->where);
3442 /* the assignment statement of a WHERE statement, or the first
3443 statement in where-body-construct of a WHERE construct */
3444 cnext = cblock->next;
3449 /* WHERE assignment statement */
3452 /* Check shape consistent for WHERE assignment target. */
3453 if (e && resolve_where_shape (cnext->expr, e) == FAILURE)
3454 gfc_error ("WHERE assignment target at %L has "
3455 "inconsistent shape", &cnext->expr->where);
3458 /* WHERE or WHERE construct is part of a where-body-construct */
3460 resolve_where (cnext, e);
3464 gfc_error ("Unsupported statement inside WHERE at %L",
3467 /* the next statement within the same where-body-construct */
3468 cnext = cnext->next;
3470 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
3471 cblock = cblock->block;
3476 /* Check whether the FORALL index appears in the expression or not. */
3479 gfc_find_forall_index (gfc_expr *expr, gfc_symbol *symbol)
3483 gfc_actual_arglist *args;
3486 switch (expr->expr_type)
3489 gcc_assert (expr->symtree->n.sym);
3491 /* A scalar assignment */
3494 if (expr->symtree->n.sym == symbol)
3500 /* the expr is array ref, substring or struct component. */
3507 /* Check if the symbol appears in the array subscript. */
3509 for (i = 0; i < GFC_MAX_DIMENSIONS; i++)
3512 if (gfc_find_forall_index (ar.start[i], symbol) == SUCCESS)
3516 if (gfc_find_forall_index (ar.end[i], symbol) == SUCCESS)
3520 if (gfc_find_forall_index (ar.stride[i], symbol) == SUCCESS)
3526 if (expr->symtree->n.sym == symbol)
3529 /* Check if the symbol appears in the substring section. */
3530 if (gfc_find_forall_index (tmp->u.ss.start, symbol) == SUCCESS)
3532 if (gfc_find_forall_index (tmp->u.ss.end, symbol) == SUCCESS)
3540 gfc_error("expresion reference type error at %L", &expr->where);
3546 /* If the expression is a function call, then check if the symbol
3547 appears in the actual arglist of the function. */
3549 for (args = expr->value.function.actual; args; args = args->next)
3551 if (gfc_find_forall_index(args->expr,symbol) == SUCCESS)
3556 /* It seems not to happen. */
3557 case EXPR_SUBSTRING:
3561 gcc_assert (expr->ref->type == REF_SUBSTRING);
3562 if (gfc_find_forall_index (tmp->u.ss.start, symbol) == SUCCESS)
3564 if (gfc_find_forall_index (tmp->u.ss.end, symbol) == SUCCESS)
3569 /* It seems not to happen. */
3570 case EXPR_STRUCTURE:
3572 gfc_error ("Unsupported statement while finding forall index in "
3577 /* Find the FORALL index in the first operand. */
3578 if (expr->value.op.op1)
3580 if (gfc_find_forall_index (expr->value.op.op1, symbol) == SUCCESS)
3584 /* Find the FORALL index in the second operand. */
3585 if (expr->value.op.op2)
3587 if (gfc_find_forall_index (expr->value.op.op2, symbol) == SUCCESS)
3600 /* Resolve assignment in FORALL construct.
3601 NVAR is the number of FORALL index variables, and VAR_EXPR records the
3602 FORALL index variables. */
3605 gfc_resolve_assign_in_forall (gfc_code *code, int nvar, gfc_expr **var_expr)
3609 for (n = 0; n < nvar; n++)
3611 gfc_symbol *forall_index;
3613 forall_index = var_expr[n]->symtree->n.sym;
3615 /* Check whether the assignment target is one of the FORALL index
3617 if ((code->expr->expr_type == EXPR_VARIABLE)
3618 && (code->expr->symtree->n.sym == forall_index))
3619 gfc_error ("Assignment to a FORALL index variable at %L",
3620 &code->expr->where);
3623 /* If one of the FORALL index variables doesn't appear in the
3624 assignment target, then there will be a many-to-one
3626 if (gfc_find_forall_index (code->expr, forall_index) == FAILURE)
3627 gfc_error ("The FORALL with index '%s' cause more than one "
3628 "assignment to this object at %L",
3629 var_expr[n]->symtree->name, &code->expr->where);
3635 /* Resolve WHERE statement in FORALL construct. */
3638 gfc_resolve_where_code_in_forall (gfc_code *code, int nvar, gfc_expr **var_expr){
3642 cblock = code->block;
3645 /* the assignment statement of a WHERE statement, or the first
3646 statement in where-body-construct of a WHERE construct */
3647 cnext = cblock->next;
3652 /* WHERE assignment statement */
3654 gfc_resolve_assign_in_forall (cnext, nvar, var_expr);
3657 /* WHERE or WHERE construct is part of a where-body-construct */
3659 gfc_resolve_where_code_in_forall (cnext, nvar, var_expr);
3663 gfc_error ("Unsupported statement inside WHERE at %L",
3666 /* the next statement within the same where-body-construct */
3667 cnext = cnext->next;
3669 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
3670 cblock = cblock->block;
3675 /* Traverse the FORALL body to check whether the following errors exist:
3676 1. For assignment, check if a many-to-one assignment happens.
3677 2. For WHERE statement, check the WHERE body to see if there is any
3678 many-to-one assignment. */
3681 gfc_resolve_forall_body (gfc_code *code, int nvar, gfc_expr **var_expr)
3685 c = code->block->next;
3691 case EXEC_POINTER_ASSIGN:
3692 gfc_resolve_assign_in_forall (c, nvar, var_expr);
3695 /* Because the resolve_blocks() will handle the nested FORALL,
3696 there is no need to handle it here. */
3700 gfc_resolve_where_code_in_forall(c, nvar, var_expr);
3705 /* The next statement in the FORALL body. */
3711 /* Given a FORALL construct, first resolve the FORALL iterator, then call
3712 gfc_resolve_forall_body to resolve the FORALL body. */
3714 static void resolve_blocks (gfc_code *, gfc_namespace *);
3717 gfc_resolve_forall (gfc_code *code, gfc_namespace *ns, int forall_save)
3719 static gfc_expr **var_expr;
3720 static int total_var = 0;
3721 static int nvar = 0;
3722 gfc_forall_iterator *fa;
3723 gfc_symbol *forall_index;
3727 /* Start to resolve a FORALL construct */
3728 if (forall_save == 0)
3730 /* Count the total number of FORALL index in the nested FORALL
3731 construct in order to allocate the VAR_EXPR with proper size. */
3733 while ((next != NULL) && (next->op == EXEC_FORALL))
3735 for (fa = next->ext.forall_iterator; fa; fa = fa->next)
3737 next = next->block->next;
3740 /* Allocate VAR_EXPR with NUMBER_OF_FORALL_INDEX elements. */
3741 var_expr = (gfc_expr **) gfc_getmem (total_var * sizeof (gfc_expr *));
3744 /* The information about FORALL iterator, including FORALL index start, end
3745 and stride. The FORALL index can not appear in start, end or stride. */
3746 for (fa = code->ext.forall_iterator; fa; fa = fa->next)
3748 /* Check if any outer FORALL index name is the same as the current
3750 for (i = 0; i < nvar; i++)
3752 if (fa->var->symtree->n.sym == var_expr[i]->symtree->n.sym)
3754 gfc_error ("An outer FORALL construct already has an index "
3755 "with this name %L", &fa->var->where);
3759 /* Record the current FORALL index. */
3760 var_expr[nvar] = gfc_copy_expr (fa->var);
3762 forall_index = fa->var->symtree->n.sym;
3764 /* Check if the FORALL index appears in start, end or stride. */
3765 if (gfc_find_forall_index (fa->start, forall_index) == SUCCESS)
3766 gfc_error ("A FORALL index must not appear in a limit or stride "
3767 "expression in the same FORALL at %L", &fa->start->where);
3768 if (gfc_find_forall_index (fa->end, forall_index) == SUCCESS)
3769 gfc_error ("A FORALL index must not appear in a limit or stride "
3770 "expression in the same FORALL at %L", &fa->end->where);
3771 if (gfc_find_forall_index (fa->stride, forall_index) == SUCCESS)
3772 gfc_error ("A FORALL index must not appear in a limit or stride "
3773 "expression in the same FORALL at %L", &fa->stride->where);
3777 /* Resolve the FORALL body. */
3778 gfc_resolve_forall_body (code, nvar, var_expr);
3780 /* May call gfc_resolve_forall to resolve the inner FORALL loop. */
3781 resolve_blocks (code->block, ns);
3783 /* Free VAR_EXPR after the whole FORALL construct resolved. */
3784 for (i = 0; i < total_var; i++)
3785 gfc_free_expr (var_expr[i]);
3787 /* Reset the counters. */
3793 /* Resolve lists of blocks found in IF, SELECT CASE, WHERE, FORALL ,GOTO and
3796 static void resolve_code (gfc_code *, gfc_namespace *);
3799 resolve_blocks (gfc_code * b, gfc_namespace * ns)
3803 for (; b; b = b->block)
3805 t = gfc_resolve_expr (b->expr);
3806 if (gfc_resolve_expr (b->expr2) == FAILURE)
3812 if (t == SUCCESS && b->expr != NULL
3813 && (b->expr->ts.type != BT_LOGICAL || b->expr->rank != 0))
3815 ("ELSE IF clause at %L requires a scalar LOGICAL expression",
3822 && (b->expr->ts.type != BT_LOGICAL
3823 || b->expr->rank == 0))
3825 ("WHERE/ELSEWHERE clause at %L requires a LOGICAL array",
3830 resolve_branch (b->label, b);
3840 gfc_internal_error ("resolve_block(): Bad block type");
3843 resolve_code (b->next, ns);
3848 /* Given a block of code, recursively resolve everything pointed to by this
3852 resolve_code (gfc_code * code, gfc_namespace * ns)
3854 int forall_save = 0;
3859 frame.prev = cs_base;
3863 for (; code; code = code->next)
3865 frame.current = code;
3867 if (code->op == EXEC_FORALL)
3869 forall_save = forall_flag;
3871 gfc_resolve_forall (code, ns, forall_save);
3874 resolve_blocks (code->block, ns);
3876 if (code->op == EXEC_FORALL)
3877 forall_flag = forall_save;
3879 t = gfc_resolve_expr (code->expr);
3880 if (gfc_resolve_expr (code->expr2) == FAILURE)
3896 resolve_where (code, NULL);
3900 if (code->expr != NULL)
3902 if (code->expr->ts.type != BT_INTEGER)
3903 gfc_error ("ASSIGNED GOTO statement at %L requires an INTEGER "
3904 "variable", &code->expr->where);
3905 else if (code->expr->symtree->n.sym->attr.assign != 1)
3906 gfc_error ("Variable '%s' has not been assigned a target label "
3907 "at %L", code->expr->symtree->n.sym->name,
3908 &code->expr->where);
3911 resolve_branch (code->label, code);
3915 if (code->expr != NULL && code->expr->ts.type != BT_INTEGER)
3916 gfc_error ("Alternate RETURN statement at %L requires an INTEGER "
3917 "return specifier", &code->expr->where);
3924 if (gfc_extend_assign (code, ns) == SUCCESS)
3927 if (gfc_pure (NULL))
3929 if (gfc_impure_variable (code->expr->symtree->n.sym))
3932 ("Cannot assign to variable '%s' in PURE procedure at %L",
3933 code->expr->symtree->n.sym->name, &code->expr->where);
3937 if (code->expr2->ts.type == BT_DERIVED
3938 && derived_pointer (code->expr2->ts.derived))
3941 ("Right side of assignment at %L is a derived type "
3942 "containing a POINTER in a PURE procedure",
3943 &code->expr2->where);
3948 gfc_check_assign (code->expr, code->expr2, 1);
3951 case EXEC_LABEL_ASSIGN:
3952 if (code->label->defined == ST_LABEL_UNKNOWN)
3953 gfc_error ("Label %d referenced at %L is never defined",
3954 code->label->value, &code->label->where);
3956 && (code->expr->expr_type != EXPR_VARIABLE
3957 || code->expr->symtree->n.sym->ts.type != BT_INTEGER
3958 || code->expr->symtree->n.sym->ts.kind
3959 != gfc_default_integer_kind
3960 || code->expr->symtree->n.sym->as != NULL))
3961 gfc_error ("ASSIGN statement at %L requires a scalar "
3962 "default INTEGER variable", &code->expr->where);
3965 case EXEC_POINTER_ASSIGN:
3969 gfc_check_pointer_assign (code->expr, code->expr2);
3972 case EXEC_ARITHMETIC_IF:
3974 && code->expr->ts.type != BT_INTEGER
3975 && code->expr->ts.type != BT_REAL)
3976 gfc_error ("Arithmetic IF statement at %L requires a numeric "
3977 "expression", &code->expr->where);
3979 resolve_branch (code->label, code);
3980 resolve_branch (code->label2, code);
3981 resolve_branch (code->label3, code);
3985 if (t == SUCCESS && code->expr != NULL
3986 && (code->expr->ts.type != BT_LOGICAL
3987 || code->expr->rank != 0))
3988 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
3989 &code->expr->where);
3994 resolve_call (code);
3998 /* Select is complicated. Also, a SELECT construct could be
3999 a transformed computed GOTO. */
4000 resolve_select (code);
4004 if (code->ext.iterator != NULL)
4005 gfc_resolve_iterator (code->ext.iterator, true);
4009 if (code->expr == NULL)
4010 gfc_internal_error ("resolve_code(): No expression on DO WHILE");
4012 && (code->expr->rank != 0
4013 || code->expr->ts.type != BT_LOGICAL))
4014 gfc_error ("Exit condition of DO WHILE loop at %L must be "
4015 "a scalar LOGICAL expression", &code->expr->where);
4019 if (t == SUCCESS && code->expr != NULL
4020 && code->expr->ts.type != BT_INTEGER)
4021 gfc_error ("STAT tag in ALLOCATE statement at %L must be "
4022 "of type INTEGER", &code->expr->where);
4024 for (a = code->ext.alloc_list; a; a = a->next)
4025 resolve_allocate_expr (a->expr);
4029 case EXEC_DEALLOCATE:
4030 if (t == SUCCESS && code->expr != NULL
4031 && code->expr->ts.type != BT_INTEGER)
4033 ("STAT tag in DEALLOCATE statement at %L must be of type "
4034 "INTEGER", &code->expr->where);
4036 for (a = code->ext.alloc_list; a; a = a->next)
4037 resolve_deallocate_expr (a->expr);
4042 if (gfc_resolve_open (code->ext.open) == FAILURE)
4045 resolve_branch (code->ext.open->err, code);
4049 if (gfc_resolve_close (code->ext.close) == FAILURE)
4052 resolve_branch (code->ext.close->err, code);
4055 case EXEC_BACKSPACE:
4059 if (gfc_resolve_filepos (code->ext.filepos) == FAILURE)
4062 resolve_branch (code->ext.filepos->err, code);
4066 if (gfc_resolve_inquire (code->ext.inquire) == FAILURE)
4069 resolve_branch (code->ext.inquire->err, code);
4073 gcc_assert (code->ext.inquire != NULL);
4074 if (gfc_resolve_inquire (code->ext.inquire) == FAILURE)
4077 resolve_branch (code->ext.inquire->err, code);
4082 if (gfc_resolve_dt (code->ext.dt) == FAILURE)
4085 resolve_branch (code->ext.dt->err, code);
4086 resolve_branch (code->ext.dt->end, code);
4087 resolve_branch (code->ext.dt->eor, code);
4091 resolve_transfer (code);
4095 resolve_forall_iterators (code->ext.forall_iterator);
4097 if (code->expr != NULL && code->expr->ts.type != BT_LOGICAL)
4099 ("FORALL mask clause at %L requires a LOGICAL expression",
4100 &code->expr->where);
4104 gfc_internal_error ("resolve_code(): Bad statement code");
4108 cs_base = frame.prev;
4112 /* Resolve initial values and make sure they are compatible with
4116 resolve_values (gfc_symbol * sym)
4119 if (sym->value == NULL)
4122 if (gfc_resolve_expr (sym->value) == FAILURE)
4125 gfc_check_assign_symbol (sym, sym->value);
4129 /* Do anything necessary to resolve a symbol. Right now, we just
4130 assume that an otherwise unknown symbol is a variable. This sort
4131 of thing commonly happens for symbols in module. */
4134 resolve_symbol (gfc_symbol * sym)
4136 /* Zero if we are checking a formal namespace. */
4137 static int formal_ns_flag = 1;
4138 int formal_ns_save, check_constant, mp_flag;
4142 gfc_symtree * symtree;
4143 gfc_symtree * this_symtree;
4146 gfc_formal_arglist * arg;
4148 if (sym->attr.flavor == FL_UNKNOWN)
4151 /* If we find that a flavorless symbol is an interface in one of the
4152 parent namespaces, find its symtree in this namespace, free the
4153 symbol and set the symtree to point to the interface symbol. */
4154 for (ns = gfc_current_ns->parent; ns; ns = ns->parent)
4156 symtree = gfc_find_symtree (ns->sym_root, sym->name);
4157 if (symtree && symtree->n.sym->generic)
4159 this_symtree = gfc_find_symtree (gfc_current_ns->sym_root,
4163 gfc_free_symbol (sym);
4164 symtree->n.sym->refs++;
4165 this_symtree->n.sym = symtree->n.sym;
4170 /* Otherwise give it a flavor according to such attributes as
4172 if (sym->attr.external == 0 && sym->attr.intrinsic == 0)
4173 sym->attr.flavor = FL_VARIABLE;
4176 sym->attr.flavor = FL_PROCEDURE;
4177 if (sym->attr.dimension)
4178 sym->attr.function = 1;
4182 /* Symbols that are module procedures with results (functions) have
4183 the types and array specification copied for type checking in
4184 procedures that call them, as well as for saving to a module
4185 file. These symbols can't stand the scrutiny that their results
4187 mp_flag = (sym->result != NULL && sym->result != sym);
4189 /* Assign default type to symbols that need one and don't have one. */
4190 if (sym->ts.type == BT_UNKNOWN)
4192 if (sym->attr.flavor == FL_VARIABLE || sym->attr.flavor == FL_PARAMETER)
4193 gfc_set_default_type (sym, 1, NULL);
4195 if (sym->attr.flavor == FL_PROCEDURE && sym->attr.function)
4198 gfc_set_default_type (sym, 0, NULL);
4201 /* Result may be in another namespace. */
4202 resolve_symbol (sym->result);
4204 sym->ts = sym->result->ts;
4205 sym->as = gfc_copy_array_spec (sym->result->as);
4206 sym->attr.dimension = sym->result->attr.dimension;
4207 sym->attr.pointer = sym->result->attr.pointer;
4212 /* Assumed size arrays and assumed shape arrays must be dummy
4216 && (sym->as->type == AS_ASSUMED_SIZE
4217 || sym->as->type == AS_ASSUMED_SHAPE)
4218 && sym->attr.dummy == 0)
4220 if (sym->as->type == AS_ASSUMED_SIZE)
4221 gfc_error ("Assumed size array at %L must be a dummy argument",
4224 gfc_error ("Assumed shape array at %L must be a dummy argument",
4229 /* A parameter array's shape needs to be constant. */
4231 if (sym->attr.flavor == FL_PARAMETER && sym->as != NULL
4232 && !gfc_is_compile_time_shape (sym->as))
4234 gfc_error ("Parameter array '%s' at %L cannot be automatic "
4235 "or assumed shape", sym->name, &sym->declared_at);
4239 /* Make sure that character string variables with assumed length are
4242 if (sym->attr.flavor == FL_VARIABLE && !sym->attr.result
4243 && sym->ts.type == BT_CHARACTER
4244 && sym->ts.cl->length == NULL && sym->attr.dummy == 0)
4246 gfc_error ("Entity with assumed character length at %L must be a "
4247 "dummy argument or a PARAMETER", &sym->declared_at);
4251 /* Make sure a parameter that has been implicitly typed still
4252 matches the implicit type, since PARAMETER statements can precede
4253 IMPLICIT statements. */
4255 if (sym->attr.flavor == FL_PARAMETER
4256 && sym->attr.implicit_type
4257 && !gfc_compare_types (&sym->ts, gfc_get_default_type (sym, sym->ns)))
4258 gfc_error ("Implicitly typed PARAMETER '%s' at %L doesn't match a "
4259 "later IMPLICIT type", sym->name, &sym->declared_at);
4261 /* Make sure the types of derived parameters are consistent. This
4262 type checking is deferred until resolution because the type may
4263 refer to a derived type from the host. */
4265 if (sym->attr.flavor == FL_PARAMETER
4266 && sym->ts.type == BT_DERIVED
4267 && !gfc_compare_types (&sym->ts, &sym->value->ts))
4268 gfc_error ("Incompatible derived type in PARAMETER at %L",
4269 &sym->value->where);
4271 /* Make sure symbols with known intent or optional are really dummy
4272 variable. Because of ENTRY statement, this has to be deferred
4273 until resolution time. */
4275 if (! sym->attr.dummy
4276 && (sym->attr.optional
4277 || sym->attr.intent != INTENT_UNKNOWN))
4279 gfc_error ("Symbol at %L is not a DUMMY variable", &sym->declared_at);
4283 if (sym->attr.proc == PROC_ST_FUNCTION)
4285 if (sym->ts.type == BT_CHARACTER)
4287 gfc_charlen *cl = sym->ts.cl;
4288 if (!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT)
4290 gfc_error ("Character-valued statement function '%s' at %L must "
4291 "have constant length", sym->name, &sym->declared_at);
4297 /* Ensure that derived type components of a public derived type
4298 are not of a private type. */
4299 if (sym->attr.flavor == FL_DERIVED
4300 && gfc_check_access(sym->attr.access, sym->ns->default_access))
4302 for (c = sym->components; c; c = c->next)
4304 if (c->ts.type == BT_DERIVED
4305 && !c->ts.derived->attr.use_assoc
4306 && !gfc_check_access(c->ts.derived->attr.access,
4307 c->ts.derived->ns->default_access))
4309 gfc_error ("The component '%s' is a PRIVATE type and cannot be "
4310 "a component of '%s', which is PUBLIC at %L",
4311 c->name, sym->name, &sym->declared_at);
4317 /* An assumed-size array with INTENT(OUT) shall not be of a type for which
4318 default initialization is defined (5.1.2.4.4). */
4319 if (sym->ts.type == BT_DERIVED
4321 && sym->attr.intent == INTENT_OUT
4322 && sym->as->type == AS_ASSUMED_SIZE)
4324 for (c = sym->ts.derived->components; c; c = c->next)
4328 gfc_error ("The INTENT(OUT) dummy argument '%s' at %L is "
4329 "ASSUMED SIZE and so cannot have a default initializer",
4330 sym->name, &sym->declared_at);
4337 /* Ensure that derived type formal arguments of a public procedure
4338 are not of a private type. */
4339 if (sym->attr.flavor == FL_PROCEDURE
4340 && gfc_check_access(sym->attr.access, sym->ns->default_access))
4342 for (arg = sym->formal; arg; arg = arg->next)
4345 && arg->sym->ts.type == BT_DERIVED
4346 && !arg->sym->ts.derived->attr.use_assoc
4347 && !gfc_check_access(arg->sym->ts.derived->attr.access,
4348 arg->sym->ts.derived->ns->default_access))
4350 gfc_error_now ("'%s' is a PRIVATE type and cannot be "
4351 "a dummy argument of '%s', which is PUBLIC at %L",
4352 arg->sym->name, sym->name, &sym->declared_at);
4353 /* Stop this message from recurring. */
4354 arg->sym->ts.derived->attr.access = ACCESS_PUBLIC;
4360 /* Constraints on deferred shape variable. */
4361 if (sym->attr.flavor == FL_VARIABLE
4362 || (sym->attr.flavor == FL_PROCEDURE
4363 && sym->attr.function))
4365 if (sym->as == NULL || sym->as->type != AS_DEFERRED)
4367 if (sym->attr.allocatable)
4369 if (sym->attr.dimension)
4370 gfc_error ("Allocatable array at %L must have a deferred shape",
4373 gfc_error ("Object at %L may not be ALLOCATABLE",
4378 if (sym->attr.pointer && sym->attr.dimension)
4380 gfc_error ("Pointer to array at %L must have a deferred shape",
4388 if (!mp_flag && !sym->attr.allocatable
4389 && !sym->attr.pointer && !sym->attr.dummy)
4391 gfc_error ("Array at %L cannot have a deferred shape",
4398 switch (sym->attr.flavor)
4401 /* Can the sybol have an initializer? */
4403 if (sym->attr.allocatable)
4404 whynot = _("Allocatable");
4405 else if (sym->attr.external)
4406 whynot = _("External");
4407 else if (sym->attr.dummy)
4408 whynot = _("Dummy");
4409 else if (sym->attr.intrinsic)
4410 whynot = _("Intrinsic");
4411 else if (sym->attr.result)
4412 whynot = _("Function Result");
4413 else if (sym->attr.dimension && !sym->attr.pointer)
4415 /* Don't allow initialization of automatic arrays. */
4416 for (i = 0; i < sym->as->rank; i++)
4418 if (sym->as->lower[i] == NULL
4419 || sym->as->lower[i]->expr_type != EXPR_CONSTANT
4420 || sym->as->upper[i] == NULL
4421 || sym->as->upper[i]->expr_type != EXPR_CONSTANT)
4423 whynot = _("Automatic array");
4429 /* Reject illegal initializers. */
4430 if (sym->value && whynot)
4432 gfc_error ("%s '%s' at %L cannot have an initializer",
4433 whynot, sym->name, &sym->declared_at);
4437 /* Assign default initializer. */
4438 if (sym->ts.type == BT_DERIVED && !(sym->value || whynot)
4439 && !sym->attr.pointer)
4440 sym->value = gfc_default_initializer (&sym->ts);
4444 /* Reject PRIVATE objects in a PUBLIC namelist. */
4445 if (gfc_check_access(sym->attr.access, sym->ns->default_access))
4447 for (nl = sym->namelist; nl; nl = nl->next)
4449 if (!nl->sym->attr.use_assoc
4451 !(sym->ns->parent == nl->sym->ns)
4453 !gfc_check_access(nl->sym->attr.access,
4454 nl->sym->ns->default_access))
4455 gfc_error ("PRIVATE symbol '%s' cannot be member of "
4456 "PUBLIC namelist at %L", nl->sym->name,
4464 /* An external symbol falls through to here if it is not referenced. */
4465 if (sym->attr.external && sym->value)
4467 gfc_error ("External object at %L may not have an initializer",
4476 /* Make sure that intrinsic exist */
4477 if (sym->attr.intrinsic
4478 && ! gfc_intrinsic_name(sym->name, 0)
4479 && ! gfc_intrinsic_name(sym->name, 1))
4480 gfc_error("Intrinsic at %L does not exist", &sym->declared_at);
4482 /* Resolve array specifier. Check as well some constraints
4483 on COMMON blocks. */
4485 check_constant = sym->attr.in_common && !sym->attr.pointer;
4486 gfc_resolve_array_spec (sym->as, check_constant);
4488 /* Resolve formal namespaces. */
4490 if (formal_ns_flag && sym != NULL && sym->formal_ns != NULL)
4492 formal_ns_save = formal_ns_flag;
4494 gfc_resolve (sym->formal_ns);
4495 formal_ns_flag = formal_ns_save;
4501 /************* Resolve DATA statements *************/
4505 gfc_data_value *vnode;
4511 /* Advance the values structure to point to the next value in the data list. */
4514 next_data_value (void)
4516 while (values.left == 0)
4518 if (values.vnode->next == NULL)
4521 values.vnode = values.vnode->next;
4522 values.left = values.vnode->repeat;
4530 check_data_variable (gfc_data_variable * var, locus * where)
4536 ar_type mark = AR_UNKNOWN;
4538 mpz_t section_index[GFC_MAX_DIMENSIONS];
4542 if (gfc_resolve_expr (var->expr) == FAILURE)
4546 mpz_init_set_si (offset, 0);
4549 if (e->expr_type != EXPR_VARIABLE)
4550 gfc_internal_error ("check_data_variable(): Bad expression");
4554 mpz_init_set_ui (size, 1);
4561 /* Find the array section reference. */
4562 for (ref = e->ref; ref; ref = ref->next)
4564 if (ref->type != REF_ARRAY)
4566 if (ref->u.ar.type == AR_ELEMENT)
4572 /* Set marks according to the reference pattern. */
4573 switch (ref->u.ar.type)
4581 /* Get the start position of array section. */
4582 gfc_get_section_index (ar, section_index, &offset);
4590 if (gfc_array_size (e, &size) == FAILURE)
4592 gfc_error ("Nonconstant array section at %L in DATA statement",
4601 while (mpz_cmp_ui (size, 0) > 0)
4603 if (next_data_value () == FAILURE)
4605 gfc_error ("DATA statement at %L has more variables than values",
4611 t = gfc_check_assign (var->expr, values.vnode->expr, 0);
4615 /* If we have more than one element left in the repeat count,
4616 and we have more than one element left in the target variable,
4617 then create a range assignment. */
4618 /* ??? Only done for full arrays for now, since array sections
4620 if (mark == AR_FULL && ref && ref->next == NULL
4621 && values.left > 1 && mpz_cmp_ui (size, 1) > 0)
4625 if (mpz_cmp_ui (size, values.left) >= 0)
4627 mpz_init_set_ui (range, values.left);
4628 mpz_sub_ui (size, size, values.left);
4633 mpz_init_set (range, size);
4634 values.left -= mpz_get_ui (size);
4635 mpz_set_ui (size, 0);
4638 gfc_assign_data_value_range (var->expr, values.vnode->expr,
4641 mpz_add (offset, offset, range);
4645 /* Assign initial value to symbol. */
4649 mpz_sub_ui (size, size, 1);
4651 gfc_assign_data_value (var->expr, values.vnode->expr, offset);
4653 if (mark == AR_FULL)
4654 mpz_add_ui (offset, offset, 1);
4656 /* Modify the array section indexes and recalculate the offset
4657 for next element. */
4658 else if (mark == AR_SECTION)
4659 gfc_advance_section (section_index, ar, &offset);
4663 if (mark == AR_SECTION)
4665 for (i = 0; i < ar->dimen; i++)
4666 mpz_clear (section_index[i]);
4676 static try traverse_data_var (gfc_data_variable *, locus *);
4678 /* Iterate over a list of elements in a DATA statement. */
4681 traverse_data_list (gfc_data_variable * var, locus * where)
4684 iterator_stack frame;
4687 mpz_init (frame.value);
4689 mpz_init_set (trip, var->iter.end->value.integer);
4690 mpz_sub (trip, trip, var->iter.start->value.integer);
4691 mpz_add (trip, trip, var->iter.step->value.integer);
4693 mpz_div (trip, trip, var->iter.step->value.integer);
4695 mpz_set (frame.value, var->iter.start->value.integer);
4697 frame.prev = iter_stack;
4698 frame.variable = var->iter.var->symtree;
4699 iter_stack = &frame;
4701 while (mpz_cmp_ui (trip, 0) > 0)
4703 if (traverse_data_var (var->list, where) == FAILURE)
4709 e = gfc_copy_expr (var->expr);
4710 if (gfc_simplify_expr (e, 1) == FAILURE)
4716 mpz_add (frame.value, frame.value, var->iter.step->value.integer);
4718 mpz_sub_ui (trip, trip, 1);
4722 mpz_clear (frame.value);
4724 iter_stack = frame.prev;
4729 /* Type resolve variables in the variable list of a DATA statement. */
4732 traverse_data_var (gfc_data_variable * var, locus * where)
4736 for (; var; var = var->next)
4738 if (var->expr == NULL)
4739 t = traverse_data_list (var, where);
4741 t = check_data_variable (var, where);
4751 /* Resolve the expressions and iterators associated with a data statement.
4752 This is separate from the assignment checking because data lists should
4753 only be resolved once. */
4756 resolve_data_variables (gfc_data_variable * d)
4758 for (; d; d = d->next)
4760 if (d->list == NULL)
4762 if (gfc_resolve_expr (d->expr) == FAILURE)
4767 if (gfc_resolve_iterator (&d->iter, false) == FAILURE)
4770 if (d->iter.start->expr_type != EXPR_CONSTANT
4771 || d->iter.end->expr_type != EXPR_CONSTANT
4772 || d->iter.step->expr_type != EXPR_CONSTANT)
4773 gfc_internal_error ("resolve_data_variables(): Bad iterator");
4775 if (resolve_data_variables (d->list) == FAILURE)
4784 /* Resolve a single DATA statement. We implement this by storing a pointer to
4785 the value list into static variables, and then recursively traversing the
4786 variables list, expanding iterators and such. */
4789 resolve_data (gfc_data * d)
4791 if (resolve_data_variables (d->var) == FAILURE)
4794 values.vnode = d->value;
4795 values.left = (d->value == NULL) ? 0 : d->value->repeat;
4797 if (traverse_data_var (d->var, &d->where) == FAILURE)
4800 /* At this point, we better not have any values left. */
4802 if (next_data_value () == SUCCESS)
4803 gfc_error ("DATA statement at %L has more values than variables",
4808 /* Determines if a variable is not 'pure', ie not assignable within a pure
4809 procedure. Returns zero if assignment is OK, nonzero if there is a problem.
4813 gfc_impure_variable (gfc_symbol * sym)
4815 if (sym->attr.use_assoc || sym->attr.in_common)
4818 if (sym->ns != gfc_current_ns)
4819 return !sym->attr.function;
4821 /* TODO: Check storage association through EQUIVALENCE statements */
4827 /* Test whether a symbol is pure or not. For a NULL pointer, checks the
4828 symbol of the current procedure. */
4831 gfc_pure (gfc_symbol * sym)
4833 symbol_attribute attr;
4836 sym = gfc_current_ns->proc_name;
4842 return attr.flavor == FL_PROCEDURE && (attr.pure || attr.elemental);
4846 /* Test whether the current procedure is elemental or not. */
4849 gfc_elemental (gfc_symbol * sym)
4851 symbol_attribute attr;
4854 sym = gfc_current_ns->proc_name;
4859 return attr.flavor == FL_PROCEDURE && attr.elemental;
4863 /* Warn about unused labels. */
4866 warn_unused_label (gfc_namespace * ns)
4877 for (; l; l = l->prev)
4879 if (l->defined == ST_LABEL_UNKNOWN)
4882 switch (l->referenced)
4884 case ST_LABEL_UNKNOWN:
4885 gfc_warning ("Label %d at %L defined but not used", l->value,
4889 case ST_LABEL_BAD_TARGET:
4890 gfc_warning ("Label %d at %L defined but cannot be used", l->value,
4901 /* Returns the sequence type of a symbol or sequence. */
4904 sequence_type (gfc_typespec ts)
4913 if (ts.derived->components == NULL)
4914 return SEQ_NONDEFAULT;
4916 result = sequence_type (ts.derived->components->ts);
4917 for (c = ts.derived->components->next; c; c = c->next)
4918 if (sequence_type (c->ts) != result)
4924 if (ts.kind != gfc_default_character_kind)
4925 return SEQ_NONDEFAULT;
4927 return SEQ_CHARACTER;
4930 if (ts.kind != gfc_default_integer_kind)
4931 return SEQ_NONDEFAULT;
4936 if (!(ts.kind == gfc_default_real_kind
4937 || ts.kind == gfc_default_double_kind))
4938 return SEQ_NONDEFAULT;
4943 if (ts.kind != gfc_default_complex_kind)
4944 return SEQ_NONDEFAULT;
4949 if (ts.kind != gfc_default_logical_kind)
4950 return SEQ_NONDEFAULT;
4955 return SEQ_NONDEFAULT;
4960 /* Resolve derived type EQUIVALENCE object. */
4963 resolve_equivalence_derived (gfc_symbol *derived, gfc_symbol *sym, gfc_expr *e)
4966 gfc_component *c = derived->components;
4971 /* Shall not be an object of nonsequence derived type. */
4972 if (!derived->attr.sequence)
4974 gfc_error ("Derived type variable '%s' at %L must have SEQUENCE "
4975 "attribute to be an EQUIVALENCE object", sym->name, &e->where);
4979 for (; c ; c = c->next)
4982 if (d && (resolve_equivalence_derived (c->ts.derived, sym, e) == FAILURE))
4985 /* Shall not be an object of sequence derived type containing a pointer
4986 in the structure. */
4989 gfc_error ("Derived type variable '%s' at %L with pointer component(s) "
4990 "cannot be an EQUIVALENCE object", sym->name, &e->where);
4996 gfc_error ("Derived type variable '%s' at %L with default initializer "
4997 "cannot be an EQUIVALENCE object", sym->name, &e->where);
5005 /* Resolve equivalence object.
5006 An EQUIVALENCE object shall not be a dummy argument, a pointer, a target,
5007 an allocatable array, an object of nonsequence derived type, an object of
5008 sequence derived type containing a pointer at any level of component
5009 selection, an automatic object, a function name, an entry name, a result
5010 name, a named constant, a structure component, or a subobject of any of
5011 the preceding objects. A substring shall not have length zero. A
5012 derived type shall not have components with default initialization nor
5013 shall two objects of an equivalence group be initialized.
5014 The simple constraints are done in symbol.c(check_conflict) and the rest
5015 are implemented here. */
5018 resolve_equivalence (gfc_equiv *eq)
5021 gfc_symbol *derived;
5022 gfc_symbol *first_sym;
5025 locus *last_where = NULL;
5026 seq_type eq_type, last_eq_type;
5027 gfc_typespec *last_ts;
5029 const char *value_name;
5033 last_ts = &eq->expr->symtree->n.sym->ts;
5035 first_sym = eq->expr->symtree->n.sym;
5037 for (object = 1; eq; eq = eq->eq, object++)
5041 e->ts = e->symtree->n.sym->ts;
5042 /* match_varspec might not know yet if it is seeing
5043 array reference or substring reference, as it doesn't
5045 if (e->ref && e->ref->type == REF_ARRAY)
5047 gfc_ref *ref = e->ref;
5048 sym = e->symtree->n.sym;
5050 if (sym->attr.dimension)
5052 ref->u.ar.as = sym->as;
5056 /* For substrings, convert REF_ARRAY into REF_SUBSTRING. */
5057 if (e->ts.type == BT_CHARACTER
5059 && ref->type == REF_ARRAY
5060 && ref->u.ar.dimen == 1
5061 && ref->u.ar.dimen_type[0] == DIMEN_RANGE
5062 && ref->u.ar.stride[0] == NULL)
5064 gfc_expr *start = ref->u.ar.start[0];
5065 gfc_expr *end = ref->u.ar.end[0];
5068 /* Optimize away the (:) reference. */
5069 if (start == NULL && end == NULL)
5074 e->ref->next = ref->next;
5079 ref->type = REF_SUBSTRING;
5081 start = gfc_int_expr (1);
5082 ref->u.ss.start = start;
5083 if (end == NULL && e->ts.cl)
5084 end = gfc_copy_expr (e->ts.cl->length);
5085 ref->u.ss.end = end;
5086 ref->u.ss.length = e->ts.cl;
5093 /* Any further ref is an error. */
5096 gcc_assert (ref->type == REF_ARRAY);
5097 gfc_error ("Syntax error in EQUIVALENCE statement at %L",
5103 if (gfc_resolve_expr (e) == FAILURE)
5106 sym = e->symtree->n.sym;
5108 /* An equivalence statement cannot have more than one initialized
5112 if (value_name != NULL)
5114 gfc_error ("Initialized objects '%s' and '%s' cannot both "
5115 "be in the EQUIVALENCE statement at %L",
5116 value_name, sym->name, &e->where);
5120 value_name = sym->name;
5123 /* Shall not equivalence common block variables in a PURE procedure. */
5124 if (sym->ns->proc_name
5125 && sym->ns->proc_name->attr.pure
5126 && sym->attr.in_common)
5128 gfc_error ("Common block member '%s' at %L cannot be an EQUIVALENCE "
5129 "object in the pure procedure '%s'",
5130 sym->name, &e->where, sym->ns->proc_name->name);
5134 /* Shall not be a named constant. */
5135 if (e->expr_type == EXPR_CONSTANT)
5137 gfc_error ("Named constant '%s' at %L cannot be an EQUIVALENCE "
5138 "object", sym->name, &e->where);
5142 derived = e->ts.derived;
5143 if (derived && resolve_equivalence_derived (derived, sym, e) == FAILURE)
5146 /* Check that the types correspond correctly:
5148 A numeric sequence structure may be equivalenced to another sequence
5149 structure, an object of default integer type, default real type, double
5150 precision real type, default logical type such that components of the
5151 structure ultimately only become associated to objects of the same
5152 kind. A character sequence structure may be equivalenced to an object
5153 of default character kind or another character sequence structure.
5154 Other objects may be equivalenced only to objects of the same type and
5157 /* Identical types are unconditionally OK. */
5158 if (object == 1 || gfc_compare_types (last_ts, &sym->ts))
5159 goto identical_types;
5161 last_eq_type = sequence_type (*last_ts);
5162 eq_type = sequence_type (sym->ts);
5164 /* Since the pair of objects is not of the same type, mixed or
5165 non-default sequences can be rejected. */
5167 msg = "Sequence %s with mixed components in EQUIVALENCE "
5168 "statement at %L with different type objects";
5170 && last_eq_type == SEQ_MIXED
5171 && gfc_notify_std (GFC_STD_GNU, msg, first_sym->name,
5172 last_where) == FAILURE)
5173 || (eq_type == SEQ_MIXED
5174 && gfc_notify_std (GFC_STD_GNU, msg,sym->name,
5175 &e->where) == FAILURE))
5178 msg = "Non-default type object or sequence %s in EQUIVALENCE "
5179 "statement at %L with objects of different type";
5181 && last_eq_type == SEQ_NONDEFAULT
5182 && gfc_notify_std (GFC_STD_GNU, msg, first_sym->name,
5183 last_where) == FAILURE)
5184 || (eq_type == SEQ_NONDEFAULT
5185 && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
5186 &e->where) == FAILURE))
5189 msg ="Non-CHARACTER object '%s' in default CHARACTER "
5190 "EQUIVALENCE statement at %L";
5191 if (last_eq_type == SEQ_CHARACTER
5192 && eq_type != SEQ_CHARACTER
5193 && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
5194 &e->where) == FAILURE)
5197 msg ="Non-NUMERIC object '%s' in default NUMERIC "
5198 "EQUIVALENCE statement at %L";
5199 if (last_eq_type == SEQ_NUMERIC
5200 && eq_type != SEQ_NUMERIC
5201 && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
5202 &e->where) == FAILURE)
5207 last_where = &e->where;
5212 /* Shall not be an automatic array. */
5213 if (e->ref->type == REF_ARRAY
5214 && gfc_resolve_array_spec (e->ref->u.ar.as, 1) == FAILURE)
5216 gfc_error ("Array '%s' at %L with non-constant bounds cannot be "
5217 "an EQUIVALENCE object", sym->name, &e->where);
5224 /* Shall not be a structure component. */
5225 if (r->type == REF_COMPONENT)
5227 gfc_error ("Structure component '%s' at %L cannot be an "
5228 "EQUIVALENCE object",
5229 r->u.c.component->name, &e->where);
5233 /* A substring shall not have length zero. */
5234 if (r->type == REF_SUBSTRING)
5236 if (compare_bound (r->u.ss.start, r->u.ss.end) == CMP_GT)
5238 gfc_error ("Substring at %L has length zero",
5239 &r->u.ss.start->where);
5249 /* Resolve function and ENTRY types, issue diagnostics if needed. */
5252 resolve_fntype (gfc_namespace * ns)
5257 if (ns->proc_name == NULL || !ns->proc_name->attr.function)
5260 /* If there are any entries, ns->proc_name is the entry master
5261 synthetic symbol and ns->entries->sym actual FUNCTION symbol. */
5263 sym = ns->entries->sym;
5265 sym = ns->proc_name;
5266 if (sym->result == sym
5267 && sym->ts.type == BT_UNKNOWN
5268 && gfc_set_default_type (sym, 0, NULL) == FAILURE
5269 && !sym->attr.untyped)
5271 gfc_error ("Function '%s' at %L has no IMPLICIT type",
5272 sym->name, &sym->declared_at);
5273 sym->attr.untyped = 1;
5277 for (el = ns->entries->next; el; el = el->next)
5279 if (el->sym->result == el->sym
5280 && el->sym->ts.type == BT_UNKNOWN
5281 && gfc_set_default_type (el->sym, 0, NULL) == FAILURE
5282 && !el->sym->attr.untyped)
5284 gfc_error ("ENTRY '%s' at %L has no IMPLICIT type",
5285 el->sym->name, &el->sym->declared_at);
5286 el->sym->attr.untyped = 1;
5292 /* This function is called after a complete program unit has been compiled.
5293 Its purpose is to examine all of the expressions associated with a program
5294 unit, assign types to all intermediate expressions, make sure that all
5295 assignments are to compatible types and figure out which names refer to
5296 which functions or subroutines. */
5299 gfc_resolve (gfc_namespace * ns)
5301 gfc_namespace *old_ns, *n;
5306 old_ns = gfc_current_ns;
5307 gfc_current_ns = ns;
5309 resolve_entries (ns);
5311 resolve_contained_functions (ns);
5313 gfc_traverse_ns (ns, resolve_symbol);
5315 resolve_fntype (ns);
5317 for (n = ns->contained; n; n = n->sibling)
5319 if (gfc_pure (ns->proc_name) && !gfc_pure (n->proc_name))
5320 gfc_error ("Contained procedure '%s' at %L of a PURE procedure must "
5321 "also be PURE", n->proc_name->name,
5322 &n->proc_name->declared_at);
5328 gfc_check_interfaces (ns);
5330 for (cl = ns->cl_list; cl; cl = cl->next)
5332 if (cl->length == NULL || gfc_resolve_expr (cl->length) == FAILURE)
5335 if (gfc_simplify_expr (cl->length, 0) == FAILURE)
5338 if (gfc_specification_expr (cl->length) == FAILURE)
5342 gfc_traverse_ns (ns, resolve_values);
5348 for (d = ns->data; d; d = d->next)
5352 gfc_traverse_ns (ns, gfc_formalize_init_value);
5354 for (eq = ns->equiv; eq; eq = eq->next)
5355 resolve_equivalence (eq);
5358 resolve_code (ns->code, ns);
5360 /* Warn about unused labels. */
5361 if (gfc_option.warn_unused_labels)
5362 warn_unused_label (ns);
5364 gfc_current_ns = old_ns;