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 /* TODO: Procedures whose return character length parameter is not constant
93 or assumed must also have explicit interfaces. */
94 if (proc->result != NULL)
99 if (gfc_elemental (proc)
100 || sym->attr.pointer || sym->attr.allocatable
101 || (sym->as && sym->as->rank > 0))
102 proc->attr.always_explicit = 1;
106 for (f = proc->formal; f; f = f->next)
112 /* Alternate return placeholder. */
113 if (gfc_elemental (proc))
114 gfc_error ("Alternate return specifier in elemental subroutine "
115 "'%s' at %L is not allowed", proc->name,
117 if (proc->attr.function)
118 gfc_error ("Alternate return specifier in function "
119 "'%s' at %L is not allowed", proc->name,
124 if (sym->attr.if_source != IFSRC_UNKNOWN)
125 resolve_formal_arglist (sym);
127 if (sym->attr.subroutine || sym->attr.external || sym->attr.intrinsic)
129 if (gfc_pure (proc) && !gfc_pure (sym))
132 ("Dummy procedure '%s' of PURE procedure at %L must also "
133 "be PURE", sym->name, &sym->declared_at);
137 if (gfc_elemental (proc))
140 ("Dummy procedure at %L not allowed in ELEMENTAL procedure",
148 if (sym->ts.type == BT_UNKNOWN)
150 if (!sym->attr.function || sym->result == sym)
151 gfc_set_default_type (sym, 1, sym->ns);
154 gfc_resolve_array_spec (sym->as, 0);
156 /* We can't tell if an array with dimension (:) is assumed or deferred
157 shape until we know if it has the pointer or allocatable attributes.
159 if (sym->as && sym->as->rank > 0 && sym->as->type == AS_DEFERRED
160 && !(sym->attr.pointer || sym->attr.allocatable))
162 sym->as->type = AS_ASSUMED_SHAPE;
163 for (i = 0; i < sym->as->rank; i++)
164 sym->as->lower[i] = gfc_int_expr (1);
167 if ((sym->as && sym->as->rank > 0 && sym->as->type == AS_ASSUMED_SHAPE)
168 || sym->attr.pointer || sym->attr.allocatable || sym->attr.target
169 || sym->attr.optional)
170 proc->attr.always_explicit = 1;
172 /* If the flavor is unknown at this point, it has to be a variable.
173 A procedure specification would have already set the type. */
175 if (sym->attr.flavor == FL_UNKNOWN)
176 gfc_add_flavor (&sym->attr, FL_VARIABLE, sym->name, &sym->declared_at);
180 if (proc->attr.function && !sym->attr.pointer
181 && sym->attr.flavor != FL_PROCEDURE
182 && sym->attr.intent != INTENT_IN)
184 gfc_error ("Argument '%s' of pure function '%s' at %L must be "
185 "INTENT(IN)", sym->name, proc->name,
188 if (proc->attr.subroutine && !sym->attr.pointer
189 && sym->attr.intent == INTENT_UNKNOWN)
192 ("Argument '%s' of pure subroutine '%s' at %L must have "
193 "its INTENT specified", sym->name, proc->name,
198 if (gfc_elemental (proc))
203 ("Argument '%s' of elemental procedure at %L must be scalar",
204 sym->name, &sym->declared_at);
208 if (sym->attr.pointer)
211 ("Argument '%s' of elemental procedure at %L cannot have "
212 "the POINTER attribute", sym->name, &sym->declared_at);
217 /* Each dummy shall be specified to be scalar. */
218 if (proc->attr.proc == PROC_ST_FUNCTION)
223 ("Argument '%s' of statement function at %L must be scalar",
224 sym->name, &sym->declared_at);
228 if (sym->ts.type == BT_CHARACTER)
230 gfc_charlen *cl = sym->ts.cl;
231 if (!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT)
234 ("Character-valued argument '%s' of statement function at "
235 "%L must has constant length",
236 sym->name, &sym->declared_at);
246 /* Work function called when searching for symbols that have argument lists
247 associated with them. */
250 find_arglists (gfc_symbol * sym)
253 if (sym->attr.if_source == IFSRC_UNKNOWN || sym->ns != gfc_current_ns)
256 resolve_formal_arglist (sym);
260 /* Given a namespace, resolve all formal argument lists within the namespace.
264 resolve_formal_arglists (gfc_namespace * ns)
270 gfc_traverse_ns (ns, find_arglists);
275 resolve_contained_fntype (gfc_symbol * sym, gfc_namespace * ns)
279 /* If this namespace is not a function, ignore it. */
281 || !(sym->attr.function
282 || sym->attr.flavor == FL_VARIABLE))
285 /* Try to find out of what the return type is. */
286 if (sym->result != NULL)
289 if (sym->ts.type == BT_UNKNOWN)
291 t = gfc_set_default_type (sym, 0, ns);
293 if (t == FAILURE && !sym->attr.untyped)
295 gfc_error ("Contained function '%s' at %L has no IMPLICIT type",
296 sym->name, &sym->declared_at); /* FIXME */
297 sym->attr.untyped = 1;
301 /*Fortran 95 Draft Standard, page 51, Section 5.1.1.5, on the Character type,
302 lists the only ways a character length value of * can be used: dummy arguments
303 of procedures, named constants, and function results in external functions.
304 Internal function results are not on that list; ergo, not permitted. */
306 if (sym->ts.type == BT_CHARACTER)
308 gfc_charlen *cl = sym->ts.cl;
309 if (!cl || !cl->length)
310 gfc_error ("Character-valued internal function '%s' at %L must "
311 "not be assumed length", sym->name, &sym->declared_at);
316 /* Add NEW_ARGS to the formal argument list of PROC, taking care not to
317 introduce duplicates. */
320 merge_argument_lists (gfc_symbol *proc, gfc_formal_arglist *new_args)
322 gfc_formal_arglist *f, *new_arglist;
325 for (; new_args != NULL; new_args = new_args->next)
327 new_sym = new_args->sym;
328 /* See if this arg is already in the formal argument list. */
329 for (f = proc->formal; f; f = f->next)
331 if (new_sym == f->sym)
338 /* Add a new argument. Argument order is not important. */
339 new_arglist = gfc_get_formal_arglist ();
340 new_arglist->sym = new_sym;
341 new_arglist->next = proc->formal;
342 proc->formal = new_arglist;
347 /* Resolve alternate entry points. If a symbol has multiple entry points we
348 create a new master symbol for the main routine, and turn the existing
349 symbol into an entry point. */
352 resolve_entries (gfc_namespace * ns)
354 gfc_namespace *old_ns;
358 char name[GFC_MAX_SYMBOL_LEN + 1];
359 static int master_count = 0;
361 if (ns->proc_name == NULL)
364 /* No need to do anything if this procedure doesn't have alternate entry
369 /* We may already have resolved alternate entry points. */
370 if (ns->proc_name->attr.entry_master)
373 /* If this isn't a procedure something has gone horribly wrong. */
374 gcc_assert (ns->proc_name->attr.flavor == FL_PROCEDURE);
376 /* Remember the current namespace. */
377 old_ns = gfc_current_ns;
381 /* Add the main entry point to the list of entry points. */
382 el = gfc_get_entry_list ();
383 el->sym = ns->proc_name;
385 el->next = ns->entries;
387 ns->proc_name->attr.entry = 1;
389 /* If it is a module function, it needs to be in the right namespace
390 so that gfc_get_fake_result_decl can gather up the results. The
391 need for this arose in get_proc_name, where these beasts were
392 left in their own namespace, to keep prior references linked to
393 the entry declaration.*/
394 if (ns->proc_name->attr.function
396 && ns->parent->proc_name->attr.flavor == FL_MODULE)
399 /* Add an entry statement for it. */
406 /* Create a new symbol for the master function. */
407 /* Give the internal function a unique name (within this file).
408 Also include the function name so the user has some hope of figuring
409 out what is going on. */
410 snprintf (name, GFC_MAX_SYMBOL_LEN, "master.%d.%s",
411 master_count++, ns->proc_name->name);
412 gfc_get_ha_symbol (name, &proc);
413 gcc_assert (proc != NULL);
415 gfc_add_procedure (&proc->attr, PROC_INTERNAL, proc->name, NULL);
416 if (ns->proc_name->attr.subroutine)
417 gfc_add_subroutine (&proc->attr, proc->name, NULL);
421 gfc_typespec *ts, *fts;
422 gfc_array_spec *as, *fas;
423 gfc_add_function (&proc->attr, proc->name, NULL);
425 fas = ns->entries->sym->as;
426 fas = fas ? fas : ns->entries->sym->result->as;
427 fts = &ns->entries->sym->result->ts;
428 if (fts->type == BT_UNKNOWN)
429 fts = gfc_get_default_type (ns->entries->sym->result, NULL);
430 for (el = ns->entries->next; el; el = el->next)
432 ts = &el->sym->result->ts;
434 as = as ? as : el->sym->result->as;
435 if (ts->type == BT_UNKNOWN)
436 ts = gfc_get_default_type (el->sym->result, NULL);
438 if (! gfc_compare_types (ts, fts)
439 || (el->sym->result->attr.dimension
440 != ns->entries->sym->result->attr.dimension)
441 || (el->sym->result->attr.pointer
442 != ns->entries->sym->result->attr.pointer))
445 else if (as && fas && gfc_compare_array_spec (as, fas) == 0)
446 gfc_error ("Procedure %s at %L has entries with mismatched "
447 "array specifications", ns->entries->sym->name,
448 &ns->entries->sym->declared_at);
453 sym = ns->entries->sym->result;
454 /* All result types the same. */
456 if (sym->attr.dimension)
457 gfc_set_array_spec (proc, gfc_copy_array_spec (sym->as), NULL);
458 if (sym->attr.pointer)
459 gfc_add_pointer (&proc->attr, NULL);
463 /* Otherwise the result will be passed through a union by
465 proc->attr.mixed_entry_master = 1;
466 for (el = ns->entries; el; el = el->next)
468 sym = el->sym->result;
469 if (sym->attr.dimension)
471 if (el == ns->entries)
473 ("FUNCTION result %s can't be an array in FUNCTION %s at %L",
474 sym->name, ns->entries->sym->name, &sym->declared_at);
477 ("ENTRY result %s can't be an array in FUNCTION %s at %L",
478 sym->name, ns->entries->sym->name, &sym->declared_at);
480 else if (sym->attr.pointer)
482 if (el == ns->entries)
484 ("FUNCTION result %s can't be a POINTER in FUNCTION %s at %L",
485 sym->name, ns->entries->sym->name, &sym->declared_at);
488 ("ENTRY result %s can't be a POINTER in FUNCTION %s at %L",
489 sym->name, ns->entries->sym->name, &sym->declared_at);
494 if (ts->type == BT_UNKNOWN)
495 ts = gfc_get_default_type (sym, NULL);
499 if (ts->kind == gfc_default_integer_kind)
503 if (ts->kind == gfc_default_real_kind
504 || ts->kind == gfc_default_double_kind)
508 if (ts->kind == gfc_default_complex_kind)
512 if (ts->kind == gfc_default_logical_kind)
516 /* We will issue error elsewhere. */
524 if (el == ns->entries)
526 ("FUNCTION result %s can't be of type %s in FUNCTION %s at %L",
527 sym->name, gfc_typename (ts), ns->entries->sym->name,
531 ("ENTRY result %s can't be of type %s in FUNCTION %s at %L",
532 sym->name, gfc_typename (ts), ns->entries->sym->name,
539 proc->attr.access = ACCESS_PRIVATE;
540 proc->attr.entry_master = 1;
542 /* Merge all the entry point arguments. */
543 for (el = ns->entries; el; el = el->next)
544 merge_argument_lists (proc, el->sym->formal);
546 /* Use the master function for the function body. */
547 ns->proc_name = proc;
549 /* Finalize the new symbols. */
550 gfc_commit_symbols ();
552 /* Restore the original namespace. */
553 gfc_current_ns = old_ns;
557 /* Resolve contained function types. Because contained functions can call one
558 another, they have to be worked out before any of the contained procedures
561 The good news is that if a function doesn't already have a type, the only
562 way it can get one is through an IMPLICIT type or a RESULT variable, because
563 by definition contained functions are contained namespace they're contained
564 in, not in a sibling or parent namespace. */
567 resolve_contained_functions (gfc_namespace * ns)
569 gfc_namespace *child;
572 resolve_formal_arglists (ns);
574 for (child = ns->contained; child; child = child->sibling)
576 /* Resolve alternate entry points first. */
577 resolve_entries (child);
579 /* Then check function return types. */
580 resolve_contained_fntype (child->proc_name, child);
581 for (el = child->entries; el; el = el->next)
582 resolve_contained_fntype (el->sym, child);
587 /* Resolve all of the elements of a structure constructor and make sure that
588 the types are correct. */
591 resolve_structure_cons (gfc_expr * expr)
593 gfc_constructor *cons;
598 cons = expr->value.constructor;
599 /* A constructor may have references if it is the result of substituting a
600 parameter variable. In this case we just pull out the component we
603 comp = expr->ref->u.c.sym->components;
605 comp = expr->ts.derived->components;
607 for (; comp; comp = comp->next, cons = cons->next)
615 if (gfc_resolve_expr (cons->expr) == FAILURE)
621 /* If we don't have the right type, try to convert it. */
623 if (!gfc_compare_types (&cons->expr->ts, &comp->ts))
626 if (comp->pointer && cons->expr->ts.type != BT_UNKNOWN)
627 gfc_error ("The element in the derived type constructor at %L, "
628 "for pointer component '%s', is %s but should be %s",
629 &cons->expr->where, comp->name,
630 gfc_basic_typename (cons->expr->ts.type),
631 gfc_basic_typename (comp->ts.type));
633 t = gfc_convert_type (cons->expr, &comp->ts, 1);
642 /****************** Expression name resolution ******************/
644 /* Returns 0 if a symbol was not declared with a type or
645 attribute declaration statement, nonzero otherwise. */
648 was_declared (gfc_symbol * sym)
654 if (!a.implicit_type && sym->ts.type != BT_UNKNOWN)
657 if (a.allocatable || a.dimension || a.dummy || a.external || a.intrinsic
658 || a.optional || a.pointer || a.save || a.target
659 || a.access != ACCESS_UNKNOWN || a.intent != INTENT_UNKNOWN)
666 /* Determine if a symbol is generic or not. */
669 generic_sym (gfc_symbol * sym)
673 if (sym->attr.generic ||
674 (sym->attr.intrinsic && gfc_generic_intrinsic (sym->name)))
677 if (was_declared (sym) || sym->ns->parent == NULL)
680 gfc_find_symbol (sym->name, sym->ns->parent, 1, &s);
682 return (s == NULL) ? 0 : generic_sym (s);
686 /* Determine if a symbol is specific or not. */
689 specific_sym (gfc_symbol * sym)
693 if (sym->attr.if_source == IFSRC_IFBODY
694 || sym->attr.proc == PROC_MODULE
695 || sym->attr.proc == PROC_INTERNAL
696 || sym->attr.proc == PROC_ST_FUNCTION
697 || (sym->attr.intrinsic &&
698 gfc_specific_intrinsic (sym->name))
699 || sym->attr.external)
702 if (was_declared (sym) || sym->ns->parent == NULL)
705 gfc_find_symbol (sym->name, sym->ns->parent, 1, &s);
707 return (s == NULL) ? 0 : specific_sym (s);
711 /* Figure out if the procedure is specific, generic or unknown. */
714 { PTYPE_GENERIC = 1, PTYPE_SPECIFIC, PTYPE_UNKNOWN }
718 procedure_kind (gfc_symbol * sym)
721 if (generic_sym (sym))
722 return PTYPE_GENERIC;
724 if (specific_sym (sym))
725 return PTYPE_SPECIFIC;
727 return PTYPE_UNKNOWN;
730 /* Check references to assumed size arrays. The flag need_full_assumed_size
731 is nonzero when matching actual arguments. */
733 static int need_full_assumed_size = 0;
736 check_assumed_size_reference (gfc_symbol * sym, gfc_expr * e)
742 if (need_full_assumed_size
743 || !(sym->as && sym->as->type == AS_ASSUMED_SIZE))
746 for (ref = e->ref; ref; ref = ref->next)
747 if (ref->type == REF_ARRAY)
748 for (dim = 0; dim < ref->u.ar.as->rank; dim++)
749 last = (ref->u.ar.end[dim] == NULL) && (ref->u.ar.type == DIMEN_ELEMENT);
753 gfc_error ("The upper bound in the last dimension must "
754 "appear in the reference to the assumed size "
755 "array '%s' at %L.", sym->name, &e->where);
762 /* Look for bad assumed size array references in argument expressions
763 of elemental and array valued intrinsic procedures. Since this is
764 called from procedure resolution functions, it only recurses at
768 resolve_assumed_size_actual (gfc_expr *e)
773 switch (e->expr_type)
777 && check_assumed_size_reference (e->symtree->n.sym, e))
782 if (resolve_assumed_size_actual (e->value.op.op1)
783 || resolve_assumed_size_actual (e->value.op.op2))
794 /* Resolve an actual argument list. Most of the time, this is just
795 resolving the expressions in the list.
796 The exception is that we sometimes have to decide whether arguments
797 that look like procedure arguments are really simple variable
801 resolve_actual_arglist (gfc_actual_arglist * arg)
804 gfc_symtree *parent_st;
807 for (; arg; arg = arg->next)
813 /* Check the label is a valid branching target. */
816 if (arg->label->defined == ST_LABEL_UNKNOWN)
818 gfc_error ("Label %d referenced at %L is never defined",
819 arg->label->value, &arg->label->where);
826 if (e->ts.type != BT_PROCEDURE)
828 if (gfc_resolve_expr (e) != SUCCESS)
833 /* See if the expression node should really be a variable
836 sym = e->symtree->n.sym;
838 if (sym->attr.flavor == FL_PROCEDURE
839 || sym->attr.intrinsic
840 || sym->attr.external)
843 /* If a procedure is not already determined to be something else
844 check if it is intrinsic. */
845 if (!sym->attr.intrinsic
846 && !(sym->attr.external || sym->attr.use_assoc
847 || sym->attr.if_source == IFSRC_IFBODY)
848 && gfc_intrinsic_name (sym->name, sym->attr.subroutine))
849 sym->attr.intrinsic = 1;
851 if (sym->attr.proc == PROC_ST_FUNCTION)
853 gfc_error ("Statement function '%s' at %L is not allowed as an "
854 "actual argument", sym->name, &e->where);
857 if (sym->attr.contained && !sym->attr.use_assoc
858 && sym->ns->proc_name->attr.flavor != FL_MODULE)
860 gfc_error ("Internal procedure '%s' is not allowed as an "
861 "actual argument at %L", sym->name, &e->where);
864 if (sym->attr.elemental && !sym->attr.intrinsic)
866 gfc_error ("ELEMENTAL non-INTRINSIC procedure '%s' is not "
867 "allowed as an actual argument at %L", sym->name,
871 if (sym->attr.generic)
873 gfc_error ("GENERIC non-INTRINSIC procedure '%s' is not "
874 "allowed as an actual argument at %L", sym->name,
878 /* If the symbol is the function that names the current (or
879 parent) scope, then we really have a variable reference. */
881 if (sym->attr.function && sym->result == sym
882 && (sym->ns->proc_name == sym
883 || (sym->ns->parent != NULL
884 && sym->ns->parent->proc_name == sym)))
890 /* See if the name is a module procedure in a parent unit. */
892 if (was_declared (sym) || sym->ns->parent == NULL)
895 if (gfc_find_sym_tree (sym->name, sym->ns->parent, 1, &parent_st))
897 gfc_error ("Symbol '%s' at %L is ambiguous", sym->name, &e->where);
901 if (parent_st == NULL)
904 sym = parent_st->n.sym;
905 e->symtree = parent_st; /* Point to the right thing. */
907 if (sym->attr.flavor == FL_PROCEDURE
908 || sym->attr.intrinsic
909 || sym->attr.external)
915 e->expr_type = EXPR_VARIABLE;
919 e->rank = sym->as->rank;
920 e->ref = gfc_get_ref ();
921 e->ref->type = REF_ARRAY;
922 e->ref->u.ar.type = AR_FULL;
923 e->ref->u.ar.as = sym->as;
931 /* Do the checks of the actual argument list that are specific to elemental
932 procedures. If called with c == NULL, we have a function, otherwise if
933 expr == NULL, we have a subroutine. */
935 resolve_elemental_actual (gfc_expr *expr, gfc_code *c)
937 gfc_actual_arglist *arg0;
938 gfc_actual_arglist *arg;
939 gfc_symbol *esym = NULL;
940 gfc_intrinsic_sym *isym = NULL;
942 gfc_intrinsic_arg *iformal = NULL;
943 gfc_formal_arglist *eformal = NULL;
944 bool formal_optional = false;
945 bool set_by_optional = false;
949 /* Is this an elemental procedure? */
950 if (expr && expr->value.function.actual != NULL)
952 if (expr->value.function.esym != NULL
953 && expr->value.function.esym->attr.elemental)
955 arg0 = expr->value.function.actual;
956 esym = expr->value.function.esym;
958 else if (expr->value.function.isym != NULL
959 && expr->value.function.isym->elemental)
961 arg0 = expr->value.function.actual;
962 isym = expr->value.function.isym;
967 else if (c && c->ext.actual != NULL
968 && c->symtree->n.sym->attr.elemental)
970 arg0 = c->ext.actual;
971 esym = c->symtree->n.sym;
976 /* The rank of an elemental is the rank of its array argument(s). */
977 for (arg = arg0; arg; arg = arg->next)
979 if (arg->expr != NULL && arg->expr->rank > 0)
981 rank = arg->expr->rank;
982 if (arg->expr->expr_type == EXPR_VARIABLE
983 && arg->expr->symtree->n.sym->attr.optional)
984 set_by_optional = true;
986 /* Function specific; set the result rank and shape. */
990 if (!expr->shape && arg->expr->shape)
992 expr->shape = gfc_get_shape (rank);
993 for (i = 0; i < rank; i++)
994 mpz_init_set (expr->shape[i], arg->expr->shape[i]);
1001 /* If it is an array, it shall not be supplied as an actual argument
1002 to an elemental procedure unless an array of the same rank is supplied
1003 as an actual argument corresponding to a nonoptional dummy argument of
1004 that elemental procedure(12.4.1.5). */
1005 formal_optional = false;
1007 iformal = isym->formal;
1009 eformal = esym->formal;
1011 for (arg = arg0; arg; arg = arg->next)
1015 if (eformal->sym && eformal->sym->attr.optional)
1016 formal_optional = true;
1017 eformal = eformal->next;
1019 else if (isym && iformal)
1021 if (iformal->optional)
1022 formal_optional = true;
1023 iformal = iformal->next;
1026 formal_optional = true;
1028 if (pedantic && arg->expr != NULL
1029 && arg->expr->expr_type == EXPR_VARIABLE
1030 && arg->expr->symtree->n.sym->attr.optional
1033 && (set_by_optional || arg->expr->rank != rank)
1034 && !(isym && isym->generic_id == GFC_ISYM_CONVERSION))
1036 gfc_warning ("'%s' at %L is an array and OPTIONAL; IF IT IS "
1037 "MISSING, it cannot be the actual argument of an "
1038 "ELEMENTAL procedure unless there is a non-optional"
1039 "argument with the same rank (12.4.1.5)",
1040 arg->expr->symtree->n.sym->name, &arg->expr->where);
1045 for (arg = arg0; arg; arg = arg->next)
1047 if (arg->expr == NULL || arg->expr->rank == 0)
1050 /* Being elemental, the last upper bound of an assumed size array
1051 argument must be present. */
1052 if (resolve_assumed_size_actual (arg->expr))
1058 /* Elemental subroutine array actual arguments must conform. */
1061 if (gfc_check_conformance ("elemental subroutine", arg->expr, e)
1073 /* Go through each actual argument in ACTUAL and see if it can be
1074 implemented as an inlined, non-copying intrinsic. FNSYM is the
1075 function being called, or NULL if not known. */
1078 find_noncopying_intrinsics (gfc_symbol * fnsym, gfc_actual_arglist * actual)
1080 gfc_actual_arglist *ap;
1083 for (ap = actual; ap; ap = ap->next)
1085 && (expr = gfc_get_noncopying_intrinsic_argument (ap->expr))
1086 && !gfc_check_fncall_dependency (expr, INTENT_IN, fnsym, actual))
1087 ap->expr->inline_noncopying_intrinsic = 1;
1090 /* This function does the checking of references to global procedures
1091 as defined in sections 18.1 and 14.1, respectively, of the Fortran
1092 77 and 95 standards. It checks for a gsymbol for the name, making
1093 one if it does not already exist. If it already exists, then the
1094 reference being resolved must correspond to the type of gsymbol.
1095 Otherwise, the new symbol is equipped with the attributes of the
1096 reference. The corresponding code that is called in creating
1097 global entities is parse.c. */
1100 resolve_global_procedure (gfc_symbol *sym, locus *where, int sub)
1105 type = sub ? GSYM_SUBROUTINE : GSYM_FUNCTION;
1107 gsym = gfc_get_gsymbol (sym->name);
1109 if ((gsym->type != GSYM_UNKNOWN && gsym->type != type))
1110 global_used (gsym, where);
1112 if (gsym->type == GSYM_UNKNOWN)
1115 gsym->where = *where;
1121 /************* Function resolution *************/
1123 /* Resolve a function call known to be generic.
1124 Section 14.1.2.4.1. */
1127 resolve_generic_f0 (gfc_expr * expr, gfc_symbol * sym)
1131 if (sym->attr.generic)
1134 gfc_search_interface (sym->generic, 0, &expr->value.function.actual);
1137 expr->value.function.name = s->name;
1138 expr->value.function.esym = s;
1140 if (s->ts.type != BT_UNKNOWN)
1142 else if (s->result != NULL && s->result->ts.type != BT_UNKNOWN)
1143 expr->ts = s->result->ts;
1146 expr->rank = s->as->rank;
1147 else if (s->result != NULL && s->result->as != NULL)
1148 expr->rank = s->result->as->rank;
1153 /* TODO: Need to search for elemental references in generic interface */
1156 if (sym->attr.intrinsic)
1157 return gfc_intrinsic_func_interface (expr, 0);
1164 resolve_generic_f (gfc_expr * expr)
1169 sym = expr->symtree->n.sym;
1173 m = resolve_generic_f0 (expr, sym);
1176 else if (m == MATCH_ERROR)
1180 if (sym->ns->parent == NULL)
1182 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
1186 if (!generic_sym (sym))
1190 /* Last ditch attempt. */
1192 if (!gfc_generic_intrinsic (expr->symtree->n.sym->name))
1194 gfc_error ("There is no specific function for the generic '%s' at %L",
1195 expr->symtree->n.sym->name, &expr->where);
1199 m = gfc_intrinsic_func_interface (expr, 0);
1204 ("Generic function '%s' at %L is not consistent with a specific "
1205 "intrinsic interface", expr->symtree->n.sym->name, &expr->where);
1211 /* Resolve a function call known to be specific. */
1214 resolve_specific_f0 (gfc_symbol * sym, gfc_expr * expr)
1218 if (sym->attr.external || sym->attr.if_source == IFSRC_IFBODY)
1220 if (sym->attr.dummy)
1222 sym->attr.proc = PROC_DUMMY;
1226 sym->attr.proc = PROC_EXTERNAL;
1230 if (sym->attr.proc == PROC_MODULE
1231 || sym->attr.proc == PROC_ST_FUNCTION
1232 || sym->attr.proc == PROC_INTERNAL)
1235 if (sym->attr.intrinsic)
1237 m = gfc_intrinsic_func_interface (expr, 1);
1242 ("Function '%s' at %L is INTRINSIC but is not compatible with "
1243 "an intrinsic", sym->name, &expr->where);
1251 gfc_procedure_use (sym, &expr->value.function.actual, &expr->where);
1254 expr->value.function.name = sym->name;
1255 expr->value.function.esym = sym;
1256 if (sym->as != NULL)
1257 expr->rank = sym->as->rank;
1264 resolve_specific_f (gfc_expr * expr)
1269 sym = expr->symtree->n.sym;
1273 m = resolve_specific_f0 (sym, expr);
1276 if (m == MATCH_ERROR)
1279 if (sym->ns->parent == NULL)
1282 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
1288 gfc_error ("Unable to resolve the specific function '%s' at %L",
1289 expr->symtree->n.sym->name, &expr->where);
1295 /* Resolve a procedure call not known to be generic nor specific. */
1298 resolve_unknown_f (gfc_expr * expr)
1303 sym = expr->symtree->n.sym;
1305 if (sym->attr.dummy)
1307 sym->attr.proc = PROC_DUMMY;
1308 expr->value.function.name = sym->name;
1312 /* See if we have an intrinsic function reference. */
1314 if (gfc_intrinsic_name (sym->name, 0))
1316 if (gfc_intrinsic_func_interface (expr, 1) == MATCH_YES)
1321 /* The reference is to an external name. */
1323 sym->attr.proc = PROC_EXTERNAL;
1324 expr->value.function.name = sym->name;
1325 expr->value.function.esym = expr->symtree->n.sym;
1327 if (sym->as != NULL)
1328 expr->rank = sym->as->rank;
1330 /* Type of the expression is either the type of the symbol or the
1331 default type of the symbol. */
1334 gfc_procedure_use (sym, &expr->value.function.actual, &expr->where);
1336 if (sym->ts.type != BT_UNKNOWN)
1340 ts = gfc_get_default_type (sym, sym->ns);
1342 if (ts->type == BT_UNKNOWN)
1344 gfc_error ("Function '%s' at %L has no IMPLICIT type",
1345 sym->name, &expr->where);
1356 /* Figure out if a function reference is pure or not. Also set the name
1357 of the function for a potential error message. Return nonzero if the
1358 function is PURE, zero if not. */
1361 pure_function (gfc_expr * e, const char **name)
1365 if (e->value.function.esym)
1367 pure = gfc_pure (e->value.function.esym);
1368 *name = e->value.function.esym->name;
1370 else if (e->value.function.isym)
1372 pure = e->value.function.isym->pure
1373 || e->value.function.isym->elemental;
1374 *name = e->value.function.isym->name;
1378 /* Implicit functions are not pure. */
1380 *name = e->value.function.name;
1387 /* Resolve a function call, which means resolving the arguments, then figuring
1388 out which entity the name refers to. */
1389 /* TODO: Check procedure arguments so that an INTENT(IN) isn't passed
1390 to INTENT(OUT) or INTENT(INOUT). */
1393 resolve_function (gfc_expr * expr)
1395 gfc_actual_arglist *arg;
1403 sym = expr->symtree->n.sym;
1405 /* If the procedure is not internal, a statement function or a module
1406 procedure,it must be external and should be checked for usage. */
1407 if (sym && !sym->attr.dummy && !sym->attr.contained
1408 && sym->attr.proc != PROC_ST_FUNCTION
1409 && !sym->attr.use_assoc)
1410 resolve_global_procedure (sym, &expr->where, 0);
1412 /* Switch off assumed size checking and do this again for certain kinds
1413 of procedure, once the procedure itself is resolved. */
1414 need_full_assumed_size++;
1416 if (resolve_actual_arglist (expr->value.function.actual) == FAILURE)
1419 /* Resume assumed_size checking. */
1420 need_full_assumed_size--;
1422 if (sym && sym->ts.type == BT_CHARACTER
1424 && sym->ts.cl->length == NULL
1426 && expr->value.function.esym == NULL
1427 && !sym->attr.contained)
1429 /* Internal procedures are taken care of in resolve_contained_fntype. */
1430 gfc_error ("Function '%s' is declared CHARACTER(*) and cannot "
1431 "be used at %L since it is not a dummy argument",
1432 sym->name, &expr->where);
1436 /* See if function is already resolved. */
1438 if (expr->value.function.name != NULL)
1440 if (expr->ts.type == BT_UNKNOWN)
1446 /* Apply the rules of section 14.1.2. */
1448 switch (procedure_kind (sym))
1451 t = resolve_generic_f (expr);
1454 case PTYPE_SPECIFIC:
1455 t = resolve_specific_f (expr);
1459 t = resolve_unknown_f (expr);
1463 gfc_internal_error ("resolve_function(): bad function type");
1467 /* If the expression is still a function (it might have simplified),
1468 then we check to see if we are calling an elemental function. */
1470 if (expr->expr_type != EXPR_FUNCTION)
1473 temp = need_full_assumed_size;
1474 need_full_assumed_size = 0;
1476 if (resolve_elemental_actual (expr, NULL) == FAILURE)
1479 if (omp_workshare_flag
1480 && expr->value.function.esym
1481 && ! gfc_elemental (expr->value.function.esym))
1483 gfc_error ("User defined non-ELEMENTAL function '%s' at %L not allowed"
1484 " in WORKSHARE construct", expr->value.function.esym->name,
1489 else if (expr->value.function.actual != NULL
1490 && expr->value.function.isym != NULL
1491 && expr->value.function.isym->generic_id != GFC_ISYM_LBOUND
1492 && expr->value.function.isym->generic_id != GFC_ISYM_LOC
1493 && expr->value.function.isym->generic_id != GFC_ISYM_PRESENT)
1495 /* Array instrinsics must also have the last upper bound of an
1496 assumed size array argument. UBOUND and SIZE have to be
1497 excluded from the check if the second argument is anything
1500 inquiry = expr->value.function.isym->generic_id == GFC_ISYM_UBOUND
1501 || expr->value.function.isym->generic_id == GFC_ISYM_SIZE;
1503 for (arg = expr->value.function.actual; arg; arg = arg->next)
1505 if (inquiry && arg->next != NULL && arg->next->expr
1506 && arg->next->expr->expr_type != EXPR_CONSTANT)
1509 if (arg->expr != NULL
1510 && arg->expr->rank > 0
1511 && resolve_assumed_size_actual (arg->expr))
1516 need_full_assumed_size = temp;
1518 if (!pure_function (expr, &name) && name)
1523 ("reference to non-PURE function '%s' at %L inside a "
1524 "FORALL %s", name, &expr->where, forall_flag == 2 ?
1528 else if (gfc_pure (NULL))
1530 gfc_error ("Function reference to '%s' at %L is to a non-PURE "
1531 "procedure within a PURE procedure", name, &expr->where);
1536 /* Functions without the RECURSIVE attribution are not allowed to
1537 * call themselves. */
1538 if (expr->value.function.esym && !expr->value.function.esym->attr.recursive)
1540 gfc_symbol *esym, *proc;
1541 esym = expr->value.function.esym;
1542 proc = gfc_current_ns->proc_name;
1545 gfc_error ("Function '%s' at %L cannot call itself, as it is not "
1546 "RECURSIVE", name, &expr->where);
1550 if (esym->attr.entry && esym->ns->entries && proc->ns->entries
1551 && esym->ns->entries->sym == proc->ns->entries->sym)
1553 gfc_error ("Call to ENTRY '%s' at %L is recursive, but function "
1554 "'%s' is not declared as RECURSIVE",
1555 esym->name, &expr->where, esym->ns->entries->sym->name);
1560 /* Character lengths of use associated functions may contains references to
1561 symbols not referenced from the current program unit otherwise. Make sure
1562 those symbols are marked as referenced. */
1564 if (expr->ts.type == BT_CHARACTER && expr->value.function.esym
1565 && expr->value.function.esym->attr.use_assoc)
1567 gfc_expr_set_symbols_referenced (expr->ts.cl->length);
1571 find_noncopying_intrinsics (expr->value.function.esym,
1572 expr->value.function.actual);
1577 /************* Subroutine resolution *************/
1580 pure_subroutine (gfc_code * c, gfc_symbol * sym)
1587 gfc_error ("Subroutine call to '%s' in FORALL block at %L is not PURE",
1588 sym->name, &c->loc);
1589 else if (gfc_pure (NULL))
1590 gfc_error ("Subroutine call to '%s' at %L is not PURE", sym->name,
1596 resolve_generic_s0 (gfc_code * c, gfc_symbol * sym)
1600 if (sym->attr.generic)
1602 s = gfc_search_interface (sym->generic, 1, &c->ext.actual);
1605 c->resolved_sym = s;
1606 pure_subroutine (c, s);
1610 /* TODO: Need to search for elemental references in generic interface. */
1613 if (sym->attr.intrinsic)
1614 return gfc_intrinsic_sub_interface (c, 0);
1621 resolve_generic_s (gfc_code * c)
1626 sym = c->symtree->n.sym;
1630 m = resolve_generic_s0 (c, sym);
1633 else if (m == MATCH_ERROR)
1637 if (sym->ns->parent == NULL)
1639 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
1643 if (!generic_sym (sym))
1647 /* Last ditch attempt. */
1648 sym = c->symtree->n.sym;
1649 if (!gfc_generic_intrinsic (sym->name))
1652 ("There is no specific subroutine for the generic '%s' at %L",
1653 sym->name, &c->loc);
1657 m = gfc_intrinsic_sub_interface (c, 0);
1661 gfc_error ("Generic subroutine '%s' at %L is not consistent with an "
1662 "intrinsic subroutine interface", sym->name, &c->loc);
1668 /* Resolve a subroutine call known to be specific. */
1671 resolve_specific_s0 (gfc_code * c, gfc_symbol * sym)
1675 if (sym->attr.external || sym->attr.if_source == IFSRC_IFBODY)
1677 if (sym->attr.dummy)
1679 sym->attr.proc = PROC_DUMMY;
1683 sym->attr.proc = PROC_EXTERNAL;
1687 if (sym->attr.proc == PROC_MODULE || sym->attr.proc == PROC_INTERNAL)
1690 if (sym->attr.intrinsic)
1692 m = gfc_intrinsic_sub_interface (c, 1);
1696 gfc_error ("Subroutine '%s' at %L is INTRINSIC but is not compatible "
1697 "with an intrinsic", sym->name, &c->loc);
1705 gfc_procedure_use (sym, &c->ext.actual, &c->loc);
1707 c->resolved_sym = sym;
1708 pure_subroutine (c, sym);
1715 resolve_specific_s (gfc_code * c)
1720 sym = c->symtree->n.sym;
1724 m = resolve_specific_s0 (c, sym);
1727 if (m == MATCH_ERROR)
1730 if (sym->ns->parent == NULL)
1733 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
1739 sym = c->symtree->n.sym;
1740 gfc_error ("Unable to resolve the specific subroutine '%s' at %L",
1741 sym->name, &c->loc);
1747 /* Resolve a subroutine call not known to be generic nor specific. */
1750 resolve_unknown_s (gfc_code * c)
1754 sym = c->symtree->n.sym;
1756 if (sym->attr.dummy)
1758 sym->attr.proc = PROC_DUMMY;
1762 /* See if we have an intrinsic function reference. */
1764 if (gfc_intrinsic_name (sym->name, 1))
1766 if (gfc_intrinsic_sub_interface (c, 1) == MATCH_YES)
1771 /* The reference is to an external name. */
1774 gfc_procedure_use (sym, &c->ext.actual, &c->loc);
1776 c->resolved_sym = sym;
1778 pure_subroutine (c, sym);
1784 /* Resolve a subroutine call. Although it was tempting to use the same code
1785 for functions, subroutines and functions are stored differently and this
1786 makes things awkward. */
1789 resolve_call (gfc_code * c)
1793 if (c->symtree && c->symtree->n.sym
1794 && c->symtree->n.sym->ts.type != BT_UNKNOWN)
1796 gfc_error ("'%s' at %L has a type, which is not consistent with "
1797 "the CALL at %L", c->symtree->n.sym->name,
1798 &c->symtree->n.sym->declared_at, &c->loc);
1802 /* If the procedure is not internal or module, it must be external and
1803 should be checked for usage. */
1804 if (c->symtree && c->symtree->n.sym
1805 && !c->symtree->n.sym->attr.dummy
1806 && !c->symtree->n.sym->attr.contained
1807 && !c->symtree->n.sym->attr.use_assoc)
1808 resolve_global_procedure (c->symtree->n.sym, &c->loc, 1);
1810 /* Subroutines without the RECURSIVE attribution are not allowed to
1811 * call themselves. */
1812 if (c->symtree && c->symtree->n.sym && !c->symtree->n.sym->attr.recursive)
1814 gfc_symbol *csym, *proc;
1815 csym = c->symtree->n.sym;
1816 proc = gfc_current_ns->proc_name;
1819 gfc_error ("SUBROUTINE '%s' at %L cannot call itself, as it is not "
1820 "RECURSIVE", csym->name, &c->loc);
1824 if (csym->attr.entry && csym->ns->entries && proc->ns->entries
1825 && csym->ns->entries->sym == proc->ns->entries->sym)
1827 gfc_error ("Call to ENTRY '%s' at %L is recursive, but subroutine "
1828 "'%s' is not declared as RECURSIVE",
1829 csym->name, &c->loc, csym->ns->entries->sym->name);
1834 /* Switch off assumed size checking and do this again for certain kinds
1835 of procedure, once the procedure itself is resolved. */
1836 need_full_assumed_size++;
1838 if (resolve_actual_arglist (c->ext.actual) == FAILURE)
1841 /* Resume assumed_size checking. */
1842 need_full_assumed_size--;
1846 if (c->resolved_sym == NULL)
1847 switch (procedure_kind (c->symtree->n.sym))
1850 t = resolve_generic_s (c);
1853 case PTYPE_SPECIFIC:
1854 t = resolve_specific_s (c);
1858 t = resolve_unknown_s (c);
1862 gfc_internal_error ("resolve_subroutine(): bad function type");
1865 /* Some checks of elemental subroutine actual arguments. */
1866 if (resolve_elemental_actual (NULL, c) == FAILURE)
1870 find_noncopying_intrinsics (c->resolved_sym, c->ext.actual);
1874 /* Compare the shapes of two arrays that have non-NULL shapes. If both
1875 op1->shape and op2->shape are non-NULL return SUCCESS if their shapes
1876 match. If both op1->shape and op2->shape are non-NULL return FAILURE
1877 if their shapes do not match. If either op1->shape or op2->shape is
1878 NULL, return SUCCESS. */
1881 compare_shapes (gfc_expr * op1, gfc_expr * op2)
1888 if (op1->shape != NULL && op2->shape != NULL)
1890 for (i = 0; i < op1->rank; i++)
1892 if (mpz_cmp (op1->shape[i], op2->shape[i]) != 0)
1894 gfc_error ("Shapes for operands at %L and %L are not conformable",
1895 &op1->where, &op2->where);
1905 /* Resolve an operator expression node. This can involve replacing the
1906 operation with a user defined function call. */
1909 resolve_operator (gfc_expr * e)
1911 gfc_expr *op1, *op2;
1915 /* Resolve all subnodes-- give them types. */
1917 switch (e->value.op.operator)
1920 if (gfc_resolve_expr (e->value.op.op2) == FAILURE)
1923 /* Fall through... */
1926 case INTRINSIC_UPLUS:
1927 case INTRINSIC_UMINUS:
1928 case INTRINSIC_PARENTHESES:
1929 if (gfc_resolve_expr (e->value.op.op1) == FAILURE)
1934 /* Typecheck the new node. */
1936 op1 = e->value.op.op1;
1937 op2 = e->value.op.op2;
1939 switch (e->value.op.operator)
1941 case INTRINSIC_UPLUS:
1942 case INTRINSIC_UMINUS:
1943 if (op1->ts.type == BT_INTEGER
1944 || op1->ts.type == BT_REAL
1945 || op1->ts.type == BT_COMPLEX)
1951 sprintf (msg, _("Operand of unary numeric operator '%s' at %%L is %s"),
1952 gfc_op2string (e->value.op.operator), gfc_typename (&e->ts));
1955 case INTRINSIC_PLUS:
1956 case INTRINSIC_MINUS:
1957 case INTRINSIC_TIMES:
1958 case INTRINSIC_DIVIDE:
1959 case INTRINSIC_POWER:
1960 if (gfc_numeric_ts (&op1->ts) && gfc_numeric_ts (&op2->ts))
1962 gfc_type_convert_binary (e);
1967 _("Operands of binary numeric operator '%s' at %%L are %s/%s"),
1968 gfc_op2string (e->value.op.operator), gfc_typename (&op1->ts),
1969 gfc_typename (&op2->ts));
1972 case INTRINSIC_CONCAT:
1973 if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER)
1975 e->ts.type = BT_CHARACTER;
1976 e->ts.kind = op1->ts.kind;
1981 _("Operands of string concatenation operator at %%L are %s/%s"),
1982 gfc_typename (&op1->ts), gfc_typename (&op2->ts));
1988 case INTRINSIC_NEQV:
1989 if (op1->ts.type == BT_LOGICAL && op2->ts.type == BT_LOGICAL)
1991 e->ts.type = BT_LOGICAL;
1992 e->ts.kind = gfc_kind_max (op1, op2);
1993 if (op1->ts.kind < e->ts.kind)
1994 gfc_convert_type (op1, &e->ts, 2);
1995 else if (op2->ts.kind < e->ts.kind)
1996 gfc_convert_type (op2, &e->ts, 2);
2000 sprintf (msg, _("Operands of logical operator '%s' at %%L are %s/%s"),
2001 gfc_op2string (e->value.op.operator), gfc_typename (&op1->ts),
2002 gfc_typename (&op2->ts));
2007 if (op1->ts.type == BT_LOGICAL)
2009 e->ts.type = BT_LOGICAL;
2010 e->ts.kind = op1->ts.kind;
2014 sprintf (msg, _("Operand of .NOT. operator at %%L is %s"),
2015 gfc_typename (&op1->ts));
2022 if (op1->ts.type == BT_COMPLEX || op2->ts.type == BT_COMPLEX)
2024 strcpy (msg, _("COMPLEX quantities cannot be compared at %L"));
2028 /* Fall through... */
2032 if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER)
2034 e->ts.type = BT_LOGICAL;
2035 e->ts.kind = gfc_default_logical_kind;
2039 if (gfc_numeric_ts (&op1->ts) && gfc_numeric_ts (&op2->ts))
2041 gfc_type_convert_binary (e);
2043 e->ts.type = BT_LOGICAL;
2044 e->ts.kind = gfc_default_logical_kind;
2048 if (op1->ts.type == BT_LOGICAL && op2->ts.type == BT_LOGICAL)
2050 _("Logicals at %%L must be compared with %s instead of %s"),
2051 e->value.op.operator == INTRINSIC_EQ ? ".EQV." : ".NEQV.",
2052 gfc_op2string (e->value.op.operator));
2055 _("Operands of comparison operator '%s' at %%L are %s/%s"),
2056 gfc_op2string (e->value.op.operator), gfc_typename (&op1->ts),
2057 gfc_typename (&op2->ts));
2061 case INTRINSIC_USER:
2063 sprintf (msg, _("Operand of user operator '%s' at %%L is %s"),
2064 e->value.op.uop->name, gfc_typename (&op1->ts));
2066 sprintf (msg, _("Operands of user operator '%s' at %%L are %s/%s"),
2067 e->value.op.uop->name, gfc_typename (&op1->ts),
2068 gfc_typename (&op2->ts));
2072 case INTRINSIC_PARENTHESES:
2076 gfc_internal_error ("resolve_operator(): Bad intrinsic");
2079 /* Deal with arrayness of an operand through an operator. */
2083 switch (e->value.op.operator)
2085 case INTRINSIC_PLUS:
2086 case INTRINSIC_MINUS:
2087 case INTRINSIC_TIMES:
2088 case INTRINSIC_DIVIDE:
2089 case INTRINSIC_POWER:
2090 case INTRINSIC_CONCAT:
2094 case INTRINSIC_NEQV:
2102 if (op1->rank == 0 && op2->rank == 0)
2105 if (op1->rank == 0 && op2->rank != 0)
2107 e->rank = op2->rank;
2109 if (e->shape == NULL)
2110 e->shape = gfc_copy_shape (op2->shape, op2->rank);
2113 if (op1->rank != 0 && op2->rank == 0)
2115 e->rank = op1->rank;
2117 if (e->shape == NULL)
2118 e->shape = gfc_copy_shape (op1->shape, op1->rank);
2121 if (op1->rank != 0 && op2->rank != 0)
2123 if (op1->rank == op2->rank)
2125 e->rank = op1->rank;
2126 if (e->shape == NULL)
2128 t = compare_shapes(op1, op2);
2132 e->shape = gfc_copy_shape (op1->shape, op1->rank);
2137 gfc_error ("Inconsistent ranks for operator at %L and %L",
2138 &op1->where, &op2->where);
2141 /* Allow higher level expressions to work. */
2149 case INTRINSIC_UPLUS:
2150 case INTRINSIC_UMINUS:
2151 case INTRINSIC_PARENTHESES:
2152 e->rank = op1->rank;
2154 if (e->shape == NULL)
2155 e->shape = gfc_copy_shape (op1->shape, op1->rank);
2157 /* Simply copy arrayness attribute */
2164 /* Attempt to simplify the expression. */
2166 t = gfc_simplify_expr (e, 0);
2171 if (gfc_extend_expr (e) == SUCCESS)
2174 gfc_error (msg, &e->where);
2180 /************** Array resolution subroutines **************/
2184 { CMP_LT, CMP_EQ, CMP_GT, CMP_UNKNOWN }
2187 /* Compare two integer expressions. */
2190 compare_bound (gfc_expr * a, gfc_expr * b)
2194 if (a == NULL || a->expr_type != EXPR_CONSTANT
2195 || b == NULL || b->expr_type != EXPR_CONSTANT)
2198 if (a->ts.type != BT_INTEGER || b->ts.type != BT_INTEGER)
2199 gfc_internal_error ("compare_bound(): Bad expression");
2201 i = mpz_cmp (a->value.integer, b->value.integer);
2211 /* Compare an integer expression with an integer. */
2214 compare_bound_int (gfc_expr * a, int b)
2218 if (a == NULL || a->expr_type != EXPR_CONSTANT)
2221 if (a->ts.type != BT_INTEGER)
2222 gfc_internal_error ("compare_bound_int(): Bad expression");
2224 i = mpz_cmp_si (a->value.integer, b);
2234 /* Compare an integer expression with a mpz_t. */
2237 compare_bound_mpz_t (gfc_expr * a, mpz_t b)
2241 if (a == NULL || a->expr_type != EXPR_CONSTANT)
2244 if (a->ts.type != BT_INTEGER)
2245 gfc_internal_error ("compare_bound_int(): Bad expression");
2247 i = mpz_cmp (a->value.integer, b);
2257 /* Compute the last value of a sequence given by a triplet.
2258 Return 0 if it wasn't able to compute the last value, or if the
2259 sequence if empty, and 1 otherwise. */
2262 compute_last_value_for_triplet (gfc_expr * start, gfc_expr * end,
2263 gfc_expr * stride, mpz_t last)
2267 if (start == NULL || start->expr_type != EXPR_CONSTANT
2268 || end == NULL || end->expr_type != EXPR_CONSTANT
2269 || (stride != NULL && stride->expr_type != EXPR_CONSTANT))
2272 if (start->ts.type != BT_INTEGER || end->ts.type != BT_INTEGER
2273 || (stride != NULL && stride->ts.type != BT_INTEGER))
2276 if (stride == NULL || compare_bound_int(stride, 1) == CMP_EQ)
2278 if (compare_bound (start, end) == CMP_GT)
2280 mpz_set (last, end->value.integer);
2284 if (compare_bound_int (stride, 0) == CMP_GT)
2286 /* Stride is positive */
2287 if (mpz_cmp (start->value.integer, end->value.integer) > 0)
2292 /* Stride is negative */
2293 if (mpz_cmp (start->value.integer, end->value.integer) < 0)
2298 mpz_sub (rem, end->value.integer, start->value.integer);
2299 mpz_tdiv_r (rem, rem, stride->value.integer);
2300 mpz_sub (last, end->value.integer, rem);
2307 /* Compare a single dimension of an array reference to the array
2311 check_dimension (int i, gfc_array_ref * ar, gfc_array_spec * as)
2315 /* Given start, end and stride values, calculate the minimum and
2316 maximum referenced indexes. */
2324 if (compare_bound (ar->start[i], as->lower[i]) == CMP_LT)
2326 if (compare_bound (ar->start[i], as->upper[i]) == CMP_GT)
2332 if (compare_bound_int (ar->stride[i], 0) == CMP_EQ)
2334 gfc_error ("Illegal stride of zero at %L", &ar->c_where[i]);
2338 #define AR_START (ar->start[i] ? ar->start[i] : as->lower[i])
2339 #define AR_END (ar->end[i] ? ar->end[i] : as->upper[i])
2341 if (compare_bound (AR_START, AR_END) == CMP_EQ
2342 && (compare_bound (AR_START, as->lower[i]) == CMP_LT
2343 || compare_bound (AR_START, as->upper[i]) == CMP_GT))
2346 if (((compare_bound_int (ar->stride[i], 0) == CMP_GT
2347 || ar->stride[i] == NULL)
2348 && compare_bound (AR_START, AR_END) != CMP_GT)
2349 || (compare_bound_int (ar->stride[i], 0) == CMP_LT
2350 && compare_bound (AR_START, AR_END) != CMP_LT))
2352 if (compare_bound (AR_START, as->lower[i]) == CMP_LT)
2354 if (compare_bound (AR_START, as->upper[i]) == CMP_GT)
2358 mpz_init (last_value);
2359 if (compute_last_value_for_triplet (AR_START, AR_END, ar->stride[i],
2362 if (compare_bound_mpz_t (as->lower[i], last_value) == CMP_GT
2363 || compare_bound_mpz_t (as->upper[i], last_value) == CMP_LT)
2365 mpz_clear (last_value);
2369 mpz_clear (last_value);
2377 gfc_internal_error ("check_dimension(): Bad array reference");
2383 gfc_warning ("Array reference at %L is out of bounds", &ar->c_where[i]);
2388 /* Compare an array reference with an array specification. */
2391 compare_spec_to_ref (gfc_array_ref * ar)
2398 /* TODO: Full array sections are only allowed as actual parameters. */
2399 if (as->type == AS_ASSUMED_SIZE
2400 && (/*ar->type == AR_FULL
2401 ||*/ (ar->type == AR_SECTION
2402 && ar->dimen_type[i] == DIMEN_RANGE && ar->end[i] == NULL)))
2404 gfc_error ("Rightmost upper bound of assumed size array section"
2405 " not specified at %L", &ar->where);
2409 if (ar->type == AR_FULL)
2412 if (as->rank != ar->dimen)
2414 gfc_error ("Rank mismatch in array reference at %L (%d/%d)",
2415 &ar->where, ar->dimen, as->rank);
2419 for (i = 0; i < as->rank; i++)
2420 if (check_dimension (i, ar, as) == FAILURE)
2427 /* Resolve one part of an array index. */
2430 gfc_resolve_index (gfc_expr * index, int check_scalar)
2437 if (gfc_resolve_expr (index) == FAILURE)
2440 if (check_scalar && index->rank != 0)
2442 gfc_error ("Array index at %L must be scalar", &index->where);
2446 if (index->ts.type != BT_INTEGER && index->ts.type != BT_REAL)
2448 gfc_error ("Array index at %L must be of INTEGER type",
2453 if (index->ts.type == BT_REAL)
2454 if (gfc_notify_std (GFC_STD_LEGACY, "Extension: REAL array index at %L",
2455 &index->where) == FAILURE)
2458 if (index->ts.kind != gfc_index_integer_kind
2459 || index->ts.type != BT_INTEGER)
2462 ts.type = BT_INTEGER;
2463 ts.kind = gfc_index_integer_kind;
2465 gfc_convert_type_warn (index, &ts, 2, 0);
2471 /* Resolve a dim argument to an intrinsic function. */
2474 gfc_resolve_dim_arg (gfc_expr *dim)
2479 if (gfc_resolve_expr (dim) == FAILURE)
2484 gfc_error ("Argument dim at %L must be scalar", &dim->where);
2488 if (dim->ts.type != BT_INTEGER)
2490 gfc_error ("Argument dim at %L must be of INTEGER type", &dim->where);
2493 if (dim->ts.kind != gfc_index_integer_kind)
2497 ts.type = BT_INTEGER;
2498 ts.kind = gfc_index_integer_kind;
2500 gfc_convert_type_warn (dim, &ts, 2, 0);
2506 /* Given an expression that contains array references, update those array
2507 references to point to the right array specifications. While this is
2508 filled in during matching, this information is difficult to save and load
2509 in a module, so we take care of it here.
2511 The idea here is that the original array reference comes from the
2512 base symbol. We traverse the list of reference structures, setting
2513 the stored reference to references. Component references can
2514 provide an additional array specification. */
2517 find_array_spec (gfc_expr * e)
2521 gfc_symbol *derived;
2524 as = e->symtree->n.sym->as;
2527 for (ref = e->ref; ref; ref = ref->next)
2532 gfc_internal_error ("find_array_spec(): Missing spec");
2539 if (derived == NULL)
2540 derived = e->symtree->n.sym->ts.derived;
2542 c = derived->components;
2544 for (; c; c = c->next)
2545 if (c == ref->u.c.component)
2547 /* Track the sequence of component references. */
2548 if (c->ts.type == BT_DERIVED)
2549 derived = c->ts.derived;
2554 gfc_internal_error ("find_array_spec(): Component not found");
2559 gfc_internal_error ("find_array_spec(): unused as(1)");
2570 gfc_internal_error ("find_array_spec(): unused as(2)");
2574 /* Resolve an array reference. */
2577 resolve_array_ref (gfc_array_ref * ar)
2579 int i, check_scalar;
2582 for (i = 0; i < ar->dimen; i++)
2584 check_scalar = ar->dimen_type[i] == DIMEN_RANGE;
2586 if (gfc_resolve_index (ar->start[i], check_scalar) == FAILURE)
2588 if (gfc_resolve_index (ar->end[i], check_scalar) == FAILURE)
2590 if (gfc_resolve_index (ar->stride[i], check_scalar) == FAILURE)
2595 if (ar->dimen_type[i] == DIMEN_UNKNOWN)
2599 ar->dimen_type[i] = DIMEN_ELEMENT;
2603 ar->dimen_type[i] = DIMEN_VECTOR;
2604 if (e->expr_type == EXPR_VARIABLE
2605 && e->symtree->n.sym->ts.type == BT_DERIVED)
2606 ar->start[i] = gfc_get_parentheses (e);
2610 gfc_error ("Array index at %L is an array of rank %d",
2611 &ar->c_where[i], e->rank);
2616 /* If the reference type is unknown, figure out what kind it is. */
2618 if (ar->type == AR_UNKNOWN)
2620 ar->type = AR_ELEMENT;
2621 for (i = 0; i < ar->dimen; i++)
2622 if (ar->dimen_type[i] == DIMEN_RANGE
2623 || ar->dimen_type[i] == DIMEN_VECTOR)
2625 ar->type = AR_SECTION;
2630 if (!ar->as->cray_pointee && compare_spec_to_ref (ar) == FAILURE)
2638 resolve_substring (gfc_ref * ref)
2641 if (ref->u.ss.start != NULL)
2643 if (gfc_resolve_expr (ref->u.ss.start) == FAILURE)
2646 if (ref->u.ss.start->ts.type != BT_INTEGER)
2648 gfc_error ("Substring start index at %L must be of type INTEGER",
2649 &ref->u.ss.start->where);
2653 if (ref->u.ss.start->rank != 0)
2655 gfc_error ("Substring start index at %L must be scalar",
2656 &ref->u.ss.start->where);
2660 if (compare_bound_int (ref->u.ss.start, 1) == CMP_LT
2661 && (compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_EQ
2662 || compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_GT))
2664 gfc_error ("Substring start index at %L is less than one",
2665 &ref->u.ss.start->where);
2670 if (ref->u.ss.end != NULL)
2672 if (gfc_resolve_expr (ref->u.ss.end) == FAILURE)
2675 if (ref->u.ss.end->ts.type != BT_INTEGER)
2677 gfc_error ("Substring end index at %L must be of type INTEGER",
2678 &ref->u.ss.end->where);
2682 if (ref->u.ss.end->rank != 0)
2684 gfc_error ("Substring end index at %L must be scalar",
2685 &ref->u.ss.end->where);
2689 if (ref->u.ss.length != NULL
2690 && compare_bound (ref->u.ss.end, ref->u.ss.length->length) == CMP_GT
2691 && (compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_EQ
2692 || compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_GT))
2694 gfc_error ("Substring end index at %L exceeds the string length",
2695 &ref->u.ss.start->where);
2704 /* Resolve subtype references. */
2707 resolve_ref (gfc_expr * expr)
2709 int current_part_dimension, n_components, seen_part_dimension;
2712 for (ref = expr->ref; ref; ref = ref->next)
2713 if (ref->type == REF_ARRAY && ref->u.ar.as == NULL)
2715 find_array_spec (expr);
2719 for (ref = expr->ref; ref; ref = ref->next)
2723 if (resolve_array_ref (&ref->u.ar) == FAILURE)
2731 resolve_substring (ref);
2735 /* Check constraints on part references. */
2737 current_part_dimension = 0;
2738 seen_part_dimension = 0;
2741 for (ref = expr->ref; ref; ref = ref->next)
2746 switch (ref->u.ar.type)
2750 current_part_dimension = 1;
2754 current_part_dimension = 0;
2758 gfc_internal_error ("resolve_ref(): Bad array reference");
2764 if ((current_part_dimension || seen_part_dimension)
2765 && ref->u.c.component->pointer)
2768 ("Component to the right of a part reference with nonzero "
2769 "rank must not have the POINTER attribute at %L",
2781 if (((ref->type == REF_COMPONENT && n_components > 1)
2782 || ref->next == NULL)
2783 && current_part_dimension
2784 && seen_part_dimension)
2787 gfc_error ("Two or more part references with nonzero rank must "
2788 "not be specified at %L", &expr->where);
2792 if (ref->type == REF_COMPONENT)
2794 if (current_part_dimension)
2795 seen_part_dimension = 1;
2797 /* reset to make sure */
2798 current_part_dimension = 0;
2806 /* Given an expression, determine its shape. This is easier than it sounds.
2807 Leaves the shape array NULL if it is not possible to determine the shape. */
2810 expression_shape (gfc_expr * e)
2812 mpz_t array[GFC_MAX_DIMENSIONS];
2815 if (e->rank == 0 || e->shape != NULL)
2818 for (i = 0; i < e->rank; i++)
2819 if (gfc_array_dimen_size (e, i, &array[i]) == FAILURE)
2822 e->shape = gfc_get_shape (e->rank);
2824 memcpy (e->shape, array, e->rank * sizeof (mpz_t));
2829 for (i--; i >= 0; i--)
2830 mpz_clear (array[i]);
2834 /* Given a variable expression node, compute the rank of the expression by
2835 examining the base symbol and any reference structures it may have. */
2838 expression_rank (gfc_expr * e)
2845 if (e->expr_type == EXPR_ARRAY)
2847 /* Constructors can have a rank different from one via RESHAPE(). */
2849 if (e->symtree == NULL)
2855 e->rank = (e->symtree->n.sym->as == NULL)
2856 ? 0 : e->symtree->n.sym->as->rank;
2862 for (ref = e->ref; ref; ref = ref->next)
2864 if (ref->type != REF_ARRAY)
2867 if (ref->u.ar.type == AR_FULL)
2869 rank = ref->u.ar.as->rank;
2873 if (ref->u.ar.type == AR_SECTION)
2875 /* Figure out the rank of the section. */
2877 gfc_internal_error ("expression_rank(): Two array specs");
2879 for (i = 0; i < ref->u.ar.dimen; i++)
2880 if (ref->u.ar.dimen_type[i] == DIMEN_RANGE
2881 || ref->u.ar.dimen_type[i] == DIMEN_VECTOR)
2891 expression_shape (e);
2895 /* Resolve a variable expression. */
2898 resolve_variable (gfc_expr * e)
2905 if (e->symtree == NULL)
2908 if (e->ref && resolve_ref (e) == FAILURE)
2911 sym = e->symtree->n.sym;
2912 if (sym->attr.flavor == FL_PROCEDURE && !sym->attr.function)
2914 e->ts.type = BT_PROCEDURE;
2918 if (sym->ts.type != BT_UNKNOWN)
2919 gfc_variable_attr (e, &e->ts);
2922 /* Must be a simple variable reference. */
2923 if (gfc_set_default_type (sym, 1, NULL) == FAILURE)
2928 if (check_assumed_size_reference (sym, e))
2931 /* Deal with forward references to entries during resolve_code, to
2932 satisfy, at least partially, 12.5.2.5. */
2933 if (gfc_current_ns->entries
2934 && current_entry_id == sym->entry_id
2937 && cs_base->current->op != EXEC_ENTRY)
2939 gfc_entry_list *entry;
2940 gfc_formal_arglist *formal;
2944 /* If the symbol is a dummy... */
2945 if (sym->attr.dummy)
2947 entry = gfc_current_ns->entries;
2950 /* ...test if the symbol is a parameter of previous entries. */
2951 for (; entry && entry->id <= current_entry_id; entry = entry->next)
2952 for (formal = entry->sym->formal; formal; formal = formal->next)
2954 if (formal->sym && sym->name == formal->sym->name)
2958 /* If it has not been seen as a dummy, this is an error. */
2961 if (specification_expr)
2962 gfc_error ("Variable '%s',used in a specification expression, "
2963 "is referenced at %L before the ENTRY statement "
2964 "in which it is a parameter",
2965 sym->name, &cs_base->current->loc);
2967 gfc_error ("Variable '%s' is used at %L before the ENTRY "
2968 "statement in which it is a parameter",
2969 sym->name, &cs_base->current->loc);
2974 /* Now do the same check on the specification expressions. */
2975 specification_expr = 1;
2976 if (sym->ts.type == BT_CHARACTER
2977 && gfc_resolve_expr (sym->ts.cl->length) == FAILURE)
2981 for (n = 0; n < sym->as->rank; n++)
2983 specification_expr = 1;
2984 if (gfc_resolve_expr (sym->as->lower[n]) == FAILURE)
2986 specification_expr = 1;
2987 if (gfc_resolve_expr (sym->as->upper[n]) == FAILURE)
2990 specification_expr = 0;
2993 /* Update the symbol's entry level. */
2994 sym->entry_id = current_entry_id + 1;
3001 /* Resolve an expression. That is, make sure that types of operands agree
3002 with their operators, intrinsic operators are converted to function calls
3003 for overloaded types and unresolved function references are resolved. */
3006 gfc_resolve_expr (gfc_expr * e)
3013 switch (e->expr_type)
3016 t = resolve_operator (e);
3020 t = resolve_function (e);
3024 t = resolve_variable (e);
3026 expression_rank (e);
3029 case EXPR_SUBSTRING:
3030 t = resolve_ref (e);
3040 if (resolve_ref (e) == FAILURE)
3043 t = gfc_resolve_array_constructor (e);
3044 /* Also try to expand a constructor. */
3047 expression_rank (e);
3048 gfc_expand_constructor (e);
3051 /* This provides the opportunity for the length of constructors with character
3052 valued function elements to propogate the string length to the expression. */
3053 if (e->ts.type == BT_CHARACTER)
3054 gfc_resolve_character_array_constructor (e);
3058 case EXPR_STRUCTURE:
3059 t = resolve_ref (e);
3063 t = resolve_structure_cons (e);
3067 t = gfc_simplify_expr (e, 0);
3071 gfc_internal_error ("gfc_resolve_expr(): Bad expression type");
3078 /* Resolve an expression from an iterator. They must be scalar and have
3079 INTEGER or (optionally) REAL type. */
3082 gfc_resolve_iterator_expr (gfc_expr * expr, bool real_ok,
3083 const char * name_msgid)
3085 if (gfc_resolve_expr (expr) == FAILURE)
3088 if (expr->rank != 0)
3090 gfc_error ("%s at %L must be a scalar", _(name_msgid), &expr->where);
3094 if (!(expr->ts.type == BT_INTEGER
3095 || (expr->ts.type == BT_REAL && real_ok)))
3098 gfc_error ("%s at %L must be INTEGER or REAL", _(name_msgid),
3101 gfc_error ("%s at %L must be INTEGER", _(name_msgid), &expr->where);
3108 /* Resolve the expressions in an iterator structure. If REAL_OK is
3109 false allow only INTEGER type iterators, otherwise allow REAL types. */
3112 gfc_resolve_iterator (gfc_iterator * iter, bool real_ok)
3115 if (iter->var->ts.type == BT_REAL)
3116 gfc_notify_std (GFC_STD_F95_DEL,
3117 "Obsolete: REAL DO loop iterator at %L",
3120 if (gfc_resolve_iterator_expr (iter->var, real_ok, "Loop variable")
3124 if (gfc_pure (NULL) && gfc_impure_variable (iter->var->symtree->n.sym))
3126 gfc_error ("Cannot assign to loop variable in PURE procedure at %L",
3131 if (gfc_resolve_iterator_expr (iter->start, real_ok,
3132 "Start expression in DO loop") == FAILURE)
3135 if (gfc_resolve_iterator_expr (iter->end, real_ok,
3136 "End expression in DO loop") == FAILURE)
3139 if (gfc_resolve_iterator_expr (iter->step, real_ok,
3140 "Step expression in DO loop") == FAILURE)
3143 if (iter->step->expr_type == EXPR_CONSTANT)
3145 if ((iter->step->ts.type == BT_INTEGER
3146 && mpz_cmp_ui (iter->step->value.integer, 0) == 0)
3147 || (iter->step->ts.type == BT_REAL
3148 && mpfr_sgn (iter->step->value.real) == 0))
3150 gfc_error ("Step expression in DO loop at %L cannot be zero",
3151 &iter->step->where);
3156 /* Convert start, end, and step to the same type as var. */
3157 if (iter->start->ts.kind != iter->var->ts.kind
3158 || iter->start->ts.type != iter->var->ts.type)
3159 gfc_convert_type (iter->start, &iter->var->ts, 2);
3161 if (iter->end->ts.kind != iter->var->ts.kind
3162 || iter->end->ts.type != iter->var->ts.type)
3163 gfc_convert_type (iter->end, &iter->var->ts, 2);
3165 if (iter->step->ts.kind != iter->var->ts.kind
3166 || iter->step->ts.type != iter->var->ts.type)
3167 gfc_convert_type (iter->step, &iter->var->ts, 2);
3173 /* Resolve a list of FORALL iterators. The FORALL index-name is constrained
3174 to be a scalar INTEGER variable. The subscripts and stride are scalar
3175 INTEGERs, and if stride is a constant it must be nonzero. */
3178 resolve_forall_iterators (gfc_forall_iterator * iter)
3183 if (gfc_resolve_expr (iter->var) == SUCCESS
3184 && (iter->var->ts.type != BT_INTEGER || iter->var->rank != 0))
3185 gfc_error ("FORALL index-name at %L must be a scalar INTEGER",
3188 if (gfc_resolve_expr (iter->start) == SUCCESS
3189 && (iter->start->ts.type != BT_INTEGER || iter->start->rank != 0))
3190 gfc_error ("FORALL start expression at %L must be a scalar INTEGER",
3191 &iter->start->where);
3192 if (iter->var->ts.kind != iter->start->ts.kind)
3193 gfc_convert_type (iter->start, &iter->var->ts, 2);
3195 if (gfc_resolve_expr (iter->end) == SUCCESS
3196 && (iter->end->ts.type != BT_INTEGER || iter->end->rank != 0))
3197 gfc_error ("FORALL end expression at %L must be a scalar INTEGER",
3199 if (iter->var->ts.kind != iter->end->ts.kind)
3200 gfc_convert_type (iter->end, &iter->var->ts, 2);
3202 if (gfc_resolve_expr (iter->stride) == SUCCESS)
3204 if (iter->stride->ts.type != BT_INTEGER || iter->stride->rank != 0)
3205 gfc_error ("FORALL stride expression at %L must be a scalar %s",
3206 &iter->stride->where, "INTEGER");
3208 if (iter->stride->expr_type == EXPR_CONSTANT
3209 && mpz_cmp_ui(iter->stride->value.integer, 0) == 0)
3210 gfc_error ("FORALL stride expression at %L cannot be zero",
3211 &iter->stride->where);
3213 if (iter->var->ts.kind != iter->stride->ts.kind)
3214 gfc_convert_type (iter->stride, &iter->var->ts, 2);
3221 /* Given a pointer to a symbol that is a derived type, see if any components
3222 have the POINTER attribute. The search is recursive if necessary.
3223 Returns zero if no pointer components are found, nonzero otherwise. */
3226 derived_pointer (gfc_symbol * sym)
3230 for (c = sym->components; c; c = c->next)
3235 if (c->ts.type == BT_DERIVED && derived_pointer (c->ts.derived))
3243 /* Given a pointer to a symbol that is a derived type, see if it's
3244 inaccessible, i.e. if it's defined in another module and the components are
3245 PRIVATE. The search is recursive if necessary. Returns zero if no
3246 inaccessible components are found, nonzero otherwise. */
3249 derived_inaccessible (gfc_symbol *sym)
3253 if (sym->attr.use_assoc && sym->component_access == ACCESS_PRIVATE)
3256 for (c = sym->components; c; c = c->next)
3258 if (c->ts.type == BT_DERIVED && derived_inaccessible (c->ts.derived))
3266 /* Resolve the argument of a deallocate expression. The expression must be
3267 a pointer or a full array. */
3270 resolve_deallocate_expr (gfc_expr * e)
3272 symbol_attribute attr;
3276 if (gfc_resolve_expr (e) == FAILURE)
3279 attr = gfc_expr_attr (e);
3283 if (e->expr_type != EXPR_VARIABLE)
3286 allocatable = e->symtree->n.sym->attr.allocatable;
3287 for (ref = e->ref; ref; ref = ref->next)
3291 if (ref->u.ar.type != AR_FULL)
3296 allocatable = (ref->u.c.component->as != NULL
3297 && ref->u.c.component->as->type == AS_DEFERRED);
3305 if (allocatable == 0)
3308 gfc_error ("Expression in DEALLOCATE statement at %L must be "
3309 "ALLOCATABLE or a POINTER", &e->where);
3312 if (e->symtree->n.sym->attr.intent == INTENT_IN)
3314 gfc_error ("Can't deallocate INTENT(IN) variable '%s' at %L",
3315 e->symtree->n.sym->name, &e->where);
3322 /* Returns true if the expression e contains a reference the symbol sym. */
3324 find_sym_in_expr (gfc_symbol *sym, gfc_expr *e)
3326 gfc_actual_arglist *arg;
3334 switch (e->expr_type)
3337 for (arg = e->value.function.actual; arg; arg = arg->next)
3338 rv = rv || find_sym_in_expr (sym, arg->expr);
3341 /* If the variable is not the same as the dependent, 'sym', and
3342 it is not marked as being declared and it is in the same
3343 namespace as 'sym', add it to the local declarations. */
3345 if (sym == e->symtree->n.sym)
3350 rv = rv || find_sym_in_expr (sym, e->value.op.op1);
3351 rv = rv || find_sym_in_expr (sym, e->value.op.op2);
3360 for (ref = e->ref; ref; ref = ref->next)
3365 for (i = 0; i < ref->u.ar.dimen; i++)
3367 rv = rv || find_sym_in_expr (sym, ref->u.ar.start[i]);
3368 rv = rv || find_sym_in_expr (sym, ref->u.ar.end[i]);
3369 rv = rv || find_sym_in_expr (sym, ref->u.ar.stride[i]);
3374 rv = rv || find_sym_in_expr (sym, ref->u.ss.start);
3375 rv = rv || find_sym_in_expr (sym, ref->u.ss.end);
3379 if (ref->u.c.component->ts.type == BT_CHARACTER
3380 && ref->u.c.component->ts.cl->length->expr_type
3382 rv = rv || find_sym_in_expr (sym, ref->u.c.component->ts.cl->length);
3384 if (ref->u.c.component->as)
3385 for (i = 0; i < ref->u.c.component->as->rank; i++)
3387 rv = rv || find_sym_in_expr (sym, ref->u.c.component->as->lower[i]);
3388 rv = rv || find_sym_in_expr (sym, ref->u.c.component->as->upper[i]);
3398 /* Given the expression node e for an allocatable/pointer of derived type to be
3399 allocated, get the expression node to be initialized afterwards (needed for
3400 derived types with default initializers). */
3403 expr_to_initialize (gfc_expr * e)
3409 result = gfc_copy_expr (e);
3411 /* Change the last array reference from AR_ELEMENT to AR_FULL. */
3412 for (ref = result->ref; ref; ref = ref->next)
3413 if (ref->type == REF_ARRAY && ref->next == NULL)
3415 ref->u.ar.type = AR_FULL;
3417 for (i = 0; i < ref->u.ar.dimen; i++)
3418 ref->u.ar.start[i] = ref->u.ar.end[i] = ref->u.ar.stride[i] = NULL;
3420 result->rank = ref->u.ar.dimen;
3428 /* Resolve the expression in an ALLOCATE statement, doing the additional
3429 checks to see whether the expression is OK or not. The expression must
3430 have a trailing array reference that gives the size of the array. */
3433 resolve_allocate_expr (gfc_expr * e, gfc_code * code)
3435 int i, pointer, allocatable, dimension;
3436 symbol_attribute attr;
3437 gfc_ref *ref, *ref2;
3444 if (gfc_resolve_expr (e) == FAILURE)
3447 if (code->expr && code->expr->expr_type == EXPR_VARIABLE)
3448 sym = code->expr->symtree->n.sym;
3452 /* Make sure the expression is allocatable or a pointer. If it is
3453 pointer, the next-to-last reference must be a pointer. */
3457 if (e->expr_type != EXPR_VARIABLE)
3461 attr = gfc_expr_attr (e);
3462 pointer = attr.pointer;
3463 dimension = attr.dimension;
3468 allocatable = e->symtree->n.sym->attr.allocatable;
3469 pointer = e->symtree->n.sym->attr.pointer;
3470 dimension = e->symtree->n.sym->attr.dimension;
3472 if (sym == e->symtree->n.sym)
3474 gfc_error ("The STAT variable '%s' in an ALLOCATE statement must "
3475 "not be allocated in the same statement at %L",
3476 sym->name, &e->where);
3480 for (ref = e->ref; ref; ref2 = ref, ref = ref->next)
3484 if (ref->next != NULL)
3489 allocatable = (ref->u.c.component->as != NULL
3490 && ref->u.c.component->as->type == AS_DEFERRED);
3492 pointer = ref->u.c.component->pointer;
3493 dimension = ref->u.c.component->dimension;
3503 if (allocatable == 0 && pointer == 0)
3505 gfc_error ("Expression in ALLOCATE statement at %L must be "
3506 "ALLOCATABLE or a POINTER", &e->where);
3510 if (e->symtree->n.sym->attr.intent == INTENT_IN)
3512 gfc_error ("Can't allocate INTENT(IN) variable '%s' at %L",
3513 e->symtree->n.sym->name, &e->where);
3517 /* Add default initializer for those derived types that need them. */
3518 if (e->ts.type == BT_DERIVED && (init_e = gfc_default_initializer (&e->ts)))
3520 init_st = gfc_get_code ();
3521 init_st->loc = code->loc;
3522 init_st->op = EXEC_ASSIGN;
3523 init_st->expr = expr_to_initialize (e);
3524 init_st->expr2 = init_e;
3526 init_st->next = code->next;
3527 code->next = init_st;
3530 if (pointer && dimension == 0)
3533 /* Make sure the next-to-last reference node is an array specification. */
3535 if (ref2 == NULL || ref2->type != REF_ARRAY || ref2->u.ar.type == AR_FULL)
3537 gfc_error ("Array specification required in ALLOCATE statement "
3538 "at %L", &e->where);
3542 /* Make sure that the array section reference makes sense in the
3543 context of an ALLOCATE specification. */
3547 for (i = 0; i < ar->dimen; i++)
3549 if (ref2->u.ar.type == AR_ELEMENT)
3552 switch (ar->dimen_type[i])
3558 if (ar->start[i] != NULL
3559 && ar->end[i] != NULL
3560 && ar->stride[i] == NULL)
3563 /* Fall Through... */
3567 gfc_error ("Bad array specification in ALLOCATE statement at %L",
3574 for (a = code->ext.alloc_list; a; a = a->next)
3576 sym = a->expr->symtree->n.sym;
3577 if ((ar->start[i] != NULL && find_sym_in_expr (sym, ar->start[i]))
3578 || (ar->end[i] != NULL && find_sym_in_expr (sym, ar->end[i])))
3580 gfc_error ("'%s' must not appear an the array specification at "
3581 "%L in the same ALLOCATE statement where it is "
3582 "itself allocated", sym->name, &ar->where);
3592 /************ SELECT CASE resolution subroutines ************/
3594 /* Callback function for our mergesort variant. Determines interval
3595 overlaps for CASEs. Return <0 if op1 < op2, 0 for overlap, >0 for
3596 op1 > op2. Assumes we're not dealing with the default case.
3597 We have op1 = (:L), (K:L) or (K:) and op2 = (:N), (M:N) or (M:).
3598 There are nine situations to check. */
3601 compare_cases (const gfc_case * op1, const gfc_case * op2)
3605 if (op1->low == NULL) /* op1 = (:L) */
3607 /* op2 = (:N), so overlap. */
3609 /* op2 = (M:) or (M:N), L < M */
3610 if (op2->low != NULL
3611 && gfc_compare_expr (op1->high, op2->low) < 0)
3614 else if (op1->high == NULL) /* op1 = (K:) */
3616 /* op2 = (M:), so overlap. */
3618 /* op2 = (:N) or (M:N), K > N */
3619 if (op2->high != NULL
3620 && gfc_compare_expr (op1->low, op2->high) > 0)
3623 else /* op1 = (K:L) */
3625 if (op2->low == NULL) /* op2 = (:N), K > N */
3626 retval = (gfc_compare_expr (op1->low, op2->high) > 0) ? 1 : 0;
3627 else if (op2->high == NULL) /* op2 = (M:), L < M */
3628 retval = (gfc_compare_expr (op1->high, op2->low) < 0) ? -1 : 0;
3629 else /* op2 = (M:N) */
3633 if (gfc_compare_expr (op1->high, op2->low) < 0)
3636 else if (gfc_compare_expr (op1->low, op2->high) > 0)
3645 /* Merge-sort a double linked case list, detecting overlap in the
3646 process. LIST is the head of the double linked case list before it
3647 is sorted. Returns the head of the sorted list if we don't see any
3648 overlap, or NULL otherwise. */
3651 check_case_overlap (gfc_case * list)
3653 gfc_case *p, *q, *e, *tail;
3654 int insize, nmerges, psize, qsize, cmp, overlap_seen;
3656 /* If the passed list was empty, return immediately. */
3663 /* Loop unconditionally. The only exit from this loop is a return
3664 statement, when we've finished sorting the case list. */
3671 /* Count the number of merges we do in this pass. */
3674 /* Loop while there exists a merge to be done. */
3679 /* Count this merge. */
3682 /* Cut the list in two pieces by stepping INSIZE places
3683 forward in the list, starting from P. */
3686 for (i = 0; i < insize; i++)
3695 /* Now we have two lists. Merge them! */
3696 while (psize > 0 || (qsize > 0 && q != NULL))
3699 /* See from which the next case to merge comes from. */
3702 /* P is empty so the next case must come from Q. */
3707 else if (qsize == 0 || q == NULL)
3716 cmp = compare_cases (p, q);
3719 /* The whole case range for P is less than the
3727 /* The whole case range for Q is greater than
3728 the case range for P. */
3735 /* The cases overlap, or they are the same
3736 element in the list. Either way, we must
3737 issue an error and get the next case from P. */
3738 /* FIXME: Sort P and Q by line number. */
3739 gfc_error ("CASE label at %L overlaps with CASE "
3740 "label at %L", &p->where, &q->where);
3748 /* Add the next element to the merged list. */
3757 /* P has now stepped INSIZE places along, and so has Q. So
3758 they're the same. */
3763 /* If we have done only one merge or none at all, we've
3764 finished sorting the cases. */
3773 /* Otherwise repeat, merging lists twice the size. */
3779 /* Check to see if an expression is suitable for use in a CASE statement.
3780 Makes sure that all case expressions are scalar constants of the same
3781 type. Return FAILURE if anything is wrong. */
3784 validate_case_label_expr (gfc_expr * e, gfc_expr * case_expr)
3786 if (e == NULL) return SUCCESS;
3788 if (e->ts.type != case_expr->ts.type)
3790 gfc_error ("Expression in CASE statement at %L must be of type %s",
3791 &e->where, gfc_basic_typename (case_expr->ts.type));
3795 /* C805 (R808) For a given case-construct, each case-value shall be of
3796 the same type as case-expr. For character type, length differences
3797 are allowed, but the kind type parameters shall be the same. */
3799 if (case_expr->ts.type == BT_CHARACTER && e->ts.kind != case_expr->ts.kind)
3801 gfc_error("Expression in CASE statement at %L must be kind %d",
3802 &e->where, case_expr->ts.kind);
3806 /* Convert the case value kind to that of case expression kind, if needed.
3807 FIXME: Should a warning be issued? */
3808 if (e->ts.kind != case_expr->ts.kind)
3809 gfc_convert_type_warn (e, &case_expr->ts, 2, 0);
3813 gfc_error ("Expression in CASE statement at %L must be scalar",
3822 /* Given a completely parsed select statement, we:
3824 - Validate all expressions and code within the SELECT.
3825 - Make sure that the selection expression is not of the wrong type.
3826 - Make sure that no case ranges overlap.
3827 - Eliminate unreachable cases and unreachable code resulting from
3828 removing case labels.
3830 The standard does allow unreachable cases, e.g. CASE (5:3). But
3831 they are a hassle for code generation, and to prevent that, we just
3832 cut them out here. This is not necessary for overlapping cases
3833 because they are illegal and we never even try to generate code.
3835 We have the additional caveat that a SELECT construct could have
3836 been a computed GOTO in the source code. Fortunately we can fairly
3837 easily work around that here: The case_expr for a "real" SELECT CASE
3838 is in code->expr1, but for a computed GOTO it is in code->expr2. All
3839 we have to do is make sure that the case_expr is a scalar integer
3843 resolve_select (gfc_code * code)
3846 gfc_expr *case_expr;
3847 gfc_case *cp, *default_case, *tail, *head;
3848 int seen_unreachable;
3854 if (code->expr == NULL)
3856 /* This was actually a computed GOTO statement. */
3857 case_expr = code->expr2;
3858 if (case_expr->ts.type != BT_INTEGER
3859 || case_expr->rank != 0)
3860 gfc_error ("Selection expression in computed GOTO statement "
3861 "at %L must be a scalar integer expression",
3864 /* Further checking is not necessary because this SELECT was built
3865 by the compiler, so it should always be OK. Just move the
3866 case_expr from expr2 to expr so that we can handle computed
3867 GOTOs as normal SELECTs from here on. */
3868 code->expr = code->expr2;
3873 case_expr = code->expr;
3875 type = case_expr->ts.type;
3876 if (type != BT_LOGICAL && type != BT_INTEGER && type != BT_CHARACTER)
3878 gfc_error ("Argument of SELECT statement at %L cannot be %s",
3879 &case_expr->where, gfc_typename (&case_expr->ts));
3881 /* Punt. Going on here just produce more garbage error messages. */
3885 if (case_expr->rank != 0)
3887 gfc_error ("Argument of SELECT statement at %L must be a scalar "
3888 "expression", &case_expr->where);
3894 /* PR 19168 has a long discussion concerning a mismatch of the kinds
3895 of the SELECT CASE expression and its CASE values. Walk the lists
3896 of case values, and if we find a mismatch, promote case_expr to
3897 the appropriate kind. */
3899 if (type == BT_LOGICAL || type == BT_INTEGER)
3901 for (body = code->block; body; body = body->block)
3903 /* Walk the case label list. */
3904 for (cp = body->ext.case_list; cp; cp = cp->next)
3906 /* Intercept the DEFAULT case. It does not have a kind. */
3907 if (cp->low == NULL && cp->high == NULL)
3910 /* Unreachable case ranges are discarded, so ignore. */
3911 if (cp->low != NULL && cp->high != NULL
3912 && cp->low != cp->high
3913 && gfc_compare_expr (cp->low, cp->high) > 0)
3916 /* FIXME: Should a warning be issued? */
3918 && case_expr->ts.kind != gfc_kind_max(case_expr, cp->low))
3919 gfc_convert_type_warn (case_expr, &cp->low->ts, 2, 0);
3921 if (cp->high != NULL
3922 && case_expr->ts.kind != gfc_kind_max(case_expr, cp->high))
3923 gfc_convert_type_warn (case_expr, &cp->high->ts, 2, 0);
3928 /* Assume there is no DEFAULT case. */
3929 default_case = NULL;
3934 for (body = code->block; body; body = body->block)
3936 /* Assume the CASE list is OK, and all CASE labels can be matched. */
3938 seen_unreachable = 0;
3940 /* Walk the case label list, making sure that all case labels
3942 for (cp = body->ext.case_list; cp; cp = cp->next)
3944 /* Count the number of cases in the whole construct. */
3947 /* Intercept the DEFAULT case. */
3948 if (cp->low == NULL && cp->high == NULL)
3950 if (default_case != NULL)
3952 gfc_error ("The DEFAULT CASE at %L cannot be followed "
3953 "by a second DEFAULT CASE at %L",
3954 &default_case->where, &cp->where);
3965 /* Deal with single value cases and case ranges. Errors are
3966 issued from the validation function. */
3967 if(validate_case_label_expr (cp->low, case_expr) != SUCCESS
3968 || validate_case_label_expr (cp->high, case_expr) != SUCCESS)
3974 if (type == BT_LOGICAL
3975 && ((cp->low == NULL || cp->high == NULL)
3976 || cp->low != cp->high))
3979 ("Logical range in CASE statement at %L is not allowed",
3985 if (type == BT_LOGICAL && cp->low->expr_type == EXPR_CONSTANT)
3988 value = cp->low->value.logical == 0 ? 2 : 1;
3989 if (value & seen_logical)
3991 gfc_error ("constant logical value in CASE statement "
3992 "is repeated at %L",
3997 seen_logical |= value;
4000 if (cp->low != NULL && cp->high != NULL
4001 && cp->low != cp->high
4002 && gfc_compare_expr (cp->low, cp->high) > 0)
4004 if (gfc_option.warn_surprising)
4005 gfc_warning ("Range specification at %L can never "
4006 "be matched", &cp->where);
4008 cp->unreachable = 1;
4009 seen_unreachable = 1;
4013 /* If the case range can be matched, it can also overlap with
4014 other cases. To make sure it does not, we put it in a
4015 double linked list here. We sort that with a merge sort
4016 later on to detect any overlapping cases. */
4020 head->right = head->left = NULL;
4025 tail->right->left = tail;
4032 /* It there was a failure in the previous case label, give up
4033 for this case label list. Continue with the next block. */
4037 /* See if any case labels that are unreachable have been seen.
4038 If so, we eliminate them. This is a bit of a kludge because
4039 the case lists for a single case statement (label) is a
4040 single forward linked lists. */
4041 if (seen_unreachable)
4043 /* Advance until the first case in the list is reachable. */
4044 while (body->ext.case_list != NULL
4045 && body->ext.case_list->unreachable)
4047 gfc_case *n = body->ext.case_list;
4048 body->ext.case_list = body->ext.case_list->next;
4050 gfc_free_case_list (n);
4053 /* Strip all other unreachable cases. */
4054 if (body->ext.case_list)
4056 for (cp = body->ext.case_list; cp->next; cp = cp->next)
4058 if (cp->next->unreachable)
4060 gfc_case *n = cp->next;
4061 cp->next = cp->next->next;
4063 gfc_free_case_list (n);
4070 /* See if there were overlapping cases. If the check returns NULL,
4071 there was overlap. In that case we don't do anything. If head
4072 is non-NULL, we prepend the DEFAULT case. The sorted list can
4073 then used during code generation for SELECT CASE constructs with
4074 a case expression of a CHARACTER type. */
4077 head = check_case_overlap (head);
4079 /* Prepend the default_case if it is there. */
4080 if (head != NULL && default_case)
4082 default_case->left = NULL;
4083 default_case->right = head;
4084 head->left = default_case;
4088 /* Eliminate dead blocks that may be the result if we've seen
4089 unreachable case labels for a block. */
4090 for (body = code; body && body->block; body = body->block)
4092 if (body->block->ext.case_list == NULL)
4094 /* Cut the unreachable block from the code chain. */
4095 gfc_code *c = body->block;
4096 body->block = c->block;
4098 /* Kill the dead block, but not the blocks below it. */
4100 gfc_free_statements (c);
4104 /* More than two cases is legal but insane for logical selects.
4105 Issue a warning for it. */
4106 if (gfc_option.warn_surprising && type == BT_LOGICAL
4108 gfc_warning ("Logical SELECT CASE block at %L has more that two cases",
4113 /* Resolve a transfer statement. This is making sure that:
4114 -- a derived type being transferred has only non-pointer components
4115 -- a derived type being transferred doesn't have private components, unless
4116 it's being transferred from the module where the type was defined
4117 -- we're not trying to transfer a whole assumed size array. */
4120 resolve_transfer (gfc_code * code)
4129 if (exp->expr_type != EXPR_VARIABLE)
4132 sym = exp->symtree->n.sym;
4135 /* Go to actual component transferred. */
4136 for (ref = code->expr->ref; ref; ref = ref->next)
4137 if (ref->type == REF_COMPONENT)
4138 ts = &ref->u.c.component->ts;
4140 if (ts->type == BT_DERIVED)
4142 /* Check that transferred derived type doesn't contain POINTER
4144 if (derived_pointer (ts->derived))
4146 gfc_error ("Data transfer element at %L cannot have "
4147 "POINTER components", &code->loc);
4151 if (derived_inaccessible (ts->derived))
4153 gfc_error ("Data transfer element at %L cannot have "
4154 "PRIVATE components",&code->loc);
4159 if (sym->as != NULL && sym->as->type == AS_ASSUMED_SIZE
4160 && exp->ref->type == REF_ARRAY && exp->ref->u.ar.type == AR_FULL)
4162 gfc_error ("Data transfer element at %L cannot be a full reference to "
4163 "an assumed-size array", &code->loc);
4169 /*********** Toplevel code resolution subroutines ***********/
4171 /* Given a branch to a label and a namespace, if the branch is conforming.
4172 The code node described where the branch is located. */
4175 resolve_branch (gfc_st_label * label, gfc_code * code)
4177 gfc_code *block, *found;
4185 /* Step one: is this a valid branching target? */
4187 if (lp->defined == ST_LABEL_UNKNOWN)
4189 gfc_error ("Label %d referenced at %L is never defined", lp->value,
4194 if (lp->defined != ST_LABEL_TARGET)
4196 gfc_error ("Statement at %L is not a valid branch target statement "
4197 "for the branch statement at %L", &lp->where, &code->loc);
4201 /* Step two: make sure this branch is not a branch to itself ;-) */
4203 if (code->here == label)
4205 gfc_warning ("Branch at %L causes an infinite loop", &code->loc);
4209 /* Step three: Try to find the label in the parse tree. To do this,
4210 we traverse the tree block-by-block: first the block that
4211 contains this GOTO, then the block that it is nested in, etc. We
4212 can ignore other blocks because branching into another block is
4217 for (stack = cs_base; stack; stack = stack->prev)
4219 for (block = stack->head; block; block = block->next)
4221 if (block->here == label)
4234 /* The label is not in an enclosing block, so illegal. This was
4235 allowed in Fortran 66, so we allow it as extension. We also
4236 forego further checks if we run into this. */
4237 gfc_notify_std (GFC_STD_LEGACY,
4238 "Label at %L is not in the same block as the "
4239 "GOTO statement at %L", &lp->where, &code->loc);
4243 /* Step four: Make sure that the branching target is legal if
4244 the statement is an END {SELECT,DO,IF}. */
4246 if (found->op == EXEC_NOP)
4248 for (stack = cs_base; stack; stack = stack->prev)
4249 if (stack->current->next == found)
4253 gfc_notify_std (GFC_STD_F95_DEL,
4254 "Obsolete: GOTO at %L jumps to END of construct at %L",
4255 &code->loc, &found->loc);
4260 /* Check whether EXPR1 has the same shape as EXPR2. */
4263 resolve_where_shape (gfc_expr *expr1, gfc_expr *expr2)
4265 mpz_t shape[GFC_MAX_DIMENSIONS];
4266 mpz_t shape2[GFC_MAX_DIMENSIONS];
4267 try result = FAILURE;
4270 /* Compare the rank. */
4271 if (expr1->rank != expr2->rank)
4274 /* Compare the size of each dimension. */
4275 for (i=0; i<expr1->rank; i++)
4277 if (gfc_array_dimen_size (expr1, i, &shape[i]) == FAILURE)
4280 if (gfc_array_dimen_size (expr2, i, &shape2[i]) == FAILURE)
4283 if (mpz_cmp (shape[i], shape2[i]))
4287 /* When either of the two expression is an assumed size array, we
4288 ignore the comparison of dimension sizes. */
4293 for (i--; i>=0; i--)
4295 mpz_clear (shape[i]);
4296 mpz_clear (shape2[i]);
4302 /* Check whether a WHERE assignment target or a WHERE mask expression
4303 has the same shape as the outmost WHERE mask expression. */
4306 resolve_where (gfc_code *code, gfc_expr *mask)
4312 cblock = code->block;
4314 /* Store the first WHERE mask-expr of the WHERE statement or construct.
4315 In case of nested WHERE, only the outmost one is stored. */
4316 if (mask == NULL) /* outmost WHERE */
4318 else /* inner WHERE */
4325 /* Check if the mask-expr has a consistent shape with the
4326 outmost WHERE mask-expr. */
4327 if (resolve_where_shape (cblock->expr, e) == FAILURE)
4328 gfc_error ("WHERE mask at %L has inconsistent shape",
4329 &cblock->expr->where);
4332 /* the assignment statement of a WHERE statement, or the first
4333 statement in where-body-construct of a WHERE construct */
4334 cnext = cblock->next;
4339 /* WHERE assignment statement */
4342 /* Check shape consistent for WHERE assignment target. */
4343 if (e && resolve_where_shape (cnext->expr, e) == FAILURE)
4344 gfc_error ("WHERE assignment target at %L has "
4345 "inconsistent shape", &cnext->expr->where);
4348 /* WHERE or WHERE construct is part of a where-body-construct */
4350 resolve_where (cnext, e);
4354 gfc_error ("Unsupported statement inside WHERE at %L",
4357 /* the next statement within the same where-body-construct */
4358 cnext = cnext->next;
4360 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
4361 cblock = cblock->block;
4366 /* Check whether the FORALL index appears in the expression or not. */
4369 gfc_find_forall_index (gfc_expr *expr, gfc_symbol *symbol)
4373 gfc_actual_arglist *args;
4376 switch (expr->expr_type)
4379 gcc_assert (expr->symtree->n.sym);
4381 /* A scalar assignment */
4384 if (expr->symtree->n.sym == symbol)
4390 /* the expr is array ref, substring or struct component. */
4397 /* Check if the symbol appears in the array subscript. */
4399 for (i = 0; i < GFC_MAX_DIMENSIONS; i++)
4402 if (gfc_find_forall_index (ar.start[i], symbol) == SUCCESS)
4406 if (gfc_find_forall_index (ar.end[i], symbol) == SUCCESS)
4410 if (gfc_find_forall_index (ar.stride[i], symbol) == SUCCESS)
4416 if (expr->symtree->n.sym == symbol)
4419 /* Check if the symbol appears in the substring section. */
4420 if (gfc_find_forall_index (tmp->u.ss.start, symbol) == SUCCESS)
4422 if (gfc_find_forall_index (tmp->u.ss.end, symbol) == SUCCESS)
4430 gfc_error("expression reference type error at %L", &expr->where);
4436 /* If the expression is a function call, then check if the symbol
4437 appears in the actual arglist of the function. */
4439 for (args = expr->value.function.actual; args; args = args->next)
4441 if (gfc_find_forall_index(args->expr,symbol) == SUCCESS)
4446 /* It seems not to happen. */
4447 case EXPR_SUBSTRING:
4451 gcc_assert (expr->ref->type == REF_SUBSTRING);
4452 if (gfc_find_forall_index (tmp->u.ss.start, symbol) == SUCCESS)
4454 if (gfc_find_forall_index (tmp->u.ss.end, symbol) == SUCCESS)
4459 /* It seems not to happen. */
4460 case EXPR_STRUCTURE:
4462 gfc_error ("Unsupported statement while finding forall index in "
4467 /* Find the FORALL index in the first operand. */
4468 if (expr->value.op.op1)
4470 if (gfc_find_forall_index (expr->value.op.op1, symbol) == SUCCESS)
4474 /* Find the FORALL index in the second operand. */
4475 if (expr->value.op.op2)
4477 if (gfc_find_forall_index (expr->value.op.op2, symbol) == SUCCESS)
4490 /* Resolve assignment in FORALL construct.
4491 NVAR is the number of FORALL index variables, and VAR_EXPR records the
4492 FORALL index variables. */
4495 gfc_resolve_assign_in_forall (gfc_code *code, int nvar, gfc_expr **var_expr)
4499 for (n = 0; n < nvar; n++)
4501 gfc_symbol *forall_index;
4503 forall_index = var_expr[n]->symtree->n.sym;
4505 /* Check whether the assignment target is one of the FORALL index
4507 if ((code->expr->expr_type == EXPR_VARIABLE)
4508 && (code->expr->symtree->n.sym == forall_index))
4509 gfc_error ("Assignment to a FORALL index variable at %L",
4510 &code->expr->where);
4513 /* If one of the FORALL index variables doesn't appear in the
4514 assignment target, then there will be a many-to-one
4516 if (gfc_find_forall_index (code->expr, forall_index) == FAILURE)
4517 gfc_error ("The FORALL with index '%s' cause more than one "
4518 "assignment to this object at %L",
4519 var_expr[n]->symtree->name, &code->expr->where);
4525 /* Resolve WHERE statement in FORALL construct. */
4528 gfc_resolve_where_code_in_forall (gfc_code *code, int nvar, gfc_expr **var_expr){
4532 cblock = code->block;
4535 /* the assignment statement of a WHERE statement, or the first
4536 statement in where-body-construct of a WHERE construct */
4537 cnext = cblock->next;
4542 /* WHERE assignment statement */
4544 gfc_resolve_assign_in_forall (cnext, nvar, var_expr);
4547 /* WHERE or WHERE construct is part of a where-body-construct */
4549 gfc_resolve_where_code_in_forall (cnext, nvar, var_expr);
4553 gfc_error ("Unsupported statement inside WHERE at %L",
4556 /* the next statement within the same where-body-construct */
4557 cnext = cnext->next;
4559 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
4560 cblock = cblock->block;
4565 /* Traverse the FORALL body to check whether the following errors exist:
4566 1. For assignment, check if a many-to-one assignment happens.
4567 2. For WHERE statement, check the WHERE body to see if there is any
4568 many-to-one assignment. */
4571 gfc_resolve_forall_body (gfc_code *code, int nvar, gfc_expr **var_expr)
4575 c = code->block->next;
4581 case EXEC_POINTER_ASSIGN:
4582 gfc_resolve_assign_in_forall (c, nvar, var_expr);
4585 /* Because the gfc_resolve_blocks() will handle the nested FORALL,
4586 there is no need to handle it here. */
4590 gfc_resolve_where_code_in_forall(c, nvar, var_expr);
4595 /* The next statement in the FORALL body. */
4601 /* Given a FORALL construct, first resolve the FORALL iterator, then call
4602 gfc_resolve_forall_body to resolve the FORALL body. */
4605 gfc_resolve_forall (gfc_code *code, gfc_namespace *ns, int forall_save)
4607 static gfc_expr **var_expr;
4608 static int total_var = 0;
4609 static int nvar = 0;
4610 gfc_forall_iterator *fa;
4611 gfc_symbol *forall_index;
4615 /* Start to resolve a FORALL construct */
4616 if (forall_save == 0)
4618 /* Count the total number of FORALL index in the nested FORALL
4619 construct in order to allocate the VAR_EXPR with proper size. */
4621 while ((next != NULL) && (next->op == EXEC_FORALL))
4623 for (fa = next->ext.forall_iterator; fa; fa = fa->next)
4625 next = next->block->next;
4628 /* Allocate VAR_EXPR with NUMBER_OF_FORALL_INDEX elements. */
4629 var_expr = (gfc_expr **) gfc_getmem (total_var * sizeof (gfc_expr *));
4632 /* The information about FORALL iterator, including FORALL index start, end
4633 and stride. The FORALL index can not appear in start, end or stride. */
4634 for (fa = code->ext.forall_iterator; fa; fa = fa->next)
4636 /* Check if any outer FORALL index name is the same as the current
4638 for (i = 0; i < nvar; i++)
4640 if (fa->var->symtree->n.sym == var_expr[i]->symtree->n.sym)
4642 gfc_error ("An outer FORALL construct already has an index "
4643 "with this name %L", &fa->var->where);
4647 /* Record the current FORALL index. */
4648 var_expr[nvar] = gfc_copy_expr (fa->var);
4650 forall_index = fa->var->symtree->n.sym;
4652 /* Check if the FORALL index appears in start, end or stride. */
4653 if (gfc_find_forall_index (fa->start, forall_index) == SUCCESS)
4654 gfc_error ("A FORALL index must not appear in a limit or stride "
4655 "expression in the same FORALL at %L", &fa->start->where);
4656 if (gfc_find_forall_index (fa->end, forall_index) == SUCCESS)
4657 gfc_error ("A FORALL index must not appear in a limit or stride "
4658 "expression in the same FORALL at %L", &fa->end->where);
4659 if (gfc_find_forall_index (fa->stride, forall_index) == SUCCESS)
4660 gfc_error ("A FORALL index must not appear in a limit or stride "
4661 "expression in the same FORALL at %L", &fa->stride->where);
4665 /* Resolve the FORALL body. */
4666 gfc_resolve_forall_body (code, nvar, var_expr);
4668 /* May call gfc_resolve_forall to resolve the inner FORALL loop. */
4669 gfc_resolve_blocks (code->block, ns);
4671 /* Free VAR_EXPR after the whole FORALL construct resolved. */
4672 for (i = 0; i < total_var; i++)
4673 gfc_free_expr (var_expr[i]);
4675 /* Reset the counters. */
4681 /* Resolve lists of blocks found in IF, SELECT CASE, WHERE, FORALL ,GOTO and
4684 static void resolve_code (gfc_code *, gfc_namespace *);
4687 gfc_resolve_blocks (gfc_code * b, gfc_namespace * ns)
4691 for (; b; b = b->block)
4693 t = gfc_resolve_expr (b->expr);
4694 if (gfc_resolve_expr (b->expr2) == FAILURE)
4700 if (t == SUCCESS && b->expr != NULL
4701 && (b->expr->ts.type != BT_LOGICAL || b->expr->rank != 0))
4703 ("ELSE IF clause at %L requires a scalar LOGICAL expression",
4710 && (b->expr->ts.type != BT_LOGICAL
4711 || b->expr->rank == 0))
4713 ("WHERE/ELSEWHERE clause at %L requires a LOGICAL array",
4718 resolve_branch (b->label, b);
4730 case EXEC_OMP_ATOMIC:
4731 case EXEC_OMP_CRITICAL:
4733 case EXEC_OMP_MASTER:
4734 case EXEC_OMP_ORDERED:
4735 case EXEC_OMP_PARALLEL:
4736 case EXEC_OMP_PARALLEL_DO:
4737 case EXEC_OMP_PARALLEL_SECTIONS:
4738 case EXEC_OMP_PARALLEL_WORKSHARE:
4739 case EXEC_OMP_SECTIONS:
4740 case EXEC_OMP_SINGLE:
4741 case EXEC_OMP_WORKSHARE:
4745 gfc_internal_error ("resolve_block(): Bad block type");
4748 resolve_code (b->next, ns);
4753 /* Given a block of code, recursively resolve everything pointed to by this
4757 resolve_code (gfc_code * code, gfc_namespace * ns)
4759 int omp_workshare_save;
4765 frame.prev = cs_base;
4769 for (; code; code = code->next)
4771 frame.current = code;
4772 forall_save = forall_flag;
4774 if (code->op == EXEC_FORALL)
4777 gfc_resolve_forall (code, ns, forall_save);
4780 else if (code->block)
4782 omp_workshare_save = -1;
4785 case EXEC_OMP_PARALLEL_WORKSHARE:
4786 omp_workshare_save = omp_workshare_flag;
4787 omp_workshare_flag = 1;
4788 gfc_resolve_omp_parallel_blocks (code, ns);
4790 case EXEC_OMP_PARALLEL:
4791 case EXEC_OMP_PARALLEL_DO:
4792 case EXEC_OMP_PARALLEL_SECTIONS:
4793 omp_workshare_save = omp_workshare_flag;
4794 omp_workshare_flag = 0;
4795 gfc_resolve_omp_parallel_blocks (code, ns);
4798 gfc_resolve_omp_do_blocks (code, ns);
4800 case EXEC_OMP_WORKSHARE:
4801 omp_workshare_save = omp_workshare_flag;
4802 omp_workshare_flag = 1;
4805 gfc_resolve_blocks (code->block, ns);
4809 if (omp_workshare_save != -1)
4810 omp_workshare_flag = omp_workshare_save;
4813 t = gfc_resolve_expr (code->expr);
4814 forall_flag = forall_save;
4816 if (gfc_resolve_expr (code->expr2) == FAILURE)
4831 /* Keep track of which entry we are up to. */
4832 current_entry_id = code->ext.entry->id;
4836 resolve_where (code, NULL);
4840 if (code->expr != NULL)
4842 if (code->expr->ts.type != BT_INTEGER)
4843 gfc_error ("ASSIGNED GOTO statement at %L requires an INTEGER "
4844 "variable", &code->expr->where);
4845 else if (code->expr->symtree->n.sym->attr.assign != 1)
4846 gfc_error ("Variable '%s' has not been assigned a target label "
4847 "at %L", code->expr->symtree->n.sym->name,
4848 &code->expr->where);
4851 resolve_branch (code->label, code);
4855 if (code->expr != NULL
4856 && (code->expr->ts.type != BT_INTEGER || code->expr->rank))
4857 gfc_error ("Alternate RETURN statement at %L requires a SCALAR-"
4858 "INTEGER return specifier", &code->expr->where);
4865 if (gfc_extend_assign (code, ns) == SUCCESS)
4867 if (gfc_pure (NULL) && !gfc_pure (code->symtree->n.sym))
4869 gfc_error ("Subroutine '%s' called instead of assignment at "
4870 "%L must be PURE", code->symtree->n.sym->name,
4877 if (gfc_pure (NULL))
4879 if (gfc_impure_variable (code->expr->symtree->n.sym))
4882 ("Cannot assign to variable '%s' in PURE procedure at %L",
4883 code->expr->symtree->n.sym->name, &code->expr->where);
4887 if (code->expr2->ts.type == BT_DERIVED
4888 && derived_pointer (code->expr2->ts.derived))
4891 ("Right side of assignment at %L is a derived type "
4892 "containing a POINTER in a PURE procedure",
4893 &code->expr2->where);
4898 gfc_check_assign (code->expr, code->expr2, 1);
4901 case EXEC_LABEL_ASSIGN:
4902 if (code->label->defined == ST_LABEL_UNKNOWN)
4903 gfc_error ("Label %d referenced at %L is never defined",
4904 code->label->value, &code->label->where);
4906 && (code->expr->expr_type != EXPR_VARIABLE
4907 || code->expr->symtree->n.sym->ts.type != BT_INTEGER
4908 || code->expr->symtree->n.sym->ts.kind
4909 != gfc_default_integer_kind
4910 || code->expr->symtree->n.sym->as != NULL))
4911 gfc_error ("ASSIGN statement at %L requires a scalar "
4912 "default INTEGER variable", &code->expr->where);
4915 case EXEC_POINTER_ASSIGN:
4919 gfc_check_pointer_assign (code->expr, code->expr2);
4922 case EXEC_ARITHMETIC_IF:
4924 && code->expr->ts.type != BT_INTEGER
4925 && code->expr->ts.type != BT_REAL)
4926 gfc_error ("Arithmetic IF statement at %L requires a numeric "
4927 "expression", &code->expr->where);
4929 resolve_branch (code->label, code);
4930 resolve_branch (code->label2, code);
4931 resolve_branch (code->label3, code);
4935 if (t == SUCCESS && code->expr != NULL
4936 && (code->expr->ts.type != BT_LOGICAL
4937 || code->expr->rank != 0))
4938 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
4939 &code->expr->where);
4944 resolve_call (code);
4948 /* Select is complicated. Also, a SELECT construct could be
4949 a transformed computed GOTO. */
4950 resolve_select (code);
4954 if (code->ext.iterator != NULL)
4956 gfc_iterator *iter = code->ext.iterator;
4957 if (gfc_resolve_iterator (iter, true) != FAILURE)
4958 gfc_resolve_do_iterator (code, iter->var->symtree->n.sym);
4963 if (code->expr == NULL)
4964 gfc_internal_error ("resolve_code(): No expression on DO WHILE");
4966 && (code->expr->rank != 0
4967 || code->expr->ts.type != BT_LOGICAL))
4968 gfc_error ("Exit condition of DO WHILE loop at %L must be "
4969 "a scalar LOGICAL expression", &code->expr->where);
4973 if (t == SUCCESS && code->expr != NULL
4974 && code->expr->ts.type != BT_INTEGER)
4975 gfc_error ("STAT tag in ALLOCATE statement at %L must be "
4976 "of type INTEGER", &code->expr->where);
4978 for (a = code->ext.alloc_list; a; a = a->next)
4979 resolve_allocate_expr (a->expr, code);
4983 case EXEC_DEALLOCATE:
4984 if (t == SUCCESS && code->expr != NULL
4985 && code->expr->ts.type != BT_INTEGER)
4987 ("STAT tag in DEALLOCATE statement at %L must be of type "
4988 "INTEGER", &code->expr->where);
4990 for (a = code->ext.alloc_list; a; a = a->next)
4991 resolve_deallocate_expr (a->expr);
4996 if (gfc_resolve_open (code->ext.open) == FAILURE)
4999 resolve_branch (code->ext.open->err, code);
5003 if (gfc_resolve_close (code->ext.close) == FAILURE)
5006 resolve_branch (code->ext.close->err, code);
5009 case EXEC_BACKSPACE:
5013 if (gfc_resolve_filepos (code->ext.filepos) == FAILURE)
5016 resolve_branch (code->ext.filepos->err, code);
5020 if (gfc_resolve_inquire (code->ext.inquire) == FAILURE)
5023 resolve_branch (code->ext.inquire->err, code);
5027 gcc_assert (code->ext.inquire != NULL);
5028 if (gfc_resolve_inquire (code->ext.inquire) == FAILURE)
5031 resolve_branch (code->ext.inquire->err, code);
5036 if (gfc_resolve_dt (code->ext.dt) == FAILURE)
5039 resolve_branch (code->ext.dt->err, code);
5040 resolve_branch (code->ext.dt->end, code);
5041 resolve_branch (code->ext.dt->eor, code);
5045 resolve_transfer (code);
5049 resolve_forall_iterators (code->ext.forall_iterator);
5051 if (code->expr != NULL && code->expr->ts.type != BT_LOGICAL)
5053 ("FORALL mask clause at %L requires a LOGICAL expression",
5054 &code->expr->where);
5057 case EXEC_OMP_ATOMIC:
5058 case EXEC_OMP_BARRIER:
5059 case EXEC_OMP_CRITICAL:
5060 case EXEC_OMP_FLUSH:
5062 case EXEC_OMP_MASTER:
5063 case EXEC_OMP_ORDERED:
5064 case EXEC_OMP_SECTIONS:
5065 case EXEC_OMP_SINGLE:
5066 case EXEC_OMP_WORKSHARE:
5067 gfc_resolve_omp_directive (code, ns);
5070 case EXEC_OMP_PARALLEL:
5071 case EXEC_OMP_PARALLEL_DO:
5072 case EXEC_OMP_PARALLEL_SECTIONS:
5073 case EXEC_OMP_PARALLEL_WORKSHARE:
5074 omp_workshare_save = omp_workshare_flag;
5075 omp_workshare_flag = 0;
5076 gfc_resolve_omp_directive (code, ns);
5077 omp_workshare_flag = omp_workshare_save;
5081 gfc_internal_error ("resolve_code(): Bad statement code");
5085 cs_base = frame.prev;
5089 /* Resolve initial values and make sure they are compatible with
5093 resolve_values (gfc_symbol * sym)
5096 if (sym->value == NULL)
5099 if (gfc_resolve_expr (sym->value) == FAILURE)
5102 gfc_check_assign_symbol (sym, sym->value);
5106 /* Resolve an index expression. */
5109 resolve_index_expr (gfc_expr * e)
5111 if (gfc_resolve_expr (e) == FAILURE)
5114 if (gfc_simplify_expr (e, 0) == FAILURE)
5117 if (gfc_specification_expr (e) == FAILURE)
5123 /* Resolve a charlen structure. */
5126 resolve_charlen (gfc_charlen *cl)
5133 specification_expr = 1;
5135 if (resolve_index_expr (cl->length) == FAILURE)
5137 specification_expr = 0;
5145 /* Test for non-constant shape arrays. */
5148 is_non_constant_shape_array (gfc_symbol *sym)
5154 not_constant = false;
5155 if (sym->as != NULL)
5157 /* Unfortunately, !gfc_is_compile_time_shape hits a legal case that
5158 has not been simplified; parameter array references. Do the
5159 simplification now. */
5160 for (i = 0; i < sym->as->rank; i++)
5162 e = sym->as->lower[i];
5163 if (e && (resolve_index_expr (e) == FAILURE
5164 || !gfc_is_constant_expr (e)))
5165 not_constant = true;
5167 e = sym->as->upper[i];
5168 if (e && (resolve_index_expr (e) == FAILURE
5169 || !gfc_is_constant_expr (e)))
5170 not_constant = true;
5173 return not_constant;
5176 /* Resolution of common features of flavors variable and procedure. */
5179 resolve_fl_var_and_proc (gfc_symbol *sym, int mp_flag)
5181 /* Constraints on deferred shape variable. */
5182 if (sym->as == NULL || sym->as->type != AS_DEFERRED)
5184 if (sym->attr.allocatable)
5186 if (sym->attr.dimension)
5187 gfc_error ("Allocatable array '%s' at %L must have "
5188 "a deferred shape", sym->name, &sym->declared_at);
5190 gfc_error ("Scalar object '%s' at %L may not be ALLOCATABLE",
5191 sym->name, &sym->declared_at);
5195 if (sym->attr.pointer && sym->attr.dimension)
5197 gfc_error ("Array pointer '%s' at %L must have a deferred shape",
5198 sym->name, &sym->declared_at);
5205 if (!mp_flag && !sym->attr.allocatable
5206 && !sym->attr.pointer && !sym->attr.dummy)
5208 gfc_error ("Array '%s' at %L cannot have a deferred shape",
5209 sym->name, &sym->declared_at);
5216 /* Resolve symbols with flavor variable. */
5219 resolve_fl_variable (gfc_symbol *sym, int mp_flag)
5224 gfc_expr *constructor_expr;
5225 const char * auto_save_msg;
5227 auto_save_msg = "automatic object '%s' at %L cannot have the "
5230 if (resolve_fl_var_and_proc (sym, mp_flag) == FAILURE)
5233 /* Set this flag to check that variables are parameters of all entries.
5234 This check is effected by the call to gfc_resolve_expr through
5235 is_non_constant_shape_array. */
5236 specification_expr = 1;
5238 if (!sym->attr.use_assoc
5239 && !sym->attr.allocatable
5240 && !sym->attr.pointer
5241 && is_non_constant_shape_array (sym))
5243 /* The shape of a main program or module array needs to be constant. */
5244 if (sym->ns->proc_name
5245 && (sym->ns->proc_name->attr.flavor == FL_MODULE
5246 || sym->ns->proc_name->attr.is_main_program))
5248 gfc_error ("The module or main program array '%s' at %L must "
5249 "have constant shape", sym->name, &sym->declared_at);
5250 specification_expr = 0;
5255 if (sym->ts.type == BT_CHARACTER)
5257 /* Make sure that character string variables with assumed length are
5259 e = sym->ts.cl->length;
5260 if (e == NULL && !sym->attr.dummy && !sym->attr.result)
5262 gfc_error ("Entity with assumed character length at %L must be a "
5263 "dummy argument or a PARAMETER", &sym->declared_at);
5267 if (e && sym->attr.save && !gfc_is_constant_expr (e))
5269 gfc_error (auto_save_msg, sym->name, &sym->declared_at);
5273 if (!gfc_is_constant_expr (e)
5274 && !(e->expr_type == EXPR_VARIABLE
5275 && e->symtree->n.sym->attr.flavor == FL_PARAMETER)
5276 && sym->ns->proc_name
5277 && (sym->ns->proc_name->attr.flavor == FL_MODULE
5278 || sym->ns->proc_name->attr.is_main_program)
5279 && !sym->attr.use_assoc)
5281 gfc_error ("'%s' at %L must have constant character length "
5282 "in this context", sym->name, &sym->declared_at);
5287 /* Can the symbol have an initializer? */
5289 if (sym->attr.allocatable || sym->attr.external || sym->attr.dummy
5290 || sym->attr.intrinsic || sym->attr.result)
5292 else if (sym->attr.dimension && !sym->attr.pointer)
5294 /* Don't allow initialization of automatic arrays. */
5295 for (i = 0; i < sym->as->rank; i++)
5297 if (sym->as->lower[i] == NULL
5298 || sym->as->lower[i]->expr_type != EXPR_CONSTANT
5299 || sym->as->upper[i] == NULL
5300 || sym->as->upper[i]->expr_type != EXPR_CONSTANT)
5307 /* Also, they must not have the SAVE attribute. */
5308 if (flag && sym->attr.save)
5310 gfc_error (auto_save_msg, sym->name, &sym->declared_at);
5315 /* Reject illegal initializers. */
5316 if (sym->value && flag)
5318 if (sym->attr.allocatable)
5319 gfc_error ("Allocatable '%s' at %L cannot have an initializer",
5320 sym->name, &sym->declared_at);
5321 else if (sym->attr.external)
5322 gfc_error ("External '%s' at %L cannot have an initializer",
5323 sym->name, &sym->declared_at);
5324 else if (sym->attr.dummy)
5325 gfc_error ("Dummy '%s' at %L cannot have an initializer",
5326 sym->name, &sym->declared_at);
5327 else if (sym->attr.intrinsic)
5328 gfc_error ("Intrinsic '%s' at %L cannot have an initializer",
5329 sym->name, &sym->declared_at);
5330 else if (sym->attr.result)
5331 gfc_error ("Function result '%s' at %L cannot have an initializer",
5332 sym->name, &sym->declared_at);
5334 gfc_error ("Automatic array '%s' at %L cannot have an initializer",
5335 sym->name, &sym->declared_at);
5339 /* 4th constraint in section 11.3: "If an object of a type for which
5340 component-initialization is specified (R429) appears in the
5341 specification-part of a module and does not have the ALLOCATABLE
5342 or POINTER attribute, the object shall have the SAVE attribute." */
5344 constructor_expr = NULL;
5345 if (sym->ts.type == BT_DERIVED && !(sym->value || flag))
5346 constructor_expr = gfc_default_initializer (&sym->ts);
5348 if (sym->ns->proc_name
5349 && sym->ns->proc_name->attr.flavor == FL_MODULE
5351 && !sym->ns->save_all && !sym->attr.save
5352 && !sym->attr.pointer && !sym->attr.allocatable)
5354 gfc_error("Object '%s' at %L must have the SAVE attribute %s",
5355 sym->name, &sym->declared_at,
5356 "for default initialization of a component");
5360 /* Assign default initializer. */
5361 if (sym->ts.type == BT_DERIVED && !sym->value && !sym->attr.pointer
5362 && !sym->attr.allocatable && (!flag || sym->attr.intent == INTENT_OUT))
5363 sym->value = gfc_default_initializer (&sym->ts);
5369 /* Resolve a procedure. */
5372 resolve_fl_procedure (gfc_symbol *sym, int mp_flag)
5374 gfc_formal_arglist *arg;
5376 if (sym->attr.function
5377 && resolve_fl_var_and_proc (sym, mp_flag) == FAILURE)
5380 if (sym->attr.proc == PROC_ST_FUNCTION)
5382 if (sym->ts.type == BT_CHARACTER)
5384 gfc_charlen *cl = sym->ts.cl;
5385 if (!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT)
5387 gfc_error ("Character-valued statement function '%s' at %L must "
5388 "have constant length", sym->name, &sym->declared_at);
5394 /* Ensure that derived type for are not of a private type. Internal
5395 module procedures are excluded by 2.2.3.3 - ie. they are not
5396 externally accessible and can access all the objects accessible in
5398 if (!(sym->ns->parent
5399 && sym->ns->parent->proc_name->attr.flavor == FL_MODULE)
5400 && gfc_check_access(sym->attr.access, sym->ns->default_access))
5402 for (arg = sym->formal; arg; arg = arg->next)
5405 && arg->sym->ts.type == BT_DERIVED
5406 && !arg->sym->ts.derived->attr.use_assoc
5407 && !gfc_check_access(arg->sym->ts.derived->attr.access,
5408 arg->sym->ts.derived->ns->default_access))
5410 gfc_error_now ("'%s' is of a PRIVATE type and cannot be "
5411 "a dummy argument of '%s', which is "
5412 "PUBLIC at %L", arg->sym->name, sym->name,
5414 /* Stop this message from recurring. */
5415 arg->sym->ts.derived->attr.access = ACCESS_PUBLIC;
5421 /* An external symbol may not have an initializer because it is taken to be
5423 if (sym->attr.external && sym->value)
5425 gfc_error ("External object '%s' at %L may not have an initializer",
5426 sym->name, &sym->declared_at);
5430 /* An elemental function is required to return a scalar 12.7.1 */
5431 if (sym->attr.elemental && sym->attr.function && sym->as)
5433 gfc_error ("ELEMENTAL function '%s' at %L must have a scalar "
5434 "result", sym->name, &sym->declared_at);
5435 /* Reset so that the error only occurs once. */
5436 sym->attr.elemental = 0;
5440 /* 5.1.1.5 of the Standard: A function name declared with an asterisk
5441 char-len-param shall not be array-valued, pointer-valued, recursive
5442 or pure. ....snip... A character value of * may only be used in the
5443 following ways: (i) Dummy arg of procedure - dummy associates with
5444 actual length; (ii) To declare a named constant; or (iii) External
5445 function - but length must be declared in calling scoping unit. */
5446 if (sym->attr.function
5447 && sym->ts.type == BT_CHARACTER
5448 && sym->ts.cl && sym->ts.cl->length == NULL)
5450 if ((sym->as && sym->as->rank) || (sym->attr.pointer)
5451 || (sym->attr.recursive) || (sym->attr.pure))
5453 if (sym->as && sym->as->rank)
5454 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
5455 "array-valued", sym->name, &sym->declared_at);
5457 if (sym->attr.pointer)
5458 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
5459 "pointer-valued", sym->name, &sym->declared_at);
5462 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
5463 "pure", sym->name, &sym->declared_at);
5465 if (sym->attr.recursive)
5466 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
5467 "recursive", sym->name, &sym->declared_at);
5472 /* Appendix B.2 of the standard. Contained functions give an
5473 error anyway. Fixed-form is likely to be F77/legacy. */
5474 if (!sym->attr.contained && gfc_current_form != FORM_FIXED)
5475 gfc_notify_std (GFC_STD_F95_OBS, "CHARACTER(*) function "
5476 "'%s' at %L is obsolescent in fortran 95",
5477 sym->name, &sym->declared_at);
5483 /* Resolve the components of a derived type. */
5486 resolve_fl_derived (gfc_symbol *sym)
5489 gfc_dt_list * dt_list;
5492 for (c = sym->components; c != NULL; c = c->next)
5494 if (c->ts.type == BT_CHARACTER)
5496 if (c->ts.cl->length == NULL
5497 || (resolve_charlen (c->ts.cl) == FAILURE)
5498 || !gfc_is_constant_expr (c->ts.cl->length))
5500 gfc_error ("Character length of component '%s' needs to "
5501 "be a constant specification expression at %L.",
5503 c->ts.cl->length ? &c->ts.cl->length->where : &c->loc);
5508 if (c->ts.type == BT_DERIVED
5509 && sym->component_access != ACCESS_PRIVATE
5510 && gfc_check_access(sym->attr.access, sym->ns->default_access)
5511 && !c->ts.derived->attr.use_assoc
5512 && !gfc_check_access(c->ts.derived->attr.access,
5513 c->ts.derived->ns->default_access))
5515 gfc_error ("The component '%s' is a PRIVATE type and cannot be "
5516 "a component of '%s', which is PUBLIC at %L",
5517 c->name, sym->name, &sym->declared_at);
5521 if (sym->attr.sequence)
5523 if (c->ts.type == BT_DERIVED && c->ts.derived->attr.sequence == 0)
5525 gfc_error ("Component %s of SEQUENCE type declared at %L does "
5526 "not have the SEQUENCE attribute",
5527 c->ts.derived->name, &sym->declared_at);
5532 if (c->pointer || c->as == NULL)
5535 for (i = 0; i < c->as->rank; i++)
5537 if (c->as->lower[i] == NULL
5538 || !gfc_is_constant_expr (c->as->lower[i])
5539 || (resolve_index_expr (c->as->lower[i]) == FAILURE)
5540 || c->as->upper[i] == NULL
5541 || (resolve_index_expr (c->as->upper[i]) == FAILURE)
5542 || !gfc_is_constant_expr (c->as->upper[i]))
5544 gfc_error ("Component '%s' of '%s' at %L must have "
5545 "constant array bounds.",
5546 c->name, sym->name, &c->loc);
5552 /* Add derived type to the derived type list. */
5553 for (dt_list = sym->ns->derived_types; dt_list; dt_list = dt_list->next)
5554 if (sym == dt_list->derived)
5557 if (dt_list == NULL)
5559 dt_list = gfc_get_dt_list ();
5560 dt_list->next = sym->ns->derived_types;
5561 dt_list->derived = sym;
5562 sym->ns->derived_types = dt_list;
5570 resolve_fl_namelist (gfc_symbol *sym)
5575 /* Reject PRIVATE objects in a PUBLIC namelist. */
5576 if (gfc_check_access(sym->attr.access, sym->ns->default_access))
5578 for (nl = sym->namelist; nl; nl = nl->next)
5580 if (!nl->sym->attr.use_assoc
5581 && !(sym->ns->parent == nl->sym->ns)
5582 && !gfc_check_access(nl->sym->attr.access,
5583 nl->sym->ns->default_access))
5585 gfc_error ("PRIVATE symbol '%s' cannot be member of "
5586 "PUBLIC namelist at %L", nl->sym->name,
5593 /* Reject namelist arrays that are not constant shape. */
5594 for (nl = sym->namelist; nl; nl = nl->next)
5596 if (is_non_constant_shape_array (nl->sym))
5598 gfc_error ("The array '%s' must have constant shape to be "
5599 "a NAMELIST object at %L", nl->sym->name,
5605 /* 14.1.2 A module or internal procedure represent local entities
5606 of the same type as a namelist member and so are not allowed.
5607 Note that this is sometimes caught by check_conflict so the
5608 same message has been used. */
5609 for (nl = sym->namelist; nl; nl = nl->next)
5612 if (sym->ns->parent && nl->sym && nl->sym->name)
5613 gfc_find_symbol (nl->sym->name, sym->ns->parent, 0, &nlsym);
5614 if (nlsym && nlsym->attr.flavor == FL_PROCEDURE)
5616 gfc_error ("PROCEDURE attribute conflicts with NAMELIST "
5617 "attribute in '%s' at %L", nlsym->name,
5628 resolve_fl_parameter (gfc_symbol *sym)
5630 /* A parameter array's shape needs to be constant. */
5631 if (sym->as != NULL && !gfc_is_compile_time_shape (sym->as))
5633 gfc_error ("Parameter array '%s' at %L cannot be automatic "
5634 "or assumed shape", sym->name, &sym->declared_at);
5638 /* Make sure a parameter that has been implicitly typed still
5639 matches the implicit type, since PARAMETER statements can precede
5640 IMPLICIT statements. */
5641 if (sym->attr.implicit_type
5642 && !gfc_compare_types (&sym->ts,
5643 gfc_get_default_type (sym, sym->ns)))
5645 gfc_error ("Implicitly typed PARAMETER '%s' at %L doesn't match a "
5646 "later IMPLICIT type", sym->name, &sym->declared_at);
5650 /* Make sure the types of derived parameters are consistent. This
5651 type checking is deferred until resolution because the type may
5652 refer to a derived type from the host. */
5653 if (sym->ts.type == BT_DERIVED
5654 && !gfc_compare_types (&sym->ts, &sym->value->ts))
5656 gfc_error ("Incompatible derived type in PARAMETER at %L",
5657 &sym->value->where);
5664 /* Do anything necessary to resolve a symbol. Right now, we just
5665 assume that an otherwise unknown symbol is a variable. This sort
5666 of thing commonly happens for symbols in module. */
5669 resolve_symbol (gfc_symbol * sym)
5671 /* Zero if we are checking a formal namespace. */
5672 static int formal_ns_flag = 1;
5673 int formal_ns_save, check_constant, mp_flag;
5674 gfc_symtree *symtree;
5675 gfc_symtree *this_symtree;
5679 if (sym->attr.flavor == FL_UNKNOWN)
5682 /* If we find that a flavorless symbol is an interface in one of the
5683 parent namespaces, find its symtree in this namespace, free the
5684 symbol and set the symtree to point to the interface symbol. */
5685 for (ns = gfc_current_ns->parent; ns; ns = ns->parent)
5687 symtree = gfc_find_symtree (ns->sym_root, sym->name);
5688 if (symtree && symtree->n.sym->generic)
5690 this_symtree = gfc_find_symtree (gfc_current_ns->sym_root,
5694 gfc_free_symbol (sym);
5695 symtree->n.sym->refs++;
5696 this_symtree->n.sym = symtree->n.sym;
5701 /* Otherwise give it a flavor according to such attributes as
5703 if (sym->attr.external == 0 && sym->attr.intrinsic == 0)
5704 sym->attr.flavor = FL_VARIABLE;
5707 sym->attr.flavor = FL_PROCEDURE;
5708 if (sym->attr.dimension)
5709 sym->attr.function = 1;
5713 if (sym->attr.flavor == FL_DERIVED && resolve_fl_derived (sym) == FAILURE)
5716 /* Symbols that are module procedures with results (functions) have
5717 the types and array specification copied for type checking in
5718 procedures that call them, as well as for saving to a module
5719 file. These symbols can't stand the scrutiny that their results
5721 mp_flag = (sym->result != NULL && sym->result != sym);
5723 /* Assign default type to symbols that need one and don't have one. */
5724 if (sym->ts.type == BT_UNKNOWN)
5726 if (sym->attr.flavor == FL_VARIABLE || sym->attr.flavor == FL_PARAMETER)
5727 gfc_set_default_type (sym, 1, NULL);
5729 if (sym->attr.flavor == FL_PROCEDURE && sym->attr.function)
5731 /* The specific case of an external procedure should emit an error
5732 in the case that there is no implicit type. */
5734 gfc_set_default_type (sym, sym->attr.external, NULL);
5737 /* Result may be in another namespace. */
5738 resolve_symbol (sym->result);
5740 sym->ts = sym->result->ts;
5741 sym->as = gfc_copy_array_spec (sym->result->as);
5742 sym->attr.dimension = sym->result->attr.dimension;
5743 sym->attr.pointer = sym->result->attr.pointer;
5744 sym->attr.allocatable = sym->result->attr.allocatable;
5749 /* Assumed size arrays and assumed shape arrays must be dummy
5753 && (sym->as->type == AS_ASSUMED_SIZE
5754 || sym->as->type == AS_ASSUMED_SHAPE)
5755 && sym->attr.dummy == 0)
5757 if (sym->as->type == AS_ASSUMED_SIZE)
5758 gfc_error ("Assumed size array at %L must be a dummy argument",
5761 gfc_error ("Assumed shape array at %L must be a dummy argument",
5766 /* Make sure symbols with known intent or optional are really dummy
5767 variable. Because of ENTRY statement, this has to be deferred
5768 until resolution time. */
5770 if (!sym->attr.dummy
5771 && (sym->attr.optional
5772 || sym->attr.intent != INTENT_UNKNOWN))
5774 gfc_error ("Symbol at %L is not a DUMMY variable", &sym->declared_at);
5778 /* If a derived type symbol has reached this point, without its
5779 type being declared, we have an error. Notice that most
5780 conditions that produce undefined derived types have already
5781 been dealt with. However, the likes of:
5782 implicit type(t) (t) ..... call foo (t) will get us here if
5783 the type is not declared in the scope of the implicit
5784 statement. Change the type to BT_UNKNOWN, both because it is so
5785 and to prevent an ICE. */
5786 if (sym->ts.type == BT_DERIVED
5787 && sym->ts.derived->components == NULL)
5789 gfc_error ("The derived type '%s' at %L is of type '%s', "
5790 "which has not been defined.", sym->name,
5791 &sym->declared_at, sym->ts.derived->name);
5792 sym->ts.type = BT_UNKNOWN;
5796 /* An assumed-size array with INTENT(OUT) shall not be of a type for which
5797 default initialization is defined (5.1.2.4.4). */
5798 if (sym->ts.type == BT_DERIVED
5800 && sym->attr.intent == INTENT_OUT
5802 && sym->as->type == AS_ASSUMED_SIZE)
5804 for (c = sym->ts.derived->components; c; c = c->next)
5808 gfc_error ("The INTENT(OUT) dummy argument '%s' at %L is "
5809 "ASSUMED SIZE and so cannot have a default initializer",
5810 sym->name, &sym->declared_at);
5816 switch (sym->attr.flavor)
5819 if (resolve_fl_variable (sym, mp_flag) == FAILURE)
5824 if (resolve_fl_procedure (sym, mp_flag) == FAILURE)
5829 if (resolve_fl_namelist (sym) == FAILURE)
5834 if (resolve_fl_parameter (sym) == FAILURE)
5844 /* Make sure that intrinsic exist */
5845 if (sym->attr.intrinsic
5846 && ! gfc_intrinsic_name(sym->name, 0)
5847 && ! gfc_intrinsic_name(sym->name, 1))
5848 gfc_error("Intrinsic at %L does not exist", &sym->declared_at);
5850 /* Resolve array specifier. Check as well some constraints
5851 on COMMON blocks. */
5853 check_constant = sym->attr.in_common && !sym->attr.pointer;
5854 gfc_resolve_array_spec (sym->as, check_constant);
5856 /* Resolve formal namespaces. */
5858 if (formal_ns_flag && sym != NULL && sym->formal_ns != NULL)
5860 formal_ns_save = formal_ns_flag;
5862 gfc_resolve (sym->formal_ns);
5863 formal_ns_flag = formal_ns_save;
5866 /* Check threadprivate restrictions. */
5867 if (sym->attr.threadprivate && !sym->attr.save
5868 && (!sym->attr.in_common
5869 && sym->module == NULL
5870 && (sym->ns->proc_name == NULL
5871 || sym->ns->proc_name->attr.flavor != FL_MODULE)))
5872 gfc_error ("Threadprivate at %L isn't SAVEd", &sym->declared_at);
5877 /************* Resolve DATA statements *************/
5881 gfc_data_value *vnode;
5887 /* Advance the values structure to point to the next value in the data list. */
5890 next_data_value (void)
5892 while (values.left == 0)
5894 if (values.vnode->next == NULL)
5897 values.vnode = values.vnode->next;
5898 values.left = values.vnode->repeat;
5906 check_data_variable (gfc_data_variable * var, locus * where)
5912 ar_type mark = AR_UNKNOWN;
5914 mpz_t section_index[GFC_MAX_DIMENSIONS];
5918 if (gfc_resolve_expr (var->expr) == FAILURE)
5922 mpz_init_set_si (offset, 0);
5925 if (e->expr_type != EXPR_VARIABLE)
5926 gfc_internal_error ("check_data_variable(): Bad expression");
5928 if (e->symtree->n.sym->ns->is_block_data
5929 && !e->symtree->n.sym->attr.in_common)
5931 gfc_error ("BLOCK DATA element '%s' at %L must be in COMMON",
5932 e->symtree->n.sym->name, &e->symtree->n.sym->declared_at);
5937 mpz_init_set_ui (size, 1);
5944 /* Find the array section reference. */
5945 for (ref = e->ref; ref; ref = ref->next)
5947 if (ref->type != REF_ARRAY)
5949 if (ref->u.ar.type == AR_ELEMENT)
5955 /* Set marks according to the reference pattern. */
5956 switch (ref->u.ar.type)
5964 /* Get the start position of array section. */
5965 gfc_get_section_index (ar, section_index, &offset);
5973 if (gfc_array_size (e, &size) == FAILURE)
5975 gfc_error ("Nonconstant array section at %L in DATA statement",
5984 while (mpz_cmp_ui (size, 0) > 0)
5986 if (next_data_value () == FAILURE)
5988 gfc_error ("DATA statement at %L has more variables than values",
5994 t = gfc_check_assign (var->expr, values.vnode->expr, 0);
5998 /* If we have more than one element left in the repeat count,
5999 and we have more than one element left in the target variable,
6000 then create a range assignment. */
6001 /* ??? Only done for full arrays for now, since array sections
6003 if (mark == AR_FULL && ref && ref->next == NULL
6004 && values.left > 1 && mpz_cmp_ui (size, 1) > 0)
6008 if (mpz_cmp_ui (size, values.left) >= 0)
6010 mpz_init_set_ui (range, values.left);
6011 mpz_sub_ui (size, size, values.left);
6016 mpz_init_set (range, size);
6017 values.left -= mpz_get_ui (size);
6018 mpz_set_ui (size, 0);
6021 gfc_assign_data_value_range (var->expr, values.vnode->expr,
6024 mpz_add (offset, offset, range);
6028 /* Assign initial value to symbol. */
6032 mpz_sub_ui (size, size, 1);
6034 gfc_assign_data_value (var->expr, values.vnode->expr, offset);
6036 if (mark == AR_FULL)
6037 mpz_add_ui (offset, offset, 1);
6039 /* Modify the array section indexes and recalculate the offset
6040 for next element. */
6041 else if (mark == AR_SECTION)
6042 gfc_advance_section (section_index, ar, &offset);
6046 if (mark == AR_SECTION)
6048 for (i = 0; i < ar->dimen; i++)
6049 mpz_clear (section_index[i]);
6059 static try traverse_data_var (gfc_data_variable *, locus *);
6061 /* Iterate over a list of elements in a DATA statement. */
6064 traverse_data_list (gfc_data_variable * var, locus * where)
6067 iterator_stack frame;
6070 mpz_init (frame.value);
6072 mpz_init_set (trip, var->iter.end->value.integer);
6073 mpz_sub (trip, trip, var->iter.start->value.integer);
6074 mpz_add (trip, trip, var->iter.step->value.integer);
6076 mpz_div (trip, trip, var->iter.step->value.integer);
6078 mpz_set (frame.value, var->iter.start->value.integer);
6080 frame.prev = iter_stack;
6081 frame.variable = var->iter.var->symtree;
6082 iter_stack = &frame;
6084 while (mpz_cmp_ui (trip, 0) > 0)
6086 if (traverse_data_var (var->list, where) == FAILURE)
6092 e = gfc_copy_expr (var->expr);
6093 if (gfc_simplify_expr (e, 1) == FAILURE)
6099 mpz_add (frame.value, frame.value, var->iter.step->value.integer);
6101 mpz_sub_ui (trip, trip, 1);
6105 mpz_clear (frame.value);
6107 iter_stack = frame.prev;
6112 /* Type resolve variables in the variable list of a DATA statement. */
6115 traverse_data_var (gfc_data_variable * var, locus * where)
6119 for (; var; var = var->next)
6121 if (var->expr == NULL)
6122 t = traverse_data_list (var, where);
6124 t = check_data_variable (var, where);
6134 /* Resolve the expressions and iterators associated with a data statement.
6135 This is separate from the assignment checking because data lists should
6136 only be resolved once. */
6139 resolve_data_variables (gfc_data_variable * d)
6141 for (; d; d = d->next)
6143 if (d->list == NULL)
6145 if (gfc_resolve_expr (d->expr) == FAILURE)
6150 if (gfc_resolve_iterator (&d->iter, false) == FAILURE)
6153 if (d->iter.start->expr_type != EXPR_CONSTANT
6154 || d->iter.end->expr_type != EXPR_CONSTANT
6155 || d->iter.step->expr_type != EXPR_CONSTANT)
6156 gfc_internal_error ("resolve_data_variables(): Bad iterator");
6158 if (resolve_data_variables (d->list) == FAILURE)
6167 /* Resolve a single DATA statement. We implement this by storing a pointer to
6168 the value list into static variables, and then recursively traversing the
6169 variables list, expanding iterators and such. */
6172 resolve_data (gfc_data * d)
6174 if (resolve_data_variables (d->var) == FAILURE)
6177 values.vnode = d->value;
6178 values.left = (d->value == NULL) ? 0 : d->value->repeat;
6180 if (traverse_data_var (d->var, &d->where) == FAILURE)
6183 /* At this point, we better not have any values left. */
6185 if (next_data_value () == SUCCESS)
6186 gfc_error ("DATA statement at %L has more values than variables",
6191 /* Determines if a variable is not 'pure', ie not assignable within a pure
6192 procedure. Returns zero if assignment is OK, nonzero if there is a problem.
6196 gfc_impure_variable (gfc_symbol * sym)
6198 if (sym->attr.use_assoc || sym->attr.in_common)
6201 if (sym->ns != gfc_current_ns)
6202 return !sym->attr.function;
6204 /* TODO: Check storage association through EQUIVALENCE statements */
6210 /* Test whether a symbol is pure or not. For a NULL pointer, checks the
6211 symbol of the current procedure. */
6214 gfc_pure (gfc_symbol * sym)
6216 symbol_attribute attr;
6219 sym = gfc_current_ns->proc_name;
6225 return attr.flavor == FL_PROCEDURE && (attr.pure || attr.elemental);
6229 /* Test whether the current procedure is elemental or not. */
6232 gfc_elemental (gfc_symbol * sym)
6234 symbol_attribute attr;
6237 sym = gfc_current_ns->proc_name;
6242 return attr.flavor == FL_PROCEDURE && attr.elemental;
6246 /* Warn about unused labels. */
6249 warn_unused_fortran_label (gfc_st_label * label)
6254 warn_unused_fortran_label (label->left);
6256 if (label->defined == ST_LABEL_UNKNOWN)
6259 switch (label->referenced)
6261 case ST_LABEL_UNKNOWN:
6262 gfc_warning ("Label %d at %L defined but not used", label->value,
6266 case ST_LABEL_BAD_TARGET:
6267 gfc_warning ("Label %d at %L defined but cannot be used",
6268 label->value, &label->where);
6275 warn_unused_fortran_label (label->right);
6279 /* Returns the sequence type of a symbol or sequence. */
6282 sequence_type (gfc_typespec ts)
6291 if (ts.derived->components == NULL)
6292 return SEQ_NONDEFAULT;
6294 result = sequence_type (ts.derived->components->ts);
6295 for (c = ts.derived->components->next; c; c = c->next)
6296 if (sequence_type (c->ts) != result)
6302 if (ts.kind != gfc_default_character_kind)
6303 return SEQ_NONDEFAULT;
6305 return SEQ_CHARACTER;
6308 if (ts.kind != gfc_default_integer_kind)
6309 return SEQ_NONDEFAULT;
6314 if (!(ts.kind == gfc_default_real_kind
6315 || ts.kind == gfc_default_double_kind))
6316 return SEQ_NONDEFAULT;
6321 if (ts.kind != gfc_default_complex_kind)
6322 return SEQ_NONDEFAULT;
6327 if (ts.kind != gfc_default_logical_kind)
6328 return SEQ_NONDEFAULT;
6333 return SEQ_NONDEFAULT;
6338 /* Resolve derived type EQUIVALENCE object. */
6341 resolve_equivalence_derived (gfc_symbol *derived, gfc_symbol *sym, gfc_expr *e)
6344 gfc_component *c = derived->components;
6349 /* Shall not be an object of nonsequence derived type. */
6350 if (!derived->attr.sequence)
6352 gfc_error ("Derived type variable '%s' at %L must have SEQUENCE "
6353 "attribute to be an EQUIVALENCE object", sym->name, &e->where);
6357 for (; c ; c = c->next)
6360 if (d && (resolve_equivalence_derived (c->ts.derived, sym, e) == FAILURE))
6363 /* Shall not be an object of sequence derived type containing a pointer
6364 in the structure. */
6367 gfc_error ("Derived type variable '%s' at %L with pointer component(s) "
6368 "cannot be an EQUIVALENCE object", sym->name, &e->where);
6374 gfc_error ("Derived type variable '%s' at %L with default initializer "
6375 "cannot be an EQUIVALENCE object", sym->name, &e->where);
6383 /* Resolve equivalence object.
6384 An EQUIVALENCE object shall not be a dummy argument, a pointer, a target,
6385 an allocatable array, an object of nonsequence derived type, an object of
6386 sequence derived type containing a pointer at any level of component
6387 selection, an automatic object, a function name, an entry name, a result
6388 name, a named constant, a structure component, or a subobject of any of
6389 the preceding objects. A substring shall not have length zero. A
6390 derived type shall not have components with default initialization nor
6391 shall two objects of an equivalence group be initialized.
6392 The simple constraints are done in symbol.c(check_conflict) and the rest
6393 are implemented here. */
6396 resolve_equivalence (gfc_equiv *eq)
6399 gfc_symbol *derived;
6400 gfc_symbol *first_sym;
6403 locus *last_where = NULL;
6404 seq_type eq_type, last_eq_type;
6405 gfc_typespec *last_ts;
6407 const char *value_name;
6411 last_ts = &eq->expr->symtree->n.sym->ts;
6413 first_sym = eq->expr->symtree->n.sym;
6415 for (object = 1; eq; eq = eq->eq, object++)
6419 e->ts = e->symtree->n.sym->ts;
6420 /* match_varspec might not know yet if it is seeing
6421 array reference or substring reference, as it doesn't
6423 if (e->ref && e->ref->type == REF_ARRAY)
6425 gfc_ref *ref = e->ref;
6426 sym = e->symtree->n.sym;
6428 if (sym->attr.dimension)
6430 ref->u.ar.as = sym->as;
6434 /* For substrings, convert REF_ARRAY into REF_SUBSTRING. */
6435 if (e->ts.type == BT_CHARACTER
6437 && ref->type == REF_ARRAY
6438 && ref->u.ar.dimen == 1
6439 && ref->u.ar.dimen_type[0] == DIMEN_RANGE
6440 && ref->u.ar.stride[0] == NULL)
6442 gfc_expr *start = ref->u.ar.start[0];
6443 gfc_expr *end = ref->u.ar.end[0];
6446 /* Optimize away the (:) reference. */
6447 if (start == NULL && end == NULL)
6452 e->ref->next = ref->next;
6457 ref->type = REF_SUBSTRING;
6459 start = gfc_int_expr (1);
6460 ref->u.ss.start = start;
6461 if (end == NULL && e->ts.cl)
6462 end = gfc_copy_expr (e->ts.cl->length);
6463 ref->u.ss.end = end;
6464 ref->u.ss.length = e->ts.cl;
6471 /* Any further ref is an error. */
6474 gcc_assert (ref->type == REF_ARRAY);
6475 gfc_error ("Syntax error in EQUIVALENCE statement at %L",
6481 if (gfc_resolve_expr (e) == FAILURE)
6484 sym = e->symtree->n.sym;
6486 /* An equivalence statement cannot have more than one initialized
6490 if (value_name != NULL)
6492 gfc_error ("Initialized objects '%s' and '%s' cannot both "
6493 "be in the EQUIVALENCE statement at %L",
6494 value_name, sym->name, &e->where);
6498 value_name = sym->name;
6501 /* Shall not equivalence common block variables in a PURE procedure. */
6502 if (sym->ns->proc_name
6503 && sym->ns->proc_name->attr.pure
6504 && sym->attr.in_common)
6506 gfc_error ("Common block member '%s' at %L cannot be an EQUIVALENCE "
6507 "object in the pure procedure '%s'",
6508 sym->name, &e->where, sym->ns->proc_name->name);
6512 /* Shall not be a named constant. */
6513 if (e->expr_type == EXPR_CONSTANT)
6515 gfc_error ("Named constant '%s' at %L cannot be an EQUIVALENCE "
6516 "object", sym->name, &e->where);
6520 derived = e->ts.derived;
6521 if (derived && resolve_equivalence_derived (derived, sym, e) == FAILURE)
6524 /* Check that the types correspond correctly:
6526 A numeric sequence structure may be equivalenced to another sequence
6527 structure, an object of default integer type, default real type, double
6528 precision real type, default logical type such that components of the
6529 structure ultimately only become associated to objects of the same
6530 kind. A character sequence structure may be equivalenced to an object
6531 of default character kind or another character sequence structure.
6532 Other objects may be equivalenced only to objects of the same type and
6535 /* Identical types are unconditionally OK. */
6536 if (object == 1 || gfc_compare_types (last_ts, &sym->ts))
6537 goto identical_types;
6539 last_eq_type = sequence_type (*last_ts);
6540 eq_type = sequence_type (sym->ts);
6542 /* Since the pair of objects is not of the same type, mixed or
6543 non-default sequences can be rejected. */
6545 msg = "Sequence %s with mixed components in EQUIVALENCE "
6546 "statement at %L with different type objects";
6548 && last_eq_type == SEQ_MIXED
6549 && gfc_notify_std (GFC_STD_GNU, msg, first_sym->name,
6550 last_where) == FAILURE)
6551 || (eq_type == SEQ_MIXED
6552 && gfc_notify_std (GFC_STD_GNU, msg,sym->name,
6553 &e->where) == FAILURE))
6556 msg = "Non-default type object or sequence %s in EQUIVALENCE "
6557 "statement at %L with objects of different type";
6559 && last_eq_type == SEQ_NONDEFAULT
6560 && gfc_notify_std (GFC_STD_GNU, msg, first_sym->name,
6561 last_where) == FAILURE)
6562 || (eq_type == SEQ_NONDEFAULT
6563 && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
6564 &e->where) == FAILURE))
6567 msg ="Non-CHARACTER object '%s' in default CHARACTER "
6568 "EQUIVALENCE statement at %L";
6569 if (last_eq_type == SEQ_CHARACTER
6570 && eq_type != SEQ_CHARACTER
6571 && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
6572 &e->where) == FAILURE)
6575 msg ="Non-NUMERIC object '%s' in default NUMERIC "
6576 "EQUIVALENCE statement at %L";
6577 if (last_eq_type == SEQ_NUMERIC
6578 && eq_type != SEQ_NUMERIC
6579 && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
6580 &e->where) == FAILURE)
6585 last_where = &e->where;
6590 /* Shall not be an automatic array. */
6591 if (e->ref->type == REF_ARRAY
6592 && gfc_resolve_array_spec (e->ref->u.ar.as, 1) == FAILURE)
6594 gfc_error ("Array '%s' at %L with non-constant bounds cannot be "
6595 "an EQUIVALENCE object", sym->name, &e->where);
6602 /* Shall not be a structure component. */
6603 if (r->type == REF_COMPONENT)
6605 gfc_error ("Structure component '%s' at %L cannot be an "
6606 "EQUIVALENCE object",
6607 r->u.c.component->name, &e->where);
6611 /* A substring shall not have length zero. */
6612 if (r->type == REF_SUBSTRING)
6614 if (compare_bound (r->u.ss.start, r->u.ss.end) == CMP_GT)
6616 gfc_error ("Substring at %L has length zero",
6617 &r->u.ss.start->where);
6627 /* Resolve function and ENTRY types, issue diagnostics if needed. */
6630 resolve_fntype (gfc_namespace * ns)
6635 if (ns->proc_name == NULL || !ns->proc_name->attr.function)
6638 /* If there are any entries, ns->proc_name is the entry master
6639 synthetic symbol and ns->entries->sym actual FUNCTION symbol. */
6641 sym = ns->entries->sym;
6643 sym = ns->proc_name;
6644 if (sym->result == sym
6645 && sym->ts.type == BT_UNKNOWN
6646 && gfc_set_default_type (sym, 0, NULL) == FAILURE
6647 && !sym->attr.untyped)
6649 gfc_error ("Function '%s' at %L has no IMPLICIT type",
6650 sym->name, &sym->declared_at);
6651 sym->attr.untyped = 1;
6654 if (sym->ts.type == BT_DERIVED && !sym->ts.derived->attr.use_assoc
6655 && !gfc_check_access (sym->ts.derived->attr.access,
6656 sym->ts.derived->ns->default_access)
6657 && gfc_check_access (sym->attr.access, sym->ns->default_access))
6659 gfc_error ("PUBLIC function '%s' at %L cannot be of PRIVATE type '%s'",
6660 sym->name, &sym->declared_at, sym->ts.derived->name);
6663 /* Make sure that the type of a module derived type function is in the
6664 module namespace, by copying it from the namespace's derived type
6665 list, if necessary. */
6666 if (sym->ts.type == BT_DERIVED
6667 && sym->ns->proc_name->attr.flavor == FL_MODULE
6668 && sym->ts.derived->ns
6669 && sym->ns != sym->ts.derived->ns)
6671 gfc_dt_list *dt = sym->ns->derived_types;
6673 for (; dt; dt = dt->next)
6674 if (gfc_compare_derived_types (sym->ts.derived, dt->derived))
6675 sym->ts.derived = dt->derived;
6679 for (el = ns->entries->next; el; el = el->next)
6681 if (el->sym->result == el->sym
6682 && el->sym->ts.type == BT_UNKNOWN
6683 && gfc_set_default_type (el->sym, 0, NULL) == FAILURE
6684 && !el->sym->attr.untyped)
6686 gfc_error ("ENTRY '%s' at %L has no IMPLICIT type",
6687 el->sym->name, &el->sym->declared_at);
6688 el->sym->attr.untyped = 1;
6693 /* 12.3.2.1.1 Defined operators. */
6696 gfc_resolve_uops(gfc_symtree *symtree)
6700 gfc_formal_arglist *formal;
6702 if (symtree == NULL)
6705 gfc_resolve_uops (symtree->left);
6706 gfc_resolve_uops (symtree->right);
6708 for (itr = symtree->n.uop->operator; itr; itr = itr->next)
6711 if (!sym->attr.function)
6712 gfc_error("User operator procedure '%s' at %L must be a FUNCTION",
6713 sym->name, &sym->declared_at);
6715 if (sym->ts.type == BT_CHARACTER
6716 && !(sym->ts.cl && sym->ts.cl->length)
6717 && !(sym->result && sym->result->ts.cl && sym->result->ts.cl->length))
6718 gfc_error("User operator procedure '%s' at %L cannot be assumed character "
6719 "length", sym->name, &sym->declared_at);
6721 formal = sym->formal;
6722 if (!formal || !formal->sym)
6724 gfc_error("User operator procedure '%s' at %L must have at least "
6725 "one argument", sym->name, &sym->declared_at);
6729 if (formal->sym->attr.intent != INTENT_IN)
6730 gfc_error ("First argument of operator interface at %L must be "
6731 "INTENT(IN)", &sym->declared_at);
6733 if (formal->sym->attr.optional)
6734 gfc_error ("First argument of operator interface at %L cannot be "
6735 "optional", &sym->declared_at);
6737 formal = formal->next;
6738 if (!formal || !formal->sym)
6741 if (formal->sym->attr.intent != INTENT_IN)
6742 gfc_error ("Second argument of operator interface at %L must be "
6743 "INTENT(IN)", &sym->declared_at);
6745 if (formal->sym->attr.optional)
6746 gfc_error ("Second argument of operator interface at %L cannot be "
6747 "optional", &sym->declared_at);
6750 gfc_error ("Operator interface at %L must have, at most, two "
6751 "arguments", &sym->declared_at);
6756 /* Examine all of the expressions associated with a program unit,
6757 assign types to all intermediate expressions, make sure that all
6758 assignments are to compatible types and figure out which names
6759 refer to which functions or subroutines. It doesn't check code
6760 block, which is handled by resolve_code. */
6763 resolve_types (gfc_namespace * ns)
6770 gfc_current_ns = ns;
6772 resolve_entries (ns);
6774 resolve_contained_functions (ns);
6776 gfc_traverse_ns (ns, resolve_symbol);
6778 resolve_fntype (ns);
6780 for (n = ns->contained; n; n = n->sibling)
6782 if (gfc_pure (ns->proc_name) && !gfc_pure (n->proc_name))
6783 gfc_error ("Contained procedure '%s' at %L of a PURE procedure must "
6784 "also be PURE", n->proc_name->name,
6785 &n->proc_name->declared_at);
6791 gfc_check_interfaces (ns);
6793 for (cl = ns->cl_list; cl; cl = cl->next)
6794 resolve_charlen (cl);
6796 gfc_traverse_ns (ns, resolve_values);
6802 for (d = ns->data; d; d = d->next)
6806 gfc_traverse_ns (ns, gfc_formalize_init_value);
6808 for (eq = ns->equiv; eq; eq = eq->next)
6809 resolve_equivalence (eq);
6811 /* Warn about unused labels. */
6812 if (gfc_option.warn_unused_labels)
6813 warn_unused_fortran_label (ns->st_labels);
6815 gfc_resolve_uops (ns->uop_root);
6819 /* Call resolve_code recursively. */
6822 resolve_codes (gfc_namespace * ns)
6826 for (n = ns->contained; n; n = n->sibling)
6829 gfc_current_ns = ns;
6831 /* Set to an out of range value. */
6832 current_entry_id = -1;
6833 resolve_code (ns->code, ns);
6837 /* This function is called after a complete program unit has been compiled.
6838 Its purpose is to examine all of the expressions associated with a program
6839 unit, assign types to all intermediate expressions, make sure that all
6840 assignments are to compatible types and figure out which names refer to
6841 which functions or subroutines. */
6844 gfc_resolve (gfc_namespace * ns)
6846 gfc_namespace *old_ns;
6848 old_ns = gfc_current_ns;
6853 gfc_current_ns = old_ns;