1 /* Perform type resolution on the various stuctures.
2 Copyright (C) 2001, 2002, 2003, 2004 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, 59 Temple Place - Suite 330,Boston, MA
24 #include "arith.h" /* For gfc_compare_expr(). */
28 /* Stack to push the current if we descend into a block during
29 resolution. See resolve_branch() and resolve_code(). */
31 typedef struct code_stack
33 struct gfc_code *head, *current;
34 struct code_stack *prev;
38 static code_stack *cs_base = NULL;
41 /* Nonzero if we're inside a FORALL block */
43 static int forall_flag;
45 /* Resolve types of formal argument lists. These have to be done early so that
46 the formal argument lists of module procedures can be copied to the
47 containing module before the individual procedures are resolved
48 individually. We also resolve argument lists of procedures in interface
49 blocks because they are self-contained scoping units.
51 Since a dummy argument cannot be a non-dummy procedure, the only
52 resort left for untyped names are the IMPLICIT types. */
55 resolve_formal_arglist (gfc_symbol * proc)
57 gfc_formal_arglist *f;
61 /* TODO: Procedures whose return character length parameter is not constant
62 or assumed must also have explicit interfaces. */
63 if (proc->result != NULL)
68 if (gfc_elemental (proc)
69 || sym->attr.pointer || sym->attr.allocatable
70 || (sym->as && sym->as->rank > 0))
71 proc->attr.always_explicit = 1;
73 for (f = proc->formal; f; f = f->next)
79 /* Alternate return placeholder. */
80 if (gfc_elemental (proc))
81 gfc_error ("Alternate return specifier in elemental subroutine "
82 "'%s' at %L is not allowed", proc->name,
84 if (proc->attr.function)
85 gfc_error ("Alternate return specifier in function "
86 "'%s' at %L is not allowed", proc->name,
91 if (sym->attr.if_source != IFSRC_UNKNOWN)
92 resolve_formal_arglist (sym);
94 if (sym->attr.subroutine || sym->attr.external || sym->attr.intrinsic)
96 if (gfc_pure (proc) && !gfc_pure (sym))
99 ("Dummy procedure '%s' of PURE procedure at %L must also "
100 "be PURE", sym->name, &sym->declared_at);
104 if (gfc_elemental (proc))
107 ("Dummy procedure at %L not allowed in ELEMENTAL procedure",
115 if (sym->ts.type == BT_UNKNOWN)
117 if (!sym->attr.function || sym->result == sym)
118 gfc_set_default_type (sym, 1, sym->ns);
121 /* Set the type of the RESULT, then copy. */
122 if (sym->result->ts.type == BT_UNKNOWN)
123 gfc_set_default_type (sym->result, 1, sym->result->ns);
125 sym->ts = sym->result->ts;
127 sym->as = gfc_copy_array_spec (sym->result->as);
131 gfc_resolve_array_spec (sym->as, 0);
133 /* We can't tell if an array with dimension (:) is assumed or deferred
134 shape until we know if it has the pointer or allocatable attributes.
136 if (sym->as && sym->as->rank > 0 && sym->as->type == AS_DEFERRED
137 && !(sym->attr.pointer || sym->attr.allocatable))
139 sym->as->type = AS_ASSUMED_SHAPE;
140 for (i = 0; i < sym->as->rank; i++)
141 sym->as->lower[i] = gfc_int_expr (1);
144 if ((sym->as && sym->as->rank > 0 && sym->as->type == AS_ASSUMED_SHAPE)
145 || sym->attr.pointer || sym->attr.allocatable || sym->attr.target
146 || sym->attr.optional)
147 proc->attr.always_explicit = 1;
149 /* If the flavor is unknown at this point, it has to be a variable.
150 A procedure specification would have already set the type. */
152 if (sym->attr.flavor == FL_UNKNOWN)
153 gfc_add_flavor (&sym->attr, FL_VARIABLE, &sym->declared_at);
157 if (proc->attr.function && !sym->attr.pointer
158 && sym->attr.flavor != FL_PROCEDURE
159 && sym->attr.intent != INTENT_IN)
161 gfc_error ("Argument '%s' of pure function '%s' at %L must be "
162 "INTENT(IN)", sym->name, proc->name,
165 if (proc->attr.subroutine && !sym->attr.pointer
166 && sym->attr.intent == INTENT_UNKNOWN)
169 ("Argument '%s' of pure subroutine '%s' at %L must have "
170 "its INTENT specified", sym->name, proc->name,
175 if (gfc_elemental (proc))
180 ("Argument '%s' of elemental procedure at %L must be scalar",
181 sym->name, &sym->declared_at);
185 if (sym->attr.pointer)
188 ("Argument '%s' of elemental procedure at %L cannot have "
189 "the POINTER attribute", sym->name, &sym->declared_at);
194 /* Each dummy shall be specified to be scalar. */
195 if (proc->attr.proc == PROC_ST_FUNCTION)
200 ("Argument '%s' of statement function at %L must be scalar",
201 sym->name, &sym->declared_at);
205 if (sym->ts.type == BT_CHARACTER)
207 gfc_charlen *cl = sym->ts.cl;
208 if (!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT)
211 ("Character-valued argument '%s' of statement function at "
212 "%L must has constant length",
213 sym->name, &sym->declared_at);
222 /* Work function called when searching for symbols that have argument lists
223 associated with them. */
226 find_arglists (gfc_symbol * sym)
229 if (sym->attr.if_source == IFSRC_UNKNOWN || sym->ns != gfc_current_ns)
232 resolve_formal_arglist (sym);
236 /* Given a namespace, resolve all formal argument lists within the namespace.
240 resolve_formal_arglists (gfc_namespace * ns)
246 gfc_traverse_ns (ns, find_arglists);
250 /* Resolve contained function types. Because contained functions can call one
251 another, they have to be worked out before any of the contained procedures
254 The good news is that if a function doesn't already have a type, the only
255 way it can get one is through an IMPLICIT type or a RESULT variable, because
256 by definition contained functions are contained namespace they're contained
257 in, not in a sibling or parent namespace. */
260 resolve_contained_functions (gfc_namespace * ns)
262 gfc_symbol *contained_sym, *sym_lower;
263 gfc_namespace *child;
266 resolve_formal_arglists (ns);
268 for (child = ns->contained; child; child = child->sibling)
270 sym_lower = child->proc_name;
272 /* If this namespace is not a function, ignore it. */
274 || !( sym_lower->attr.function
275 || sym_lower->attr.flavor == FL_VARIABLE))
278 /* Find the contained symbol in the current namespace. */
279 gfc_find_symbol (sym_lower->name, ns, 0, &contained_sym);
281 if (contained_sym == NULL)
282 gfc_internal_error ("resolve_contained_functions(): Contained "
283 "function not found in parent namespace");
285 /* Try to find out of what type the function is. If there was an
286 explicit RESULT clause, try to get the type from it. If the
287 function is never defined, set it to the implicit type. If
288 even that fails, give up. */
289 if (sym_lower->result != NULL)
290 sym_lower = sym_lower->result;
292 if (sym_lower->ts.type == BT_UNKNOWN)
294 /* Assume we can find an implicit type. */
297 if (sym_lower->result == NULL)
298 t = gfc_set_default_type (sym_lower, 0, child);
301 if (sym_lower->result->ts.type == BT_UNKNOWN)
302 t = gfc_set_default_type (sym_lower->result, 0, NULL);
304 sym_lower->ts = sym_lower->result->ts;
308 gfc_error ("Contained function '%s' at %L has no IMPLICIT type",
309 sym_lower->name, &sym_lower->declared_at); /* FIXME */
312 /* If the symbol in the parent of the contained namespace is not
313 the same as the one in contained namespace itself, copy over
314 the type information. */
315 /* ??? Shouldn't we replace the symbol with the parent symbol instead? */
316 if (contained_sym != sym_lower)
318 contained_sym->ts = sym_lower->ts;
319 contained_sym->as = gfc_copy_array_spec (sym_lower->as);
325 /* Resolve all of the elements of a structure constructor and make sure that
326 the types are correct. */
329 resolve_structure_cons (gfc_expr * expr)
331 gfc_constructor *cons;
336 cons = expr->value.constructor;
337 /* A constructor may have references if it is the result of substituting a
338 parameter variable. In this case we just pull out the component we
341 comp = expr->ref->u.c.sym->components;
343 comp = expr->ts.derived->components;
345 for (; comp; comp = comp->next, cons = cons->next)
353 if (gfc_resolve_expr (cons->expr) == FAILURE)
359 /* If we don't have the right type, try to convert it. */
361 if (!gfc_compare_types (&cons->expr->ts, &comp->ts)
362 && gfc_convert_type (cons->expr, &comp->ts, 1) == FAILURE)
371 /****************** Expression name resolution ******************/
373 /* Returns 0 if a symbol was not declared with a type or
374 or attribute declaration statement, nonzero otherwise. */
377 was_declared (gfc_symbol * sym)
383 if (!a.implicit_type && sym->ts.type != BT_UNKNOWN)
386 if (a.allocatable || a.dimension || a.external || a.intrinsic
387 || a.optional || a.pointer || a.save || a.target
388 || a.access != ACCESS_UNKNOWN || a.intent != INTENT_UNKNOWN)
395 /* Determine if a symbol is generic or not. */
398 generic_sym (gfc_symbol * sym)
402 if (sym->attr.generic ||
403 (sym->attr.intrinsic && gfc_generic_intrinsic (sym->name)))
406 if (was_declared (sym) || sym->ns->parent == NULL)
409 gfc_find_symbol (sym->name, sym->ns->parent, 1, &s);
411 return (s == NULL) ? 0 : generic_sym (s);
415 /* Determine if a symbol is specific or not. */
418 specific_sym (gfc_symbol * sym)
422 if (sym->attr.if_source == IFSRC_IFBODY
423 || sym->attr.proc == PROC_MODULE
424 || sym->attr.proc == PROC_INTERNAL
425 || sym->attr.proc == PROC_ST_FUNCTION
426 || (sym->attr.intrinsic &&
427 gfc_specific_intrinsic (sym->name))
428 || sym->attr.external)
431 if (was_declared (sym) || sym->ns->parent == NULL)
434 gfc_find_symbol (sym->name, sym->ns->parent, 1, &s);
436 return (s == NULL) ? 0 : specific_sym (s);
440 /* Figure out if the procedure is specific, generic or unknown. */
443 { PTYPE_GENERIC = 1, PTYPE_SPECIFIC, PTYPE_UNKNOWN }
447 procedure_kind (gfc_symbol * sym)
450 if (generic_sym (sym))
451 return PTYPE_GENERIC;
453 if (specific_sym (sym))
454 return PTYPE_SPECIFIC;
456 return PTYPE_UNKNOWN;
460 /* Resolve an actual argument list. Most of the time, this is just
461 resolving the expressions in the list.
462 The exception is that we sometimes have to decide whether arguments
463 that look like procedure arguments are really simple variable
467 resolve_actual_arglist (gfc_actual_arglist * arg)
470 gfc_symtree *parent_st;
473 for (; arg; arg = arg->next)
479 /* Check the label is a valid branching target. */
482 if (arg->label->defined == ST_LABEL_UNKNOWN)
484 gfc_error ("Label %d referenced at %L is never defined",
485 arg->label->value, &arg->label->where);
492 if (e->ts.type != BT_PROCEDURE)
494 if (gfc_resolve_expr (e) != SUCCESS)
499 /* See if the expression node should really be a variable
502 sym = e->symtree->n.sym;
504 if (sym->attr.flavor == FL_PROCEDURE
505 || sym->attr.intrinsic
506 || sym->attr.external)
509 /* If the symbol is the function that names the current (or
510 parent) scope, then we really have a variable reference. */
512 if (sym->attr.function && sym->result == sym
513 && (sym->ns->proc_name == sym
514 || (sym->ns->parent != NULL
515 && sym->ns->parent->proc_name == sym)))
521 /* See if the name is a module procedure in a parent unit. */
523 if (was_declared (sym) || sym->ns->parent == NULL)
526 if (gfc_find_sym_tree (sym->name, sym->ns->parent, 1, &parent_st))
528 gfc_error ("Symbol '%s' at %L is ambiguous", sym->name, &e->where);
532 if (parent_st == NULL)
535 sym = parent_st->n.sym;
536 e->symtree = parent_st; /* Point to the right thing. */
538 if (sym->attr.flavor == FL_PROCEDURE
539 || sym->attr.intrinsic
540 || sym->attr.external)
546 e->expr_type = EXPR_VARIABLE;
550 e->rank = sym->as->rank;
551 e->ref = gfc_get_ref ();
552 e->ref->type = REF_ARRAY;
553 e->ref->u.ar.type = AR_FULL;
554 e->ref->u.ar.as = sym->as;
562 /************* Function resolution *************/
564 /* Resolve a function call known to be generic.
565 Section 14.1.2.4.1. */
568 resolve_generic_f0 (gfc_expr * expr, gfc_symbol * sym)
572 if (sym->attr.generic)
575 gfc_search_interface (sym->generic, 0, &expr->value.function.actual);
578 expr->value.function.name = s->name;
579 expr->value.function.esym = s;
582 expr->rank = s->as->rank;
586 /* TODO: Need to search for elemental references in generic interface */
589 if (sym->attr.intrinsic)
590 return gfc_intrinsic_func_interface (expr, 0);
597 resolve_generic_f (gfc_expr * expr)
602 sym = expr->symtree->n.sym;
606 m = resolve_generic_f0 (expr, sym);
609 else if (m == MATCH_ERROR)
613 if (sym->ns->parent == NULL)
615 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
619 if (!generic_sym (sym))
623 /* Last ditch attempt. */
625 if (!gfc_generic_intrinsic (expr->symtree->n.sym->name))
627 gfc_error ("Generic function '%s' at %L is not an intrinsic function",
628 expr->symtree->n.sym->name, &expr->where);
632 m = gfc_intrinsic_func_interface (expr, 0);
637 ("Generic function '%s' at %L is not consistent with a specific "
638 "intrinsic interface", expr->symtree->n.sym->name, &expr->where);
644 /* Resolve a function call known to be specific. */
647 resolve_specific_f0 (gfc_symbol * sym, gfc_expr * expr)
651 if (sym->attr.external || sym->attr.if_source == IFSRC_IFBODY)
655 sym->attr.proc = PROC_DUMMY;
659 sym->attr.proc = PROC_EXTERNAL;
663 if (sym->attr.proc == PROC_MODULE
664 || sym->attr.proc == PROC_ST_FUNCTION
665 || sym->attr.proc == PROC_INTERNAL)
668 if (sym->attr.intrinsic)
670 m = gfc_intrinsic_func_interface (expr, 1);
675 ("Function '%s' at %L is INTRINSIC but is not compatible with "
676 "an intrinsic", sym->name, &expr->where);
684 gfc_procedure_use (sym, &expr->value.function.actual, &expr->where);
687 expr->value.function.name = sym->name;
688 expr->value.function.esym = sym;
690 expr->rank = sym->as->rank;
697 resolve_specific_f (gfc_expr * expr)
702 sym = expr->symtree->n.sym;
706 m = resolve_specific_f0 (sym, expr);
709 if (m == MATCH_ERROR)
712 if (sym->ns->parent == NULL)
715 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
721 gfc_error ("Unable to resolve the specific function '%s' at %L",
722 expr->symtree->n.sym->name, &expr->where);
728 /* Resolve a procedure call not known to be generic nor specific. */
731 resolve_unknown_f (gfc_expr * expr)
736 sym = expr->symtree->n.sym;
740 sym->attr.proc = PROC_DUMMY;
741 expr->value.function.name = sym->name;
745 /* See if we have an intrinsic function reference. */
747 if (gfc_intrinsic_name (sym->name, 0))
749 if (gfc_intrinsic_func_interface (expr, 1) == MATCH_YES)
754 /* The reference is to an external name. */
756 sym->attr.proc = PROC_EXTERNAL;
757 expr->value.function.name = sym->name;
758 expr->value.function.esym = expr->symtree->n.sym;
761 expr->rank = sym->as->rank;
763 /* Type of the expression is either the type of the symbol or the
764 default type of the symbol. */
767 gfc_procedure_use (sym, &expr->value.function.actual, &expr->where);
769 if (sym->ts.type != BT_UNKNOWN)
773 ts = gfc_get_default_type (sym, sym->ns);
775 if (ts->type == BT_UNKNOWN)
777 gfc_error ("Function '%s' at %L has no implicit type",
778 sym->name, &expr->where);
789 /* Figure out if if a function reference is pure or not. Also sets the name
790 of the function for a potential error message. Returns nonzero if the
791 function is PURE, zero if not. */
794 pure_function (gfc_expr * e, char **name)
798 if (e->value.function.esym)
800 pure = gfc_pure (e->value.function.esym);
801 *name = e->value.function.esym->name;
803 else if (e->value.function.isym)
805 pure = e->value.function.isym->pure
806 || e->value.function.isym->elemental;
807 *name = e->value.function.isym->name;
811 /* Implicit functions are not pure. */
813 *name = e->value.function.name;
820 /* Resolve a function call, which means resolving the arguments, then figuring
821 out which entity the name refers to. */
822 /* TODO: Check procedure arguments so that an INTENT(IN) isn't passed
823 to INTENT(OUT) or INTENT(INOUT). */
826 resolve_function (gfc_expr * expr)
828 gfc_actual_arglist *arg;
832 if (resolve_actual_arglist (expr->value.function.actual) == FAILURE)
835 /* See if function is already resolved. */
837 if (expr->value.function.name != NULL)
839 if (expr->ts.type == BT_UNKNOWN)
840 expr->ts = expr->symtree->n.sym->ts;
845 /* Apply the rules of section 14.1.2. */
847 switch (procedure_kind (expr->symtree->n.sym))
850 t = resolve_generic_f (expr);
854 t = resolve_specific_f (expr);
858 t = resolve_unknown_f (expr);
862 gfc_internal_error ("resolve_function(): bad function type");
866 /* If the expression is still a function (it might have simplified),
867 then we check to see if we are calling an elemental function. */
869 if (expr->expr_type != EXPR_FUNCTION)
872 if (expr->value.function.actual != NULL
873 && ((expr->value.function.esym != NULL
874 && expr->value.function.esym->attr.elemental)
875 || (expr->value.function.isym != NULL
876 && expr->value.function.isym->elemental)))
879 /* The rank of an elemental is the rank of its array argument(s). */
881 for (arg = expr->value.function.actual; arg; arg = arg->next)
883 if (arg->expr != NULL && arg->expr->rank > 0)
885 expr->rank = arg->expr->rank;
891 if (!pure_function (expr, &name))
896 ("Function reference to '%s' at %L is inside a FORALL block",
900 else if (gfc_pure (NULL))
902 gfc_error ("Function reference to '%s' at %L is to a non-PURE "
903 "procedure within a PURE procedure", name, &expr->where);
912 /************* Subroutine resolution *************/
915 pure_subroutine (gfc_code * c, gfc_symbol * sym)
922 gfc_error ("Subroutine call to '%s' in FORALL block at %L is not PURE",
924 else if (gfc_pure (NULL))
925 gfc_error ("Subroutine call to '%s' at %L is not PURE", sym->name,
931 resolve_generic_s0 (gfc_code * c, gfc_symbol * sym)
935 if (sym->attr.generic)
937 s = gfc_search_interface (sym->generic, 1, &c->ext.actual);
941 pure_subroutine (c, s);
945 /* TODO: Need to search for elemental references in generic interface. */
948 if (sym->attr.intrinsic)
949 return gfc_intrinsic_sub_interface (c, 0);
956 resolve_generic_s (gfc_code * c)
961 sym = c->symtree->n.sym;
963 m = resolve_generic_s0 (c, sym);
966 if (m == MATCH_ERROR)
969 if (sym->ns->parent != NULL)
971 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
974 m = resolve_generic_s0 (c, sym);
977 if (m == MATCH_ERROR)
982 /* Last ditch attempt. */
984 if (!gfc_generic_intrinsic (sym->name))
987 ("Generic subroutine '%s' at %L is not an intrinsic subroutine",
992 m = gfc_intrinsic_sub_interface (c, 0);
996 gfc_error ("Generic subroutine '%s' at %L is not consistent with an "
997 "intrinsic subroutine interface", sym->name, &c->loc);
1003 /* Resolve a subroutine call known to be specific. */
1006 resolve_specific_s0 (gfc_code * c, gfc_symbol * sym)
1010 if (sym->attr.external || sym->attr.if_source == IFSRC_IFBODY)
1012 if (sym->attr.dummy)
1014 sym->attr.proc = PROC_DUMMY;
1018 sym->attr.proc = PROC_EXTERNAL;
1022 if (sym->attr.proc == PROC_MODULE || sym->attr.proc == PROC_INTERNAL)
1025 if (sym->attr.intrinsic)
1027 m = gfc_intrinsic_sub_interface (c, 1);
1031 gfc_error ("Subroutine '%s' at %L is INTRINSIC but is not compatible "
1032 "with an intrinsic", sym->name, &c->loc);
1040 gfc_procedure_use (sym, &c->ext.actual, &c->loc);
1042 c->resolved_sym = sym;
1043 pure_subroutine (c, sym);
1050 resolve_specific_s (gfc_code * c)
1055 sym = c->symtree->n.sym;
1057 m = resolve_specific_s0 (c, sym);
1060 if (m == MATCH_ERROR)
1063 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
1067 m = resolve_specific_s0 (c, sym);
1070 if (m == MATCH_ERROR)
1074 gfc_error ("Unable to resolve the specific subroutine '%s' at %L",
1075 sym->name, &c->loc);
1081 /* Resolve a subroutine call not known to be generic nor specific. */
1084 resolve_unknown_s (gfc_code * c)
1088 sym = c->symtree->n.sym;
1090 if (sym->attr.dummy)
1092 sym->attr.proc = PROC_DUMMY;
1096 /* See if we have an intrinsic function reference. */
1098 if (gfc_intrinsic_name (sym->name, 1))
1100 if (gfc_intrinsic_sub_interface (c, 1) == MATCH_YES)
1105 /* The reference is to an external name. */
1108 gfc_procedure_use (sym, &c->ext.actual, &c->loc);
1110 c->resolved_sym = sym;
1112 pure_subroutine (c, sym);
1118 /* Resolve a subroutine call. Although it was tempting to use the same code
1119 for functions, subroutines and functions are stored differently and this
1120 makes things awkward. */
1123 resolve_call (gfc_code * c)
1127 if (resolve_actual_arglist (c->ext.actual) == FAILURE)
1130 if (c->resolved_sym != NULL)
1133 switch (procedure_kind (c->symtree->n.sym))
1136 t = resolve_generic_s (c);
1139 case PTYPE_SPECIFIC:
1140 t = resolve_specific_s (c);
1144 t = resolve_unknown_s (c);
1148 gfc_internal_error ("resolve_subroutine(): bad function type");
1155 /* Resolve an operator expression node. This can involve replacing the
1156 operation with a user defined function call. */
1159 resolve_operator (gfc_expr * e)
1161 gfc_expr *op1, *op2;
1165 /* Resolve all subnodes-- give them types. */
1167 switch (e->operator)
1170 if (gfc_resolve_expr (e->op2) == FAILURE)
1173 /* Fall through... */
1176 case INTRINSIC_UPLUS:
1177 case INTRINSIC_UMINUS:
1178 if (gfc_resolve_expr (e->op1) == FAILURE)
1183 /* Typecheck the new node. */
1188 switch (e->operator)
1190 case INTRINSIC_UPLUS:
1191 case INTRINSIC_UMINUS:
1192 if (op1->ts.type == BT_INTEGER
1193 || op1->ts.type == BT_REAL
1194 || op1->ts.type == BT_COMPLEX)
1200 sprintf (msg, "Operand of unary numeric operator '%s' at %%L is %s",
1201 gfc_op2string (e->operator), gfc_typename (&e->ts));
1204 case INTRINSIC_PLUS:
1205 case INTRINSIC_MINUS:
1206 case INTRINSIC_TIMES:
1207 case INTRINSIC_DIVIDE:
1208 case INTRINSIC_POWER:
1209 if (gfc_numeric_ts (&op1->ts) && gfc_numeric_ts (&op2->ts))
1211 gfc_type_convert_binary (e);
1216 "Operands of binary numeric operator '%s' at %%L are %s/%s",
1217 gfc_op2string (e->operator), gfc_typename (&op1->ts),
1218 gfc_typename (&op2->ts));
1221 case INTRINSIC_CONCAT:
1222 if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER)
1224 e->ts.type = BT_CHARACTER;
1225 e->ts.kind = op1->ts.kind;
1230 "Operands of string concatenation operator at %%L are %s/%s",
1231 gfc_typename (&op1->ts), gfc_typename (&op2->ts));
1237 case INTRINSIC_NEQV:
1238 if (op1->ts.type == BT_LOGICAL && op2->ts.type == BT_LOGICAL)
1240 e->ts.type = BT_LOGICAL;
1241 e->ts.kind = gfc_kind_max (op1, op2);
1242 if (op1->ts.kind < e->ts.kind)
1243 gfc_convert_type (op1, &e->ts, 2);
1244 else if (op2->ts.kind < e->ts.kind)
1245 gfc_convert_type (op2, &e->ts, 2);
1249 sprintf (msg, "Operands of logical operator '%s' at %%L are %s/%s",
1250 gfc_op2string (e->operator), gfc_typename (&op1->ts),
1251 gfc_typename (&op2->ts));
1256 if (op1->ts.type == BT_LOGICAL)
1258 e->ts.type = BT_LOGICAL;
1259 e->ts.kind = op1->ts.kind;
1263 sprintf (msg, "Operand of .NOT. operator at %%L is %s",
1264 gfc_typename (&op1->ts));
1271 if (op1->ts.type == BT_COMPLEX || op2->ts.type == BT_COMPLEX)
1273 strcpy (msg, "COMPLEX quantities cannot be compared at %L");
1277 /* Fall through... */
1281 if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER)
1283 e->ts.type = BT_LOGICAL;
1284 e->ts.kind = gfc_default_logical_kind ();
1288 if (gfc_numeric_ts (&op1->ts) && gfc_numeric_ts (&op2->ts))
1290 gfc_type_convert_binary (e);
1292 e->ts.type = BT_LOGICAL;
1293 e->ts.kind = gfc_default_logical_kind ();
1297 sprintf (msg, "Operands of comparison operator '%s' at %%L are %s/%s",
1298 gfc_op2string (e->operator), gfc_typename (&op1->ts),
1299 gfc_typename (&op2->ts));
1303 case INTRINSIC_USER:
1305 sprintf (msg, "Operand of user operator '%s' at %%L is %s",
1306 e->uop->ns->proc_name->name, gfc_typename (&op1->ts));
1308 sprintf (msg, "Operands of user operator '%s' at %%L are %s/%s",
1309 e->uop->ns->proc_name->name, gfc_typename (&op1->ts),
1310 gfc_typename (&op2->ts));
1315 gfc_internal_error ("resolve_operator(): Bad intrinsic");
1318 /* Deal with arrayness of an operand through an operator. */
1322 switch (e->operator)
1324 case INTRINSIC_PLUS:
1325 case INTRINSIC_MINUS:
1326 case INTRINSIC_TIMES:
1327 case INTRINSIC_DIVIDE:
1328 case INTRINSIC_POWER:
1329 case INTRINSIC_CONCAT:
1333 case INTRINSIC_NEQV:
1341 if (op1->rank == 0 && op2->rank == 0)
1344 if (op1->rank == 0 && op2->rank != 0)
1346 e->rank = op2->rank;
1348 if (e->shape == NULL)
1349 e->shape = gfc_copy_shape (op2->shape, op2->rank);
1352 if (op1->rank != 0 && op2->rank == 0)
1354 e->rank = op1->rank;
1356 if (e->shape == NULL)
1357 e->shape = gfc_copy_shape (op1->shape, op1->rank);
1360 if (op1->rank != 0 && op2->rank != 0)
1362 if (op1->rank == op2->rank)
1364 e->rank = op1->rank;
1366 if (e->shape == NULL)
1367 e->shape = gfc_copy_shape (op1->shape, op1->rank);
1372 gfc_error ("Inconsistent ranks for operator at %L and %L",
1373 &op1->where, &op2->where);
1376 /* Allow higher level expressions to work. */
1384 case INTRINSIC_UPLUS:
1385 case INTRINSIC_UMINUS:
1386 e->rank = op1->rank;
1388 if (e->shape == NULL)
1389 e->shape = gfc_copy_shape (op1->shape, op1->rank);
1391 /* Simply copy arrayness attribute */
1398 /* Attempt to simplify the expression. */
1400 t = gfc_simplify_expr (e, 0);
1404 if (gfc_extend_expr (e) == SUCCESS)
1407 gfc_error (msg, &e->where);
1412 /************** Array resolution subroutines **************/
1416 { CMP_LT, CMP_EQ, CMP_GT, CMP_UNKNOWN }
1419 /* Compare two integer expressions. */
1422 compare_bound (gfc_expr * a, gfc_expr * b)
1426 if (a == NULL || a->expr_type != EXPR_CONSTANT
1427 || b == NULL || b->expr_type != EXPR_CONSTANT)
1430 if (a->ts.type != BT_INTEGER || b->ts.type != BT_INTEGER)
1431 gfc_internal_error ("compare_bound(): Bad expression");
1433 i = mpz_cmp (a->value.integer, b->value.integer);
1443 /* Compare an integer expression with an integer. */
1446 compare_bound_int (gfc_expr * a, int b)
1450 if (a == NULL || a->expr_type != EXPR_CONSTANT)
1453 if (a->ts.type != BT_INTEGER)
1454 gfc_internal_error ("compare_bound_int(): Bad expression");
1456 i = mpz_cmp_si (a->value.integer, b);
1466 /* Compare a single dimension of an array reference to the array
1470 check_dimension (int i, gfc_array_ref * ar, gfc_array_spec * as)
1473 /* Given start, end and stride values, calculate the minimum and
1474 maximum referenced indexes. */
1482 if (compare_bound (ar->start[i], as->lower[i]) == CMP_LT)
1484 if (compare_bound (ar->start[i], as->upper[i]) == CMP_GT)
1490 if (compare_bound_int (ar->stride[i], 0) == CMP_EQ)
1492 gfc_error ("Illegal stride of zero at %L", &ar->c_where[i]);
1496 if (compare_bound (ar->start[i], as->lower[i]) == CMP_LT)
1498 if (compare_bound (ar->start[i], as->upper[i]) == CMP_GT)
1501 /* TODO: Possibly, we could warn about end[i] being out-of-bound although
1502 it is legal (see 6.2.2.3.1). */
1507 gfc_internal_error ("check_dimension(): Bad array reference");
1513 gfc_warning ("Array reference at %L is out of bounds", &ar->c_where[i]);
1518 /* Compare an array reference with an array specification. */
1521 compare_spec_to_ref (gfc_array_ref * ar)
1528 /* TODO: Full array sections are only allowed as actual parameters. */
1529 if (as->type == AS_ASSUMED_SIZE
1530 && (/*ar->type == AR_FULL
1531 ||*/ (ar->type == AR_SECTION
1532 && ar->dimen_type[i] == DIMEN_RANGE && ar->end[i] == NULL)))
1534 gfc_error ("Rightmost upper bound of assumed size array section"
1535 " not specified at %L", &ar->where);
1539 if (ar->type == AR_FULL)
1542 if (as->rank != ar->dimen)
1544 gfc_error ("Rank mismatch in array reference at %L (%d/%d)",
1545 &ar->where, ar->dimen, as->rank);
1549 for (i = 0; i < as->rank; i++)
1550 if (check_dimension (i, ar, as) == FAILURE)
1557 /* Resolve one part of an array index. */
1560 gfc_resolve_index (gfc_expr * index, int check_scalar)
1567 if (gfc_resolve_expr (index) == FAILURE)
1570 if (index->ts.type != BT_INTEGER)
1572 gfc_error ("Array index at %L must be of INTEGER type", &index->where);
1576 if (check_scalar && index->rank != 0)
1578 gfc_error ("Array index at %L must be scalar", &index->where);
1582 if (index->ts.kind != gfc_index_integer_kind)
1584 ts.type = BT_INTEGER;
1585 ts.kind = gfc_index_integer_kind;
1587 gfc_convert_type_warn (index, &ts, 2, 0);
1594 /* Given an expression that contains array references, update those array
1595 references to point to the right array specifications. While this is
1596 filled in during matching, this information is difficult to save and load
1597 in a module, so we take care of it here.
1599 The idea here is that the original array reference comes from the
1600 base symbol. We traverse the list of reference structures, setting
1601 the stored reference to references. Component references can
1602 provide an additional array specification. */
1605 find_array_spec (gfc_expr * e)
1611 as = e->symtree->n.sym->as;
1612 c = e->symtree->n.sym->components;
1614 for (ref = e->ref; ref; ref = ref->next)
1619 gfc_internal_error ("find_array_spec(): Missing spec");
1626 for (; c; c = c->next)
1627 if (c == ref->u.c.component)
1631 gfc_internal_error ("find_array_spec(): Component not found");
1636 gfc_internal_error ("find_array_spec(): unused as(1)");
1640 c = c->ts.derived->components;
1648 gfc_internal_error ("find_array_spec(): unused as(2)");
1652 /* Resolve an array reference. */
1655 resolve_array_ref (gfc_array_ref * ar)
1657 int i, check_scalar;
1659 for (i = 0; i < ar->dimen; i++)
1661 check_scalar = ar->dimen_type[i] == DIMEN_RANGE;
1663 if (gfc_resolve_index (ar->start[i], check_scalar) == FAILURE)
1665 if (gfc_resolve_index (ar->end[i], check_scalar) == FAILURE)
1667 if (gfc_resolve_index (ar->stride[i], check_scalar) == FAILURE)
1670 if (ar->dimen_type[i] == DIMEN_UNKNOWN)
1671 switch (ar->start[i]->rank)
1674 ar->dimen_type[i] = DIMEN_ELEMENT;
1678 ar->dimen_type[i] = DIMEN_VECTOR;
1682 gfc_error ("Array index at %L is an array of rank %d",
1683 &ar->c_where[i], ar->start[i]->rank);
1688 /* If the reference type is unknown, figure out what kind it is. */
1690 if (ar->type == AR_UNKNOWN)
1692 ar->type = AR_ELEMENT;
1693 for (i = 0; i < ar->dimen; i++)
1694 if (ar->dimen_type[i] == DIMEN_RANGE
1695 || ar->dimen_type[i] == DIMEN_VECTOR)
1697 ar->type = AR_SECTION;
1702 if (compare_spec_to_ref (ar) == FAILURE)
1710 resolve_substring (gfc_ref * ref)
1713 if (ref->u.ss.start != NULL)
1715 if (gfc_resolve_expr (ref->u.ss.start) == FAILURE)
1718 if (ref->u.ss.start->ts.type != BT_INTEGER)
1720 gfc_error ("Substring start index at %L must be of type INTEGER",
1721 &ref->u.ss.start->where);
1725 if (ref->u.ss.start->rank != 0)
1727 gfc_error ("Substring start index at %L must be scalar",
1728 &ref->u.ss.start->where);
1732 if (compare_bound_int (ref->u.ss.start, 1) == CMP_LT)
1734 gfc_error ("Substring start index at %L is less than one",
1735 &ref->u.ss.start->where);
1740 if (ref->u.ss.end != NULL)
1742 if (gfc_resolve_expr (ref->u.ss.end) == FAILURE)
1745 if (ref->u.ss.end->ts.type != BT_INTEGER)
1747 gfc_error ("Substring end index at %L must be of type INTEGER",
1748 &ref->u.ss.end->where);
1752 if (ref->u.ss.end->rank != 0)
1754 gfc_error ("Substring end index at %L must be scalar",
1755 &ref->u.ss.end->where);
1759 if (ref->u.ss.length != NULL
1760 && compare_bound (ref->u.ss.end, ref->u.ss.length->length) == CMP_GT)
1762 gfc_error ("Substring end index at %L is out of bounds",
1763 &ref->u.ss.start->where);
1772 /* Resolve subtype references. */
1775 resolve_ref (gfc_expr * expr)
1777 int current_part_dimension, n_components, seen_part_dimension;
1780 for (ref = expr->ref; ref; ref = ref->next)
1781 if (ref->type == REF_ARRAY && ref->u.ar.as == NULL)
1783 find_array_spec (expr);
1787 for (ref = expr->ref; ref; ref = ref->next)
1791 if (resolve_array_ref (&ref->u.ar) == FAILURE)
1799 resolve_substring (ref);
1803 /* Check constraints on part references. */
1805 current_part_dimension = 0;
1806 seen_part_dimension = 0;
1809 for (ref = expr->ref; ref; ref = ref->next)
1814 switch (ref->u.ar.type)
1818 current_part_dimension = 1;
1822 current_part_dimension = 0;
1826 gfc_internal_error ("resolve_ref(): Bad array reference");
1832 if ((current_part_dimension || seen_part_dimension)
1833 && ref->u.c.component->pointer)
1836 ("Component to the right of a part reference with nonzero "
1837 "rank must not have the POINTER attribute at %L",
1849 if (((ref->type == REF_COMPONENT && n_components > 1)
1850 || ref->next == NULL)
1851 && current_part_dimension
1852 && seen_part_dimension)
1855 gfc_error ("Two or more part references with nonzero rank must "
1856 "not be specified at %L", &expr->where);
1860 if (ref->type == REF_COMPONENT)
1862 if (current_part_dimension)
1863 seen_part_dimension = 1;
1865 /* reset to make sure */
1866 current_part_dimension = 0;
1874 /* Given an expression, determine its shape. This is easier than it sounds.
1875 Leaves the shape array NULL if it is not possible to determine the shape. */
1878 expression_shape (gfc_expr * e)
1880 mpz_t array[GFC_MAX_DIMENSIONS];
1883 if (e->rank == 0 || e->shape != NULL)
1886 for (i = 0; i < e->rank; i++)
1887 if (gfc_array_dimen_size (e, i, &array[i]) == FAILURE)
1890 e->shape = gfc_get_shape (e->rank);
1892 memcpy (e->shape, array, e->rank * sizeof (mpz_t));
1897 for (i--; i >= 0; i--)
1898 mpz_clear (array[i]);
1902 /* Given a variable expression node, compute the rank of the expression by
1903 examining the base symbol and any reference structures it may have. */
1906 expression_rank (gfc_expr * e)
1913 if (e->expr_type == EXPR_ARRAY)
1915 /* Constructors can have a rank different from one via RESHAPE(). */
1917 if (e->symtree == NULL)
1923 e->rank = (e->symtree->n.sym->as == NULL)
1924 ? 0 : e->symtree->n.sym->as->rank;
1930 for (ref = e->ref; ref; ref = ref->next)
1932 if (ref->type != REF_ARRAY)
1935 if (ref->u.ar.type == AR_FULL)
1937 rank = ref->u.ar.as->rank;
1941 if (ref->u.ar.type == AR_SECTION)
1943 /* Figure out the rank of the section. */
1945 gfc_internal_error ("expression_rank(): Two array specs");
1947 for (i = 0; i < ref->u.ar.dimen; i++)
1948 if (ref->u.ar.dimen_type[i] == DIMEN_RANGE
1949 || ref->u.ar.dimen_type[i] == DIMEN_VECTOR)
1959 expression_shape (e);
1963 /* Resolve a variable expression. */
1966 resolve_variable (gfc_expr * e)
1970 if (e->ref && resolve_ref (e) == FAILURE)
1973 sym = e->symtree->n.sym;
1974 if (sym->attr.flavor == FL_PROCEDURE && !sym->attr.function)
1976 e->ts.type = BT_PROCEDURE;
1980 if (sym->ts.type != BT_UNKNOWN)
1981 gfc_variable_attr (e, &e->ts);
1984 /* Must be a simple variable reference. */
1985 if (gfc_set_default_type (sym, 1, NULL) == FAILURE)
1994 /* Resolve an expression. That is, make sure that types of operands agree
1995 with their operators, intrinsic operators are converted to function calls
1996 for overloaded types and unresolved function references are resolved. */
1999 gfc_resolve_expr (gfc_expr * e)
2006 switch (e->expr_type)
2009 t = resolve_operator (e);
2013 t = resolve_function (e);
2017 t = resolve_variable (e);
2019 expression_rank (e);
2022 case EXPR_SUBSTRING:
2023 t = resolve_ref (e);
2033 if (resolve_ref (e) == FAILURE)
2036 t = gfc_resolve_array_constructor (e);
2037 /* Also try to expand a constructor. */
2040 expression_rank (e);
2041 gfc_expand_constructor (e);
2046 case EXPR_STRUCTURE:
2047 t = resolve_ref (e);
2051 t = resolve_structure_cons (e);
2055 t = gfc_simplify_expr (e, 0);
2059 gfc_internal_error ("gfc_resolve_expr(): Bad expression type");
2066 /* Resolve the expressions in an iterator structure and require that they all
2067 be of integer type. */
2070 gfc_resolve_iterator (gfc_iterator * iter)
2073 if (gfc_resolve_expr (iter->var) == FAILURE)
2076 if (iter->var->ts.type != BT_INTEGER || iter->var->rank != 0)
2078 gfc_error ("Loop variable at %L must be a scalar INTEGER",
2083 if (gfc_pure (NULL) && gfc_impure_variable (iter->var->symtree->n.sym))
2085 gfc_error ("Cannot assign to loop variable in PURE procedure at %L",
2090 if (gfc_resolve_expr (iter->start) == FAILURE)
2093 if (iter->start->ts.type != BT_INTEGER || iter->start->rank != 0)
2095 gfc_error ("Start expression in DO loop at %L must be a scalar INTEGER",
2096 &iter->start->where);
2100 if (gfc_resolve_expr (iter->end) == FAILURE)
2103 if (iter->end->ts.type != BT_INTEGER || iter->end->rank != 0)
2105 gfc_error ("End expression in DO loop at %L must be a scalar INTEGER",
2110 if (gfc_resolve_expr (iter->step) == FAILURE)
2113 if (iter->step->ts.type != BT_INTEGER || iter->step->rank != 0)
2115 gfc_error ("Step expression in DO loop at %L must be a scalar INTEGER",
2116 &iter->step->where);
2120 if (iter->step->expr_type == EXPR_CONSTANT
2121 && mpz_cmp_ui (iter->step->value.integer, 0) == 0)
2123 gfc_error ("Step expression in DO loop at %L cannot be zero",
2124 &iter->step->where);
2132 /* Resolve a list of FORALL iterators. */
2135 resolve_forall_iterators (gfc_forall_iterator * iter)
2140 if (gfc_resolve_expr (iter->var) == SUCCESS
2141 && iter->var->ts.type != BT_INTEGER)
2142 gfc_error ("FORALL Iteration variable at %L must be INTEGER",
2145 if (gfc_resolve_expr (iter->start) == SUCCESS
2146 && iter->start->ts.type != BT_INTEGER)
2147 gfc_error ("FORALL start expression at %L must be INTEGER",
2148 &iter->start->where);
2149 if (iter->var->ts.kind != iter->start->ts.kind)
2150 gfc_convert_type (iter->start, &iter->var->ts, 2);
2152 if (gfc_resolve_expr (iter->end) == SUCCESS
2153 && iter->end->ts.type != BT_INTEGER)
2154 gfc_error ("FORALL end expression at %L must be INTEGER",
2156 if (iter->var->ts.kind != iter->end->ts.kind)
2157 gfc_convert_type (iter->end, &iter->var->ts, 2);
2159 if (gfc_resolve_expr (iter->stride) == SUCCESS
2160 && iter->stride->ts.type != BT_INTEGER)
2161 gfc_error ("FORALL Stride expression at %L must be INTEGER",
2162 &iter->stride->where);
2163 if (iter->var->ts.kind != iter->stride->ts.kind)
2164 gfc_convert_type (iter->stride, &iter->var->ts, 2);
2171 /* Given a pointer to a symbol that is a derived type, see if any components
2172 have the POINTER attribute. The search is recursive if necessary.
2173 Returns zero if no pointer components are found, nonzero otherwise. */
2176 derived_pointer (gfc_symbol * sym)
2180 for (c = sym->components; c; c = c->next)
2185 if (c->ts.type == BT_DERIVED && derived_pointer (c->ts.derived))
2193 /* Resolve the argument of a deallocate expression. The expression must be
2194 a pointer or a full array. */
2197 resolve_deallocate_expr (gfc_expr * e)
2199 symbol_attribute attr;
2203 if (gfc_resolve_expr (e) == FAILURE)
2206 attr = gfc_expr_attr (e);
2210 if (e->expr_type != EXPR_VARIABLE)
2213 allocatable = e->symtree->n.sym->attr.allocatable;
2214 for (ref = e->ref; ref; ref = ref->next)
2218 if (ref->u.ar.type != AR_FULL)
2223 allocatable = (ref->u.c.component->as != NULL
2224 && ref->u.c.component->as->type == AS_DEFERRED);
2232 if (allocatable == 0)
2235 gfc_error ("Expression in DEALLOCATE statement at %L must be "
2236 "ALLOCATABLE or a POINTER", &e->where);
2243 /* Resolve the expression in an ALLOCATE statement, doing the additional
2244 checks to see whether the expression is OK or not. The expression must
2245 have a trailing array reference that gives the size of the array. */
2248 resolve_allocate_expr (gfc_expr * e)
2250 int i, pointer, allocatable, dimension;
2251 symbol_attribute attr;
2252 gfc_ref *ref, *ref2;
2255 if (gfc_resolve_expr (e) == FAILURE)
2258 /* Make sure the expression is allocatable or a pointer. If it is
2259 pointer, the next-to-last reference must be a pointer. */
2263 if (e->expr_type != EXPR_VARIABLE)
2267 attr = gfc_expr_attr (e);
2268 pointer = attr.pointer;
2269 dimension = attr.dimension;
2274 allocatable = e->symtree->n.sym->attr.allocatable;
2275 pointer = e->symtree->n.sym->attr.pointer;
2276 dimension = e->symtree->n.sym->attr.dimension;
2278 for (ref = e->ref; ref; ref2 = ref, ref = ref->next)
2282 if (ref->next != NULL)
2287 allocatable = (ref->u.c.component->as != NULL
2288 && ref->u.c.component->as->type == AS_DEFERRED);
2290 pointer = ref->u.c.component->pointer;
2291 dimension = ref->u.c.component->dimension;
2301 if (allocatable == 0 && pointer == 0)
2303 gfc_error ("Expression in ALLOCATE statement at %L must be "
2304 "ALLOCATABLE or a POINTER", &e->where);
2308 if (pointer && dimension == 0)
2311 /* Make sure the next-to-last reference node is an array specification. */
2313 if (ref2 == NULL || ref2->type != REF_ARRAY || ref2->u.ar.type == AR_FULL)
2315 gfc_error ("Array specification required in ALLOCATE statement "
2316 "at %L", &e->where);
2320 if (ref2->u.ar.type == AR_ELEMENT)
2323 /* Make sure that the array section reference makes sense in the
2324 context of an ALLOCATE specification. */
2328 for (i = 0; i < ar->dimen; i++)
2329 switch (ar->dimen_type[i])
2335 if (ar->start[i] != NULL
2336 && ar->end[i] != NULL
2337 && ar->stride[i] == NULL)
2340 /* Fall Through... */
2344 gfc_error ("Bad array specification in ALLOCATE statement at %L",
2353 /************ SELECT CASE resolution subroutines ************/
2355 /* Callback function for our mergesort variant. Determines interval
2356 overlaps for CASEs. Return <0 if op1 < op2, 0 for overlap, >0 for
2357 op1 > op2. Assumes we're not dealing with the default case. */
2360 compare_cases (const void * _op1, const void * _op2)
2362 const gfc_case *op1, *op2;
2364 op1 = (const gfc_case *) _op1;
2365 op2 = (const gfc_case *) _op2;
2367 if (op1->low == NULL) /* op1 = (:N) */
2369 if (op2->low == NULL) /* op2 = (:M), so overlap. */
2372 else if (op2->high == NULL) /* op2 = (M:) */
2374 if (gfc_compare_expr (op1->high, op2->low) < 0)
2375 return -1; /* N < M */
2380 else /* op2 = (L:M) */
2382 if (gfc_compare_expr (op1->high, op2->low) < 0)
2383 return -1; /* N < L */
2389 else if (op1->high == NULL) /* op1 = (N:) */
2391 if (op2->low == NULL) /* op2 = (:M) */
2393 if (gfc_compare_expr (op1->low, op2->high) > 0)
2394 return 1; /* N > M */
2399 else if (op2->high == NULL) /* op2 = (M:), so overlap. */
2402 else /* op2 = (L:M) */
2404 if (gfc_compare_expr (op1->low, op2->high) > 0)
2405 return 1; /* N > M */
2411 else /* op1 = (N:P) */
2413 if (op2->low == NULL) /* op2 = (:M) */
2415 if (gfc_compare_expr (op1->low, op2->high) > 0)
2416 return 1; /* N > M */
2421 else if (op2->high == NULL) /* op2 = (M:) */
2423 if (gfc_compare_expr (op1->high, op2->low) < 0)
2424 return -1; /* P < M */
2429 else /* op2 = (L:M) */
2431 if (gfc_compare_expr (op1->high, op2->low) < 0)
2432 return -1; /* P < L */
2434 if (gfc_compare_expr (op1->low, op2->high) > 0)
2435 return 1; /* N > M */
2443 /* Merge-sort a double linked case list, detecting overlap in the
2444 process. LIST is the head of the double linked case list before it
2445 is sorted. Returns the head of the sorted list if we don't see any
2446 overlap, or NULL otherwise. */
2449 check_case_overlap (gfc_case * list)
2451 gfc_case *p, *q, *e, *tail;
2452 int insize, nmerges, psize, qsize, cmp, overlap_seen;
2454 /* If the passed list was empty, return immediately. */
2461 /* Loop unconditionally. The only exit from this loop is a return
2462 statement, when we've finished sorting the case list. */
2469 /* Count the number of merges we do in this pass. */
2472 /* Loop while there exists a merge to be done. */
2477 /* Count this merge. */
2480 /* Cut the list in two pieces by steppin INSIZE places
2481 forward in the list, starting from P. */
2484 for (i = 0; i < insize; i++)
2493 /* Now we have two lists. Merge them! */
2494 while (psize > 0 || (qsize > 0 && q != NULL))
2497 /* See from which the next case to merge comes from. */
2500 /* P is empty so the next case must come from Q. */
2505 else if (qsize == 0 || q == NULL)
2514 cmp = compare_cases (p, q);
2517 /* The whole case range for P is less than the
2525 /* The whole case range for Q is greater than
2526 the case range for P. */
2533 /* The cases overlap, or they are the same
2534 element in the list. Either way, we must
2535 issue an error and get the next case from P. */
2536 /* FIXME: Sort P and Q by line number. */
2537 gfc_error ("CASE label at %L overlaps with CASE "
2538 "label at %L", &p->where, &q->where);
2546 /* Add the next element to the merged list. */
2555 /* P has now stepped INSIZE places along, and so has Q. So
2556 they're the same. */
2561 /* If we have done only one merge or none at all, we've
2562 finished sorting the cases. */
2571 /* Otherwise repeat, merging lists twice the size. */
2577 /* Check to see if an expression is suitable for use in a CASE
2578 statement. Makes sure that all case expressions are scalar
2579 constants of the same type/kind. Return FAILURE if anything
2583 validate_case_label_expr (gfc_expr * e, gfc_expr * case_expr)
2585 gfc_typespec case_ts = case_expr->ts;
2587 if (e == NULL) return SUCCESS;
2589 if (e->ts.type != case_ts.type)
2591 gfc_error ("Expression in CASE statement at %L must be of type %s",
2592 &e->where, gfc_basic_typename (case_ts.type));
2596 if (e->ts.kind != case_ts.kind)
2598 gfc_error("Expression in CASE statement at %L must be kind %d",
2599 &e->where, case_ts.kind);
2605 gfc_error ("Expression in CASE statement at %L must be scalar",
2614 /* Given a completely parsed select statement, we:
2616 - Validate all expressions and code within the SELECT.
2617 - Make sure that the selection expression is not of the wrong type.
2618 - Make sure that no case ranges overlap.
2619 - Eliminate unreachable cases and unreachable code resulting from
2620 removing case labels.
2622 The standard does allow unreachable cases, e.g. CASE (5:3). But
2623 they are a hassle for code generation, and to prevent that, we just
2624 cut them out here. This is not necessary for overlapping cases
2625 because they are illegal and we never even try to generate code.
2627 We have the additional caveat that a SELECT construct could have
2628 been a computed GOTO in the source code. Furtunately we can fairly
2629 easily work around that here: The case_expr for a "real" SELECT CASE
2630 is in code->expr1, but for a computed GOTO it is in code->expr2. All
2631 we have to do is make sure that the case_expr is a scalar integer
2635 resolve_select (gfc_code * code)
2638 gfc_expr *case_expr;
2639 gfc_case *cp, *default_case, *tail, *head;
2640 int seen_unreachable;
2645 if (code->expr == NULL)
2647 /* This was actually a computed GOTO statement. */
2648 case_expr = code->expr2;
2649 if (case_expr->ts.type != BT_INTEGER
2650 || case_expr->rank != 0)
2651 gfc_error ("Selection expression in computed GOTO statement "
2652 "at %L must be a scalar integer expression",
2655 /* Further checking is not necessary because this SELECT was built
2656 by the compiler, so it should always be OK. Just move the
2657 case_expr from expr2 to expr so that we can handle computed
2658 GOTOs as normal SELECTs from here on. */
2659 code->expr = code->expr2;
2664 case_expr = code->expr;
2666 type = case_expr->ts.type;
2667 if (type != BT_LOGICAL && type != BT_INTEGER && type != BT_CHARACTER)
2669 gfc_error ("Argument of SELECT statement at %L cannot be %s",
2670 &case_expr->where, gfc_typename (&case_expr->ts));
2672 /* Punt. Going on here just produce more garbage error messages. */
2676 if (case_expr->rank != 0)
2678 gfc_error ("Argument of SELECT statement at %L must be a scalar "
2679 "expression", &case_expr->where);
2685 /* Assume there is no DEFAULT case. */
2686 default_case = NULL;
2690 for (body = code->block; body; body = body->block)
2692 /* Assume the CASE list is OK, and all CASE labels can be matched. */
2694 seen_unreachable = 0;
2696 /* Walk the case label list, making sure that all case labels
2698 for (cp = body->ext.case_list; cp; cp = cp->next)
2700 /* Count the number of cases in the whole construct. */
2703 /* Intercept the DEFAULT case. */
2704 if (cp->low == NULL && cp->high == NULL)
2706 if (default_case != NULL)
2708 gfc_error ("The DEFAULT CASE at %L cannot be followed "
2709 "by a second DEFAULT CASE at %L",
2710 &default_case->where, &cp->where);
2721 /* Deal with single value cases and case ranges. Errors are
2722 issued from the validation function. */
2723 if(validate_case_label_expr (cp->low, case_expr) != SUCCESS
2724 || validate_case_label_expr (cp->high, case_expr) != SUCCESS)
2730 if (type == BT_LOGICAL
2731 && ((cp->low == NULL || cp->high == NULL)
2732 || cp->low != cp->high))
2735 ("Logical range in CASE statement at %L is not allowed",
2741 if (cp->low != NULL && cp->high != NULL
2742 && cp->low != cp->high
2743 && gfc_compare_expr (cp->low, cp->high) > 0)
2745 if (gfc_option.warn_surprising)
2746 gfc_warning ("Range specification at %L can never "
2747 "be matched", &cp->where);
2749 cp->unreachable = 1;
2750 seen_unreachable = 1;
2754 /* If the case range can be matched, it can also overlap with
2755 other cases. To make sure it does not, we put it in a
2756 double linked list here. We sort that with a merge sort
2757 later on to detect any overlapping cases. */
2761 head->right = head->left = NULL;
2766 tail->right->left = tail;
2773 /* It there was a failure in the previous case label, give up
2774 for this case label list. Continue with the next block. */
2778 /* See if any case labels that are unreachable have been seen.
2779 If so, we eliminate them. This is a bit of a kludge because
2780 the case lists for a single case statement (label) is a
2781 single forward linked lists. */
2782 if (seen_unreachable)
2784 /* Advance until the first case in the list is reachable. */
2785 while (body->ext.case_list != NULL
2786 && body->ext.case_list->unreachable)
2788 gfc_case *n = body->ext.case_list;
2789 body->ext.case_list = body->ext.case_list->next;
2791 gfc_free_case_list (n);
2794 /* Strip all other unreachable cases. */
2795 if (body->ext.case_list)
2797 for (cp = body->ext.case_list; cp->next; cp = cp->next)
2799 if (cp->next->unreachable)
2801 gfc_case *n = cp->next;
2802 cp->next = cp->next->next;
2804 gfc_free_case_list (n);
2811 /* See if there were overlapping cases. If the check returns NULL,
2812 there was overlap. In that case we don't do anything. If head
2813 is non-NULL, we prepend the DEFAULT case. The sorted list can
2814 then used during code generation for SELECT CASE constructs with
2815 a case expression of a CHARACTER type. */
2818 head = check_case_overlap (head);
2820 /* Prepend the default_case if it is there. */
2821 if (head != NULL && default_case)
2823 default_case->left = NULL;
2824 default_case->right = head;
2825 head->left = default_case;
2829 /* Eliminate dead blocks that may be the result if we've seen
2830 unreachable case labels for a block. */
2831 for (body = code; body && body->block; body = body->block)
2833 if (body->block->ext.case_list == NULL)
2835 /* Cut the unreachable block from the code chain. */
2836 gfc_code *c = body->block;
2837 body->block = c->block;
2839 /* Kill the dead block, but not the blocks below it. */
2841 gfc_free_statements (c);
2845 /* More than two cases is legal but insane for logical selects.
2846 Issue a warning for it. */
2847 if (gfc_option.warn_surprising && type == BT_LOGICAL
2849 gfc_warning ("Logical SELECT CASE block at %L has more that two cases",
2854 /*********** Toplevel code resolution subroutines ***********/
2856 /* Given a branch to a label and a namespace, if the branch is conforming.
2857 The code node described where the branch is located. */
2860 resolve_branch (gfc_st_label * label, gfc_code * code)
2862 gfc_code *block, *found;
2870 /* Step one: is this a valid branching target? */
2872 if (lp->defined == ST_LABEL_UNKNOWN)
2874 gfc_error ("Label %d referenced at %L is never defined", lp->value,
2879 if (lp->defined != ST_LABEL_TARGET)
2881 gfc_error ("Statement at %L is not a valid branch target statement "
2882 "for the branch statement at %L", &lp->where, &code->loc);
2886 /* Step two: make sure this branch is not a branch to itself ;-) */
2888 if (code->here == label)
2890 gfc_warning ("Branch at %L causes an infinite loop", &code->loc);
2894 /* Step three: Try to find the label in the parse tree. To do this,
2895 we traverse the tree block-by-block: first the block that
2896 contains this GOTO, then the block that it is nested in, etc. We
2897 can ignore other blocks because branching into another block is
2902 for (stack = cs_base; stack; stack = stack->prev)
2904 for (block = stack->head; block; block = block->next)
2906 if (block->here == label)
2919 /* still nothing, so illegal. */
2920 gfc_error_now ("Label at %L is not in the same block as the "
2921 "GOTO statement at %L", &lp->where, &code->loc);
2925 /* Step four: Make sure that the branching target is legal if
2926 the statement is an END {SELECT,DO,IF}. */
2928 if (found->op == EXEC_NOP)
2930 for (stack = cs_base; stack; stack = stack->prev)
2931 if (stack->current->next == found)
2935 gfc_notify_std (GFC_STD_F95_DEL,
2936 "Obsolete: GOTO at %L jumps to END of construct at %L",
2937 &code->loc, &found->loc);
2942 /* Check whether EXPR1 has the same shape as EXPR2. */
2945 resolve_where_shape (gfc_expr *expr1, gfc_expr *expr2)
2947 mpz_t shape[GFC_MAX_DIMENSIONS];
2948 mpz_t shape2[GFC_MAX_DIMENSIONS];
2949 try result = FAILURE;
2952 /* Compare the rank. */
2953 if (expr1->rank != expr2->rank)
2956 /* Compare the size of each dimension. */
2957 for (i=0; i<expr1->rank; i++)
2959 if (gfc_array_dimen_size (expr1, i, &shape[i]) == FAILURE)
2962 if (gfc_array_dimen_size (expr2, i, &shape2[i]) == FAILURE)
2965 if (mpz_cmp (shape[i], shape2[i]))
2969 /* When either of the two expression is an assumed size array, we
2970 ignore the comparison of dimension sizes. */
2975 for (i--; i>=0; i--)
2977 mpz_clear (shape[i]);
2978 mpz_clear (shape2[i]);
2984 /* Check whether a WHERE assignment target or a WHERE mask expression
2985 has the same shape as the outmost WHERE mask expression. */
2988 resolve_where (gfc_code *code, gfc_expr *mask)
2994 cblock = code->block;
2996 /* Store the first WHERE mask-expr of the WHERE statement or construct.
2997 In case of nested WHERE, only the outmost one is stored. */
2998 if (mask == NULL) /* outmost WHERE */
3000 else /* inner WHERE */
3007 /* Check if the mask-expr has a consistent shape with the
3008 outmost WHERE mask-expr. */
3009 if (resolve_where_shape (cblock->expr, e) == FAILURE)
3010 gfc_error ("WHERE mask at %L has inconsistent shape",
3011 &cblock->expr->where);
3014 /* the assignment statement of a WHERE statement, or the first
3015 statement in where-body-construct of a WHERE construct */
3016 cnext = cblock->next;
3021 /* WHERE assignment statement */
3024 /* Check shape consistent for WHERE assignment target. */
3025 if (e && resolve_where_shape (cnext->expr, e) == FAILURE)
3026 gfc_error ("WHERE assignment target at %L has "
3027 "inconsistent shape", &cnext->expr->where);
3030 /* WHERE or WHERE construct is part of a where-body-construct */
3032 resolve_where (cnext, e);
3036 gfc_error ("Unsupported statement inside WHERE at %L",
3039 /* the next statement within the same where-body-construct */
3040 cnext = cnext->next;
3042 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
3043 cblock = cblock->block;
3048 /* Check whether the FORALL index appears in the expression or not. */
3051 gfc_find_forall_index (gfc_expr *expr, gfc_symbol *symbol)
3055 gfc_actual_arglist *args;
3058 switch (expr->expr_type)
3061 assert (expr->symtree->n.sym);
3063 /* A scalar assignment */
3066 if (expr->symtree->n.sym == symbol)
3072 /* the expr is array ref, substring or struct component. */
3079 /* Check if the symbol appears in the array subscript. */
3081 for (i = 0; i < GFC_MAX_DIMENSIONS; i++)
3084 if (gfc_find_forall_index (ar.start[i], symbol) == SUCCESS)
3088 if (gfc_find_forall_index (ar.end[i], symbol) == SUCCESS)
3092 if (gfc_find_forall_index (ar.stride[i], symbol) == SUCCESS)
3098 if (expr->symtree->n.sym == symbol)
3101 /* Check if the symbol appears in the substring section. */
3102 if (gfc_find_forall_index (tmp->u.ss.start, symbol) == SUCCESS)
3104 if (gfc_find_forall_index (tmp->u.ss.end, symbol) == SUCCESS)
3112 gfc_error("expresion reference type error at %L", &expr->where);
3118 /* If the expression is a function call, then check if the symbol
3119 appears in the actual arglist of the function. */
3121 for (args = expr->value.function.actual; args; args = args->next)
3123 if (gfc_find_forall_index(args->expr,symbol) == SUCCESS)
3128 /* It seems not to happen. */
3129 case EXPR_SUBSTRING:
3133 assert(expr->ref->type == REF_SUBSTRING);
3134 if (gfc_find_forall_index (tmp->u.ss.start, symbol) == SUCCESS)
3136 if (gfc_find_forall_index (tmp->u.ss.end, symbol) == SUCCESS)
3141 /* It seems not to happen. */
3142 case EXPR_STRUCTURE:
3144 gfc_error ("Unsupported statement while finding forall index in "
3151 /* Find the FORALL index in the first operand. */
3154 if (gfc_find_forall_index (expr->op1, symbol) == SUCCESS)
3158 /* Find the FORALL index in the second operand. */
3161 if (gfc_find_forall_index (expr->op2, symbol) == SUCCESS)
3168 /* Resolve assignment in FORALL construct.
3169 NVAR is the number of FORALL index variables, and VAR_EXPR records the
3170 FORALL index variables. */
3173 gfc_resolve_assign_in_forall (gfc_code *code, int nvar, gfc_expr **var_expr)
3177 for (n = 0; n < nvar; n++)
3179 gfc_symbol *forall_index;
3181 forall_index = var_expr[n]->symtree->n.sym;
3183 /* Check whether the assignment target is one of the FORALL index
3185 if ((code->expr->expr_type == EXPR_VARIABLE)
3186 && (code->expr->symtree->n.sym == forall_index))
3187 gfc_error ("Assignment to a FORALL index variable at %L",
3188 &code->expr->where);
3191 /* If one of the FORALL index variables doesn't appear in the
3192 assignment target, then there will be a many-to-one
3194 if (gfc_find_forall_index (code->expr, forall_index) == FAILURE)
3195 gfc_error ("The FORALL with index '%s' cause more than one "
3196 "assignment to this object at %L",
3197 var_expr[n]->symtree->name, &code->expr->where);
3203 /* Resolve WHERE statement in FORALL construct. */
3206 gfc_resolve_where_code_in_forall (gfc_code *code, int nvar, gfc_expr **var_expr){
3210 cblock = code->block;
3213 /* the assignment statement of a WHERE statement, or the first
3214 statement in where-body-construct of a WHERE construct */
3215 cnext = cblock->next;
3220 /* WHERE assignment statement */
3222 gfc_resolve_assign_in_forall (cnext, nvar, var_expr);
3225 /* WHERE or WHERE construct is part of a where-body-construct */
3227 gfc_resolve_where_code_in_forall (cnext, nvar, var_expr);
3231 gfc_error ("Unsupported statement inside WHERE at %L",
3234 /* the next statement within the same where-body-construct */
3235 cnext = cnext->next;
3237 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
3238 cblock = cblock->block;
3243 /* Traverse the FORALL body to check whether the following errors exist:
3244 1. For assignment, check if a many-to-one assignment happens.
3245 2. For WHERE statement, check the WHERE body to see if there is any
3246 many-to-one assignment. */
3249 gfc_resolve_forall_body (gfc_code *code, int nvar, gfc_expr **var_expr)
3253 c = code->block->next;
3259 case EXEC_POINTER_ASSIGN:
3260 gfc_resolve_assign_in_forall (c, nvar, var_expr);
3263 /* Because the resolve_blocks() will handle the nested FORALL,
3264 there is no need to handle it here. */
3268 gfc_resolve_where_code_in_forall(c, nvar, var_expr);
3273 /* The next statement in the FORALL body. */
3279 /* Given a FORALL construct, first resolve the FORALL iterator, then call
3280 gfc_resolve_forall_body to resolve the FORALL body. */
3282 static void resolve_blocks (gfc_code *, gfc_namespace *);
3285 gfc_resolve_forall (gfc_code *code, gfc_namespace *ns, int forall_save)
3287 static gfc_expr **var_expr;
3288 static int total_var = 0;
3289 static int nvar = 0;
3290 gfc_forall_iterator *fa;
3291 gfc_symbol *forall_index;
3295 /* Start to resolve a FORALL construct */
3296 if (forall_save == 0)
3298 /* Count the total number of FORALL index in the nested FORALL
3299 construct in order to allocate the VAR_EXPR with proper size. */
3301 while ((next != NULL) && (next->op == EXEC_FORALL))
3303 for (fa = next->ext.forall_iterator; fa; fa = fa->next)
3305 next = next->block->next;
3308 /* allocate VAR_EXPR with NUMBER_OF_FORALL_INDEX elements. */
3309 var_expr = (gfc_expr **) gfc_getmem (total_var * sizeof (gfc_expr *));
3312 /* The information about FORALL iterator, including FORALL index start, end
3313 and stride. The FORALL index can not appear in start, end or stride. */
3314 for (fa = code->ext.forall_iterator; fa; fa = fa->next)
3316 /* Check if any outer FORALL index name is the same as the current
3318 for (i = 0; i < nvar; i++)
3320 if (fa->var->symtree->n.sym == var_expr[i]->symtree->n.sym)
3322 gfc_error ("An outer FORALL construct already has an index "
3323 "with this name %L", &fa->var->where);
3327 /* Record the current FORALL index. */
3328 var_expr[nvar] = gfc_copy_expr (fa->var);
3330 forall_index = fa->var->symtree->n.sym;
3332 /* Check if the FORALL index appears in start, end or stride. */
3333 if (gfc_find_forall_index (fa->start, forall_index) == SUCCESS)
3334 gfc_error ("A FORALL index must not appear in a limit or stride "
3335 "expression in the same FORALL at %L", &fa->start->where);
3336 if (gfc_find_forall_index (fa->end, forall_index) == SUCCESS)
3337 gfc_error ("A FORALL index must not appear in a limit or stride "
3338 "expression in the same FORALL at %L", &fa->end->where);
3339 if (gfc_find_forall_index (fa->stride, forall_index) == SUCCESS)
3340 gfc_error ("A FORALL index must not appear in a limit or stride "
3341 "expression in the same FORALL at %L", &fa->stride->where);
3345 /* Resolve the FORALL body. */
3346 gfc_resolve_forall_body (code, nvar, var_expr);
3348 /* May call gfc_resolve_forall to resolve the inner FORALL loop. */
3349 resolve_blocks (code->block, ns);
3351 /* Free VAR_EXPR after the whole FORALL construct resolved. */
3352 for (i = 0; i < total_var; i++)
3353 gfc_free_expr (var_expr[i]);
3355 /* Reset the counters. */
3361 /* Resolve lists of blocks found in IF, SELECT CASE, WHERE, FORALL ,GOTO and
3364 static void resolve_code (gfc_code *, gfc_namespace *);
3367 resolve_blocks (gfc_code * b, gfc_namespace * ns)
3371 for (; b; b = b->block)
3373 t = gfc_resolve_expr (b->expr);
3374 if (gfc_resolve_expr (b->expr2) == FAILURE)
3380 if (t == SUCCESS && b->expr != NULL
3381 && (b->expr->ts.type != BT_LOGICAL || b->expr->rank != 0))
3383 ("ELSE IF clause at %L requires a scalar LOGICAL expression",
3390 && (b->expr->ts.type != BT_LOGICAL
3391 || b->expr->rank == 0))
3393 ("WHERE/ELSEWHERE clause at %L requires a LOGICAL array",
3398 resolve_branch (b->label, b);
3408 gfc_internal_error ("resolve_block(): Bad block type");
3411 resolve_code (b->next, ns);
3416 /* Given a block of code, recursively resolve everything pointed to by this
3420 resolve_code (gfc_code * code, gfc_namespace * ns)
3422 int forall_save = 0;
3427 frame.prev = cs_base;
3431 for (; code; code = code->next)
3433 frame.current = code;
3435 if (code->op == EXEC_FORALL)
3437 forall_save = forall_flag;
3439 gfc_resolve_forall (code, ns, forall_save);
3442 resolve_blocks (code->block, ns);
3444 if (code->op == EXEC_FORALL)
3445 forall_flag = forall_save;
3447 t = gfc_resolve_expr (code->expr);
3448 if (gfc_resolve_expr (code->expr2) == FAILURE)
3464 resolve_where (code, NULL);
3468 if (code->expr != NULL && code->expr->ts.type != BT_INTEGER)
3469 gfc_error ("ASSIGNED GOTO statement at %L requires an INTEGER "
3470 "variable", &code->expr->where);
3472 resolve_branch (code->label, code);
3476 if (code->expr != NULL && code->expr->ts.type != BT_INTEGER)
3477 gfc_error ("Alternate RETURN statement at %L requires an INTEGER "
3478 "return specifier", &code->expr->where);
3485 if (gfc_extend_assign (code, ns) == SUCCESS)
3488 if (gfc_pure (NULL))
3490 if (gfc_impure_variable (code->expr->symtree->n.sym))
3493 ("Cannot assign to variable '%s' in PURE procedure at %L",
3494 code->expr->symtree->n.sym->name, &code->expr->where);
3498 if (code->expr2->ts.type == BT_DERIVED
3499 && derived_pointer (code->expr2->ts.derived))
3502 ("Right side of assignment at %L is a derived type "
3503 "containing a POINTER in a PURE procedure",
3504 &code->expr2->where);
3509 gfc_check_assign (code->expr, code->expr2, 1);
3512 case EXEC_LABEL_ASSIGN:
3513 if (code->label->defined == ST_LABEL_UNKNOWN)
3514 gfc_error ("Label %d referenced at %L is never defined",
3515 code->label->value, &code->label->where);
3516 if (t == SUCCESS && code->expr->ts.type != BT_INTEGER)
3517 gfc_error ("ASSIGN statement at %L requires an INTEGER "
3518 "variable", &code->expr->where);
3521 case EXEC_POINTER_ASSIGN:
3525 gfc_check_pointer_assign (code->expr, code->expr2);
3528 case EXEC_ARITHMETIC_IF:
3530 && code->expr->ts.type != BT_INTEGER
3531 && code->expr->ts.type != BT_REAL)
3532 gfc_error ("Arithmetic IF statement at %L requires a numeric "
3533 "expression", &code->expr->where);
3535 resolve_branch (code->label, code);
3536 resolve_branch (code->label2, code);
3537 resolve_branch (code->label3, code);
3541 if (t == SUCCESS && code->expr != NULL
3542 && (code->expr->ts.type != BT_LOGICAL
3543 || code->expr->rank != 0))
3544 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
3545 &code->expr->where);
3550 resolve_call (code);
3554 /* Select is complicated. Also, a SELECT construct could be
3555 a transformed computed GOTO. */
3556 resolve_select (code);
3560 if (code->ext.iterator != NULL)
3561 gfc_resolve_iterator (code->ext.iterator);
3565 if (code->expr == NULL)
3566 gfc_internal_error ("resolve_code(): No expression on DO WHILE");
3568 && (code->expr->rank != 0
3569 || code->expr->ts.type != BT_LOGICAL))
3570 gfc_error ("Exit condition of DO WHILE loop at %L must be "
3571 "a scalar LOGICAL expression", &code->expr->where);
3575 if (t == SUCCESS && code->expr != NULL
3576 && code->expr->ts.type != BT_INTEGER)
3577 gfc_error ("STAT tag in ALLOCATE statement at %L must be "
3578 "of type INTEGER", &code->expr->where);
3580 for (a = code->ext.alloc_list; a; a = a->next)
3581 resolve_allocate_expr (a->expr);
3585 case EXEC_DEALLOCATE:
3586 if (t == SUCCESS && code->expr != NULL
3587 && code->expr->ts.type != BT_INTEGER)
3589 ("STAT tag in DEALLOCATE statement at %L must be of type "
3590 "INTEGER", &code->expr->where);
3592 for (a = code->ext.alloc_list; a; a = a->next)
3593 resolve_deallocate_expr (a->expr);
3598 if (gfc_resolve_open (code->ext.open) == FAILURE)
3601 resolve_branch (code->ext.open->err, code);
3605 if (gfc_resolve_close (code->ext.close) == FAILURE)
3608 resolve_branch (code->ext.close->err, code);
3611 case EXEC_BACKSPACE:
3614 if (gfc_resolve_filepos (code->ext.filepos) == FAILURE)
3617 resolve_branch (code->ext.filepos->err, code);
3621 if (gfc_resolve_inquire (code->ext.inquire) == FAILURE)
3624 resolve_branch (code->ext.inquire->err, code);
3628 assert(code->ext.inquire != NULL);
3629 if (gfc_resolve_inquire (code->ext.inquire) == FAILURE)
3632 resolve_branch (code->ext.inquire->err, code);
3637 if (gfc_resolve_dt (code->ext.dt) == FAILURE)
3640 resolve_branch (code->ext.dt->err, code);
3641 resolve_branch (code->ext.dt->end, code);
3642 resolve_branch (code->ext.dt->eor, code);
3646 resolve_forall_iterators (code->ext.forall_iterator);
3648 if (code->expr != NULL && code->expr->ts.type != BT_LOGICAL)
3650 ("FORALL mask clause at %L requires a LOGICAL expression",
3651 &code->expr->where);
3655 gfc_internal_error ("resolve_code(): Bad statement code");
3659 cs_base = frame.prev;
3663 /* Resolve initial values and make sure they are compatible with
3667 resolve_values (gfc_symbol * sym)
3670 if (sym->value == NULL)
3673 if (gfc_resolve_expr (sym->value) == FAILURE)
3676 gfc_check_assign_symbol (sym, sym->value);
3680 /* Do anything necessary to resolve a symbol. Right now, we just
3681 assume that an otherwise unknown symbol is a variable. This sort
3682 of thing commonly happens for symbols in module. */
3685 resolve_symbol (gfc_symbol * sym)
3687 /* Zero if we are checking a formal namespace. */
3688 static int formal_ns_flag = 1;
3689 int formal_ns_save, check_constant, mp_flag;
3694 if (sym->attr.flavor == FL_UNKNOWN)
3696 if (sym->attr.external == 0 && sym->attr.intrinsic == 0)
3697 sym->attr.flavor = FL_VARIABLE;
3700 sym->attr.flavor = FL_PROCEDURE;
3701 if (sym->attr.dimension)
3702 sym->attr.function = 1;
3706 /* Symbols that are module procedures with results (functions) have
3707 the types and array specification copied for type checking in
3708 procedures that call them, as well as for saving to a module
3709 file. These symbols can't stand the scrutiny that their results
3711 mp_flag = (sym->result != NULL && sym->result != sym);
3713 /* Assign default type to symbols that need one and don't have one. */
3714 if (sym->ts.type == BT_UNKNOWN)
3716 if (sym->attr.flavor == FL_VARIABLE || sym->attr.flavor == FL_PARAMETER)
3717 gfc_set_default_type (sym, 0, NULL);
3719 if (sym->attr.flavor == FL_PROCEDURE && sym->attr.function)
3722 gfc_set_default_type (sym, 0, NULL);
3725 /* Result may be in another namespace. */
3726 resolve_symbol (sym->result);
3728 sym->ts = sym->result->ts;
3729 sym->as = gfc_copy_array_spec (sym->result->as);
3734 /* Assumed size arrays and assumed shape arrays must be dummy
3738 && (sym->as->type == AS_ASSUMED_SIZE
3739 || sym->as->type == AS_ASSUMED_SHAPE)
3740 && sym->attr.dummy == 0)
3742 gfc_error ("Assumed %s array at %L must be a dummy argument",
3743 sym->as->type == AS_ASSUMED_SIZE ? "size" : "shape",
3748 if (sym->attr.flavor == FL_PARAMETER
3749 && sym->as != NULL && sym->as->type != AS_EXPLICIT)
3751 gfc_error ("Parameter array '%s' at %L must have an explicit shape",
3752 sym->name, &sym->declared_at);
3756 /* Make sure that character string variables with assumed length are
3759 if (sym->attr.flavor == FL_VARIABLE && !sym->attr.result
3760 && sym->ts.type == BT_CHARACTER
3761 && sym->ts.cl->length == NULL && sym->attr.dummy == 0)
3763 gfc_error ("Entity with assumed character length at %L must be a "
3764 "dummy argument or a PARAMETER", &sym->declared_at);
3768 /* Make sure a parameter that has been implicitly typed still
3769 matches the implicit type, since PARAMETER statements can precede
3770 IMPLICIT statements. */
3772 if (sym->attr.flavor == FL_PARAMETER
3773 && sym->attr.implicit_type
3774 && !gfc_compare_types (&sym->ts, gfc_get_default_type (sym, sym->ns)))
3775 gfc_error ("Implicitly typed PARAMETER '%s' at %L doesn't match a "
3776 "later IMPLICIT type", sym->name, &sym->declared_at);
3778 /* Make sure the types of derived parameters are consistent. This
3779 type checking is deferred until resolution because the type may
3780 refer to a derived type from the host. */
3782 if (sym->attr.flavor == FL_PARAMETER
3783 && sym->ts.type == BT_DERIVED
3784 && !gfc_compare_types (&sym->ts, &sym->value->ts))
3785 gfc_error ("Incompatible derived type in PARAMETER at %L",
3786 &sym->value->where);
3788 /* Make sure symbols with known intent or optional are really dummy
3789 variable. Because of ENTRY statement, this has to be deferred
3790 until resolution time. */
3792 if (! sym->attr.dummy
3793 && (sym->attr.optional
3794 || sym->attr.intent != INTENT_UNKNOWN))
3796 gfc_error ("Symbol at %L is not a DUMMY variable", &sym->declared_at);
3800 if (sym->attr.proc == PROC_ST_FUNCTION)
3802 if (sym->ts.type == BT_CHARACTER)
3804 gfc_charlen *cl = sym->ts.cl;
3805 if (!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT)
3807 gfc_error ("Character-valued statement function '%s' at %L must "
3808 "have constant length", sym->name, &sym->declared_at);
3814 /* Constraints on deferred shape variable. */
3815 if (sym->attr.flavor == FL_VARIABLE
3816 || (sym->attr.flavor == FL_PROCEDURE
3817 && sym->attr.function))
3819 if (sym->as == NULL || sym->as->type != AS_DEFERRED)
3821 if (sym->attr.allocatable)
3823 if (sym->attr.dimension)
3824 gfc_error ("Allocatable array at %L must have a deferred shape",
3827 gfc_error ("Object at %L may not be ALLOCATABLE",
3832 if (sym->attr.pointer && sym->attr.dimension)
3834 gfc_error ("Pointer to array at %L must have a deferred shape",
3842 if (!mp_flag && !sym->attr.allocatable
3843 && !sym->attr.pointer && !sym->attr.dummy)
3845 gfc_error ("Array at %L cannot have a deferred shape",
3852 if (sym->attr.flavor == FL_VARIABLE)
3854 /* Can the sybol have an initializer? */
3856 if (sym->attr.allocatable)
3857 whynot = "Allocatable";
3858 else if (sym->attr.external)
3859 whynot = "External";
3860 else if (sym->attr.dummy)
3862 else if (sym->attr.intrinsic)
3863 whynot = "Intrinsic";
3864 else if (sym->attr.result)
3865 whynot = "Function Result";
3866 else if (sym->attr.dimension && !sym->attr.pointer)
3868 /* Don't allow initialization of automatic arrays. */
3869 for (i = 0; i < sym->as->rank; i++)
3871 if (sym->as->lower[i] == NULL
3872 || sym->as->lower[i]->expr_type != EXPR_CONSTANT
3873 || sym->as->upper[i] == NULL
3874 || sym->as->upper[i]->expr_type != EXPR_CONSTANT)
3876 whynot = "Automatic array";
3882 /* Reject illegal initializers. */
3883 if (sym->value && whynot)
3885 gfc_error ("%s '%s' at %L cannot have an initializer",
3886 whynot, sym->name, &sym->declared_at);
3890 /* Assign default initializer. */
3891 if (sym->ts.type == BT_DERIVED && !(sym->value || whynot))
3892 sym->value = gfc_default_initializer (&sym->ts);
3896 /* Make sure that intrinsic exist */
3897 if (sym->attr.intrinsic
3898 && ! gfc_intrinsic_name(sym->name, 0)
3899 && ! gfc_intrinsic_name(sym->name, 1))
3900 gfc_error("Intrinsic at %L does not exist", &sym->declared_at);
3902 /* Resolve array specifier. Check as well some constraints
3903 on COMMON blocks. */
3905 check_constant = sym->attr.in_common && !sym->attr.pointer;
3906 gfc_resolve_array_spec (sym->as, check_constant);
3908 /* Resolve formal namespaces. */
3910 if (formal_ns_flag && sym != NULL && sym->formal_ns != NULL)
3912 formal_ns_save = formal_ns_flag;
3914 gfc_resolve (sym->formal_ns);
3915 formal_ns_flag = formal_ns_save;
3921 /************* Resolve DATA statements *************/
3925 gfc_data_value *vnode;
3931 /* Advance the values structure to point to the next value in the data list. */
3934 next_data_value (void)
3937 while (values.left == 0)
3939 if (values.vnode->next == NULL)
3942 values.vnode = values.vnode->next;
3943 values.left = values.vnode->repeat;
3952 check_data_variable (gfc_data_variable * var, locus * where)
3958 ar_type mark = AR_UNKNOWN;
3960 mpz_t section_index[GFC_MAX_DIMENSIONS];
3964 if (gfc_resolve_expr (var->expr) == FAILURE)
3968 mpz_init_set_si (offset, 0);
3971 if (e->expr_type != EXPR_VARIABLE)
3972 gfc_internal_error ("check_data_variable(): Bad expression");
3975 mpz_init_set_ui (size, 1);
3980 /* Find the array section reference. */
3981 for (ref = e->ref; ref; ref = ref->next)
3983 if (ref->type != REF_ARRAY)
3985 if (ref->u.ar.type == AR_ELEMENT)
3991 /* Set marks asscording to the reference pattern. */
3992 switch (ref->u.ar.type)
4000 /* Get the start position of array section. */
4001 gfc_get_section_index (ar, section_index, &offset);
4009 if (gfc_array_size (e, &size) == FAILURE)
4011 gfc_error ("Nonconstant array section at %L in DATA statement",
4020 while (mpz_cmp_ui (size, 0) > 0)
4022 if (next_data_value () == FAILURE)
4024 gfc_error ("DATA statement at %L has more variables than values",
4030 t = gfc_check_assign (var->expr, values.vnode->expr, 0);
4034 /* Assign initial value to symbol. */
4035 gfc_assign_data_value (var->expr, values.vnode->expr, offset);
4037 if (mark == AR_FULL)
4038 mpz_add_ui (offset, offset, 1);
4040 /* Modify the array section indexes and recalculate the offset for
4042 else if (mark == AR_SECTION)
4043 gfc_advance_section (section_index, ar, &offset);
4045 mpz_sub_ui (size, size, 1);
4047 if (mark == AR_SECTION)
4049 for (i = 0; i < ar->dimen; i++)
4050 mpz_clear (section_index[i]);
4060 static try traverse_data_var (gfc_data_variable *, locus *);
4062 /* Iterate over a list of elements in a DATA statement. */
4065 traverse_data_list (gfc_data_variable * var, locus * where)
4068 iterator_stack frame;
4071 mpz_init (frame.value);
4073 mpz_init_set (trip, var->iter.end->value.integer);
4074 mpz_sub (trip, trip, var->iter.start->value.integer);
4075 mpz_add (trip, trip, var->iter.step->value.integer);
4077 mpz_div (trip, trip, var->iter.step->value.integer);
4079 mpz_set (frame.value, var->iter.start->value.integer);
4081 frame.prev = iter_stack;
4082 frame.variable = var->iter.var->symtree;
4083 iter_stack = &frame;
4085 while (mpz_cmp_ui (trip, 0) > 0)
4087 if (traverse_data_var (var->list, where) == FAILURE)
4093 e = gfc_copy_expr (var->expr);
4094 if (gfc_simplify_expr (e, 1) == FAILURE)
4100 mpz_add (frame.value, frame.value, var->iter.step->value.integer);
4102 mpz_sub_ui (trip, trip, 1);
4106 mpz_clear (frame.value);
4108 iter_stack = frame.prev;
4113 /* Type resolve variables in the variable list of a DATA statement. */
4116 traverse_data_var (gfc_data_variable * var, locus * where)
4120 for (; var; var = var->next)
4122 if (var->expr == NULL)
4123 t = traverse_data_list (var, where);
4125 t = check_data_variable (var, where);
4135 /* Resolve the expressions and iterators associated with a data statement.
4136 This is separate from the assignment checking because data lists should
4137 only be resolved once. */
4140 resolve_data_variables (gfc_data_variable * d)
4143 for (; d; d = d->next)
4145 if (d->list == NULL)
4147 if (gfc_resolve_expr (d->expr) == FAILURE)
4152 if (gfc_resolve_iterator (&d->iter) == FAILURE)
4155 if (d->iter.start->expr_type != EXPR_CONSTANT
4156 || d->iter.end->expr_type != EXPR_CONSTANT
4157 || d->iter.step->expr_type != EXPR_CONSTANT)
4158 gfc_internal_error ("resolve_data_variables(): Bad iterator");
4160 if (resolve_data_variables (d->list) == FAILURE)
4169 /* Resolve a single DATA statement. We implement this by storing a pointer to
4170 the value list into static variables, and then recursively traversing the
4171 variables list, expanding iterators and such. */
4174 resolve_data (gfc_data * d)
4177 if (resolve_data_variables (d->var) == FAILURE)
4180 values.vnode = d->value;
4181 values.left = (d->value == NULL) ? 0 : d->value->repeat;
4183 if (traverse_data_var (d->var, &d->where) == FAILURE)
4186 /* At this point, we better not have any values left. */
4188 if (next_data_value () == SUCCESS)
4189 gfc_error ("DATA statement at %L has more values than variables",
4194 /* Determines if a variable is not 'pure', ie not assignable within a pure
4195 procedure. Returns zero if assignment is OK, nonzero if there is a problem.
4199 gfc_impure_variable (gfc_symbol * sym)
4202 if (sym->attr.use_assoc || sym->attr.in_common)
4205 if (sym->ns != gfc_current_ns)
4206 return !sym->attr.function;
4208 /* TODO: Check storage association through EQUIVALENCE statements */
4214 /* Test whether a symbol is pure or not. For a NULL pointer, checks the
4215 symbol of the current procedure. */
4218 gfc_pure (gfc_symbol * sym)
4220 symbol_attribute attr;
4223 sym = gfc_current_ns->proc_name;
4229 return attr.flavor == FL_PROCEDURE && (attr.pure || attr.elemental);
4233 /* Test whether the current procedure is elemental or not. */
4236 gfc_elemental (gfc_symbol * sym)
4238 symbol_attribute attr;
4241 sym = gfc_current_ns->proc_name;
4246 return attr.flavor == FL_PROCEDURE && attr.elemental;
4250 /* Warn about unused labels. */
4253 warn_unused_label (gfc_namespace * ns)
4264 for (; l; l = l->prev)
4266 if (l->defined == ST_LABEL_UNKNOWN)
4269 switch (l->referenced)
4271 case ST_LABEL_UNKNOWN:
4272 gfc_warning ("Label %d at %L defined but not used", l->value,
4276 case ST_LABEL_BAD_TARGET:
4277 gfc_warning ("Label %d at %L defined but cannot be used", l->value,
4288 /* Resolve derived type EQUIVALENCE object. */
4291 resolve_equivalence_derived (gfc_symbol *derived, gfc_symbol *sym, gfc_expr *e)
4294 gfc_component *c = derived->components;
4299 /* Shall not be an object of nonsequence derived type. */
4300 if (!derived->attr.sequence)
4302 gfc_error ("Derived type variable '%s' at %L must have SEQUENCE "
4303 "attribute to be an EQUIVALENCE object", sym->name, &e->where);
4307 for (; c ; c = c->next)
4310 if (d && (resolve_equivalence_derived (c->ts.derived, sym, e) == FAILURE))
4313 /* Shall not be an object of sequence derived type containing a pointer
4314 in the structure. */
4317 gfc_error ("Derived type variable '%s' at %L has pointer componet(s) "
4318 "cannot be an EQUIVALENCE object", sym->name, &e->where);
4326 /* Resolve equivalence object.
4327 An EQUIVALENCE object shall not be a dummy argument, a pointer, an
4328 allocatable array, an object of nonsequence derived type, an object of
4329 sequence derived type containing a pointer at any level of component
4330 selection, an automatic object, a function name, an entry name, a result
4331 name, a named constant, a structure component, or a subobject of any of
4332 the preceding objects. */
4335 resolve_equivalence (gfc_equiv *eq)
4338 gfc_symbol *derived;
4342 for (; eq; eq = eq->eq)
4345 if (gfc_resolve_expr (e) == FAILURE)
4348 sym = e->symtree->n.sym;
4350 /* Shall not be a dummy argument. */
4351 if (sym->attr.dummy)
4353 gfc_error ("Dummy argument '%s' at %L cannot be an EQUIVALENCE "
4354 "object", sym->name, &e->where);
4358 /* Shall not be an allocatable array. */
4359 if (sym->attr.allocatable)
4361 gfc_error ("Allocatable array '%s' at %L cannot be an EQUIVALENCE "
4362 "object", sym->name, &e->where);
4366 /* Shall not be a pointer. */
4367 if (sym->attr.pointer)
4369 gfc_error ("Pointer '%s' at %L cannot be an EQUIVALENCE object",
4370 sym->name, &e->where);
4374 /* Shall not be a function name, ... */
4375 if (sym->attr.function || sym->attr.result || sym->attr.entry
4376 || sym->attr.subroutine)
4378 gfc_error ("Entity '%s' at %L cannot be an EQUIVALENCE object",
4379 sym->name, &e->where);
4383 /* Shall not be a named constant. */
4384 if (e->expr_type == EXPR_CONSTANT)
4386 gfc_error ("Named constant '%s' at %L cannot be an EQUIVALENCE "
4387 "object", sym->name, &e->where);
4391 derived = e->ts.derived;
4392 if (derived && resolve_equivalence_derived (derived, sym, e) == FAILURE)
4398 /* Shall not be an automatic array. */
4399 if (e->ref->type == REF_ARRAY
4400 && gfc_resolve_array_spec (e->ref->u.ar.as, 1) == FAILURE)
4402 gfc_error ("Array '%s' at %L with non-constant bounds cannot be "
4403 "an EQUIVALENCE object", sym->name, &e->where);
4407 /* Shall not be a structure component. */
4411 if (r->type == REF_COMPONENT)
4413 gfc_error ("Structure component '%s' at %L cannot be an "
4414 "EQUIVALENCE object",
4415 r->u.c.component->name, &e->where);
4424 /* This function is called after a complete program unit has been compiled.
4425 Its purpose is to examine all of the expressions associated with a program
4426 unit, assign types to all intermediate expressions, make sure that all
4427 assignments are to compatible types and figure out which names refer to
4428 which functions or subroutines. */
4431 gfc_resolve (gfc_namespace * ns)
4433 gfc_namespace *old_ns, *n;
4438 old_ns = gfc_current_ns;
4439 gfc_current_ns = ns;
4441 resolve_contained_functions (ns);
4443 gfc_traverse_ns (ns, resolve_symbol);
4445 for (n = ns->contained; n; n = n->sibling)
4447 if (gfc_pure (ns->proc_name) && !gfc_pure (n->proc_name))
4448 gfc_error ("Contained procedure '%s' at %L of a PURE procedure must "
4449 "also be PURE", n->proc_name->name,
4450 &n->proc_name->declared_at);
4456 gfc_check_interfaces (ns);
4458 for (cl = ns->cl_list; cl; cl = cl->next)
4460 if (cl->length == NULL || gfc_resolve_expr (cl->length) == FAILURE)
4463 if (cl->length->ts.type != BT_INTEGER)
4465 ("Character length specification at %L must be of type INTEGER",
4466 &cl->length->where);
4469 gfc_traverse_ns (ns, resolve_values);
4475 for (d = ns->data; d; d = d->next)
4479 gfc_traverse_ns (ns, gfc_formalize_init_value);
4481 for (eq = ns->equiv; eq; eq = eq->next)
4482 resolve_equivalence (eq);
4485 resolve_code (ns->code, ns);
4487 /* Warn about unused labels. */
4488 if (gfc_option.warn_unused_labels)
4489 warn_unused_label (ns);
4491 gfc_current_ns = old_ns;