1 /* Perform type resolution on the various stuctures.
2 Copyright (C) 2001, 2002, 2003, 2004, 2005, 2006 Free Software Foundation,
4 Contributed by Andy Vaught
6 This file is part of GCC.
8 GCC is free software; you can redistribute it and/or modify it under
9 the terms of the GNU General Public License as published by the Free
10 Software Foundation; either version 2, or (at your option) any later
13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
14 WARRANTY; without even the implied warranty of MERCHANTABILITY or
15 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
18 You should have received a copy of the GNU General Public License
19 along with GCC; see the file COPYING. If not, write to the Free
20 Software Foundation, 51 Franklin Street, Fifth Floor,Boston, MA
28 #include "arith.h" /* For gfc_compare_expr(). */
29 #include "dependency.h"
31 /* Types used in equivalence statements. */
35 SEQ_NONDEFAULT, SEQ_NUMERIC, SEQ_CHARACTER, SEQ_MIXED
39 /* Stack to push the current if we descend into a block during
40 resolution. See resolve_branch() and resolve_code(). */
42 typedef struct code_stack
44 struct gfc_code *head, *current;
45 struct code_stack *prev;
49 static code_stack *cs_base = NULL;
52 /* Nonzero if we're inside a FORALL block. */
54 static int forall_flag;
56 /* Nonzero if we're inside a OpenMP WORKSHARE or PARALLEL WORKSHARE block. */
58 static int omp_workshare_flag;
60 /* Nonzero if we are processing a formal arglist. The corresponding function
61 resets the flag each time that it is read. */
62 static int formal_arg_flag = 0;
64 /* True if we are resolving a specification expression. */
65 static int specification_expr = 0;
67 /* The id of the last entry seen. */
68 static int current_entry_id;
71 gfc_is_formal_arg (void)
73 return formal_arg_flag;
76 /* Resolve types of formal argument lists. These have to be done early so that
77 the formal argument lists of module procedures can be copied to the
78 containing module before the individual procedures are resolved
79 individually. We also resolve argument lists of procedures in interface
80 blocks because they are self-contained scoping units.
82 Since a dummy argument cannot be a non-dummy procedure, the only
83 resort left for untyped names are the IMPLICIT types. */
86 resolve_formal_arglist (gfc_symbol * proc)
88 gfc_formal_arglist *f;
92 if (proc->result != NULL)
97 if (gfc_elemental (proc)
98 || sym->attr.pointer || sym->attr.allocatable
99 || (sym->as && sym->as->rank > 0))
100 proc->attr.always_explicit = 1;
104 for (f = proc->formal; f; f = f->next)
110 /* Alternate return placeholder. */
111 if (gfc_elemental (proc))
112 gfc_error ("Alternate return specifier in elemental subroutine "
113 "'%s' at %L is not allowed", proc->name,
115 if (proc->attr.function)
116 gfc_error ("Alternate return specifier in function "
117 "'%s' at %L is not allowed", proc->name,
122 if (sym->attr.if_source != IFSRC_UNKNOWN)
123 resolve_formal_arglist (sym);
125 if (sym->attr.subroutine || sym->attr.external || sym->attr.intrinsic)
127 if (gfc_pure (proc) && !gfc_pure (sym))
130 ("Dummy procedure '%s' of PURE procedure at %L must also "
131 "be PURE", sym->name, &sym->declared_at);
135 if (gfc_elemental (proc))
138 ("Dummy procedure at %L not allowed in ELEMENTAL procedure",
146 if (sym->ts.type == BT_UNKNOWN)
148 if (!sym->attr.function || sym->result == sym)
149 gfc_set_default_type (sym, 1, sym->ns);
152 gfc_resolve_array_spec (sym->as, 0);
154 /* We can't tell if an array with dimension (:) is assumed or deferred
155 shape until we know if it has the pointer or allocatable attributes.
157 if (sym->as && sym->as->rank > 0 && sym->as->type == AS_DEFERRED
158 && !(sym->attr.pointer || sym->attr.allocatable))
160 sym->as->type = AS_ASSUMED_SHAPE;
161 for (i = 0; i < sym->as->rank; i++)
162 sym->as->lower[i] = gfc_int_expr (1);
165 if ((sym->as && sym->as->rank > 0 && sym->as->type == AS_ASSUMED_SHAPE)
166 || sym->attr.pointer || sym->attr.allocatable || sym->attr.target
167 || sym->attr.optional)
168 proc->attr.always_explicit = 1;
170 /* If the flavor is unknown at this point, it has to be a variable.
171 A procedure specification would have already set the type. */
173 if (sym->attr.flavor == FL_UNKNOWN)
174 gfc_add_flavor (&sym->attr, FL_VARIABLE, sym->name, &sym->declared_at);
178 if (proc->attr.function && !sym->attr.pointer
179 && sym->attr.flavor != FL_PROCEDURE
180 && sym->attr.intent != INTENT_IN)
182 gfc_error ("Argument '%s' of pure function '%s' at %L must be "
183 "INTENT(IN)", sym->name, proc->name,
186 if (proc->attr.subroutine && !sym->attr.pointer
187 && sym->attr.intent == INTENT_UNKNOWN)
190 ("Argument '%s' of pure subroutine '%s' at %L must have "
191 "its INTENT specified", sym->name, proc->name,
196 if (gfc_elemental (proc))
201 ("Argument '%s' of elemental procedure at %L must be scalar",
202 sym->name, &sym->declared_at);
206 if (sym->attr.pointer)
209 ("Argument '%s' of elemental procedure at %L cannot have "
210 "the POINTER attribute", sym->name, &sym->declared_at);
215 /* Each dummy shall be specified to be scalar. */
216 if (proc->attr.proc == PROC_ST_FUNCTION)
221 ("Argument '%s' of statement function at %L must be scalar",
222 sym->name, &sym->declared_at);
226 if (sym->ts.type == BT_CHARACTER)
228 gfc_charlen *cl = sym->ts.cl;
229 if (!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT)
232 ("Character-valued argument '%s' of statement function at "
233 "%L must have constant length",
234 sym->name, &sym->declared_at);
244 /* Work function called when searching for symbols that have argument lists
245 associated with them. */
248 find_arglists (gfc_symbol * sym)
251 if (sym->attr.if_source == IFSRC_UNKNOWN || sym->ns != gfc_current_ns)
254 resolve_formal_arglist (sym);
258 /* Given a namespace, resolve all formal argument lists within the namespace.
262 resolve_formal_arglists (gfc_namespace * ns)
268 gfc_traverse_ns (ns, find_arglists);
273 resolve_contained_fntype (gfc_symbol * sym, gfc_namespace * ns)
277 /* If this namespace is not a function, ignore it. */
279 || !(sym->attr.function
280 || sym->attr.flavor == FL_VARIABLE))
283 /* Try to find out of what the return type is. */
284 if (sym->result != NULL)
287 if (sym->ts.type == BT_UNKNOWN)
289 t = gfc_set_default_type (sym, 0, ns);
291 if (t == FAILURE && !sym->attr.untyped)
293 gfc_error ("Contained function '%s' at %L has no IMPLICIT type",
294 sym->name, &sym->declared_at); /* FIXME */
295 sym->attr.untyped = 1;
299 /*Fortran 95 Draft Standard, page 51, Section 5.1.1.5, on the Character type,
300 lists the only ways a character length value of * can be used: dummy arguments
301 of procedures, named constants, and function results in external functions.
302 Internal function results are not on that list; ergo, not permitted. */
304 if (sym->ts.type == BT_CHARACTER)
306 gfc_charlen *cl = sym->ts.cl;
307 if (!cl || !cl->length)
308 gfc_error ("Character-valued internal function '%s' at %L must "
309 "not be assumed length", sym->name, &sym->declared_at);
314 /* Add NEW_ARGS to the formal argument list of PROC, taking care not to
315 introduce duplicates. */
318 merge_argument_lists (gfc_symbol *proc, gfc_formal_arglist *new_args)
320 gfc_formal_arglist *f, *new_arglist;
323 for (; new_args != NULL; new_args = new_args->next)
325 new_sym = new_args->sym;
326 /* See if this arg is already in the formal argument list. */
327 for (f = proc->formal; f; f = f->next)
329 if (new_sym == f->sym)
336 /* Add a new argument. Argument order is not important. */
337 new_arglist = gfc_get_formal_arglist ();
338 new_arglist->sym = new_sym;
339 new_arglist->next = proc->formal;
340 proc->formal = new_arglist;
345 /* Resolve alternate entry points. If a symbol has multiple entry points we
346 create a new master symbol for the main routine, and turn the existing
347 symbol into an entry point. */
350 resolve_entries (gfc_namespace * ns)
352 gfc_namespace *old_ns;
356 char name[GFC_MAX_SYMBOL_LEN + 1];
357 static int master_count = 0;
359 if (ns->proc_name == NULL)
362 /* No need to do anything if this procedure doesn't have alternate entry
367 /* We may already have resolved alternate entry points. */
368 if (ns->proc_name->attr.entry_master)
371 /* If this isn't a procedure something has gone horribly wrong. */
372 gcc_assert (ns->proc_name->attr.flavor == FL_PROCEDURE);
374 /* Remember the current namespace. */
375 old_ns = gfc_current_ns;
379 /* Add the main entry point to the list of entry points. */
380 el = gfc_get_entry_list ();
381 el->sym = ns->proc_name;
383 el->next = ns->entries;
385 ns->proc_name->attr.entry = 1;
387 /* If it is a module function, it needs to be in the right namespace
388 so that gfc_get_fake_result_decl can gather up the results. The
389 need for this arose in get_proc_name, where these beasts were
390 left in their own namespace, to keep prior references linked to
391 the entry declaration.*/
392 if (ns->proc_name->attr.function
394 && ns->parent->proc_name->attr.flavor == FL_MODULE)
397 /* Add an entry statement for it. */
404 /* Create a new symbol for the master function. */
405 /* Give the internal function a unique name (within this file).
406 Also include the function name so the user has some hope of figuring
407 out what is going on. */
408 snprintf (name, GFC_MAX_SYMBOL_LEN, "master.%d.%s",
409 master_count++, ns->proc_name->name);
410 gfc_get_ha_symbol (name, &proc);
411 gcc_assert (proc != NULL);
413 gfc_add_procedure (&proc->attr, PROC_INTERNAL, proc->name, NULL);
414 if (ns->proc_name->attr.subroutine)
415 gfc_add_subroutine (&proc->attr, proc->name, NULL);
419 gfc_typespec *ts, *fts;
420 gfc_array_spec *as, *fas;
421 gfc_add_function (&proc->attr, proc->name, NULL);
423 fas = ns->entries->sym->as;
424 fas = fas ? fas : ns->entries->sym->result->as;
425 fts = &ns->entries->sym->result->ts;
426 if (fts->type == BT_UNKNOWN)
427 fts = gfc_get_default_type (ns->entries->sym->result, NULL);
428 for (el = ns->entries->next; el; el = el->next)
430 ts = &el->sym->result->ts;
432 as = as ? as : el->sym->result->as;
433 if (ts->type == BT_UNKNOWN)
434 ts = gfc_get_default_type (el->sym->result, NULL);
436 if (! gfc_compare_types (ts, fts)
437 || (el->sym->result->attr.dimension
438 != ns->entries->sym->result->attr.dimension)
439 || (el->sym->result->attr.pointer
440 != ns->entries->sym->result->attr.pointer))
443 else if (as && fas && gfc_compare_array_spec (as, fas) == 0)
444 gfc_error ("Procedure %s at %L has entries with mismatched "
445 "array specifications", ns->entries->sym->name,
446 &ns->entries->sym->declared_at);
451 sym = ns->entries->sym->result;
452 /* All result types the same. */
454 if (sym->attr.dimension)
455 gfc_set_array_spec (proc, gfc_copy_array_spec (sym->as), NULL);
456 if (sym->attr.pointer)
457 gfc_add_pointer (&proc->attr, NULL);
461 /* Otherwise the result will be passed through a union by
463 proc->attr.mixed_entry_master = 1;
464 for (el = ns->entries; el; el = el->next)
466 sym = el->sym->result;
467 if (sym->attr.dimension)
469 if (el == ns->entries)
471 ("FUNCTION result %s can't be an array in FUNCTION %s at %L",
472 sym->name, ns->entries->sym->name, &sym->declared_at);
475 ("ENTRY result %s can't be an array in FUNCTION %s at %L",
476 sym->name, ns->entries->sym->name, &sym->declared_at);
478 else if (sym->attr.pointer)
480 if (el == ns->entries)
482 ("FUNCTION result %s can't be a POINTER in FUNCTION %s at %L",
483 sym->name, ns->entries->sym->name, &sym->declared_at);
486 ("ENTRY result %s can't be a POINTER in FUNCTION %s at %L",
487 sym->name, ns->entries->sym->name, &sym->declared_at);
492 if (ts->type == BT_UNKNOWN)
493 ts = gfc_get_default_type (sym, NULL);
497 if (ts->kind == gfc_default_integer_kind)
501 if (ts->kind == gfc_default_real_kind
502 || ts->kind == gfc_default_double_kind)
506 if (ts->kind == gfc_default_complex_kind)
510 if (ts->kind == gfc_default_logical_kind)
514 /* We will issue error elsewhere. */
522 if (el == ns->entries)
524 ("FUNCTION result %s can't be of type %s in FUNCTION %s at %L",
525 sym->name, gfc_typename (ts), ns->entries->sym->name,
529 ("ENTRY result %s can't be of type %s in FUNCTION %s at %L",
530 sym->name, gfc_typename (ts), ns->entries->sym->name,
537 proc->attr.access = ACCESS_PRIVATE;
538 proc->attr.entry_master = 1;
540 /* Merge all the entry point arguments. */
541 for (el = ns->entries; el; el = el->next)
542 merge_argument_lists (proc, el->sym->formal);
544 /* Use the master function for the function body. */
545 ns->proc_name = proc;
547 /* Finalize the new symbols. */
548 gfc_commit_symbols ();
550 /* Restore the original namespace. */
551 gfc_current_ns = old_ns;
555 /* Resolve contained function types. Because contained functions can call one
556 another, they have to be worked out before any of the contained procedures
559 The good news is that if a function doesn't already have a type, the only
560 way it can get one is through an IMPLICIT type or a RESULT variable, because
561 by definition contained functions are contained namespace they're contained
562 in, not in a sibling or parent namespace. */
565 resolve_contained_functions (gfc_namespace * ns)
567 gfc_namespace *child;
570 resolve_formal_arglists (ns);
572 for (child = ns->contained; child; child = child->sibling)
574 /* Resolve alternate entry points first. */
575 resolve_entries (child);
577 /* Then check function return types. */
578 resolve_contained_fntype (child->proc_name, child);
579 for (el = child->entries; el; el = el->next)
580 resolve_contained_fntype (el->sym, child);
585 /* Resolve all of the elements of a structure constructor and make sure that
586 the types are correct. */
589 resolve_structure_cons (gfc_expr * expr)
591 gfc_constructor *cons;
597 cons = expr->value.constructor;
598 /* A constructor may have references if it is the result of substituting a
599 parameter variable. In this case we just pull out the component we
602 comp = expr->ref->u.c.sym->components;
604 comp = expr->ts.derived->components;
606 for (; comp; comp = comp->next, cons = cons->next)
611 if (gfc_resolve_expr (cons->expr) == FAILURE)
617 if (cons->expr->expr_type != EXPR_NULL
618 && comp->as && comp->as->rank != cons->expr->rank
619 && (comp->allocatable || cons->expr->rank))
621 gfc_error ("The rank of the element in the derived type "
622 "constructor at %L does not match that of the "
623 "component (%d/%d)", &cons->expr->where,
624 cons->expr->rank, comp->as ? comp->as->rank : 0);
628 /* If we don't have the right type, try to convert it. */
630 if (!gfc_compare_types (&cons->expr->ts, &comp->ts))
633 if (comp->pointer && cons->expr->ts.type != BT_UNKNOWN)
634 gfc_error ("The element in the derived type constructor at %L, "
635 "for pointer component '%s', is %s but should be %s",
636 &cons->expr->where, comp->name,
637 gfc_basic_typename (cons->expr->ts.type),
638 gfc_basic_typename (comp->ts.type));
640 t = gfc_convert_type (cons->expr, &comp->ts, 1);
643 if (!comp->pointer || cons->expr->expr_type == EXPR_NULL)
646 a = gfc_expr_attr (cons->expr);
648 if (!a.pointer && !a.target)
651 gfc_error ("The element in the derived type constructor at %L, "
652 "for pointer component '%s' should be a POINTER or "
653 "a TARGET", &cons->expr->where, comp->name);
662 /****************** Expression name resolution ******************/
664 /* Returns 0 if a symbol was not declared with a type or
665 attribute declaration statement, nonzero otherwise. */
668 was_declared (gfc_symbol * sym)
674 if (!a.implicit_type && sym->ts.type != BT_UNKNOWN)
677 if (a.allocatable || a.dimension || a.dummy || a.external || a.intrinsic
678 || a.optional || a.pointer || a.save || a.target || a.volatile_ || a.value
679 || a.access != ACCESS_UNKNOWN || a.intent != INTENT_UNKNOWN)
686 /* Determine if a symbol is generic or not. */
689 generic_sym (gfc_symbol * sym)
693 if (sym->attr.generic ||
694 (sym->attr.intrinsic && gfc_generic_intrinsic (sym->name)))
697 if (was_declared (sym) || sym->ns->parent == NULL)
700 gfc_find_symbol (sym->name, sym->ns->parent, 1, &s);
702 return (s == NULL) ? 0 : generic_sym (s);
706 /* Determine if a symbol is specific or not. */
709 specific_sym (gfc_symbol * sym)
713 if (sym->attr.if_source == IFSRC_IFBODY
714 || sym->attr.proc == PROC_MODULE
715 || sym->attr.proc == PROC_INTERNAL
716 || sym->attr.proc == PROC_ST_FUNCTION
717 || (sym->attr.intrinsic &&
718 gfc_specific_intrinsic (sym->name))
719 || sym->attr.external)
722 if (was_declared (sym) || sym->ns->parent == NULL)
725 gfc_find_symbol (sym->name, sym->ns->parent, 1, &s);
727 return (s == NULL) ? 0 : specific_sym (s);
731 /* Figure out if the procedure is specific, generic or unknown. */
734 { PTYPE_GENERIC = 1, PTYPE_SPECIFIC, PTYPE_UNKNOWN }
738 procedure_kind (gfc_symbol * sym)
741 if (generic_sym (sym))
742 return PTYPE_GENERIC;
744 if (specific_sym (sym))
745 return PTYPE_SPECIFIC;
747 return PTYPE_UNKNOWN;
750 /* Check references to assumed size arrays. The flag need_full_assumed_size
751 is nonzero when matching actual arguments. */
753 static int need_full_assumed_size = 0;
756 check_assumed_size_reference (gfc_symbol * sym, gfc_expr * e)
762 if (need_full_assumed_size
763 || !(sym->as && sym->as->type == AS_ASSUMED_SIZE))
766 for (ref = e->ref; ref; ref = ref->next)
767 if (ref->type == REF_ARRAY)
768 for (dim = 0; dim < ref->u.ar.as->rank; dim++)
769 last = (ref->u.ar.end[dim] == NULL) && (ref->u.ar.type == DIMEN_ELEMENT);
773 gfc_error ("The upper bound in the last dimension must "
774 "appear in the reference to the assumed size "
775 "array '%s' at %L", sym->name, &e->where);
782 /* Look for bad assumed size array references in argument expressions
783 of elemental and array valued intrinsic procedures. Since this is
784 called from procedure resolution functions, it only recurses at
788 resolve_assumed_size_actual (gfc_expr *e)
793 switch (e->expr_type)
797 && check_assumed_size_reference (e->symtree->n.sym, e))
802 if (resolve_assumed_size_actual (e->value.op.op1)
803 || resolve_assumed_size_actual (e->value.op.op2))
814 /* Resolve an actual argument list. Most of the time, this is just
815 resolving the expressions in the list.
816 The exception is that we sometimes have to decide whether arguments
817 that look like procedure arguments are really simple variable
821 resolve_actual_arglist (gfc_actual_arglist * arg)
824 gfc_symtree *parent_st;
827 for (; arg; arg = arg->next)
833 /* Check the label is a valid branching target. */
836 if (arg->label->defined == ST_LABEL_UNKNOWN)
838 gfc_error ("Label %d referenced at %L is never defined",
839 arg->label->value, &arg->label->where);
846 if (e->ts.type != BT_PROCEDURE)
848 if (gfc_resolve_expr (e) != SUCCESS)
853 /* See if the expression node should really be a variable
856 sym = e->symtree->n.sym;
858 if (sym->attr.flavor == FL_PROCEDURE
859 || sym->attr.intrinsic
860 || sym->attr.external)
864 /* If a procedure is not already determined to be something else
865 check if it is intrinsic. */
866 if (!sym->attr.intrinsic
867 && !(sym->attr.external || sym->attr.use_assoc
868 || sym->attr.if_source == IFSRC_IFBODY)
869 && gfc_intrinsic_name (sym->name, sym->attr.subroutine))
870 sym->attr.intrinsic = 1;
872 if (sym->attr.proc == PROC_ST_FUNCTION)
874 gfc_error ("Statement function '%s' at %L is not allowed as an "
875 "actual argument", sym->name, &e->where);
878 actual_ok = gfc_intrinsic_actual_ok (sym->name, sym->attr.subroutine);
879 if (sym->attr.intrinsic && actual_ok == 0)
881 gfc_error ("Intrinsic '%s' at %L is not allowed as an "
882 "actual argument", sym->name, &e->where);
885 if (sym->attr.contained && !sym->attr.use_assoc
886 && sym->ns->proc_name->attr.flavor != FL_MODULE)
888 gfc_error ("Internal procedure '%s' is not allowed as an "
889 "actual argument at %L", sym->name, &e->where);
892 if (sym->attr.elemental && !sym->attr.intrinsic)
894 gfc_error ("ELEMENTAL non-INTRINSIC procedure '%s' is not "
895 "allowed as an actual argument at %L", sym->name,
899 if (sym->attr.generic)
901 gfc_error ("GENERIC non-INTRINSIC procedure '%s' is not "
902 "allowed as an actual argument at %L", sym->name,
906 /* If the symbol is the function that names the current (or
907 parent) scope, then we really have a variable reference. */
909 if (sym->attr.function && sym->result == sym
910 && (sym->ns->proc_name == sym
911 || (sym->ns->parent != NULL
912 && sym->ns->parent->proc_name == sym)))
918 /* See if the name is a module procedure in a parent unit. */
920 if (was_declared (sym) || sym->ns->parent == NULL)
923 if (gfc_find_sym_tree (sym->name, sym->ns->parent, 1, &parent_st))
925 gfc_error ("Symbol '%s' at %L is ambiguous", sym->name, &e->where);
929 if (parent_st == NULL)
932 sym = parent_st->n.sym;
933 e->symtree = parent_st; /* Point to the right thing. */
935 if (sym->attr.flavor == FL_PROCEDURE
936 || sym->attr.intrinsic
937 || sym->attr.external)
943 e->expr_type = EXPR_VARIABLE;
947 e->rank = sym->as->rank;
948 e->ref = gfc_get_ref ();
949 e->ref->type = REF_ARRAY;
950 e->ref->u.ar.type = AR_FULL;
951 e->ref->u.ar.as = sym->as;
959 /* Do the checks of the actual argument list that are specific to elemental
960 procedures. If called with c == NULL, we have a function, otherwise if
961 expr == NULL, we have a subroutine. */
963 resolve_elemental_actual (gfc_expr *expr, gfc_code *c)
965 gfc_actual_arglist *arg0;
966 gfc_actual_arglist *arg;
967 gfc_symbol *esym = NULL;
968 gfc_intrinsic_sym *isym = NULL;
970 gfc_intrinsic_arg *iformal = NULL;
971 gfc_formal_arglist *eformal = NULL;
972 bool formal_optional = false;
973 bool set_by_optional = false;
977 /* Is this an elemental procedure? */
978 if (expr && expr->value.function.actual != NULL)
980 if (expr->value.function.esym != NULL
981 && expr->value.function.esym->attr.elemental)
983 arg0 = expr->value.function.actual;
984 esym = expr->value.function.esym;
986 else if (expr->value.function.isym != NULL
987 && expr->value.function.isym->elemental)
989 arg0 = expr->value.function.actual;
990 isym = expr->value.function.isym;
995 else if (c && c->ext.actual != NULL
996 && c->symtree->n.sym->attr.elemental)
998 arg0 = c->ext.actual;
999 esym = c->symtree->n.sym;
1004 /* The rank of an elemental is the rank of its array argument(s). */
1005 for (arg = arg0; arg; arg = arg->next)
1007 if (arg->expr != NULL && arg->expr->rank > 0)
1009 rank = arg->expr->rank;
1010 if (arg->expr->expr_type == EXPR_VARIABLE
1011 && arg->expr->symtree->n.sym->attr.optional)
1012 set_by_optional = true;
1014 /* Function specific; set the result rank and shape. */
1018 if (!expr->shape && arg->expr->shape)
1020 expr->shape = gfc_get_shape (rank);
1021 for (i = 0; i < rank; i++)
1022 mpz_init_set (expr->shape[i], arg->expr->shape[i]);
1029 /* If it is an array, it shall not be supplied as an actual argument
1030 to an elemental procedure unless an array of the same rank is supplied
1031 as an actual argument corresponding to a nonoptional dummy argument of
1032 that elemental procedure(12.4.1.5). */
1033 formal_optional = false;
1035 iformal = isym->formal;
1037 eformal = esym->formal;
1039 for (arg = arg0; arg; arg = arg->next)
1043 if (eformal->sym && eformal->sym->attr.optional)
1044 formal_optional = true;
1045 eformal = eformal->next;
1047 else if (isym && iformal)
1049 if (iformal->optional)
1050 formal_optional = true;
1051 iformal = iformal->next;
1054 formal_optional = true;
1056 if (pedantic && arg->expr != NULL
1057 && arg->expr->expr_type == EXPR_VARIABLE
1058 && arg->expr->symtree->n.sym->attr.optional
1061 && (set_by_optional || arg->expr->rank != rank)
1062 && !(isym && isym->generic_id == GFC_ISYM_CONVERSION))
1064 gfc_warning ("'%s' at %L is an array and OPTIONAL; IF IT IS "
1065 "MISSING, it cannot be the actual argument of an "
1066 "ELEMENTAL procedure unless there is a non-optional"
1067 "argument with the same rank (12.4.1.5)",
1068 arg->expr->symtree->n.sym->name, &arg->expr->where);
1073 for (arg = arg0; arg; arg = arg->next)
1075 if (arg->expr == NULL || arg->expr->rank == 0)
1078 /* Being elemental, the last upper bound of an assumed size array
1079 argument must be present. */
1080 if (resolve_assumed_size_actual (arg->expr))
1086 /* Elemental subroutine array actual arguments must conform. */
1089 if (gfc_check_conformance ("elemental subroutine", arg->expr, e)
1101 /* Go through each actual argument in ACTUAL and see if it can be
1102 implemented as an inlined, non-copying intrinsic. FNSYM is the
1103 function being called, or NULL if not known. */
1106 find_noncopying_intrinsics (gfc_symbol * fnsym, gfc_actual_arglist * actual)
1108 gfc_actual_arglist *ap;
1111 for (ap = actual; ap; ap = ap->next)
1113 && (expr = gfc_get_noncopying_intrinsic_argument (ap->expr))
1114 && !gfc_check_fncall_dependency (expr, INTENT_IN, fnsym, actual))
1115 ap->expr->inline_noncopying_intrinsic = 1;
1118 /* This function does the checking of references to global procedures
1119 as defined in sections 18.1 and 14.1, respectively, of the Fortran
1120 77 and 95 standards. It checks for a gsymbol for the name, making
1121 one if it does not already exist. If it already exists, then the
1122 reference being resolved must correspond to the type of gsymbol.
1123 Otherwise, the new symbol is equipped with the attributes of the
1124 reference. The corresponding code that is called in creating
1125 global entities is parse.c. */
1128 resolve_global_procedure (gfc_symbol *sym, locus *where, int sub)
1133 type = sub ? GSYM_SUBROUTINE : GSYM_FUNCTION;
1135 gsym = gfc_get_gsymbol (sym->name);
1137 if ((gsym->type != GSYM_UNKNOWN && gsym->type != type))
1138 global_used (gsym, where);
1140 if (gsym->type == GSYM_UNKNOWN)
1143 gsym->where = *where;
1149 /************* Function resolution *************/
1151 /* Resolve a function call known to be generic.
1152 Section 14.1.2.4.1. */
1155 resolve_generic_f0 (gfc_expr * expr, gfc_symbol * sym)
1159 if (sym->attr.generic)
1162 gfc_search_interface (sym->generic, 0, &expr->value.function.actual);
1165 expr->value.function.name = s->name;
1166 expr->value.function.esym = s;
1168 if (s->ts.type != BT_UNKNOWN)
1170 else if (s->result != NULL && s->result->ts.type != BT_UNKNOWN)
1171 expr->ts = s->result->ts;
1174 expr->rank = s->as->rank;
1175 else if (s->result != NULL && s->result->as != NULL)
1176 expr->rank = s->result->as->rank;
1181 /* TODO: Need to search for elemental references in generic interface */
1184 if (sym->attr.intrinsic)
1185 return gfc_intrinsic_func_interface (expr, 0);
1192 resolve_generic_f (gfc_expr * expr)
1197 sym = expr->symtree->n.sym;
1201 m = resolve_generic_f0 (expr, sym);
1204 else if (m == MATCH_ERROR)
1208 if (sym->ns->parent == NULL)
1210 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
1214 if (!generic_sym (sym))
1218 /* Last ditch attempt. */
1220 if (!gfc_generic_intrinsic (expr->symtree->n.sym->name))
1222 gfc_error ("There is no specific function for the generic '%s' at %L",
1223 expr->symtree->n.sym->name, &expr->where);
1227 m = gfc_intrinsic_func_interface (expr, 0);
1232 ("Generic function '%s' at %L is not consistent with a specific "
1233 "intrinsic interface", expr->symtree->n.sym->name, &expr->where);
1239 /* Resolve a function call known to be specific. */
1242 resolve_specific_f0 (gfc_symbol * sym, gfc_expr * expr)
1246 if (sym->attr.external || sym->attr.if_source == IFSRC_IFBODY)
1248 if (sym->attr.dummy)
1250 sym->attr.proc = PROC_DUMMY;
1254 sym->attr.proc = PROC_EXTERNAL;
1258 if (sym->attr.proc == PROC_MODULE
1259 || sym->attr.proc == PROC_ST_FUNCTION
1260 || sym->attr.proc == PROC_INTERNAL)
1263 if (sym->attr.intrinsic)
1265 m = gfc_intrinsic_func_interface (expr, 1);
1270 ("Function '%s' at %L is INTRINSIC but is not compatible with "
1271 "an intrinsic", sym->name, &expr->where);
1279 gfc_procedure_use (sym, &expr->value.function.actual, &expr->where);
1282 expr->value.function.name = sym->name;
1283 expr->value.function.esym = sym;
1284 if (sym->as != NULL)
1285 expr->rank = sym->as->rank;
1292 resolve_specific_f (gfc_expr * expr)
1297 sym = expr->symtree->n.sym;
1301 m = resolve_specific_f0 (sym, expr);
1304 if (m == MATCH_ERROR)
1307 if (sym->ns->parent == NULL)
1310 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
1316 gfc_error ("Unable to resolve the specific function '%s' at %L",
1317 expr->symtree->n.sym->name, &expr->where);
1323 /* Resolve a procedure call not known to be generic nor specific. */
1326 resolve_unknown_f (gfc_expr * expr)
1331 sym = expr->symtree->n.sym;
1333 if (sym->attr.dummy)
1335 sym->attr.proc = PROC_DUMMY;
1336 expr->value.function.name = sym->name;
1340 /* See if we have an intrinsic function reference. */
1342 if (gfc_intrinsic_name (sym->name, 0))
1344 if (gfc_intrinsic_func_interface (expr, 1) == MATCH_YES)
1349 /* The reference is to an external name. */
1351 sym->attr.proc = PROC_EXTERNAL;
1352 expr->value.function.name = sym->name;
1353 expr->value.function.esym = expr->symtree->n.sym;
1355 if (sym->as != NULL)
1356 expr->rank = sym->as->rank;
1358 /* Type of the expression is either the type of the symbol or the
1359 default type of the symbol. */
1362 gfc_procedure_use (sym, &expr->value.function.actual, &expr->where);
1364 if (sym->ts.type != BT_UNKNOWN)
1368 ts = gfc_get_default_type (sym, sym->ns);
1370 if (ts->type == BT_UNKNOWN)
1372 gfc_error ("Function '%s' at %L has no IMPLICIT type",
1373 sym->name, &expr->where);
1384 /* Figure out if a function reference is pure or not. Also set the name
1385 of the function for a potential error message. Return nonzero if the
1386 function is PURE, zero if not. */
1389 pure_function (gfc_expr * e, const char **name)
1393 if (e->value.function.esym)
1395 pure = gfc_pure (e->value.function.esym);
1396 *name = e->value.function.esym->name;
1398 else if (e->value.function.isym)
1400 pure = e->value.function.isym->pure
1401 || e->value.function.isym->elemental;
1402 *name = e->value.function.isym->name;
1406 /* Implicit functions are not pure. */
1408 *name = e->value.function.name;
1415 /* Resolve a function call, which means resolving the arguments, then figuring
1416 out which entity the name refers to. */
1417 /* TODO: Check procedure arguments so that an INTENT(IN) isn't passed
1418 to INTENT(OUT) or INTENT(INOUT). */
1421 resolve_function (gfc_expr * expr)
1423 gfc_actual_arglist *arg;
1431 sym = expr->symtree->n.sym;
1433 /* If the procedure is not internal, a statement function or a module
1434 procedure,it must be external and should be checked for usage. */
1435 if (sym && !sym->attr.dummy && !sym->attr.contained
1436 && sym->attr.proc != PROC_ST_FUNCTION
1437 && !sym->attr.use_assoc)
1438 resolve_global_procedure (sym, &expr->where, 0);
1440 /* Switch off assumed size checking and do this again for certain kinds
1441 of procedure, once the procedure itself is resolved. */
1442 need_full_assumed_size++;
1444 if (resolve_actual_arglist (expr->value.function.actual) == FAILURE)
1447 /* Resume assumed_size checking. */
1448 need_full_assumed_size--;
1450 if (sym && sym->ts.type == BT_CHARACTER
1452 && sym->ts.cl->length == NULL
1454 && expr->value.function.esym == NULL
1455 && !sym->attr.contained)
1457 /* Internal procedures are taken care of in resolve_contained_fntype. */
1458 gfc_error ("Function '%s' is declared CHARACTER(*) and cannot "
1459 "be used at %L since it is not a dummy argument",
1460 sym->name, &expr->where);
1464 /* See if function is already resolved. */
1466 if (expr->value.function.name != NULL)
1468 if (expr->ts.type == BT_UNKNOWN)
1474 /* Apply the rules of section 14.1.2. */
1476 switch (procedure_kind (sym))
1479 t = resolve_generic_f (expr);
1482 case PTYPE_SPECIFIC:
1483 t = resolve_specific_f (expr);
1487 t = resolve_unknown_f (expr);
1491 gfc_internal_error ("resolve_function(): bad function type");
1495 /* If the expression is still a function (it might have simplified),
1496 then we check to see if we are calling an elemental function. */
1498 if (expr->expr_type != EXPR_FUNCTION)
1501 temp = need_full_assumed_size;
1502 need_full_assumed_size = 0;
1504 if (resolve_elemental_actual (expr, NULL) == FAILURE)
1507 if (omp_workshare_flag
1508 && expr->value.function.esym
1509 && ! gfc_elemental (expr->value.function.esym))
1511 gfc_error ("User defined non-ELEMENTAL function '%s' at %L not allowed"
1512 " in WORKSHARE construct", expr->value.function.esym->name,
1517 else if (expr->value.function.actual != NULL
1518 && expr->value.function.isym != NULL
1519 && expr->value.function.isym->generic_id != GFC_ISYM_LBOUND
1520 && expr->value.function.isym->generic_id != GFC_ISYM_LOC
1521 && expr->value.function.isym->generic_id != GFC_ISYM_PRESENT)
1523 /* Array intrinsics must also have the last upper bound of an
1524 assumed size array argument. UBOUND and SIZE have to be
1525 excluded from the check if the second argument is anything
1528 inquiry = expr->value.function.isym->generic_id == GFC_ISYM_UBOUND
1529 || expr->value.function.isym->generic_id == GFC_ISYM_SIZE;
1531 for (arg = expr->value.function.actual; arg; arg = arg->next)
1533 if (inquiry && arg->next != NULL && arg->next->expr
1534 && arg->next->expr->expr_type != EXPR_CONSTANT)
1537 if (arg->expr != NULL
1538 && arg->expr->rank > 0
1539 && resolve_assumed_size_actual (arg->expr))
1544 need_full_assumed_size = temp;
1546 if (!pure_function (expr, &name) && name)
1551 ("reference to non-PURE function '%s' at %L inside a "
1552 "FORALL %s", name, &expr->where, forall_flag == 2 ?
1556 else if (gfc_pure (NULL))
1558 gfc_error ("Function reference to '%s' at %L is to a non-PURE "
1559 "procedure within a PURE procedure", name, &expr->where);
1564 /* Functions without the RECURSIVE attribution are not allowed to
1565 * call themselves. */
1566 if (expr->value.function.esym && !expr->value.function.esym->attr.recursive)
1568 gfc_symbol *esym, *proc;
1569 esym = expr->value.function.esym;
1570 proc = gfc_current_ns->proc_name;
1573 gfc_error ("Function '%s' at %L cannot call itself, as it is not "
1574 "RECURSIVE", name, &expr->where);
1578 if (esym->attr.entry && esym->ns->entries && proc->ns->entries
1579 && esym->ns->entries->sym == proc->ns->entries->sym)
1581 gfc_error ("Call to ENTRY '%s' at %L is recursive, but function "
1582 "'%s' is not declared as RECURSIVE",
1583 esym->name, &expr->where, esym->ns->entries->sym->name);
1588 /* Character lengths of use associated functions may contains references to
1589 symbols not referenced from the current program unit otherwise. Make sure
1590 those symbols are marked as referenced. */
1592 if (expr->ts.type == BT_CHARACTER && expr->value.function.esym
1593 && expr->value.function.esym->attr.use_assoc)
1595 gfc_expr_set_symbols_referenced (expr->ts.cl->length);
1599 find_noncopying_intrinsics (expr->value.function.esym,
1600 expr->value.function.actual);
1605 /************* Subroutine resolution *************/
1608 pure_subroutine (gfc_code * c, gfc_symbol * sym)
1615 gfc_error ("Subroutine call to '%s' in FORALL block at %L is not PURE",
1616 sym->name, &c->loc);
1617 else if (gfc_pure (NULL))
1618 gfc_error ("Subroutine call to '%s' at %L is not PURE", sym->name,
1624 resolve_generic_s0 (gfc_code * c, gfc_symbol * sym)
1628 if (sym->attr.generic)
1630 s = gfc_search_interface (sym->generic, 1, &c->ext.actual);
1633 c->resolved_sym = s;
1634 pure_subroutine (c, s);
1638 /* TODO: Need to search for elemental references in generic interface. */
1641 if (sym->attr.intrinsic)
1642 return gfc_intrinsic_sub_interface (c, 0);
1649 resolve_generic_s (gfc_code * c)
1654 sym = c->symtree->n.sym;
1658 m = resolve_generic_s0 (c, sym);
1661 else if (m == MATCH_ERROR)
1665 if (sym->ns->parent == NULL)
1667 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
1671 if (!generic_sym (sym))
1675 /* Last ditch attempt. */
1676 sym = c->symtree->n.sym;
1677 if (!gfc_generic_intrinsic (sym->name))
1680 ("There is no specific subroutine for the generic '%s' at %L",
1681 sym->name, &c->loc);
1685 m = gfc_intrinsic_sub_interface (c, 0);
1689 gfc_error ("Generic subroutine '%s' at %L is not consistent with an "
1690 "intrinsic subroutine interface", sym->name, &c->loc);
1696 /* Resolve a subroutine call known to be specific. */
1699 resolve_specific_s0 (gfc_code * c, gfc_symbol * sym)
1703 if (sym->attr.external || sym->attr.if_source == IFSRC_IFBODY)
1705 if (sym->attr.dummy)
1707 sym->attr.proc = PROC_DUMMY;
1711 sym->attr.proc = PROC_EXTERNAL;
1715 if (sym->attr.proc == PROC_MODULE || sym->attr.proc == PROC_INTERNAL)
1718 if (sym->attr.intrinsic)
1720 m = gfc_intrinsic_sub_interface (c, 1);
1724 gfc_error ("Subroutine '%s' at %L is INTRINSIC but is not compatible "
1725 "with an intrinsic", sym->name, &c->loc);
1733 gfc_procedure_use (sym, &c->ext.actual, &c->loc);
1735 c->resolved_sym = sym;
1736 pure_subroutine (c, sym);
1743 resolve_specific_s (gfc_code * c)
1748 sym = c->symtree->n.sym;
1752 m = resolve_specific_s0 (c, sym);
1755 if (m == MATCH_ERROR)
1758 if (sym->ns->parent == NULL)
1761 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
1767 sym = c->symtree->n.sym;
1768 gfc_error ("Unable to resolve the specific subroutine '%s' at %L",
1769 sym->name, &c->loc);
1775 /* Resolve a subroutine call not known to be generic nor specific. */
1778 resolve_unknown_s (gfc_code * c)
1782 sym = c->symtree->n.sym;
1784 if (sym->attr.dummy)
1786 sym->attr.proc = PROC_DUMMY;
1790 /* See if we have an intrinsic function reference. */
1792 if (gfc_intrinsic_name (sym->name, 1))
1794 if (gfc_intrinsic_sub_interface (c, 1) == MATCH_YES)
1799 /* The reference is to an external name. */
1802 gfc_procedure_use (sym, &c->ext.actual, &c->loc);
1804 c->resolved_sym = sym;
1806 pure_subroutine (c, sym);
1812 /* Resolve a subroutine call. Although it was tempting to use the same code
1813 for functions, subroutines and functions are stored differently and this
1814 makes things awkward. */
1817 resolve_call (gfc_code * c)
1821 if (c->symtree && c->symtree->n.sym
1822 && c->symtree->n.sym->ts.type != BT_UNKNOWN)
1824 gfc_error ("'%s' at %L has a type, which is not consistent with "
1825 "the CALL at %L", c->symtree->n.sym->name,
1826 &c->symtree->n.sym->declared_at, &c->loc);
1830 /* If the procedure is not internal or module, it must be external and
1831 should be checked for usage. */
1832 if (c->symtree && c->symtree->n.sym
1833 && !c->symtree->n.sym->attr.dummy
1834 && !c->symtree->n.sym->attr.contained
1835 && !c->symtree->n.sym->attr.use_assoc)
1836 resolve_global_procedure (c->symtree->n.sym, &c->loc, 1);
1838 /* Subroutines without the RECURSIVE attribution are not allowed to
1839 * call themselves. */
1840 if (c->symtree && c->symtree->n.sym && !c->symtree->n.sym->attr.recursive)
1842 gfc_symbol *csym, *proc;
1843 csym = c->symtree->n.sym;
1844 proc = gfc_current_ns->proc_name;
1847 gfc_error ("SUBROUTINE '%s' at %L cannot call itself, as it is not "
1848 "RECURSIVE", csym->name, &c->loc);
1852 if (csym->attr.entry && csym->ns->entries && proc->ns->entries
1853 && csym->ns->entries->sym == proc->ns->entries->sym)
1855 gfc_error ("Call to ENTRY '%s' at %L is recursive, but subroutine "
1856 "'%s' is not declared as RECURSIVE",
1857 csym->name, &c->loc, csym->ns->entries->sym->name);
1862 /* Switch off assumed size checking and do this again for certain kinds
1863 of procedure, once the procedure itself is resolved. */
1864 need_full_assumed_size++;
1866 if (resolve_actual_arglist (c->ext.actual) == FAILURE)
1869 /* Resume assumed_size checking. */
1870 need_full_assumed_size--;
1874 if (c->resolved_sym == NULL)
1875 switch (procedure_kind (c->symtree->n.sym))
1878 t = resolve_generic_s (c);
1881 case PTYPE_SPECIFIC:
1882 t = resolve_specific_s (c);
1886 t = resolve_unknown_s (c);
1890 gfc_internal_error ("resolve_subroutine(): bad function type");
1893 /* Some checks of elemental subroutine actual arguments. */
1894 if (resolve_elemental_actual (NULL, c) == FAILURE)
1898 find_noncopying_intrinsics (c->resolved_sym, c->ext.actual);
1902 /* Compare the shapes of two arrays that have non-NULL shapes. If both
1903 op1->shape and op2->shape are non-NULL return SUCCESS if their shapes
1904 match. If both op1->shape and op2->shape are non-NULL return FAILURE
1905 if their shapes do not match. If either op1->shape or op2->shape is
1906 NULL, return SUCCESS. */
1909 compare_shapes (gfc_expr * op1, gfc_expr * op2)
1916 if (op1->shape != NULL && op2->shape != NULL)
1918 for (i = 0; i < op1->rank; i++)
1920 if (mpz_cmp (op1->shape[i], op2->shape[i]) != 0)
1922 gfc_error ("Shapes for operands at %L and %L are not conformable",
1923 &op1->where, &op2->where);
1933 /* Resolve an operator expression node. This can involve replacing the
1934 operation with a user defined function call. */
1937 resolve_operator (gfc_expr * e)
1939 gfc_expr *op1, *op2;
1943 /* Resolve all subnodes-- give them types. */
1945 switch (e->value.op.operator)
1948 if (gfc_resolve_expr (e->value.op.op2) == FAILURE)
1951 /* Fall through... */
1954 case INTRINSIC_UPLUS:
1955 case INTRINSIC_UMINUS:
1956 case INTRINSIC_PARENTHESES:
1957 if (gfc_resolve_expr (e->value.op.op1) == FAILURE)
1962 /* Typecheck the new node. */
1964 op1 = e->value.op.op1;
1965 op2 = e->value.op.op2;
1967 switch (e->value.op.operator)
1969 case INTRINSIC_UPLUS:
1970 case INTRINSIC_UMINUS:
1971 if (op1->ts.type == BT_INTEGER
1972 || op1->ts.type == BT_REAL
1973 || op1->ts.type == BT_COMPLEX)
1979 sprintf (msg, _("Operand of unary numeric operator '%s' at %%L is %s"),
1980 gfc_op2string (e->value.op.operator), gfc_typename (&e->ts));
1983 case INTRINSIC_PLUS:
1984 case INTRINSIC_MINUS:
1985 case INTRINSIC_TIMES:
1986 case INTRINSIC_DIVIDE:
1987 case INTRINSIC_POWER:
1988 if (gfc_numeric_ts (&op1->ts) && gfc_numeric_ts (&op2->ts))
1990 gfc_type_convert_binary (e);
1995 _("Operands of binary numeric operator '%s' at %%L are %s/%s"),
1996 gfc_op2string (e->value.op.operator), gfc_typename (&op1->ts),
1997 gfc_typename (&op2->ts));
2000 case INTRINSIC_CONCAT:
2001 if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER)
2003 e->ts.type = BT_CHARACTER;
2004 e->ts.kind = op1->ts.kind;
2009 _("Operands of string concatenation operator at %%L are %s/%s"),
2010 gfc_typename (&op1->ts), gfc_typename (&op2->ts));
2016 case INTRINSIC_NEQV:
2017 if (op1->ts.type == BT_LOGICAL && op2->ts.type == BT_LOGICAL)
2019 e->ts.type = BT_LOGICAL;
2020 e->ts.kind = gfc_kind_max (op1, op2);
2021 if (op1->ts.kind < e->ts.kind)
2022 gfc_convert_type (op1, &e->ts, 2);
2023 else if (op2->ts.kind < e->ts.kind)
2024 gfc_convert_type (op2, &e->ts, 2);
2028 sprintf (msg, _("Operands of logical operator '%s' at %%L are %s/%s"),
2029 gfc_op2string (e->value.op.operator), gfc_typename (&op1->ts),
2030 gfc_typename (&op2->ts));
2035 if (op1->ts.type == BT_LOGICAL)
2037 e->ts.type = BT_LOGICAL;
2038 e->ts.kind = op1->ts.kind;
2042 sprintf (msg, _("Operand of .NOT. operator at %%L is %s"),
2043 gfc_typename (&op1->ts));
2050 if (op1->ts.type == BT_COMPLEX || op2->ts.type == BT_COMPLEX)
2052 strcpy (msg, _("COMPLEX quantities cannot be compared at %L"));
2056 /* Fall through... */
2060 if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER)
2062 e->ts.type = BT_LOGICAL;
2063 e->ts.kind = gfc_default_logical_kind;
2067 if (gfc_numeric_ts (&op1->ts) && gfc_numeric_ts (&op2->ts))
2069 gfc_type_convert_binary (e);
2071 e->ts.type = BT_LOGICAL;
2072 e->ts.kind = gfc_default_logical_kind;
2076 if (op1->ts.type == BT_LOGICAL && op2->ts.type == BT_LOGICAL)
2078 _("Logicals at %%L must be compared with %s instead of %s"),
2079 e->value.op.operator == INTRINSIC_EQ ? ".EQV." : ".NEQV.",
2080 gfc_op2string (e->value.op.operator));
2083 _("Operands of comparison operator '%s' at %%L are %s/%s"),
2084 gfc_op2string (e->value.op.operator), gfc_typename (&op1->ts),
2085 gfc_typename (&op2->ts));
2089 case INTRINSIC_USER:
2091 sprintf (msg, _("Operand of user operator '%s' at %%L is %s"),
2092 e->value.op.uop->name, gfc_typename (&op1->ts));
2094 sprintf (msg, _("Operands of user operator '%s' at %%L are %s/%s"),
2095 e->value.op.uop->name, gfc_typename (&op1->ts),
2096 gfc_typename (&op2->ts));
2100 case INTRINSIC_PARENTHESES:
2104 gfc_internal_error ("resolve_operator(): Bad intrinsic");
2107 /* Deal with arrayness of an operand through an operator. */
2111 switch (e->value.op.operator)
2113 case INTRINSIC_PLUS:
2114 case INTRINSIC_MINUS:
2115 case INTRINSIC_TIMES:
2116 case INTRINSIC_DIVIDE:
2117 case INTRINSIC_POWER:
2118 case INTRINSIC_CONCAT:
2122 case INTRINSIC_NEQV:
2130 if (op1->rank == 0 && op2->rank == 0)
2133 if (op1->rank == 0 && op2->rank != 0)
2135 e->rank = op2->rank;
2137 if (e->shape == NULL)
2138 e->shape = gfc_copy_shape (op2->shape, op2->rank);
2141 if (op1->rank != 0 && op2->rank == 0)
2143 e->rank = op1->rank;
2145 if (e->shape == NULL)
2146 e->shape = gfc_copy_shape (op1->shape, op1->rank);
2149 if (op1->rank != 0 && op2->rank != 0)
2151 if (op1->rank == op2->rank)
2153 e->rank = op1->rank;
2154 if (e->shape == NULL)
2156 t = compare_shapes(op1, op2);
2160 e->shape = gfc_copy_shape (op1->shape, op1->rank);
2165 gfc_error ("Inconsistent ranks for operator at %L and %L",
2166 &op1->where, &op2->where);
2169 /* Allow higher level expressions to work. */
2177 case INTRINSIC_UPLUS:
2178 case INTRINSIC_UMINUS:
2179 case INTRINSIC_PARENTHESES:
2180 e->rank = op1->rank;
2182 if (e->shape == NULL)
2183 e->shape = gfc_copy_shape (op1->shape, op1->rank);
2185 /* Simply copy arrayness attribute */
2192 /* Attempt to simplify the expression. */
2194 t = gfc_simplify_expr (e, 0);
2199 if (gfc_extend_expr (e) == SUCCESS)
2202 gfc_error (msg, &e->where);
2208 /************** Array resolution subroutines **************/
2212 { CMP_LT, CMP_EQ, CMP_GT, CMP_UNKNOWN }
2215 /* Compare two integer expressions. */
2218 compare_bound (gfc_expr * a, gfc_expr * b)
2222 if (a == NULL || a->expr_type != EXPR_CONSTANT
2223 || b == NULL || b->expr_type != EXPR_CONSTANT)
2226 if (a->ts.type != BT_INTEGER || b->ts.type != BT_INTEGER)
2227 gfc_internal_error ("compare_bound(): Bad expression");
2229 i = mpz_cmp (a->value.integer, b->value.integer);
2239 /* Compare an integer expression with an integer. */
2242 compare_bound_int (gfc_expr * a, int b)
2246 if (a == NULL || a->expr_type != EXPR_CONSTANT)
2249 if (a->ts.type != BT_INTEGER)
2250 gfc_internal_error ("compare_bound_int(): Bad expression");
2252 i = mpz_cmp_si (a->value.integer, b);
2262 /* Compare an integer expression with a mpz_t. */
2265 compare_bound_mpz_t (gfc_expr * a, mpz_t b)
2269 if (a == NULL || a->expr_type != EXPR_CONSTANT)
2272 if (a->ts.type != BT_INTEGER)
2273 gfc_internal_error ("compare_bound_int(): Bad expression");
2275 i = mpz_cmp (a->value.integer, b);
2285 /* Compute the last value of a sequence given by a triplet.
2286 Return 0 if it wasn't able to compute the last value, or if the
2287 sequence if empty, and 1 otherwise. */
2290 compute_last_value_for_triplet (gfc_expr * start, gfc_expr * end,
2291 gfc_expr * stride, mpz_t last)
2295 if (start == NULL || start->expr_type != EXPR_CONSTANT
2296 || end == NULL || end->expr_type != EXPR_CONSTANT
2297 || (stride != NULL && stride->expr_type != EXPR_CONSTANT))
2300 if (start->ts.type != BT_INTEGER || end->ts.type != BT_INTEGER
2301 || (stride != NULL && stride->ts.type != BT_INTEGER))
2304 if (stride == NULL || compare_bound_int(stride, 1) == CMP_EQ)
2306 if (compare_bound (start, end) == CMP_GT)
2308 mpz_set (last, end->value.integer);
2312 if (compare_bound_int (stride, 0) == CMP_GT)
2314 /* Stride is positive */
2315 if (mpz_cmp (start->value.integer, end->value.integer) > 0)
2320 /* Stride is negative */
2321 if (mpz_cmp (start->value.integer, end->value.integer) < 0)
2326 mpz_sub (rem, end->value.integer, start->value.integer);
2327 mpz_tdiv_r (rem, rem, stride->value.integer);
2328 mpz_sub (last, end->value.integer, rem);
2335 /* Compare a single dimension of an array reference to the array
2339 check_dimension (int i, gfc_array_ref * ar, gfc_array_spec * as)
2343 /* Given start, end and stride values, calculate the minimum and
2344 maximum referenced indexes. */
2352 if (compare_bound (ar->start[i], as->lower[i]) == CMP_LT)
2354 if (compare_bound (ar->start[i], as->upper[i]) == CMP_GT)
2360 if (compare_bound_int (ar->stride[i], 0) == CMP_EQ)
2362 gfc_error ("Illegal stride of zero at %L", &ar->c_where[i]);
2366 #define AR_START (ar->start[i] ? ar->start[i] : as->lower[i])
2367 #define AR_END (ar->end[i] ? ar->end[i] : as->upper[i])
2369 if (compare_bound (AR_START, AR_END) == CMP_EQ
2370 && (compare_bound (AR_START, as->lower[i]) == CMP_LT
2371 || compare_bound (AR_START, as->upper[i]) == CMP_GT))
2374 if (((compare_bound_int (ar->stride[i], 0) == CMP_GT
2375 || ar->stride[i] == NULL)
2376 && compare_bound (AR_START, AR_END) != CMP_GT)
2377 || (compare_bound_int (ar->stride[i], 0) == CMP_LT
2378 && compare_bound (AR_START, AR_END) != CMP_LT))
2380 if (compare_bound (AR_START, as->lower[i]) == CMP_LT)
2382 if (compare_bound (AR_START, as->upper[i]) == CMP_GT)
2386 mpz_init (last_value);
2387 if (compute_last_value_for_triplet (AR_START, AR_END, ar->stride[i],
2390 if (compare_bound_mpz_t (as->lower[i], last_value) == CMP_GT
2391 || compare_bound_mpz_t (as->upper[i], last_value) == CMP_LT)
2393 mpz_clear (last_value);
2397 mpz_clear (last_value);
2405 gfc_internal_error ("check_dimension(): Bad array reference");
2411 gfc_warning ("Array reference at %L is out of bounds", &ar->c_where[i]);
2416 /* Compare an array reference with an array specification. */
2419 compare_spec_to_ref (gfc_array_ref * ar)
2426 /* TODO: Full array sections are only allowed as actual parameters. */
2427 if (as->type == AS_ASSUMED_SIZE
2428 && (/*ar->type == AR_FULL
2429 ||*/ (ar->type == AR_SECTION
2430 && ar->dimen_type[i] == DIMEN_RANGE && ar->end[i] == NULL)))
2432 gfc_error ("Rightmost upper bound of assumed size array section"
2433 " not specified at %L", &ar->where);
2437 if (ar->type == AR_FULL)
2440 if (as->rank != ar->dimen)
2442 gfc_error ("Rank mismatch in array reference at %L (%d/%d)",
2443 &ar->where, ar->dimen, as->rank);
2447 for (i = 0; i < as->rank; i++)
2448 if (check_dimension (i, ar, as) == FAILURE)
2455 /* Resolve one part of an array index. */
2458 gfc_resolve_index (gfc_expr * index, int check_scalar)
2465 if (gfc_resolve_expr (index) == FAILURE)
2468 if (check_scalar && index->rank != 0)
2470 gfc_error ("Array index at %L must be scalar", &index->where);
2474 if (index->ts.type != BT_INTEGER && index->ts.type != BT_REAL)
2476 gfc_error ("Array index at %L must be of INTEGER type",
2481 if (index->ts.type == BT_REAL)
2482 if (gfc_notify_std (GFC_STD_LEGACY, "Extension: REAL array index at %L",
2483 &index->where) == FAILURE)
2486 if (index->ts.kind != gfc_index_integer_kind
2487 || index->ts.type != BT_INTEGER)
2490 ts.type = BT_INTEGER;
2491 ts.kind = gfc_index_integer_kind;
2493 gfc_convert_type_warn (index, &ts, 2, 0);
2499 /* Resolve a dim argument to an intrinsic function. */
2502 gfc_resolve_dim_arg (gfc_expr *dim)
2507 if (gfc_resolve_expr (dim) == FAILURE)
2512 gfc_error ("Argument dim at %L must be scalar", &dim->where);
2516 if (dim->ts.type != BT_INTEGER)
2518 gfc_error ("Argument dim at %L must be of INTEGER type", &dim->where);
2521 if (dim->ts.kind != gfc_index_integer_kind)
2525 ts.type = BT_INTEGER;
2526 ts.kind = gfc_index_integer_kind;
2528 gfc_convert_type_warn (dim, &ts, 2, 0);
2534 /* Given an expression that contains array references, update those array
2535 references to point to the right array specifications. While this is
2536 filled in during matching, this information is difficult to save and load
2537 in a module, so we take care of it here.
2539 The idea here is that the original array reference comes from the
2540 base symbol. We traverse the list of reference structures, setting
2541 the stored reference to references. Component references can
2542 provide an additional array specification. */
2545 find_array_spec (gfc_expr * e)
2549 gfc_symbol *derived;
2552 as = e->symtree->n.sym->as;
2555 for (ref = e->ref; ref; ref = ref->next)
2560 gfc_internal_error ("find_array_spec(): Missing spec");
2567 if (derived == NULL)
2568 derived = e->symtree->n.sym->ts.derived;
2570 c = derived->components;
2572 for (; c; c = c->next)
2573 if (c == ref->u.c.component)
2575 /* Track the sequence of component references. */
2576 if (c->ts.type == BT_DERIVED)
2577 derived = c->ts.derived;
2582 gfc_internal_error ("find_array_spec(): Component not found");
2587 gfc_internal_error ("find_array_spec(): unused as(1)");
2598 gfc_internal_error ("find_array_spec(): unused as(2)");
2602 /* Resolve an array reference. */
2605 resolve_array_ref (gfc_array_ref * ar)
2607 int i, check_scalar;
2610 for (i = 0; i < ar->dimen; i++)
2612 check_scalar = ar->dimen_type[i] == DIMEN_RANGE;
2614 if (gfc_resolve_index (ar->start[i], check_scalar) == FAILURE)
2616 if (gfc_resolve_index (ar->end[i], check_scalar) == FAILURE)
2618 if (gfc_resolve_index (ar->stride[i], check_scalar) == FAILURE)
2623 if (ar->dimen_type[i] == DIMEN_UNKNOWN)
2627 ar->dimen_type[i] = DIMEN_ELEMENT;
2631 ar->dimen_type[i] = DIMEN_VECTOR;
2632 if (e->expr_type == EXPR_VARIABLE
2633 && e->symtree->n.sym->ts.type == BT_DERIVED)
2634 ar->start[i] = gfc_get_parentheses (e);
2638 gfc_error ("Array index at %L is an array of rank %d",
2639 &ar->c_where[i], e->rank);
2644 /* If the reference type is unknown, figure out what kind it is. */
2646 if (ar->type == AR_UNKNOWN)
2648 ar->type = AR_ELEMENT;
2649 for (i = 0; i < ar->dimen; i++)
2650 if (ar->dimen_type[i] == DIMEN_RANGE
2651 || ar->dimen_type[i] == DIMEN_VECTOR)
2653 ar->type = AR_SECTION;
2658 if (!ar->as->cray_pointee && compare_spec_to_ref (ar) == FAILURE)
2666 resolve_substring (gfc_ref * ref)
2669 if (ref->u.ss.start != NULL)
2671 if (gfc_resolve_expr (ref->u.ss.start) == FAILURE)
2674 if (ref->u.ss.start->ts.type != BT_INTEGER)
2676 gfc_error ("Substring start index at %L must be of type INTEGER",
2677 &ref->u.ss.start->where);
2681 if (ref->u.ss.start->rank != 0)
2683 gfc_error ("Substring start index at %L must be scalar",
2684 &ref->u.ss.start->where);
2688 if (compare_bound_int (ref->u.ss.start, 1) == CMP_LT
2689 && (compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_EQ
2690 || compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_GT))
2692 gfc_error ("Substring start index at %L is less than one",
2693 &ref->u.ss.start->where);
2698 if (ref->u.ss.end != NULL)
2700 if (gfc_resolve_expr (ref->u.ss.end) == FAILURE)
2703 if (ref->u.ss.end->ts.type != BT_INTEGER)
2705 gfc_error ("Substring end index at %L must be of type INTEGER",
2706 &ref->u.ss.end->where);
2710 if (ref->u.ss.end->rank != 0)
2712 gfc_error ("Substring end index at %L must be scalar",
2713 &ref->u.ss.end->where);
2717 if (ref->u.ss.length != NULL
2718 && compare_bound (ref->u.ss.end, ref->u.ss.length->length) == CMP_GT
2719 && (compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_EQ
2720 || compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_GT))
2722 gfc_error ("Substring end index at %L exceeds the string length",
2723 &ref->u.ss.start->where);
2732 /* Resolve subtype references. */
2735 resolve_ref (gfc_expr * expr)
2737 int current_part_dimension, n_components, seen_part_dimension;
2740 for (ref = expr->ref; ref; ref = ref->next)
2741 if (ref->type == REF_ARRAY && ref->u.ar.as == NULL)
2743 find_array_spec (expr);
2747 for (ref = expr->ref; ref; ref = ref->next)
2751 if (resolve_array_ref (&ref->u.ar) == FAILURE)
2759 resolve_substring (ref);
2763 /* Check constraints on part references. */
2765 current_part_dimension = 0;
2766 seen_part_dimension = 0;
2769 for (ref = expr->ref; ref; ref = ref->next)
2774 switch (ref->u.ar.type)
2778 current_part_dimension = 1;
2782 current_part_dimension = 0;
2786 gfc_internal_error ("resolve_ref(): Bad array reference");
2792 if (current_part_dimension || seen_part_dimension)
2794 if (ref->u.c.component->pointer)
2797 ("Component to the right of a part reference with nonzero "
2798 "rank must not have the POINTER attribute at %L",
2802 else if (ref->u.c.component->allocatable)
2805 ("Component to the right of a part reference with nonzero "
2806 "rank must not have the ALLOCATABLE attribute at %L",
2819 if (((ref->type == REF_COMPONENT && n_components > 1)
2820 || ref->next == NULL)
2821 && current_part_dimension
2822 && seen_part_dimension)
2825 gfc_error ("Two or more part references with nonzero rank must "
2826 "not be specified at %L", &expr->where);
2830 if (ref->type == REF_COMPONENT)
2832 if (current_part_dimension)
2833 seen_part_dimension = 1;
2835 /* reset to make sure */
2836 current_part_dimension = 0;
2844 /* Given an expression, determine its shape. This is easier than it sounds.
2845 Leaves the shape array NULL if it is not possible to determine the shape. */
2848 expression_shape (gfc_expr * e)
2850 mpz_t array[GFC_MAX_DIMENSIONS];
2853 if (e->rank == 0 || e->shape != NULL)
2856 for (i = 0; i < e->rank; i++)
2857 if (gfc_array_dimen_size (e, i, &array[i]) == FAILURE)
2860 e->shape = gfc_get_shape (e->rank);
2862 memcpy (e->shape, array, e->rank * sizeof (mpz_t));
2867 for (i--; i >= 0; i--)
2868 mpz_clear (array[i]);
2872 /* Given a variable expression node, compute the rank of the expression by
2873 examining the base symbol and any reference structures it may have. */
2876 expression_rank (gfc_expr * e)
2883 if (e->expr_type == EXPR_ARRAY)
2885 /* Constructors can have a rank different from one via RESHAPE(). */
2887 if (e->symtree == NULL)
2893 e->rank = (e->symtree->n.sym->as == NULL)
2894 ? 0 : e->symtree->n.sym->as->rank;
2900 for (ref = e->ref; ref; ref = ref->next)
2902 if (ref->type != REF_ARRAY)
2905 if (ref->u.ar.type == AR_FULL)
2907 rank = ref->u.ar.as->rank;
2911 if (ref->u.ar.type == AR_SECTION)
2913 /* Figure out the rank of the section. */
2915 gfc_internal_error ("expression_rank(): Two array specs");
2917 for (i = 0; i < ref->u.ar.dimen; i++)
2918 if (ref->u.ar.dimen_type[i] == DIMEN_RANGE
2919 || ref->u.ar.dimen_type[i] == DIMEN_VECTOR)
2929 expression_shape (e);
2933 /* Resolve a variable expression. */
2936 resolve_variable (gfc_expr * e)
2943 if (e->symtree == NULL)
2946 if (e->ref && resolve_ref (e) == FAILURE)
2949 sym = e->symtree->n.sym;
2950 if (sym->attr.flavor == FL_PROCEDURE && !sym->attr.function)
2952 e->ts.type = BT_PROCEDURE;
2956 if (sym->ts.type != BT_UNKNOWN)
2957 gfc_variable_attr (e, &e->ts);
2960 /* Must be a simple variable reference. */
2961 if (gfc_set_default_type (sym, 1, sym->ns) == FAILURE)
2966 if (check_assumed_size_reference (sym, e))
2969 /* Deal with forward references to entries during resolve_code, to
2970 satisfy, at least partially, 12.5.2.5. */
2971 if (gfc_current_ns->entries
2972 && current_entry_id == sym->entry_id
2975 && cs_base->current->op != EXEC_ENTRY)
2977 gfc_entry_list *entry;
2978 gfc_formal_arglist *formal;
2982 /* If the symbol is a dummy... */
2983 if (sym->attr.dummy)
2985 entry = gfc_current_ns->entries;
2988 /* ...test if the symbol is a parameter of previous entries. */
2989 for (; entry && entry->id <= current_entry_id; entry = entry->next)
2990 for (formal = entry->sym->formal; formal; formal = formal->next)
2992 if (formal->sym && sym->name == formal->sym->name)
2996 /* If it has not been seen as a dummy, this is an error. */
2999 if (specification_expr)
3000 gfc_error ("Variable '%s',used in a specification expression, "
3001 "is referenced at %L before the ENTRY statement "
3002 "in which it is a parameter",
3003 sym->name, &cs_base->current->loc);
3005 gfc_error ("Variable '%s' is used at %L before the ENTRY "
3006 "statement in which it is a parameter",
3007 sym->name, &cs_base->current->loc);
3012 /* Now do the same check on the specification expressions. */
3013 specification_expr = 1;
3014 if (sym->ts.type == BT_CHARACTER
3015 && gfc_resolve_expr (sym->ts.cl->length) == FAILURE)
3019 for (n = 0; n < sym->as->rank; n++)
3021 specification_expr = 1;
3022 if (gfc_resolve_expr (sym->as->lower[n]) == FAILURE)
3024 specification_expr = 1;
3025 if (gfc_resolve_expr (sym->as->upper[n]) == FAILURE)
3028 specification_expr = 0;
3031 /* Update the symbol's entry level. */
3032 sym->entry_id = current_entry_id + 1;
3039 /* Resolve an expression. That is, make sure that types of operands agree
3040 with their operators, intrinsic operators are converted to function calls
3041 for overloaded types and unresolved function references are resolved. */
3044 gfc_resolve_expr (gfc_expr * e)
3051 switch (e->expr_type)
3054 t = resolve_operator (e);
3058 t = resolve_function (e);
3062 t = resolve_variable (e);
3064 expression_rank (e);
3067 case EXPR_SUBSTRING:
3068 t = resolve_ref (e);
3078 if (resolve_ref (e) == FAILURE)
3081 t = gfc_resolve_array_constructor (e);
3082 /* Also try to expand a constructor. */
3085 expression_rank (e);
3086 gfc_expand_constructor (e);
3089 /* This provides the opportunity for the length of constructors with character
3090 valued function elements to propogate the string length to the expression. */
3091 if (e->ts.type == BT_CHARACTER)
3092 gfc_resolve_character_array_constructor (e);
3096 case EXPR_STRUCTURE:
3097 t = resolve_ref (e);
3101 t = resolve_structure_cons (e);
3105 t = gfc_simplify_expr (e, 0);
3109 gfc_internal_error ("gfc_resolve_expr(): Bad expression type");
3116 /* Resolve an expression from an iterator. They must be scalar and have
3117 INTEGER or (optionally) REAL type. */
3120 gfc_resolve_iterator_expr (gfc_expr * expr, bool real_ok,
3121 const char * name_msgid)
3123 if (gfc_resolve_expr (expr) == FAILURE)
3126 if (expr->rank != 0)
3128 gfc_error ("%s at %L must be a scalar", _(name_msgid), &expr->where);
3132 if (!(expr->ts.type == BT_INTEGER
3133 || (expr->ts.type == BT_REAL && real_ok)))
3136 gfc_error ("%s at %L must be INTEGER or REAL", _(name_msgid),
3139 gfc_error ("%s at %L must be INTEGER", _(name_msgid), &expr->where);
3146 /* Resolve the expressions in an iterator structure. If REAL_OK is
3147 false allow only INTEGER type iterators, otherwise allow REAL types. */
3150 gfc_resolve_iterator (gfc_iterator * iter, bool real_ok)
3153 if (iter->var->ts.type == BT_REAL)
3154 gfc_notify_std (GFC_STD_F95_DEL,
3155 "Obsolete: REAL DO loop iterator at %L",
3158 if (gfc_resolve_iterator_expr (iter->var, real_ok, "Loop variable")
3162 if (gfc_pure (NULL) && gfc_impure_variable (iter->var->symtree->n.sym))
3164 gfc_error ("Cannot assign to loop variable in PURE procedure at %L",
3169 if (gfc_resolve_iterator_expr (iter->start, real_ok,
3170 "Start expression in DO loop") == FAILURE)
3173 if (gfc_resolve_iterator_expr (iter->end, real_ok,
3174 "End expression in DO loop") == FAILURE)
3177 if (gfc_resolve_iterator_expr (iter->step, real_ok,
3178 "Step expression in DO loop") == FAILURE)
3181 if (iter->step->expr_type == EXPR_CONSTANT)
3183 if ((iter->step->ts.type == BT_INTEGER
3184 && mpz_cmp_ui (iter->step->value.integer, 0) == 0)
3185 || (iter->step->ts.type == BT_REAL
3186 && mpfr_sgn (iter->step->value.real) == 0))
3188 gfc_error ("Step expression in DO loop at %L cannot be zero",
3189 &iter->step->where);
3194 /* Convert start, end, and step to the same type as var. */
3195 if (iter->start->ts.kind != iter->var->ts.kind
3196 || iter->start->ts.type != iter->var->ts.type)
3197 gfc_convert_type (iter->start, &iter->var->ts, 2);
3199 if (iter->end->ts.kind != iter->var->ts.kind
3200 || iter->end->ts.type != iter->var->ts.type)
3201 gfc_convert_type (iter->end, &iter->var->ts, 2);
3203 if (iter->step->ts.kind != iter->var->ts.kind
3204 || iter->step->ts.type != iter->var->ts.type)
3205 gfc_convert_type (iter->step, &iter->var->ts, 2);
3211 /* Resolve a list of FORALL iterators. The FORALL index-name is constrained
3212 to be a scalar INTEGER variable. The subscripts and stride are scalar
3213 INTEGERs, and if stride is a constant it must be nonzero. */
3216 resolve_forall_iterators (gfc_forall_iterator * iter)
3221 if (gfc_resolve_expr (iter->var) == SUCCESS
3222 && (iter->var->ts.type != BT_INTEGER || iter->var->rank != 0))
3223 gfc_error ("FORALL index-name at %L must be a scalar INTEGER",
3226 if (gfc_resolve_expr (iter->start) == SUCCESS
3227 && (iter->start->ts.type != BT_INTEGER || iter->start->rank != 0))
3228 gfc_error ("FORALL start expression at %L must be a scalar INTEGER",
3229 &iter->start->where);
3230 if (iter->var->ts.kind != iter->start->ts.kind)
3231 gfc_convert_type (iter->start, &iter->var->ts, 2);
3233 if (gfc_resolve_expr (iter->end) == SUCCESS
3234 && (iter->end->ts.type != BT_INTEGER || iter->end->rank != 0))
3235 gfc_error ("FORALL end expression at %L must be a scalar INTEGER",
3237 if (iter->var->ts.kind != iter->end->ts.kind)
3238 gfc_convert_type (iter->end, &iter->var->ts, 2);
3240 if (gfc_resolve_expr (iter->stride) == SUCCESS)
3242 if (iter->stride->ts.type != BT_INTEGER || iter->stride->rank != 0)
3243 gfc_error ("FORALL stride expression at %L must be a scalar %s",
3244 &iter->stride->where, "INTEGER");
3246 if (iter->stride->expr_type == EXPR_CONSTANT
3247 && mpz_cmp_ui(iter->stride->value.integer, 0) == 0)
3248 gfc_error ("FORALL stride expression at %L cannot be zero",
3249 &iter->stride->where);
3251 if (iter->var->ts.kind != iter->stride->ts.kind)
3252 gfc_convert_type (iter->stride, &iter->var->ts, 2);
3259 /* Given a pointer to a symbol that is a derived type, see if any components
3260 have the POINTER attribute. The search is recursive if necessary.
3261 Returns zero if no pointer components are found, nonzero otherwise. */
3264 derived_pointer (gfc_symbol * sym)
3268 for (c = sym->components; c; c = c->next)
3273 if (c->ts.type == BT_DERIVED && derived_pointer (c->ts.derived))
3281 /* Given a pointer to a symbol that is a derived type, see if it's
3282 inaccessible, i.e. if it's defined in another module and the components are
3283 PRIVATE. The search is recursive if necessary. Returns zero if no
3284 inaccessible components are found, nonzero otherwise. */
3287 derived_inaccessible (gfc_symbol *sym)
3291 if (sym->attr.use_assoc && sym->component_access == ACCESS_PRIVATE)
3294 for (c = sym->components; c; c = c->next)
3296 if (c->ts.type == BT_DERIVED && derived_inaccessible (c->ts.derived))
3304 /* Resolve the argument of a deallocate expression. The expression must be
3305 a pointer or a full array. */
3308 resolve_deallocate_expr (gfc_expr * e)
3310 symbol_attribute attr;
3314 if (gfc_resolve_expr (e) == FAILURE)
3317 attr = gfc_expr_attr (e);
3321 if (e->expr_type != EXPR_VARIABLE)
3324 allocatable = e->symtree->n.sym->attr.allocatable;
3325 for (ref = e->ref; ref; ref = ref->next)
3329 if (ref->u.ar.type != AR_FULL)
3334 allocatable = (ref->u.c.component->as != NULL
3335 && ref->u.c.component->as->type == AS_DEFERRED);
3343 if (allocatable == 0)
3346 gfc_error ("Expression in DEALLOCATE statement at %L must be "
3347 "ALLOCATABLE or a POINTER", &e->where);
3350 if (e->symtree->n.sym->attr.intent == INTENT_IN)
3352 gfc_error ("Can't deallocate INTENT(IN) variable '%s' at %L",
3353 e->symtree->n.sym->name, &e->where);
3360 /* Returns true if the expression e contains a reference the symbol sym. */
3362 find_sym_in_expr (gfc_symbol *sym, gfc_expr *e)
3364 gfc_actual_arglist *arg;
3372 switch (e->expr_type)
3375 for (arg = e->value.function.actual; arg; arg = arg->next)
3376 rv = rv || find_sym_in_expr (sym, arg->expr);
3379 /* If the variable is not the same as the dependent, 'sym', and
3380 it is not marked as being declared and it is in the same
3381 namespace as 'sym', add it to the local declarations. */
3383 if (sym == e->symtree->n.sym)
3388 rv = rv || find_sym_in_expr (sym, e->value.op.op1);
3389 rv = rv || find_sym_in_expr (sym, e->value.op.op2);
3398 for (ref = e->ref; ref; ref = ref->next)
3403 for (i = 0; i < ref->u.ar.dimen; i++)
3405 rv = rv || find_sym_in_expr (sym, ref->u.ar.start[i]);
3406 rv = rv || find_sym_in_expr (sym, ref->u.ar.end[i]);
3407 rv = rv || find_sym_in_expr (sym, ref->u.ar.stride[i]);
3412 rv = rv || find_sym_in_expr (sym, ref->u.ss.start);
3413 rv = rv || find_sym_in_expr (sym, ref->u.ss.end);
3417 if (ref->u.c.component->ts.type == BT_CHARACTER
3418 && ref->u.c.component->ts.cl->length->expr_type
3420 rv = rv || find_sym_in_expr (sym, ref->u.c.component->ts.cl->length);
3422 if (ref->u.c.component->as)
3423 for (i = 0; i < ref->u.c.component->as->rank; i++)
3425 rv = rv || find_sym_in_expr (sym, ref->u.c.component->as->lower[i]);
3426 rv = rv || find_sym_in_expr (sym, ref->u.c.component->as->upper[i]);
3436 /* Given the expression node e for an allocatable/pointer of derived type to be
3437 allocated, get the expression node to be initialized afterwards (needed for
3438 derived types with default initializers, and derived types with allocatable
3439 components that need nullification.) */
3442 expr_to_initialize (gfc_expr * e)
3448 result = gfc_copy_expr (e);
3450 /* Change the last array reference from AR_ELEMENT to AR_FULL. */
3451 for (ref = result->ref; ref; ref = ref->next)
3452 if (ref->type == REF_ARRAY && ref->next == NULL)
3454 ref->u.ar.type = AR_FULL;
3456 for (i = 0; i < ref->u.ar.dimen; i++)
3457 ref->u.ar.start[i] = ref->u.ar.end[i] = ref->u.ar.stride[i] = NULL;
3459 result->rank = ref->u.ar.dimen;
3467 /* Resolve the expression in an ALLOCATE statement, doing the additional
3468 checks to see whether the expression is OK or not. The expression must
3469 have a trailing array reference that gives the size of the array. */
3472 resolve_allocate_expr (gfc_expr * e, gfc_code * code)
3474 int i, pointer, allocatable, dimension;
3475 symbol_attribute attr;
3476 gfc_ref *ref, *ref2;
3483 if (gfc_resolve_expr (e) == FAILURE)
3486 if (code->expr && code->expr->expr_type == EXPR_VARIABLE)
3487 sym = code->expr->symtree->n.sym;
3491 /* Make sure the expression is allocatable or a pointer. If it is
3492 pointer, the next-to-last reference must be a pointer. */
3496 if (e->expr_type != EXPR_VARIABLE)
3500 attr = gfc_expr_attr (e);
3501 pointer = attr.pointer;
3502 dimension = attr.dimension;
3507 allocatable = e->symtree->n.sym->attr.allocatable;
3508 pointer = e->symtree->n.sym->attr.pointer;
3509 dimension = e->symtree->n.sym->attr.dimension;
3511 if (sym == e->symtree->n.sym && sym->ts.type != BT_DERIVED)
3513 gfc_error ("The STAT variable '%s' in an ALLOCATE statement must "
3514 "not be allocated in the same statement at %L",
3515 sym->name, &e->where);
3519 for (ref = e->ref; ref; ref2 = ref, ref = ref->next)
3523 if (ref->next != NULL)
3528 allocatable = (ref->u.c.component->as != NULL
3529 && ref->u.c.component->as->type == AS_DEFERRED);
3531 pointer = ref->u.c.component->pointer;
3532 dimension = ref->u.c.component->dimension;
3542 if (allocatable == 0 && pointer == 0)
3544 gfc_error ("Expression in ALLOCATE statement at %L must be "
3545 "ALLOCATABLE or a POINTER", &e->where);
3549 if (e->symtree->n.sym->attr.intent == INTENT_IN)
3551 gfc_error ("Can't allocate INTENT(IN) variable '%s' at %L",
3552 e->symtree->n.sym->name, &e->where);
3556 /* Add default initializer for those derived types that need them. */
3557 if (e->ts.type == BT_DERIVED && (init_e = gfc_default_initializer (&e->ts)))
3559 init_st = gfc_get_code ();
3560 init_st->loc = code->loc;
3561 init_st->op = EXEC_INIT_ASSIGN;
3562 init_st->expr = expr_to_initialize (e);
3563 init_st->expr2 = init_e;
3564 init_st->next = code->next;
3565 code->next = init_st;
3568 if (pointer && dimension == 0)
3571 /* Make sure the next-to-last reference node is an array specification. */
3573 if (ref2 == NULL || ref2->type != REF_ARRAY || ref2->u.ar.type == AR_FULL)
3575 gfc_error ("Array specification required in ALLOCATE statement "
3576 "at %L", &e->where);
3580 /* Make sure that the array section reference makes sense in the
3581 context of an ALLOCATE specification. */
3585 for (i = 0; i < ar->dimen; i++)
3587 if (ref2->u.ar.type == AR_ELEMENT)
3590 switch (ar->dimen_type[i])
3596 if (ar->start[i] != NULL
3597 && ar->end[i] != NULL
3598 && ar->stride[i] == NULL)
3601 /* Fall Through... */
3605 gfc_error ("Bad array specification in ALLOCATE statement at %L",
3612 for (a = code->ext.alloc_list; a; a = a->next)
3614 sym = a->expr->symtree->n.sym;
3616 /* TODO - check derived type components. */
3617 if (sym->ts.type == BT_DERIVED)
3620 if ((ar->start[i] != NULL && find_sym_in_expr (sym, ar->start[i]))
3621 || (ar->end[i] != NULL && find_sym_in_expr (sym, ar->end[i])))
3623 gfc_error ("'%s' must not appear an the array specification at "
3624 "%L in the same ALLOCATE statement where it is "
3625 "itself allocated", sym->name, &ar->where);
3635 /************ SELECT CASE resolution subroutines ************/
3637 /* Callback function for our mergesort variant. Determines interval
3638 overlaps for CASEs. Return <0 if op1 < op2, 0 for overlap, >0 for
3639 op1 > op2. Assumes we're not dealing with the default case.
3640 We have op1 = (:L), (K:L) or (K:) and op2 = (:N), (M:N) or (M:).
3641 There are nine situations to check. */
3644 compare_cases (const gfc_case * op1, const gfc_case * op2)
3648 if (op1->low == NULL) /* op1 = (:L) */
3650 /* op2 = (:N), so overlap. */
3652 /* op2 = (M:) or (M:N), L < M */
3653 if (op2->low != NULL
3654 && gfc_compare_expr (op1->high, op2->low) < 0)
3657 else if (op1->high == NULL) /* op1 = (K:) */
3659 /* op2 = (M:), so overlap. */
3661 /* op2 = (:N) or (M:N), K > N */
3662 if (op2->high != NULL
3663 && gfc_compare_expr (op1->low, op2->high) > 0)
3666 else /* op1 = (K:L) */
3668 if (op2->low == NULL) /* op2 = (:N), K > N */
3669 retval = (gfc_compare_expr (op1->low, op2->high) > 0) ? 1 : 0;
3670 else if (op2->high == NULL) /* op2 = (M:), L < M */
3671 retval = (gfc_compare_expr (op1->high, op2->low) < 0) ? -1 : 0;
3672 else /* op2 = (M:N) */
3676 if (gfc_compare_expr (op1->high, op2->low) < 0)
3679 else if (gfc_compare_expr (op1->low, op2->high) > 0)
3688 /* Merge-sort a double linked case list, detecting overlap in the
3689 process. LIST is the head of the double linked case list before it
3690 is sorted. Returns the head of the sorted list if we don't see any
3691 overlap, or NULL otherwise. */
3694 check_case_overlap (gfc_case * list)
3696 gfc_case *p, *q, *e, *tail;
3697 int insize, nmerges, psize, qsize, cmp, overlap_seen;
3699 /* If the passed list was empty, return immediately. */
3706 /* Loop unconditionally. The only exit from this loop is a return
3707 statement, when we've finished sorting the case list. */
3714 /* Count the number of merges we do in this pass. */
3717 /* Loop while there exists a merge to be done. */
3722 /* Count this merge. */
3725 /* Cut the list in two pieces by stepping INSIZE places
3726 forward in the list, starting from P. */
3729 for (i = 0; i < insize; i++)
3738 /* Now we have two lists. Merge them! */
3739 while (psize > 0 || (qsize > 0 && q != NULL))
3742 /* See from which the next case to merge comes from. */
3745 /* P is empty so the next case must come from Q. */
3750 else if (qsize == 0 || q == NULL)
3759 cmp = compare_cases (p, q);
3762 /* The whole case range for P is less than the
3770 /* The whole case range for Q is greater than
3771 the case range for P. */
3778 /* The cases overlap, or they are the same
3779 element in the list. Either way, we must
3780 issue an error and get the next case from P. */
3781 /* FIXME: Sort P and Q by line number. */
3782 gfc_error ("CASE label at %L overlaps with CASE "
3783 "label at %L", &p->where, &q->where);
3791 /* Add the next element to the merged list. */
3800 /* P has now stepped INSIZE places along, and so has Q. So
3801 they're the same. */
3806 /* If we have done only one merge or none at all, we've
3807 finished sorting the cases. */
3816 /* Otherwise repeat, merging lists twice the size. */
3822 /* Check to see if an expression is suitable for use in a CASE statement.
3823 Makes sure that all case expressions are scalar constants of the same
3824 type. Return FAILURE if anything is wrong. */
3827 validate_case_label_expr (gfc_expr * e, gfc_expr * case_expr)
3829 if (e == NULL) return SUCCESS;
3831 if (e->ts.type != case_expr->ts.type)
3833 gfc_error ("Expression in CASE statement at %L must be of type %s",
3834 &e->where, gfc_basic_typename (case_expr->ts.type));
3838 /* C805 (R808) For a given case-construct, each case-value shall be of
3839 the same type as case-expr. For character type, length differences
3840 are allowed, but the kind type parameters shall be the same. */
3842 if (case_expr->ts.type == BT_CHARACTER && e->ts.kind != case_expr->ts.kind)
3844 gfc_error("Expression in CASE statement at %L must be kind %d",
3845 &e->where, case_expr->ts.kind);
3849 /* Convert the case value kind to that of case expression kind, if needed.
3850 FIXME: Should a warning be issued? */
3851 if (e->ts.kind != case_expr->ts.kind)
3852 gfc_convert_type_warn (e, &case_expr->ts, 2, 0);
3856 gfc_error ("Expression in CASE statement at %L must be scalar",
3865 /* Given a completely parsed select statement, we:
3867 - Validate all expressions and code within the SELECT.
3868 - Make sure that the selection expression is not of the wrong type.
3869 - Make sure that no case ranges overlap.
3870 - Eliminate unreachable cases and unreachable code resulting from
3871 removing case labels.
3873 The standard does allow unreachable cases, e.g. CASE (5:3). But
3874 they are a hassle for code generation, and to prevent that, we just
3875 cut them out here. This is not necessary for overlapping cases
3876 because they are illegal and we never even try to generate code.
3878 We have the additional caveat that a SELECT construct could have
3879 been a computed GOTO in the source code. Fortunately we can fairly
3880 easily work around that here: The case_expr for a "real" SELECT CASE
3881 is in code->expr1, but for a computed GOTO it is in code->expr2. All
3882 we have to do is make sure that the case_expr is a scalar integer
3886 resolve_select (gfc_code * code)
3889 gfc_expr *case_expr;
3890 gfc_case *cp, *default_case, *tail, *head;
3891 int seen_unreachable;
3897 if (code->expr == NULL)
3899 /* This was actually a computed GOTO statement. */
3900 case_expr = code->expr2;
3901 if (case_expr->ts.type != BT_INTEGER
3902 || case_expr->rank != 0)
3903 gfc_error ("Selection expression in computed GOTO statement "
3904 "at %L must be a scalar integer expression",
3907 /* Further checking is not necessary because this SELECT was built
3908 by the compiler, so it should always be OK. Just move the
3909 case_expr from expr2 to expr so that we can handle computed
3910 GOTOs as normal SELECTs from here on. */
3911 code->expr = code->expr2;
3916 case_expr = code->expr;
3918 type = case_expr->ts.type;
3919 if (type != BT_LOGICAL && type != BT_INTEGER && type != BT_CHARACTER)
3921 gfc_error ("Argument of SELECT statement at %L cannot be %s",
3922 &case_expr->where, gfc_typename (&case_expr->ts));
3924 /* Punt. Going on here just produce more garbage error messages. */
3928 if (case_expr->rank != 0)
3930 gfc_error ("Argument of SELECT statement at %L must be a scalar "
3931 "expression", &case_expr->where);
3937 /* PR 19168 has a long discussion concerning a mismatch of the kinds
3938 of the SELECT CASE expression and its CASE values. Walk the lists
3939 of case values, and if we find a mismatch, promote case_expr to
3940 the appropriate kind. */
3942 if (type == BT_LOGICAL || type == BT_INTEGER)
3944 for (body = code->block; body; body = body->block)
3946 /* Walk the case label list. */
3947 for (cp = body->ext.case_list; cp; cp = cp->next)
3949 /* Intercept the DEFAULT case. It does not have a kind. */
3950 if (cp->low == NULL && cp->high == NULL)
3953 /* Unreachable case ranges are discarded, so ignore. */
3954 if (cp->low != NULL && cp->high != NULL
3955 && cp->low != cp->high
3956 && gfc_compare_expr (cp->low, cp->high) > 0)
3959 /* FIXME: Should a warning be issued? */
3961 && case_expr->ts.kind != gfc_kind_max(case_expr, cp->low))
3962 gfc_convert_type_warn (case_expr, &cp->low->ts, 2, 0);
3964 if (cp->high != NULL
3965 && case_expr->ts.kind != gfc_kind_max(case_expr, cp->high))
3966 gfc_convert_type_warn (case_expr, &cp->high->ts, 2, 0);
3971 /* Assume there is no DEFAULT case. */
3972 default_case = NULL;
3977 for (body = code->block; body; body = body->block)
3979 /* Assume the CASE list is OK, and all CASE labels can be matched. */
3981 seen_unreachable = 0;
3983 /* Walk the case label list, making sure that all case labels
3985 for (cp = body->ext.case_list; cp; cp = cp->next)
3987 /* Count the number of cases in the whole construct. */
3990 /* Intercept the DEFAULT case. */
3991 if (cp->low == NULL && cp->high == NULL)
3993 if (default_case != NULL)
3995 gfc_error ("The DEFAULT CASE at %L cannot be followed "
3996 "by a second DEFAULT CASE at %L",
3997 &default_case->where, &cp->where);
4008 /* Deal with single value cases and case ranges. Errors are
4009 issued from the validation function. */
4010 if(validate_case_label_expr (cp->low, case_expr) != SUCCESS
4011 || validate_case_label_expr (cp->high, case_expr) != SUCCESS)
4017 if (type == BT_LOGICAL
4018 && ((cp->low == NULL || cp->high == NULL)
4019 || cp->low != cp->high))
4022 ("Logical range in CASE statement at %L is not allowed",
4028 if (type == BT_LOGICAL && cp->low->expr_type == EXPR_CONSTANT)
4031 value = cp->low->value.logical == 0 ? 2 : 1;
4032 if (value & seen_logical)
4034 gfc_error ("constant logical value in CASE statement "
4035 "is repeated at %L",
4040 seen_logical |= value;
4043 if (cp->low != NULL && cp->high != NULL
4044 && cp->low != cp->high
4045 && gfc_compare_expr (cp->low, cp->high) > 0)
4047 if (gfc_option.warn_surprising)
4048 gfc_warning ("Range specification at %L can never "
4049 "be matched", &cp->where);
4051 cp->unreachable = 1;
4052 seen_unreachable = 1;
4056 /* If the case range can be matched, it can also overlap with
4057 other cases. To make sure it does not, we put it in a
4058 double linked list here. We sort that with a merge sort
4059 later on to detect any overlapping cases. */
4063 head->right = head->left = NULL;
4068 tail->right->left = tail;
4075 /* It there was a failure in the previous case label, give up
4076 for this case label list. Continue with the next block. */
4080 /* See if any case labels that are unreachable have been seen.
4081 If so, we eliminate them. This is a bit of a kludge because
4082 the case lists for a single case statement (label) is a
4083 single forward linked lists. */
4084 if (seen_unreachable)
4086 /* Advance until the first case in the list is reachable. */
4087 while (body->ext.case_list != NULL
4088 && body->ext.case_list->unreachable)
4090 gfc_case *n = body->ext.case_list;
4091 body->ext.case_list = body->ext.case_list->next;
4093 gfc_free_case_list (n);
4096 /* Strip all other unreachable cases. */
4097 if (body->ext.case_list)
4099 for (cp = body->ext.case_list; cp->next; cp = cp->next)
4101 if (cp->next->unreachable)
4103 gfc_case *n = cp->next;
4104 cp->next = cp->next->next;
4106 gfc_free_case_list (n);
4113 /* See if there were overlapping cases. If the check returns NULL,
4114 there was overlap. In that case we don't do anything. If head
4115 is non-NULL, we prepend the DEFAULT case. The sorted list can
4116 then used during code generation for SELECT CASE constructs with
4117 a case expression of a CHARACTER type. */
4120 head = check_case_overlap (head);
4122 /* Prepend the default_case if it is there. */
4123 if (head != NULL && default_case)
4125 default_case->left = NULL;
4126 default_case->right = head;
4127 head->left = default_case;
4131 /* Eliminate dead blocks that may be the result if we've seen
4132 unreachable case labels for a block. */
4133 for (body = code; body && body->block; body = body->block)
4135 if (body->block->ext.case_list == NULL)
4137 /* Cut the unreachable block from the code chain. */
4138 gfc_code *c = body->block;
4139 body->block = c->block;
4141 /* Kill the dead block, but not the blocks below it. */
4143 gfc_free_statements (c);
4147 /* More than two cases is legal but insane for logical selects.
4148 Issue a warning for it. */
4149 if (gfc_option.warn_surprising && type == BT_LOGICAL
4151 gfc_warning ("Logical SELECT CASE block at %L has more that two cases",
4156 /* Resolve a transfer statement. This is making sure that:
4157 -- a derived type being transferred has only non-pointer components
4158 -- a derived type being transferred doesn't have private components, unless
4159 it's being transferred from the module where the type was defined
4160 -- we're not trying to transfer a whole assumed size array. */
4163 resolve_transfer (gfc_code * code)
4172 if (exp->expr_type != EXPR_VARIABLE
4173 && exp->expr_type != EXPR_FUNCTION)
4176 sym = exp->symtree->n.sym;
4179 /* Go to actual component transferred. */
4180 for (ref = code->expr->ref; ref; ref = ref->next)
4181 if (ref->type == REF_COMPONENT)
4182 ts = &ref->u.c.component->ts;
4184 if (ts->type == BT_DERIVED)
4186 /* Check that transferred derived type doesn't contain POINTER
4188 if (derived_pointer (ts->derived))
4190 gfc_error ("Data transfer element at %L cannot have "
4191 "POINTER components", &code->loc);
4195 if (ts->derived->attr.alloc_comp)
4197 gfc_error ("Data transfer element at %L cannot have "
4198 "ALLOCATABLE components", &code->loc);
4202 if (derived_inaccessible (ts->derived))
4204 gfc_error ("Data transfer element at %L cannot have "
4205 "PRIVATE components",&code->loc);
4210 if (sym->as != NULL && sym->as->type == AS_ASSUMED_SIZE
4211 && exp->ref->type == REF_ARRAY && exp->ref->u.ar.type == AR_FULL)
4213 gfc_error ("Data transfer element at %L cannot be a full reference to "
4214 "an assumed-size array", &code->loc);
4220 /*********** Toplevel code resolution subroutines ***********/
4222 /* Given a branch to a label and a namespace, if the branch is conforming.
4223 The code node described where the branch is located. */
4226 resolve_branch (gfc_st_label * label, gfc_code * code)
4228 gfc_code *block, *found;
4236 /* Step one: is this a valid branching target? */
4238 if (lp->defined == ST_LABEL_UNKNOWN)
4240 gfc_error ("Label %d referenced at %L is never defined", lp->value,
4245 if (lp->defined != ST_LABEL_TARGET)
4247 gfc_error ("Statement at %L is not a valid branch target statement "
4248 "for the branch statement at %L", &lp->where, &code->loc);
4252 /* Step two: make sure this branch is not a branch to itself ;-) */
4254 if (code->here == label)
4256 gfc_warning ("Branch at %L causes an infinite loop", &code->loc);
4260 /* Step three: Try to find the label in the parse tree. To do this,
4261 we traverse the tree block-by-block: first the block that
4262 contains this GOTO, then the block that it is nested in, etc. We
4263 can ignore other blocks because branching into another block is
4268 for (stack = cs_base; stack; stack = stack->prev)
4270 for (block = stack->head; block; block = block->next)
4272 if (block->here == label)
4285 /* The label is not in an enclosing block, so illegal. This was
4286 allowed in Fortran 66, so we allow it as extension. We also
4287 forego further checks if we run into this. */
4288 gfc_notify_std (GFC_STD_LEGACY,
4289 "Label at %L is not in the same block as the "
4290 "GOTO statement at %L", &lp->where, &code->loc);
4294 /* Step four: Make sure that the branching target is legal if
4295 the statement is an END {SELECT,DO,IF}. */
4297 if (found->op == EXEC_NOP)
4299 for (stack = cs_base; stack; stack = stack->prev)
4300 if (stack->current->next == found)
4304 gfc_notify_std (GFC_STD_F95_DEL,
4305 "Obsolete: GOTO at %L jumps to END of construct at %L",
4306 &code->loc, &found->loc);
4311 /* Check whether EXPR1 has the same shape as EXPR2. */
4314 resolve_where_shape (gfc_expr *expr1, gfc_expr *expr2)
4316 mpz_t shape[GFC_MAX_DIMENSIONS];
4317 mpz_t shape2[GFC_MAX_DIMENSIONS];
4318 try result = FAILURE;
4321 /* Compare the rank. */
4322 if (expr1->rank != expr2->rank)
4325 /* Compare the size of each dimension. */
4326 for (i=0; i<expr1->rank; i++)
4328 if (gfc_array_dimen_size (expr1, i, &shape[i]) == FAILURE)
4331 if (gfc_array_dimen_size (expr2, i, &shape2[i]) == FAILURE)
4334 if (mpz_cmp (shape[i], shape2[i]))
4338 /* When either of the two expression is an assumed size array, we
4339 ignore the comparison of dimension sizes. */
4344 for (i--; i>=0; i--)
4346 mpz_clear (shape[i]);
4347 mpz_clear (shape2[i]);
4353 /* Check whether a WHERE assignment target or a WHERE mask expression
4354 has the same shape as the outmost WHERE mask expression. */
4357 resolve_where (gfc_code *code, gfc_expr *mask)
4363 cblock = code->block;
4365 /* Store the first WHERE mask-expr of the WHERE statement or construct.
4366 In case of nested WHERE, only the outmost one is stored. */
4367 if (mask == NULL) /* outmost WHERE */
4369 else /* inner WHERE */
4376 /* Check if the mask-expr has a consistent shape with the
4377 outmost WHERE mask-expr. */
4378 if (resolve_where_shape (cblock->expr, e) == FAILURE)
4379 gfc_error ("WHERE mask at %L has inconsistent shape",
4380 &cblock->expr->where);
4383 /* the assignment statement of a WHERE statement, or the first
4384 statement in where-body-construct of a WHERE construct */
4385 cnext = cblock->next;
4390 /* WHERE assignment statement */
4393 /* Check shape consistent for WHERE assignment target. */
4394 if (e && resolve_where_shape (cnext->expr, e) == FAILURE)
4395 gfc_error ("WHERE assignment target at %L has "
4396 "inconsistent shape", &cnext->expr->where);
4399 /* WHERE or WHERE construct is part of a where-body-construct */
4401 resolve_where (cnext, e);
4405 gfc_error ("Unsupported statement inside WHERE at %L",
4408 /* the next statement within the same where-body-construct */
4409 cnext = cnext->next;
4411 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
4412 cblock = cblock->block;
4417 /* Check whether the FORALL index appears in the expression or not. */
4420 gfc_find_forall_index (gfc_expr *expr, gfc_symbol *symbol)
4424 gfc_actual_arglist *args;
4427 switch (expr->expr_type)
4430 gcc_assert (expr->symtree->n.sym);
4432 /* A scalar assignment */
4435 if (expr->symtree->n.sym == symbol)
4441 /* the expr is array ref, substring or struct component. */
4448 /* Check if the symbol appears in the array subscript. */
4450 for (i = 0; i < GFC_MAX_DIMENSIONS; i++)
4453 if (gfc_find_forall_index (ar.start[i], symbol) == SUCCESS)
4457 if (gfc_find_forall_index (ar.end[i], symbol) == SUCCESS)
4461 if (gfc_find_forall_index (ar.stride[i], symbol) == SUCCESS)
4467 if (expr->symtree->n.sym == symbol)
4470 /* Check if the symbol appears in the substring section. */
4471 if (gfc_find_forall_index (tmp->u.ss.start, symbol) == SUCCESS)
4473 if (gfc_find_forall_index (tmp->u.ss.end, symbol) == SUCCESS)
4481 gfc_error("expression reference type error at %L", &expr->where);
4487 /* If the expression is a function call, then check if the symbol
4488 appears in the actual arglist of the function. */
4490 for (args = expr->value.function.actual; args; args = args->next)
4492 if (gfc_find_forall_index(args->expr,symbol) == SUCCESS)
4497 /* It seems not to happen. */
4498 case EXPR_SUBSTRING:
4502 gcc_assert (expr->ref->type == REF_SUBSTRING);
4503 if (gfc_find_forall_index (tmp->u.ss.start, symbol) == SUCCESS)
4505 if (gfc_find_forall_index (tmp->u.ss.end, symbol) == SUCCESS)
4510 /* It seems not to happen. */
4511 case EXPR_STRUCTURE:
4513 gfc_error ("Unsupported statement while finding forall index in "
4518 /* Find the FORALL index in the first operand. */
4519 if (expr->value.op.op1)
4521 if (gfc_find_forall_index (expr->value.op.op1, symbol) == SUCCESS)
4525 /* Find the FORALL index in the second operand. */
4526 if (expr->value.op.op2)
4528 if (gfc_find_forall_index (expr->value.op.op2, symbol) == SUCCESS)
4541 /* Resolve assignment in FORALL construct.
4542 NVAR is the number of FORALL index variables, and VAR_EXPR records the
4543 FORALL index variables. */
4546 gfc_resolve_assign_in_forall (gfc_code *code, int nvar, gfc_expr **var_expr)
4550 for (n = 0; n < nvar; n++)
4552 gfc_symbol *forall_index;
4554 forall_index = var_expr[n]->symtree->n.sym;
4556 /* Check whether the assignment target is one of the FORALL index
4558 if ((code->expr->expr_type == EXPR_VARIABLE)
4559 && (code->expr->symtree->n.sym == forall_index))
4560 gfc_error ("Assignment to a FORALL index variable at %L",
4561 &code->expr->where);
4564 /* If one of the FORALL index variables doesn't appear in the
4565 assignment target, then there will be a many-to-one
4567 if (gfc_find_forall_index (code->expr, forall_index) == FAILURE)
4568 gfc_error ("The FORALL with index '%s' cause more than one "
4569 "assignment to this object at %L",
4570 var_expr[n]->symtree->name, &code->expr->where);
4576 /* Resolve WHERE statement in FORALL construct. */
4579 gfc_resolve_where_code_in_forall (gfc_code *code, int nvar, gfc_expr **var_expr){
4583 cblock = code->block;
4586 /* the assignment statement of a WHERE statement, or the first
4587 statement in where-body-construct of a WHERE construct */
4588 cnext = cblock->next;
4593 /* WHERE assignment statement */
4595 gfc_resolve_assign_in_forall (cnext, nvar, var_expr);
4598 /* WHERE or WHERE construct is part of a where-body-construct */
4600 gfc_resolve_where_code_in_forall (cnext, nvar, var_expr);
4604 gfc_error ("Unsupported statement inside WHERE at %L",
4607 /* the next statement within the same where-body-construct */
4608 cnext = cnext->next;
4610 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
4611 cblock = cblock->block;
4616 /* Traverse the FORALL body to check whether the following errors exist:
4617 1. For assignment, check if a many-to-one assignment happens.
4618 2. For WHERE statement, check the WHERE body to see if there is any
4619 many-to-one assignment. */
4622 gfc_resolve_forall_body (gfc_code *code, int nvar, gfc_expr **var_expr)
4626 c = code->block->next;
4632 case EXEC_POINTER_ASSIGN:
4633 gfc_resolve_assign_in_forall (c, nvar, var_expr);
4636 /* Because the gfc_resolve_blocks() will handle the nested FORALL,
4637 there is no need to handle it here. */
4641 gfc_resolve_where_code_in_forall(c, nvar, var_expr);
4646 /* The next statement in the FORALL body. */
4652 /* Given a FORALL construct, first resolve the FORALL iterator, then call
4653 gfc_resolve_forall_body to resolve the FORALL body. */
4656 gfc_resolve_forall (gfc_code *code, gfc_namespace *ns, int forall_save)
4658 static gfc_expr **var_expr;
4659 static int total_var = 0;
4660 static int nvar = 0;
4661 gfc_forall_iterator *fa;
4662 gfc_symbol *forall_index;
4666 /* Start to resolve a FORALL construct */
4667 if (forall_save == 0)
4669 /* Count the total number of FORALL index in the nested FORALL
4670 construct in order to allocate the VAR_EXPR with proper size. */
4672 while ((next != NULL) && (next->op == EXEC_FORALL))
4674 for (fa = next->ext.forall_iterator; fa; fa = fa->next)
4676 next = next->block->next;
4679 /* Allocate VAR_EXPR with NUMBER_OF_FORALL_INDEX elements. */
4680 var_expr = (gfc_expr **) gfc_getmem (total_var * sizeof (gfc_expr *));
4683 /* The information about FORALL iterator, including FORALL index start, end
4684 and stride. The FORALL index can not appear in start, end or stride. */
4685 for (fa = code->ext.forall_iterator; fa; fa = fa->next)
4687 /* Check if any outer FORALL index name is the same as the current
4689 for (i = 0; i < nvar; i++)
4691 if (fa->var->symtree->n.sym == var_expr[i]->symtree->n.sym)
4693 gfc_error ("An outer FORALL construct already has an index "
4694 "with this name %L", &fa->var->where);
4698 /* Record the current FORALL index. */
4699 var_expr[nvar] = gfc_copy_expr (fa->var);
4701 forall_index = fa->var->symtree->n.sym;
4703 /* Check if the FORALL index appears in start, end or stride. */
4704 if (gfc_find_forall_index (fa->start, forall_index) == SUCCESS)
4705 gfc_error ("A FORALL index must not appear in a limit or stride "
4706 "expression in the same FORALL at %L", &fa->start->where);
4707 if (gfc_find_forall_index (fa->end, forall_index) == SUCCESS)
4708 gfc_error ("A FORALL index must not appear in a limit or stride "
4709 "expression in the same FORALL at %L", &fa->end->where);
4710 if (gfc_find_forall_index (fa->stride, forall_index) == SUCCESS)
4711 gfc_error ("A FORALL index must not appear in a limit or stride "
4712 "expression in the same FORALL at %L", &fa->stride->where);
4716 /* Resolve the FORALL body. */
4717 gfc_resolve_forall_body (code, nvar, var_expr);
4719 /* May call gfc_resolve_forall to resolve the inner FORALL loop. */
4720 gfc_resolve_blocks (code->block, ns);
4722 /* Free VAR_EXPR after the whole FORALL construct resolved. */
4723 for (i = 0; i < total_var; i++)
4724 gfc_free_expr (var_expr[i]);
4726 /* Reset the counters. */
4732 /* Resolve lists of blocks found in IF, SELECT CASE, WHERE, FORALL ,GOTO and
4735 static void resolve_code (gfc_code *, gfc_namespace *);
4738 gfc_resolve_blocks (gfc_code * b, gfc_namespace * ns)
4742 for (; b; b = b->block)
4744 t = gfc_resolve_expr (b->expr);
4745 if (gfc_resolve_expr (b->expr2) == FAILURE)
4751 if (t == SUCCESS && b->expr != NULL
4752 && (b->expr->ts.type != BT_LOGICAL || b->expr->rank != 0))
4754 ("IF clause at %L requires a scalar LOGICAL expression",
4761 && (b->expr->ts.type != BT_LOGICAL
4762 || b->expr->rank == 0))
4764 ("WHERE/ELSEWHERE clause at %L requires a LOGICAL array",
4769 resolve_branch (b->label, b);
4781 case EXEC_OMP_ATOMIC:
4782 case EXEC_OMP_CRITICAL:
4784 case EXEC_OMP_MASTER:
4785 case EXEC_OMP_ORDERED:
4786 case EXEC_OMP_PARALLEL:
4787 case EXEC_OMP_PARALLEL_DO:
4788 case EXEC_OMP_PARALLEL_SECTIONS:
4789 case EXEC_OMP_PARALLEL_WORKSHARE:
4790 case EXEC_OMP_SECTIONS:
4791 case EXEC_OMP_SINGLE:
4792 case EXEC_OMP_WORKSHARE:
4796 gfc_internal_error ("resolve_block(): Bad block type");
4799 resolve_code (b->next, ns);
4804 /* Given a block of code, recursively resolve everything pointed to by this
4808 resolve_code (gfc_code * code, gfc_namespace * ns)
4810 int omp_workshare_save;
4816 frame.prev = cs_base;
4820 for (; code; code = code->next)
4822 frame.current = code;
4823 forall_save = forall_flag;
4825 if (code->op == EXEC_FORALL)
4828 gfc_resolve_forall (code, ns, forall_save);
4831 else if (code->block)
4833 omp_workshare_save = -1;
4836 case EXEC_OMP_PARALLEL_WORKSHARE:
4837 omp_workshare_save = omp_workshare_flag;
4838 omp_workshare_flag = 1;
4839 gfc_resolve_omp_parallel_blocks (code, ns);
4841 case EXEC_OMP_PARALLEL:
4842 case EXEC_OMP_PARALLEL_DO:
4843 case EXEC_OMP_PARALLEL_SECTIONS:
4844 omp_workshare_save = omp_workshare_flag;
4845 omp_workshare_flag = 0;
4846 gfc_resolve_omp_parallel_blocks (code, ns);
4849 gfc_resolve_omp_do_blocks (code, ns);
4851 case EXEC_OMP_WORKSHARE:
4852 omp_workshare_save = omp_workshare_flag;
4853 omp_workshare_flag = 1;
4856 gfc_resolve_blocks (code->block, ns);
4860 if (omp_workshare_save != -1)
4861 omp_workshare_flag = omp_workshare_save;
4864 t = gfc_resolve_expr (code->expr);
4865 forall_flag = forall_save;
4867 if (gfc_resolve_expr (code->expr2) == FAILURE)
4882 /* Keep track of which entry we are up to. */
4883 current_entry_id = code->ext.entry->id;
4887 resolve_where (code, NULL);
4891 if (code->expr != NULL)
4893 if (code->expr->ts.type != BT_INTEGER)
4894 gfc_error ("ASSIGNED GOTO statement at %L requires an INTEGER "
4895 "variable", &code->expr->where);
4896 else if (code->expr->symtree->n.sym->attr.assign != 1)
4897 gfc_error ("Variable '%s' has not been assigned a target label "
4898 "at %L", code->expr->symtree->n.sym->name,
4899 &code->expr->where);
4902 resolve_branch (code->label, code);
4906 if (code->expr != NULL
4907 && (code->expr->ts.type != BT_INTEGER || code->expr->rank))
4908 gfc_error ("Alternate RETURN statement at %L requires a SCALAR-"
4909 "INTEGER return specifier", &code->expr->where);
4912 case EXEC_INIT_ASSIGN:
4919 if (gfc_extend_assign (code, ns) == SUCCESS)
4921 if (gfc_pure (NULL) && !gfc_pure (code->symtree->n.sym))
4923 gfc_error ("Subroutine '%s' called instead of assignment at "
4924 "%L must be PURE", code->symtree->n.sym->name,
4931 if (gfc_pure (NULL))
4933 if (gfc_impure_variable (code->expr->symtree->n.sym))
4936 ("Cannot assign to variable '%s' in PURE procedure at %L",
4937 code->expr->symtree->n.sym->name, &code->expr->where);
4941 if (code->expr2->ts.type == BT_DERIVED
4942 && derived_pointer (code->expr2->ts.derived))
4945 ("Right side of assignment at %L is a derived type "
4946 "containing a POINTER in a PURE procedure",
4947 &code->expr2->where);
4952 gfc_check_assign (code->expr, code->expr2, 1);
4955 case EXEC_LABEL_ASSIGN:
4956 if (code->label->defined == ST_LABEL_UNKNOWN)
4957 gfc_error ("Label %d referenced at %L is never defined",
4958 code->label->value, &code->label->where);
4960 && (code->expr->expr_type != EXPR_VARIABLE
4961 || code->expr->symtree->n.sym->ts.type != BT_INTEGER
4962 || code->expr->symtree->n.sym->ts.kind
4963 != gfc_default_integer_kind
4964 || code->expr->symtree->n.sym->as != NULL))
4965 gfc_error ("ASSIGN statement at %L requires a scalar "
4966 "default INTEGER variable", &code->expr->where);
4969 case EXEC_POINTER_ASSIGN:
4973 gfc_check_pointer_assign (code->expr, code->expr2);
4976 case EXEC_ARITHMETIC_IF:
4978 && code->expr->ts.type != BT_INTEGER
4979 && code->expr->ts.type != BT_REAL)
4980 gfc_error ("Arithmetic IF statement at %L requires a numeric "
4981 "expression", &code->expr->where);
4983 resolve_branch (code->label, code);
4984 resolve_branch (code->label2, code);
4985 resolve_branch (code->label3, code);
4989 if (t == SUCCESS && code->expr != NULL
4990 && (code->expr->ts.type != BT_LOGICAL
4991 || code->expr->rank != 0))
4992 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
4993 &code->expr->where);
4998 resolve_call (code);
5002 /* Select is complicated. Also, a SELECT construct could be
5003 a transformed computed GOTO. */
5004 resolve_select (code);
5008 if (code->ext.iterator != NULL)
5010 gfc_iterator *iter = code->ext.iterator;
5011 if (gfc_resolve_iterator (iter, true) != FAILURE)
5012 gfc_resolve_do_iterator (code, iter->var->symtree->n.sym);
5017 if (code->expr == NULL)
5018 gfc_internal_error ("resolve_code(): No expression on DO WHILE");
5020 && (code->expr->rank != 0
5021 || code->expr->ts.type != BT_LOGICAL))
5022 gfc_error ("Exit condition of DO WHILE loop at %L must be "
5023 "a scalar LOGICAL expression", &code->expr->where);
5027 if (t == SUCCESS && code->expr != NULL
5028 && code->expr->ts.type != BT_INTEGER)
5029 gfc_error ("STAT tag in ALLOCATE statement at %L must be "
5030 "of type INTEGER", &code->expr->where);
5032 for (a = code->ext.alloc_list; a; a = a->next)
5033 resolve_allocate_expr (a->expr, code);
5037 case EXEC_DEALLOCATE:
5038 if (t == SUCCESS && code->expr != NULL
5039 && code->expr->ts.type != BT_INTEGER)
5041 ("STAT tag in DEALLOCATE statement at %L must be of type "
5042 "INTEGER", &code->expr->where);
5044 for (a = code->ext.alloc_list; a; a = a->next)
5045 resolve_deallocate_expr (a->expr);
5050 if (gfc_resolve_open (code->ext.open) == FAILURE)
5053 resolve_branch (code->ext.open->err, code);
5057 if (gfc_resolve_close (code->ext.close) == FAILURE)
5060 resolve_branch (code->ext.close->err, code);
5063 case EXEC_BACKSPACE:
5067 if (gfc_resolve_filepos (code->ext.filepos) == FAILURE)
5070 resolve_branch (code->ext.filepos->err, code);
5074 if (gfc_resolve_inquire (code->ext.inquire) == FAILURE)
5077 resolve_branch (code->ext.inquire->err, code);
5081 gcc_assert (code->ext.inquire != NULL);
5082 if (gfc_resolve_inquire (code->ext.inquire) == FAILURE)
5085 resolve_branch (code->ext.inquire->err, code);
5090 if (gfc_resolve_dt (code->ext.dt) == FAILURE)
5093 resolve_branch (code->ext.dt->err, code);
5094 resolve_branch (code->ext.dt->end, code);
5095 resolve_branch (code->ext.dt->eor, code);
5099 resolve_transfer (code);
5103 resolve_forall_iterators (code->ext.forall_iterator);
5105 if (code->expr != NULL && code->expr->ts.type != BT_LOGICAL)
5107 ("FORALL mask clause at %L requires a LOGICAL expression",
5108 &code->expr->where);
5111 case EXEC_OMP_ATOMIC:
5112 case EXEC_OMP_BARRIER:
5113 case EXEC_OMP_CRITICAL:
5114 case EXEC_OMP_FLUSH:
5116 case EXEC_OMP_MASTER:
5117 case EXEC_OMP_ORDERED:
5118 case EXEC_OMP_SECTIONS:
5119 case EXEC_OMP_SINGLE:
5120 case EXEC_OMP_WORKSHARE:
5121 gfc_resolve_omp_directive (code, ns);
5124 case EXEC_OMP_PARALLEL:
5125 case EXEC_OMP_PARALLEL_DO:
5126 case EXEC_OMP_PARALLEL_SECTIONS:
5127 case EXEC_OMP_PARALLEL_WORKSHARE:
5128 omp_workshare_save = omp_workshare_flag;
5129 omp_workshare_flag = 0;
5130 gfc_resolve_omp_directive (code, ns);
5131 omp_workshare_flag = omp_workshare_save;
5135 gfc_internal_error ("resolve_code(): Bad statement code");
5139 cs_base = frame.prev;
5143 /* Resolve initial values and make sure they are compatible with
5147 resolve_values (gfc_symbol * sym)
5150 if (sym->value == NULL)
5153 if (gfc_resolve_expr (sym->value) == FAILURE)
5156 gfc_check_assign_symbol (sym, sym->value);
5160 /* Resolve an index expression. */
5163 resolve_index_expr (gfc_expr * e)
5165 if (gfc_resolve_expr (e) == FAILURE)
5168 if (gfc_simplify_expr (e, 0) == FAILURE)
5171 if (gfc_specification_expr (e) == FAILURE)
5177 /* Resolve a charlen structure. */
5180 resolve_charlen (gfc_charlen *cl)
5187 specification_expr = 1;
5189 if (resolve_index_expr (cl->length) == FAILURE)
5191 specification_expr = 0;
5199 /* Test for non-constant shape arrays. */
5202 is_non_constant_shape_array (gfc_symbol *sym)
5208 not_constant = false;
5209 if (sym->as != NULL)
5211 /* Unfortunately, !gfc_is_compile_time_shape hits a legal case that
5212 has not been simplified; parameter array references. Do the
5213 simplification now. */
5214 for (i = 0; i < sym->as->rank; i++)
5216 e = sym->as->lower[i];
5217 if (e && (resolve_index_expr (e) == FAILURE
5218 || !gfc_is_constant_expr (e)))
5219 not_constant = true;
5221 e = sym->as->upper[i];
5222 if (e && (resolve_index_expr (e) == FAILURE
5223 || !gfc_is_constant_expr (e)))
5224 not_constant = true;
5227 return not_constant;
5231 /* Assign the default initializer to a derived type variable or result. */
5234 apply_default_init (gfc_symbol *sym)
5237 gfc_expr *init = NULL;
5239 gfc_namespace *ns = sym->ns;
5241 if (sym->attr.flavor != FL_VARIABLE && !sym->attr.function)
5244 if (sym->ts.type == BT_DERIVED && sym->ts.derived)
5245 init = gfc_default_initializer (&sym->ts);
5250 /* Search for the function namespace if this is a contained
5251 function without an explicit result. */
5252 if (sym->attr.function && sym == sym->result
5253 && sym->name != sym->ns->proc_name->name)
5256 for (;ns; ns = ns->sibling)
5257 if (strcmp (ns->proc_name->name, sym->name) == 0)
5263 gfc_free_expr (init);
5267 /* Build an l-value expression for the result. */
5268 lval = gfc_get_expr ();
5269 lval->expr_type = EXPR_VARIABLE;
5270 lval->where = sym->declared_at;
5272 lval->symtree = gfc_find_symtree (sym->ns->sym_root, sym->name);
5274 /* It will always be a full array. */
5275 lval->rank = sym->as ? sym->as->rank : 0;
5278 lval->ref = gfc_get_ref ();
5279 lval->ref->type = REF_ARRAY;
5280 lval->ref->u.ar.type = AR_FULL;
5281 lval->ref->u.ar.dimen = lval->rank;
5282 lval->ref->u.ar.where = sym->declared_at;
5283 lval->ref->u.ar.as = sym->as;
5286 /* Add the code at scope entry. */
5287 init_st = gfc_get_code ();
5288 init_st->next = ns->code;
5291 /* Assign the default initializer to the l-value. */
5292 init_st->loc = sym->declared_at;
5293 init_st->op = EXEC_INIT_ASSIGN;
5294 init_st->expr = lval;
5295 init_st->expr2 = init;
5299 /* Resolution of common features of flavors variable and procedure. */
5302 resolve_fl_var_and_proc (gfc_symbol *sym, int mp_flag)
5304 /* Constraints on deferred shape variable. */
5305 if (sym->as == NULL || sym->as->type != AS_DEFERRED)
5307 if (sym->attr.allocatable)
5309 if (sym->attr.dimension)
5310 gfc_error ("Allocatable array '%s' at %L must have "
5311 "a deferred shape", sym->name, &sym->declared_at);
5313 gfc_error ("Scalar object '%s' at %L may not be ALLOCATABLE",
5314 sym->name, &sym->declared_at);
5318 if (sym->attr.pointer && sym->attr.dimension)
5320 gfc_error ("Array pointer '%s' at %L must have a deferred shape",
5321 sym->name, &sym->declared_at);
5328 if (!mp_flag && !sym->attr.allocatable
5329 && !sym->attr.pointer && !sym->attr.dummy)
5331 gfc_error ("Array '%s' at %L cannot have a deferred shape",
5332 sym->name, &sym->declared_at);
5339 /* Resolve symbols with flavor variable. */
5342 resolve_fl_variable (gfc_symbol *sym, int mp_flag)
5347 gfc_expr *constructor_expr;
5348 const char * auto_save_msg;
5350 auto_save_msg = "automatic object '%s' at %L cannot have the "
5353 if (resolve_fl_var_and_proc (sym, mp_flag) == FAILURE)
5356 /* Set this flag to check that variables are parameters of all entries.
5357 This check is effected by the call to gfc_resolve_expr through
5358 is_non_constant_shape_array. */
5359 specification_expr = 1;
5361 if (!sym->attr.use_assoc
5362 && !sym->attr.allocatable
5363 && !sym->attr.pointer
5364 && is_non_constant_shape_array (sym))
5366 /* The shape of a main program or module array needs to be constant. */
5367 if (sym->ns->proc_name
5368 && (sym->ns->proc_name->attr.flavor == FL_MODULE
5369 || sym->ns->proc_name->attr.is_main_program))
5371 gfc_error ("The module or main program array '%s' at %L must "
5372 "have constant shape", sym->name, &sym->declared_at);
5373 specification_expr = 0;
5378 if (sym->ts.type == BT_CHARACTER)
5380 /* Make sure that character string variables with assumed length are
5382 e = sym->ts.cl->length;
5383 if (e == NULL && !sym->attr.dummy && !sym->attr.result)
5385 gfc_error ("Entity with assumed character length at %L must be a "
5386 "dummy argument or a PARAMETER", &sym->declared_at);
5390 if (e && sym->attr.save && !gfc_is_constant_expr (e))
5392 gfc_error (auto_save_msg, sym->name, &sym->declared_at);
5396 if (!gfc_is_constant_expr (e)
5397 && !(e->expr_type == EXPR_VARIABLE
5398 && e->symtree->n.sym->attr.flavor == FL_PARAMETER)
5399 && sym->ns->proc_name
5400 && (sym->ns->proc_name->attr.flavor == FL_MODULE
5401 || sym->ns->proc_name->attr.is_main_program)
5402 && !sym->attr.use_assoc)
5404 gfc_error ("'%s' at %L must have constant character length "
5405 "in this context", sym->name, &sym->declared_at);
5410 /* Can the symbol have an initializer? */
5412 if (sym->attr.allocatable || sym->attr.external || sym->attr.dummy
5413 || sym->attr.intrinsic || sym->attr.result)
5415 else if (sym->attr.dimension && !sym->attr.pointer)
5417 /* Don't allow initialization of automatic arrays. */
5418 for (i = 0; i < sym->as->rank; i++)
5420 if (sym->as->lower[i] == NULL
5421 || sym->as->lower[i]->expr_type != EXPR_CONSTANT
5422 || sym->as->upper[i] == NULL
5423 || sym->as->upper[i]->expr_type != EXPR_CONSTANT)
5430 /* Also, they must not have the SAVE attribute. */
5431 if (flag && sym->attr.save)
5433 gfc_error (auto_save_msg, sym->name, &sym->declared_at);
5438 /* Reject illegal initializers. */
5439 if (sym->value && flag)
5441 if (sym->attr.allocatable)
5442 gfc_error ("Allocatable '%s' at %L cannot have an initializer",
5443 sym->name, &sym->declared_at);
5444 else if (sym->attr.external)
5445 gfc_error ("External '%s' at %L cannot have an initializer",
5446 sym->name, &sym->declared_at);
5447 else if (sym->attr.dummy)
5448 gfc_error ("Dummy '%s' at %L cannot have an initializer",
5449 sym->name, &sym->declared_at);
5450 else if (sym->attr.intrinsic)
5451 gfc_error ("Intrinsic '%s' at %L cannot have an initializer",
5452 sym->name, &sym->declared_at);
5453 else if (sym->attr.result)
5454 gfc_error ("Function result '%s' at %L cannot have an initializer",
5455 sym->name, &sym->declared_at);
5457 gfc_error ("Automatic array '%s' at %L cannot have an initializer",
5458 sym->name, &sym->declared_at);
5462 /* Check to see if a derived type is blocked from being host associated
5463 by the presence of another class I symbol in the same namespace.
5464 14.6.1.3 of the standard and the discussion on comp.lang.fortran. */
5465 if (sym->ts.type == BT_DERIVED && sym->ns != sym->ts.derived->ns)
5468 gfc_find_symbol (sym->ts.derived->name, sym->ns, 0, &s);
5469 if (s && (s->attr.flavor != FL_DERIVED
5470 || !gfc_compare_derived_types (s, sym->ts.derived)))
5472 gfc_error ("The type %s cannot be host associated at %L because "
5473 "it is blocked by an incompatible object of the same "
5474 "name at %L", sym->ts.derived->name, &sym->declared_at,
5480 /* 4th constraint in section 11.3: "If an object of a type for which
5481 component-initialization is specified (R429) appears in the
5482 specification-part of a module and does not have the ALLOCATABLE
5483 or POINTER attribute, the object shall have the SAVE attribute." */
5485 constructor_expr = NULL;
5486 if (sym->ts.type == BT_DERIVED && !(sym->value || flag))
5487 constructor_expr = gfc_default_initializer (&sym->ts);
5489 if (sym->ns->proc_name
5490 && sym->ns->proc_name->attr.flavor == FL_MODULE
5492 && !sym->ns->save_all && !sym->attr.save
5493 && !sym->attr.pointer && !sym->attr.allocatable)
5495 gfc_error("Object '%s' at %L must have the SAVE attribute %s",
5496 sym->name, &sym->declared_at,
5497 "for default initialization of a component");
5501 /* Assign default initializer. */
5502 if (sym->ts.type == BT_DERIVED
5504 && !sym->attr.pointer
5505 && !sym->attr.allocatable
5506 && (!flag || sym->attr.intent == INTENT_OUT))
5507 sym->value = gfc_default_initializer (&sym->ts);
5513 /* Resolve a procedure. */
5516 resolve_fl_procedure (gfc_symbol *sym, int mp_flag)
5518 gfc_formal_arglist *arg;
5521 if (sym->attr.function
5522 && resolve_fl_var_and_proc (sym, mp_flag) == FAILURE)
5525 st = gfc_find_symtree (gfc_current_ns->sym_root, sym->name);
5526 if (st && st->ambiguous
5527 && sym->attr.referenced
5528 && !sym->attr.generic)
5530 gfc_error ("Procedure %s at %L is ambiguous",
5531 sym->name, &sym->declared_at);
5535 if (sym->ts.type == BT_CHARACTER)
5537 gfc_charlen *cl = sym->ts.cl;
5538 if (!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT)
5540 if (sym->attr.proc == PROC_ST_FUNCTION)
5542 gfc_error ("Character-valued statement function '%s' at %L must "
5543 "have constant length", sym->name, &sym->declared_at);
5547 if (sym->attr.external && sym->formal == NULL
5548 && cl && cl->length && cl->length->expr_type != EXPR_CONSTANT)
5550 gfc_error ("Automatic character length function '%s' at %L must "
5551 "have an explicit interface", sym->name, &sym->declared_at);
5557 /* Ensure that derived type for are not of a private type. Internal
5558 module procedures are excluded by 2.2.3.3 - ie. they are not
5559 externally accessible and can access all the objects accessible in
5561 if (!(sym->ns->parent
5562 && sym->ns->parent->proc_name->attr.flavor == FL_MODULE)
5563 && gfc_check_access(sym->attr.access, sym->ns->default_access))
5565 for (arg = sym->formal; arg; arg = arg->next)
5568 && arg->sym->ts.type == BT_DERIVED
5569 && !arg->sym->ts.derived->attr.use_assoc
5570 && !gfc_check_access(arg->sym->ts.derived->attr.access,
5571 arg->sym->ts.derived->ns->default_access))
5573 gfc_error_now ("'%s' is of a PRIVATE type and cannot be "
5574 "a dummy argument of '%s', which is "
5575 "PUBLIC at %L", arg->sym->name, sym->name,
5577 /* Stop this message from recurring. */
5578 arg->sym->ts.derived->attr.access = ACCESS_PUBLIC;
5584 /* An external symbol may not have an initializer because it is taken to be
5586 if (sym->attr.external && sym->value)
5588 gfc_error ("External object '%s' at %L may not have an initializer",
5589 sym->name, &sym->declared_at);
5593 /* An elemental function is required to return a scalar 12.7.1 */
5594 if (sym->attr.elemental && sym->attr.function && sym->as)
5596 gfc_error ("ELEMENTAL function '%s' at %L must have a scalar "
5597 "result", sym->name, &sym->declared_at);
5598 /* Reset so that the error only occurs once. */
5599 sym->attr.elemental = 0;
5603 /* 5.1.1.5 of the Standard: A function name declared with an asterisk
5604 char-len-param shall not be array-valued, pointer-valued, recursive
5605 or pure. ....snip... A character value of * may only be used in the
5606 following ways: (i) Dummy arg of procedure - dummy associates with
5607 actual length; (ii) To declare a named constant; or (iii) External
5608 function - but length must be declared in calling scoping unit. */
5609 if (sym->attr.function
5610 && sym->ts.type == BT_CHARACTER
5611 && sym->ts.cl && sym->ts.cl->length == NULL)
5613 if ((sym->as && sym->as->rank) || (sym->attr.pointer)
5614 || (sym->attr.recursive) || (sym->attr.pure))
5616 if (sym->as && sym->as->rank)
5617 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
5618 "array-valued", sym->name, &sym->declared_at);
5620 if (sym->attr.pointer)
5621 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
5622 "pointer-valued", sym->name, &sym->declared_at);
5625 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
5626 "pure", sym->name, &sym->declared_at);
5628 if (sym->attr.recursive)
5629 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
5630 "recursive", sym->name, &sym->declared_at);
5635 /* Appendix B.2 of the standard. Contained functions give an
5636 error anyway. Fixed-form is likely to be F77/legacy. */
5637 if (!sym->attr.contained && gfc_current_form != FORM_FIXED)
5638 gfc_notify_std (GFC_STD_F95_OBS, "CHARACTER(*) function "
5639 "'%s' at %L is obsolescent in fortran 95",
5640 sym->name, &sym->declared_at);
5646 /* Resolve the components of a derived type. */
5649 resolve_fl_derived (gfc_symbol *sym)
5652 gfc_dt_list * dt_list;
5655 for (c = sym->components; c != NULL; c = c->next)
5657 if (c->ts.type == BT_CHARACTER)
5659 if (c->ts.cl->length == NULL
5660 || (resolve_charlen (c->ts.cl) == FAILURE)
5661 || !gfc_is_constant_expr (c->ts.cl->length))
5663 gfc_error ("Character length of component '%s' needs to "
5664 "be a constant specification expression at %L",
5666 c->ts.cl->length ? &c->ts.cl->length->where : &c->loc);
5671 if (c->ts.type == BT_DERIVED
5672 && sym->component_access != ACCESS_PRIVATE
5673 && gfc_check_access(sym->attr.access, sym->ns->default_access)
5674 && !c->ts.derived->attr.use_assoc
5675 && !gfc_check_access(c->ts.derived->attr.access,
5676 c->ts.derived->ns->default_access))
5678 gfc_error ("The component '%s' is a PRIVATE type and cannot be "
5679 "a component of '%s', which is PUBLIC at %L",
5680 c->name, sym->name, &sym->declared_at);
5684 if (sym->attr.sequence)
5686 if (c->ts.type == BT_DERIVED && c->ts.derived->attr.sequence == 0)
5688 gfc_error ("Component %s of SEQUENCE type declared at %L does "
5689 "not have the SEQUENCE attribute",
5690 c->ts.derived->name, &sym->declared_at);
5695 if (c->ts.type == BT_DERIVED && c->pointer
5696 && c->ts.derived->components == NULL)
5698 gfc_error ("The pointer component '%s' of '%s' at %L is a type "
5699 "that has not been declared", c->name, sym->name,
5704 if (c->pointer || c->allocatable || c->as == NULL)
5707 for (i = 0; i < c->as->rank; i++)
5709 if (c->as->lower[i] == NULL
5710 || !gfc_is_constant_expr (c->as->lower[i])
5711 || (resolve_index_expr (c->as->lower[i]) == FAILURE)
5712 || c->as->upper[i] == NULL
5713 || (resolve_index_expr (c->as->upper[i]) == FAILURE)
5714 || !gfc_is_constant_expr (c->as->upper[i]))
5716 gfc_error ("Component '%s' of '%s' at %L must have "
5717 "constant array bounds",
5718 c->name, sym->name, &c->loc);
5724 /* Add derived type to the derived type list. */
5725 for (dt_list = sym->ns->derived_types; dt_list; dt_list = dt_list->next)
5726 if (sym == dt_list->derived)
5729 if (dt_list == NULL)
5731 dt_list = gfc_get_dt_list ();
5732 dt_list->next = sym->ns->derived_types;
5733 dt_list->derived = sym;
5734 sym->ns->derived_types = dt_list;
5742 resolve_fl_namelist (gfc_symbol *sym)
5747 /* Reject PRIVATE objects in a PUBLIC namelist. */
5748 if (gfc_check_access(sym->attr.access, sym->ns->default_access))
5750 for (nl = sym->namelist; nl; nl = nl->next)
5752 if (!nl->sym->attr.use_assoc
5753 && !(sym->ns->parent == nl->sym->ns)
5754 && !gfc_check_access(nl->sym->attr.access,
5755 nl->sym->ns->default_access))
5757 gfc_error ("PRIVATE symbol '%s' cannot be member of "
5758 "PUBLIC namelist at %L", nl->sym->name,
5765 /* Reject namelist arrays that are not constant shape. */
5766 for (nl = sym->namelist; nl; nl = nl->next)
5768 if (is_non_constant_shape_array (nl->sym))
5770 gfc_error ("The array '%s' must have constant shape to be "
5771 "a NAMELIST object at %L", nl->sym->name,
5777 /* Namelist objects cannot have allocatable components. */
5778 for (nl = sym->namelist; nl; nl = nl->next)
5780 if (nl->sym->ts.type == BT_DERIVED
5781 && nl->sym->ts.derived->attr.alloc_comp)
5783 gfc_error ("NAMELIST object '%s' at %L cannot have ALLOCATABLE "
5784 "components", nl->sym->name, &sym->declared_at);
5789 /* 14.1.2 A module or internal procedure represent local entities
5790 of the same type as a namelist member and so are not allowed.
5791 Note that this is sometimes caught by check_conflict so the
5792 same message has been used. */
5793 for (nl = sym->namelist; nl; nl = nl->next)
5795 if (nl->sym->ts.kind != 0 && nl->sym->attr.flavor == FL_VARIABLE)
5798 if (sym->ns->parent && nl->sym && nl->sym->name)
5799 gfc_find_symbol (nl->sym->name, sym->ns->parent, 0, &nlsym);
5800 if (nlsym && nlsym->attr.flavor == FL_PROCEDURE)
5802 gfc_error ("PROCEDURE attribute conflicts with NAMELIST "
5803 "attribute in '%s' at %L", nlsym->name,
5814 resolve_fl_parameter (gfc_symbol *sym)
5816 /* A parameter array's shape needs to be constant. */
5817 if (sym->as != NULL && !gfc_is_compile_time_shape (sym->as))
5819 gfc_error ("Parameter array '%s' at %L cannot be automatic "
5820 "or assumed shape", sym->name, &sym->declared_at);
5824 /* Make sure a parameter that has been implicitly typed still
5825 matches the implicit type, since PARAMETER statements can precede
5826 IMPLICIT statements. */
5827 if (sym->attr.implicit_type
5828 && !gfc_compare_types (&sym->ts,
5829 gfc_get_default_type (sym, sym->ns)))
5831 gfc_error ("Implicitly typed PARAMETER '%s' at %L doesn't match a "
5832 "later IMPLICIT type", sym->name, &sym->declared_at);
5836 /* Make sure the types of derived parameters are consistent. This
5837 type checking is deferred until resolution because the type may
5838 refer to a derived type from the host. */
5839 if (sym->ts.type == BT_DERIVED
5840 && !gfc_compare_types (&sym->ts, &sym->value->ts))
5842 gfc_error ("Incompatible derived type in PARAMETER at %L",
5843 &sym->value->where);
5850 /* Do anything necessary to resolve a symbol. Right now, we just
5851 assume that an otherwise unknown symbol is a variable. This sort
5852 of thing commonly happens for symbols in module. */
5855 resolve_symbol (gfc_symbol * sym)
5857 /* Zero if we are checking a formal namespace. */
5858 static int formal_ns_flag = 1;
5859 int formal_ns_save, check_constant, mp_flag;
5860 gfc_symtree *symtree;
5861 gfc_symtree *this_symtree;
5865 if (sym->attr.flavor == FL_UNKNOWN)
5868 /* If we find that a flavorless symbol is an interface in one of the
5869 parent namespaces, find its symtree in this namespace, free the
5870 symbol and set the symtree to point to the interface symbol. */
5871 for (ns = gfc_current_ns->parent; ns; ns = ns->parent)
5873 symtree = gfc_find_symtree (ns->sym_root, sym->name);
5874 if (symtree && symtree->n.sym->generic)
5876 this_symtree = gfc_find_symtree (gfc_current_ns->sym_root,
5880 gfc_free_symbol (sym);
5881 symtree->n.sym->refs++;
5882 this_symtree->n.sym = symtree->n.sym;
5887 /* Otherwise give it a flavor according to such attributes as
5889 if (sym->attr.external == 0 && sym->attr.intrinsic == 0)
5890 sym->attr.flavor = FL_VARIABLE;
5893 sym->attr.flavor = FL_PROCEDURE;
5894 if (sym->attr.dimension)
5895 sym->attr.function = 1;
5899 if (sym->attr.flavor == FL_DERIVED && resolve_fl_derived (sym) == FAILURE)
5902 /* Symbols that are module procedures with results (functions) have
5903 the types and array specification copied for type checking in
5904 procedures that call them, as well as for saving to a module
5905 file. These symbols can't stand the scrutiny that their results
5907 mp_flag = (sym->result != NULL && sym->result != sym);
5909 /* Assign default type to symbols that need one and don't have one. */
5910 if (sym->ts.type == BT_UNKNOWN)
5912 if (sym->attr.flavor == FL_VARIABLE || sym->attr.flavor == FL_PARAMETER)
5913 gfc_set_default_type (sym, 1, NULL);
5915 if (sym->attr.flavor == FL_PROCEDURE && sym->attr.function)
5917 /* The specific case of an external procedure should emit an error
5918 in the case that there is no implicit type. */
5920 gfc_set_default_type (sym, sym->attr.external, NULL);
5923 /* Result may be in another namespace. */
5924 resolve_symbol (sym->result);
5926 sym->ts = sym->result->ts;
5927 sym->as = gfc_copy_array_spec (sym->result->as);
5928 sym->attr.dimension = sym->result->attr.dimension;
5929 sym->attr.pointer = sym->result->attr.pointer;
5930 sym->attr.allocatable = sym->result->attr.allocatable;
5935 /* Assumed size arrays and assumed shape arrays must be dummy
5939 && (sym->as->type == AS_ASSUMED_SIZE
5940 || sym->as->type == AS_ASSUMED_SHAPE)
5941 && sym->attr.dummy == 0)
5943 if (sym->as->type == AS_ASSUMED_SIZE)
5944 gfc_error ("Assumed size array at %L must be a dummy argument",
5947 gfc_error ("Assumed shape array at %L must be a dummy argument",
5952 /* Make sure symbols with known intent or optional are really dummy
5953 variable. Because of ENTRY statement, this has to be deferred
5954 until resolution time. */
5956 if (!sym->attr.dummy
5957 && (sym->attr.optional
5958 || sym->attr.intent != INTENT_UNKNOWN))
5960 gfc_error ("Symbol at %L is not a DUMMY variable", &sym->declared_at);
5964 if (sym->attr.value && !sym->attr.dummy)
5966 gfc_error ("'%s' at %L cannot have the VALUE attribute because "
5967 "it is not a dummy", sym->name, &sym->declared_at);
5972 /* If a derived type symbol has reached this point, without its
5973 type being declared, we have an error. Notice that most
5974 conditions that produce undefined derived types have already
5975 been dealt with. However, the likes of:
5976 implicit type(t) (t) ..... call foo (t) will get us here if
5977 the type is not declared in the scope of the implicit
5978 statement. Change the type to BT_UNKNOWN, both because it is so
5979 and to prevent an ICE. */
5980 if (sym->ts.type == BT_DERIVED
5981 && sym->ts.derived->components == NULL)
5983 gfc_error ("The derived type '%s' at %L is of type '%s', "
5984 "which has not been defined", sym->name,
5985 &sym->declared_at, sym->ts.derived->name);
5986 sym->ts.type = BT_UNKNOWN;
5990 /* An assumed-size array with INTENT(OUT) shall not be of a type for which
5991 default initialization is defined (5.1.2.4.4). */
5992 if (sym->ts.type == BT_DERIVED
5994 && sym->attr.intent == INTENT_OUT
5996 && sym->as->type == AS_ASSUMED_SIZE)
5998 for (c = sym->ts.derived->components; c; c = c->next)
6002 gfc_error ("The INTENT(OUT) dummy argument '%s' at %L is "
6003 "ASSUMED SIZE and so cannot have a default initializer",
6004 sym->name, &sym->declared_at);
6010 switch (sym->attr.flavor)
6013 if (resolve_fl_variable (sym, mp_flag) == FAILURE)
6018 if (resolve_fl_procedure (sym, mp_flag) == FAILURE)
6023 if (resolve_fl_namelist (sym) == FAILURE)
6028 if (resolve_fl_parameter (sym) == FAILURE)
6036 /* Make sure that intrinsic exist */
6037 if (sym->attr.flavor != FL_MODULE && sym->attr.intrinsic
6038 && ! gfc_intrinsic_name(sym->name, 0)
6039 && ! gfc_intrinsic_name(sym->name, 1))
6040 gfc_error("Intrinsic at %L does not exist", &sym->declared_at);
6042 /* Resolve array specifier. Check as well some constraints
6043 on COMMON blocks. */
6045 check_constant = sym->attr.in_common && !sym->attr.pointer;
6046 gfc_resolve_array_spec (sym->as, check_constant);
6048 /* Resolve formal namespaces. */
6050 if (formal_ns_flag && sym != NULL && sym->formal_ns != NULL)
6052 formal_ns_save = formal_ns_flag;
6054 gfc_resolve (sym->formal_ns);
6055 formal_ns_flag = formal_ns_save;
6058 /* Check threadprivate restrictions. */
6059 if (sym->attr.threadprivate && !sym->attr.save
6060 && (!sym->attr.in_common
6061 && sym->module == NULL
6062 && (sym->ns->proc_name == NULL
6063 || sym->ns->proc_name->attr.flavor != FL_MODULE)))
6064 gfc_error ("Threadprivate at %L isn't SAVEd", &sym->declared_at);
6066 /* If we have come this far we can apply default-initializers, as
6067 described in 14.7.5, to those variables that have not already
6068 been assigned one. */
6069 if (sym->ts.type == BT_DERIVED
6070 && sym->attr.referenced
6071 && sym->ns == gfc_current_ns
6073 && !sym->attr.allocatable
6074 && !sym->attr.alloc_comp)
6076 symbol_attribute *a = &sym->attr;
6078 if ((!a->save && !a->dummy && !a->pointer
6079 && !a->in_common && !a->use_assoc
6080 && !(a->function && sym != sym->result))
6082 (a->dummy && a->intent == INTENT_OUT))
6083 apply_default_init (sym);
6089 /************* Resolve DATA statements *************/
6093 gfc_data_value *vnode;
6099 /* Advance the values structure to point to the next value in the data list. */
6102 next_data_value (void)
6104 while (values.left == 0)
6106 if (values.vnode->next == NULL)
6109 values.vnode = values.vnode->next;
6110 values.left = values.vnode->repeat;
6118 check_data_variable (gfc_data_variable * var, locus * where)
6124 ar_type mark = AR_UNKNOWN;
6126 mpz_t section_index[GFC_MAX_DIMENSIONS];
6130 if (gfc_resolve_expr (var->expr) == FAILURE)
6134 mpz_init_set_si (offset, 0);
6137 if (e->expr_type != EXPR_VARIABLE)
6138 gfc_internal_error ("check_data_variable(): Bad expression");
6140 if (e->symtree->n.sym->ns->is_block_data
6141 && !e->symtree->n.sym->attr.in_common)
6143 gfc_error ("BLOCK DATA element '%s' at %L must be in COMMON",
6144 e->symtree->n.sym->name, &e->symtree->n.sym->declared_at);
6149 mpz_init_set_ui (size, 1);
6156 /* Find the array section reference. */
6157 for (ref = e->ref; ref; ref = ref->next)
6159 if (ref->type != REF_ARRAY)
6161 if (ref->u.ar.type == AR_ELEMENT)
6167 /* Set marks according to the reference pattern. */
6168 switch (ref->u.ar.type)
6176 /* Get the start position of array section. */
6177 gfc_get_section_index (ar, section_index, &offset);
6185 if (gfc_array_size (e, &size) == FAILURE)
6187 gfc_error ("Nonconstant array section at %L in DATA statement",
6196 while (mpz_cmp_ui (size, 0) > 0)
6198 if (next_data_value () == FAILURE)
6200 gfc_error ("DATA statement at %L has more variables than values",
6206 t = gfc_check_assign (var->expr, values.vnode->expr, 0);
6210 /* If we have more than one element left in the repeat count,
6211 and we have more than one element left in the target variable,
6212 then create a range assignment. */
6213 /* ??? Only done for full arrays for now, since array sections
6215 if (mark == AR_FULL && ref && ref->next == NULL
6216 && values.left > 1 && mpz_cmp_ui (size, 1) > 0)
6220 if (mpz_cmp_ui (size, values.left) >= 0)
6222 mpz_init_set_ui (range, values.left);
6223 mpz_sub_ui (size, size, values.left);
6228 mpz_init_set (range, size);
6229 values.left -= mpz_get_ui (size);
6230 mpz_set_ui (size, 0);
6233 gfc_assign_data_value_range (var->expr, values.vnode->expr,
6236 mpz_add (offset, offset, range);
6240 /* Assign initial value to symbol. */
6244 mpz_sub_ui (size, size, 1);
6246 gfc_assign_data_value (var->expr, values.vnode->expr, offset);
6248 if (mark == AR_FULL)
6249 mpz_add_ui (offset, offset, 1);
6251 /* Modify the array section indexes and recalculate the offset
6252 for next element. */
6253 else if (mark == AR_SECTION)
6254 gfc_advance_section (section_index, ar, &offset);
6258 if (mark == AR_SECTION)
6260 for (i = 0; i < ar->dimen; i++)
6261 mpz_clear (section_index[i]);
6271 static try traverse_data_var (gfc_data_variable *, locus *);
6273 /* Iterate over a list of elements in a DATA statement. */
6276 traverse_data_list (gfc_data_variable * var, locus * where)
6279 iterator_stack frame;
6282 mpz_init (frame.value);
6284 mpz_init_set (trip, var->iter.end->value.integer);
6285 mpz_sub (trip, trip, var->iter.start->value.integer);
6286 mpz_add (trip, trip, var->iter.step->value.integer);
6288 mpz_div (trip, trip, var->iter.step->value.integer);
6290 mpz_set (frame.value, var->iter.start->value.integer);
6292 frame.prev = iter_stack;
6293 frame.variable = var->iter.var->symtree;
6294 iter_stack = &frame;
6296 while (mpz_cmp_ui (trip, 0) > 0)
6298 if (traverse_data_var (var->list, where) == FAILURE)
6304 e = gfc_copy_expr (var->expr);
6305 if (gfc_simplify_expr (e, 1) == FAILURE)
6311 mpz_add (frame.value, frame.value, var->iter.step->value.integer);
6313 mpz_sub_ui (trip, trip, 1);
6317 mpz_clear (frame.value);
6319 iter_stack = frame.prev;
6324 /* Type resolve variables in the variable list of a DATA statement. */
6327 traverse_data_var (gfc_data_variable * var, locus * where)
6331 for (; var; var = var->next)
6333 if (var->expr == NULL)
6334 t = traverse_data_list (var, where);
6336 t = check_data_variable (var, where);
6346 /* Resolve the expressions and iterators associated with a data statement.
6347 This is separate from the assignment checking because data lists should
6348 only be resolved once. */
6351 resolve_data_variables (gfc_data_variable * d)
6353 for (; d; d = d->next)
6355 if (d->list == NULL)
6357 if (gfc_resolve_expr (d->expr) == FAILURE)
6362 if (gfc_resolve_iterator (&d->iter, false) == FAILURE)
6365 if (d->iter.start->expr_type != EXPR_CONSTANT
6366 || d->iter.end->expr_type != EXPR_CONSTANT
6367 || d->iter.step->expr_type != EXPR_CONSTANT)
6368 gfc_internal_error ("resolve_data_variables(): Bad iterator");
6370 if (resolve_data_variables (d->list) == FAILURE)
6379 /* Resolve a single DATA statement. We implement this by storing a pointer to
6380 the value list into static variables, and then recursively traversing the
6381 variables list, expanding iterators and such. */
6384 resolve_data (gfc_data * d)
6386 if (resolve_data_variables (d->var) == FAILURE)
6389 values.vnode = d->value;
6390 values.left = (d->value == NULL) ? 0 : d->value->repeat;
6392 if (traverse_data_var (d->var, &d->where) == FAILURE)
6395 /* At this point, we better not have any values left. */
6397 if (next_data_value () == SUCCESS)
6398 gfc_error ("DATA statement at %L has more values than variables",
6403 /* Determines if a variable is not 'pure', ie not assignable within a pure
6404 procedure. Returns zero if assignment is OK, nonzero if there is a problem.
6408 gfc_impure_variable (gfc_symbol * sym)
6410 if (sym->attr.use_assoc || sym->attr.in_common)
6413 if (sym->ns != gfc_current_ns)
6414 return !sym->attr.function;
6416 /* TODO: Check storage association through EQUIVALENCE statements */
6422 /* Test whether a symbol is pure or not. For a NULL pointer, checks the
6423 symbol of the current procedure. */
6426 gfc_pure (gfc_symbol * sym)
6428 symbol_attribute attr;
6431 sym = gfc_current_ns->proc_name;
6437 return attr.flavor == FL_PROCEDURE && (attr.pure || attr.elemental);
6441 /* Test whether the current procedure is elemental or not. */
6444 gfc_elemental (gfc_symbol * sym)
6446 symbol_attribute attr;
6449 sym = gfc_current_ns->proc_name;
6454 return attr.flavor == FL_PROCEDURE && attr.elemental;
6458 /* Warn about unused labels. */
6461 warn_unused_fortran_label (gfc_st_label * label)
6466 warn_unused_fortran_label (label->left);
6468 if (label->defined == ST_LABEL_UNKNOWN)
6471 switch (label->referenced)
6473 case ST_LABEL_UNKNOWN:
6474 gfc_warning ("Label %d at %L defined but not used", label->value,
6478 case ST_LABEL_BAD_TARGET:
6479 gfc_warning ("Label %d at %L defined but cannot be used",
6480 label->value, &label->where);
6487 warn_unused_fortran_label (label->right);
6491 /* Returns the sequence type of a symbol or sequence. */
6494 sequence_type (gfc_typespec ts)
6503 if (ts.derived->components == NULL)
6504 return SEQ_NONDEFAULT;
6506 result = sequence_type (ts.derived->components->ts);
6507 for (c = ts.derived->components->next; c; c = c->next)
6508 if (sequence_type (c->ts) != result)
6514 if (ts.kind != gfc_default_character_kind)
6515 return SEQ_NONDEFAULT;
6517 return SEQ_CHARACTER;
6520 if (ts.kind != gfc_default_integer_kind)
6521 return SEQ_NONDEFAULT;
6526 if (!(ts.kind == gfc_default_real_kind
6527 || ts.kind == gfc_default_double_kind))
6528 return SEQ_NONDEFAULT;
6533 if (ts.kind != gfc_default_complex_kind)
6534 return SEQ_NONDEFAULT;
6539 if (ts.kind != gfc_default_logical_kind)
6540 return SEQ_NONDEFAULT;
6545 return SEQ_NONDEFAULT;
6550 /* Resolve derived type EQUIVALENCE object. */
6553 resolve_equivalence_derived (gfc_symbol *derived, gfc_symbol *sym, gfc_expr *e)
6556 gfc_component *c = derived->components;
6561 /* Shall not be an object of nonsequence derived type. */
6562 if (!derived->attr.sequence)
6564 gfc_error ("Derived type variable '%s' at %L must have SEQUENCE "
6565 "attribute to be an EQUIVALENCE object", sym->name, &e->where);
6569 /* Shall not have allocatable components. */
6570 if (derived->attr.alloc_comp)
6572 gfc_error ("Derived type variable '%s' at %L cannot have ALLOCATABLE "
6573 "components to be an EQUIVALENCE object",sym->name, &e->where);
6577 for (; c ; c = c->next)
6580 if (d && (resolve_equivalence_derived (c->ts.derived, sym, e) == FAILURE))
6583 /* Shall not be an object of sequence derived type containing a pointer
6584 in the structure. */
6587 gfc_error ("Derived type variable '%s' at %L with pointer component(s) "
6588 "cannot be an EQUIVALENCE object", sym->name, &e->where);
6594 gfc_error ("Derived type variable '%s' at %L with default initializer "
6595 "cannot be an EQUIVALENCE object", sym->name, &e->where);
6603 /* Resolve equivalence object.
6604 An EQUIVALENCE object shall not be a dummy argument, a pointer, a target,
6605 an allocatable array, an object of nonsequence derived type, an object of
6606 sequence derived type containing a pointer at any level of component
6607 selection, an automatic object, a function name, an entry name, a result
6608 name, a named constant, a structure component, or a subobject of any of
6609 the preceding objects. A substring shall not have length zero. A
6610 derived type shall not have components with default initialization nor
6611 shall two objects of an equivalence group be initialized.
6612 The simple constraints are done in symbol.c(check_conflict) and the rest
6613 are implemented here. */
6616 resolve_equivalence (gfc_equiv *eq)
6619 gfc_symbol *derived;
6620 gfc_symbol *first_sym;
6623 locus *last_where = NULL;
6624 seq_type eq_type, last_eq_type;
6625 gfc_typespec *last_ts;
6627 const char *value_name;
6631 last_ts = &eq->expr->symtree->n.sym->ts;
6633 first_sym = eq->expr->symtree->n.sym;
6635 for (object = 1; eq; eq = eq->eq, object++)
6639 e->ts = e->symtree->n.sym->ts;
6640 /* match_varspec might not know yet if it is seeing
6641 array reference or substring reference, as it doesn't
6643 if (e->ref && e->ref->type == REF_ARRAY)
6645 gfc_ref *ref = e->ref;
6646 sym = e->symtree->n.sym;
6648 if (sym->attr.dimension)
6650 ref->u.ar.as = sym->as;
6654 /* For substrings, convert REF_ARRAY into REF_SUBSTRING. */
6655 if (e->ts.type == BT_CHARACTER
6657 && ref->type == REF_ARRAY
6658 && ref->u.ar.dimen == 1
6659 && ref->u.ar.dimen_type[0] == DIMEN_RANGE
6660 && ref->u.ar.stride[0] == NULL)
6662 gfc_expr *start = ref->u.ar.start[0];
6663 gfc_expr *end = ref->u.ar.end[0];
6666 /* Optimize away the (:) reference. */
6667 if (start == NULL && end == NULL)
6672 e->ref->next = ref->next;
6677 ref->type = REF_SUBSTRING;
6679 start = gfc_int_expr (1);
6680 ref->u.ss.start = start;
6681 if (end == NULL && e->ts.cl)
6682 end = gfc_copy_expr (e->ts.cl->length);
6683 ref->u.ss.end = end;
6684 ref->u.ss.length = e->ts.cl;
6691 /* Any further ref is an error. */
6694 gcc_assert (ref->type == REF_ARRAY);
6695 gfc_error ("Syntax error in EQUIVALENCE statement at %L",
6701 if (gfc_resolve_expr (e) == FAILURE)
6704 sym = e->symtree->n.sym;
6706 /* An equivalence statement cannot have more than one initialized
6710 if (value_name != NULL)
6712 gfc_error ("Initialized objects '%s' and '%s' cannot both "
6713 "be in the EQUIVALENCE statement at %L",
6714 value_name, sym->name, &e->where);
6718 value_name = sym->name;
6721 /* Shall not equivalence common block variables in a PURE procedure. */
6722 if (sym->ns->proc_name
6723 && sym->ns->proc_name->attr.pure
6724 && sym->attr.in_common)
6726 gfc_error ("Common block member '%s' at %L cannot be an EQUIVALENCE "
6727 "object in the pure procedure '%s'",
6728 sym->name, &e->where, sym->ns->proc_name->name);
6732 /* Shall not be a named constant. */
6733 if (e->expr_type == EXPR_CONSTANT)
6735 gfc_error ("Named constant '%s' at %L cannot be an EQUIVALENCE "
6736 "object", sym->name, &e->where);
6740 derived = e->ts.derived;
6741 if (derived && resolve_equivalence_derived (derived, sym, e) == FAILURE)
6744 /* Check that the types correspond correctly:
6746 A numeric sequence structure may be equivalenced to another sequence
6747 structure, an object of default integer type, default real type, double
6748 precision real type, default logical type such that components of the
6749 structure ultimately only become associated to objects of the same
6750 kind. A character sequence structure may be equivalenced to an object
6751 of default character kind or another character sequence structure.
6752 Other objects may be equivalenced only to objects of the same type and
6755 /* Identical types are unconditionally OK. */
6756 if (object == 1 || gfc_compare_types (last_ts, &sym->ts))
6757 goto identical_types;
6759 last_eq_type = sequence_type (*last_ts);
6760 eq_type = sequence_type (sym->ts);
6762 /* Since the pair of objects is not of the same type, mixed or
6763 non-default sequences can be rejected. */
6765 msg = "Sequence %s with mixed components in EQUIVALENCE "
6766 "statement at %L with different type objects";
6768 && last_eq_type == SEQ_MIXED
6769 && gfc_notify_std (GFC_STD_GNU, msg, first_sym->name,
6770 last_where) == FAILURE)
6771 || (eq_type == SEQ_MIXED
6772 && gfc_notify_std (GFC_STD_GNU, msg,sym->name,
6773 &e->where) == FAILURE))
6776 msg = "Non-default type object or sequence %s in EQUIVALENCE "
6777 "statement at %L with objects of different type";
6779 && last_eq_type == SEQ_NONDEFAULT
6780 && gfc_notify_std (GFC_STD_GNU, msg, first_sym->name,
6781 last_where) == FAILURE)
6782 || (eq_type == SEQ_NONDEFAULT
6783 && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
6784 &e->where) == FAILURE))
6787 msg ="Non-CHARACTER object '%s' in default CHARACTER "
6788 "EQUIVALENCE statement at %L";
6789 if (last_eq_type == SEQ_CHARACTER
6790 && eq_type != SEQ_CHARACTER
6791 && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
6792 &e->where) == FAILURE)
6795 msg ="Non-NUMERIC object '%s' in default NUMERIC "
6796 "EQUIVALENCE statement at %L";
6797 if (last_eq_type == SEQ_NUMERIC
6798 && eq_type != SEQ_NUMERIC
6799 && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
6800 &e->where) == FAILURE)
6805 last_where = &e->where;
6810 /* Shall not be an automatic array. */
6811 if (e->ref->type == REF_ARRAY
6812 && gfc_resolve_array_spec (e->ref->u.ar.as, 1) == FAILURE)
6814 gfc_error ("Array '%s' at %L with non-constant bounds cannot be "
6815 "an EQUIVALENCE object", sym->name, &e->where);
6822 /* Shall not be a structure component. */
6823 if (r->type == REF_COMPONENT)
6825 gfc_error ("Structure component '%s' at %L cannot be an "
6826 "EQUIVALENCE object",
6827 r->u.c.component->name, &e->where);
6831 /* A substring shall not have length zero. */
6832 if (r->type == REF_SUBSTRING)
6834 if (compare_bound (r->u.ss.start, r->u.ss.end) == CMP_GT)
6836 gfc_error ("Substring at %L has length zero",
6837 &r->u.ss.start->where);
6847 /* Resolve function and ENTRY types, issue diagnostics if needed. */
6850 resolve_fntype (gfc_namespace * ns)
6855 if (ns->proc_name == NULL || !ns->proc_name->attr.function)
6858 /* If there are any entries, ns->proc_name is the entry master
6859 synthetic symbol and ns->entries->sym actual FUNCTION symbol. */
6861 sym = ns->entries->sym;
6863 sym = ns->proc_name;
6864 if (sym->result == sym
6865 && sym->ts.type == BT_UNKNOWN
6866 && gfc_set_default_type (sym, 0, NULL) == FAILURE
6867 && !sym->attr.untyped)
6869 gfc_error ("Function '%s' at %L has no IMPLICIT type",
6870 sym->name, &sym->declared_at);
6871 sym->attr.untyped = 1;
6874 if (sym->ts.type == BT_DERIVED && !sym->ts.derived->attr.use_assoc
6875 && !gfc_check_access (sym->ts.derived->attr.access,
6876 sym->ts.derived->ns->default_access)
6877 && gfc_check_access (sym->attr.access, sym->ns->default_access))
6879 gfc_error ("PUBLIC function '%s' at %L cannot be of PRIVATE type '%s'",
6880 sym->name, &sym->declared_at, sym->ts.derived->name);
6883 /* Make sure that the type of a module derived type function is in the
6884 module namespace, by copying it from the namespace's derived type
6885 list, if necessary. */
6886 if (sym->ts.type == BT_DERIVED
6887 && sym->ns->proc_name->attr.flavor == FL_MODULE
6888 && sym->ts.derived->ns
6889 && sym->ns != sym->ts.derived->ns)
6891 gfc_dt_list *dt = sym->ns->derived_types;
6893 for (; dt; dt = dt->next)
6894 if (gfc_compare_derived_types (sym->ts.derived, dt->derived))
6895 sym->ts.derived = dt->derived;
6899 for (el = ns->entries->next; el; el = el->next)
6901 if (el->sym->result == el->sym
6902 && el->sym->ts.type == BT_UNKNOWN
6903 && gfc_set_default_type (el->sym, 0, NULL) == FAILURE
6904 && !el->sym->attr.untyped)
6906 gfc_error ("ENTRY '%s' at %L has no IMPLICIT type",
6907 el->sym->name, &el->sym->declared_at);
6908 el->sym->attr.untyped = 1;
6913 /* 12.3.2.1.1 Defined operators. */
6916 gfc_resolve_uops(gfc_symtree *symtree)
6920 gfc_formal_arglist *formal;
6922 if (symtree == NULL)
6925 gfc_resolve_uops (symtree->left);
6926 gfc_resolve_uops (symtree->right);
6928 for (itr = symtree->n.uop->operator; itr; itr = itr->next)
6931 if (!sym->attr.function)
6932 gfc_error("User operator procedure '%s' at %L must be a FUNCTION",
6933 sym->name, &sym->declared_at);
6935 if (sym->ts.type == BT_CHARACTER
6936 && !(sym->ts.cl && sym->ts.cl->length)
6937 && !(sym->result && sym->result->ts.cl && sym->result->ts.cl->length))
6938 gfc_error("User operator procedure '%s' at %L cannot be assumed character "
6939 "length", sym->name, &sym->declared_at);
6941 formal = sym->formal;
6942 if (!formal || !formal->sym)
6944 gfc_error("User operator procedure '%s' at %L must have at least "
6945 "one argument", sym->name, &sym->declared_at);
6949 if (formal->sym->attr.intent != INTENT_IN)
6950 gfc_error ("First argument of operator interface at %L must be "
6951 "INTENT(IN)", &sym->declared_at);
6953 if (formal->sym->attr.optional)
6954 gfc_error ("First argument of operator interface at %L cannot be "
6955 "optional", &sym->declared_at);
6957 formal = formal->next;
6958 if (!formal || !formal->sym)
6961 if (formal->sym->attr.intent != INTENT_IN)
6962 gfc_error ("Second argument of operator interface at %L must be "
6963 "INTENT(IN)", &sym->declared_at);
6965 if (formal->sym->attr.optional)
6966 gfc_error ("Second argument of operator interface at %L cannot be "
6967 "optional", &sym->declared_at);
6970 gfc_error ("Operator interface at %L must have, at most, two "
6971 "arguments", &sym->declared_at);
6976 /* Examine all of the expressions associated with a program unit,
6977 assign types to all intermediate expressions, make sure that all
6978 assignments are to compatible types and figure out which names
6979 refer to which functions or subroutines. It doesn't check code
6980 block, which is handled by resolve_code. */
6983 resolve_types (gfc_namespace * ns)
6990 gfc_current_ns = ns;
6992 resolve_entries (ns);
6994 resolve_contained_functions (ns);
6996 gfc_traverse_ns (ns, resolve_symbol);
6998 resolve_fntype (ns);
7000 for (n = ns->contained; n; n = n->sibling)
7002 if (gfc_pure (ns->proc_name) && !gfc_pure (n->proc_name))
7003 gfc_error ("Contained procedure '%s' at %L of a PURE procedure must "
7004 "also be PURE", n->proc_name->name,
7005 &n->proc_name->declared_at);
7011 gfc_check_interfaces (ns);
7013 for (cl = ns->cl_list; cl; cl = cl->next)
7014 resolve_charlen (cl);
7016 gfc_traverse_ns (ns, resolve_values);
7022 for (d = ns->data; d; d = d->next)
7026 gfc_traverse_ns (ns, gfc_formalize_init_value);
7028 for (eq = ns->equiv; eq; eq = eq->next)
7029 resolve_equivalence (eq);
7031 /* Warn about unused labels. */
7032 if (warn_unused_label)
7033 warn_unused_fortran_label (ns->st_labels);
7035 gfc_resolve_uops (ns->uop_root);
7039 /* Call resolve_code recursively. */
7042 resolve_codes (gfc_namespace * ns)
7046 for (n = ns->contained; n; n = n->sibling)
7049 gfc_current_ns = ns;
7051 /* Set to an out of range value. */
7052 current_entry_id = -1;
7053 resolve_code (ns->code, ns);
7057 /* This function is called after a complete program unit has been compiled.
7058 Its purpose is to examine all of the expressions associated with a program
7059 unit, assign types to all intermediate expressions, make sure that all
7060 assignments are to compatible types and figure out which names refer to
7061 which functions or subroutines. */
7064 gfc_resolve (gfc_namespace * ns)
7066 gfc_namespace *old_ns;
7068 old_ns = gfc_current_ns;
7073 gfc_current_ns = old_ns;