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)
612 if (gfc_resolve_expr (cons->expr) == FAILURE)
618 /* If we don't have the right type, try to convert it. */
620 if (!gfc_compare_types (&cons->expr->ts, &comp->ts))
623 if (comp->pointer && cons->expr->ts.type != BT_UNKNOWN)
624 gfc_error ("The element in the derived type constructor at %L, "
625 "for pointer component '%s', is %s but should be %s",
626 &cons->expr->where, comp->name,
627 gfc_basic_typename (cons->expr->ts.type),
628 gfc_basic_typename (comp->ts.type));
630 t = gfc_convert_type (cons->expr, &comp->ts, 1);
639 /****************** Expression name resolution ******************/
641 /* Returns 0 if a symbol was not declared with a type or
642 attribute declaration statement, nonzero otherwise. */
645 was_declared (gfc_symbol * sym)
651 if (!a.implicit_type && sym->ts.type != BT_UNKNOWN)
654 if (a.allocatable || a.dimension || a.dummy || a.external || a.intrinsic
655 || a.optional || a.pointer || a.save || a.target
656 || a.access != ACCESS_UNKNOWN || a.intent != INTENT_UNKNOWN)
663 /* Determine if a symbol is generic or not. */
666 generic_sym (gfc_symbol * sym)
670 if (sym->attr.generic ||
671 (sym->attr.intrinsic && gfc_generic_intrinsic (sym->name)))
674 if (was_declared (sym) || sym->ns->parent == NULL)
677 gfc_find_symbol (sym->name, sym->ns->parent, 1, &s);
679 return (s == NULL) ? 0 : generic_sym (s);
683 /* Determine if a symbol is specific or not. */
686 specific_sym (gfc_symbol * sym)
690 if (sym->attr.if_source == IFSRC_IFBODY
691 || sym->attr.proc == PROC_MODULE
692 || sym->attr.proc == PROC_INTERNAL
693 || sym->attr.proc == PROC_ST_FUNCTION
694 || (sym->attr.intrinsic &&
695 gfc_specific_intrinsic (sym->name))
696 || sym->attr.external)
699 if (was_declared (sym) || sym->ns->parent == NULL)
702 gfc_find_symbol (sym->name, sym->ns->parent, 1, &s);
704 return (s == NULL) ? 0 : specific_sym (s);
708 /* Figure out if the procedure is specific, generic or unknown. */
711 { PTYPE_GENERIC = 1, PTYPE_SPECIFIC, PTYPE_UNKNOWN }
715 procedure_kind (gfc_symbol * sym)
718 if (generic_sym (sym))
719 return PTYPE_GENERIC;
721 if (specific_sym (sym))
722 return PTYPE_SPECIFIC;
724 return PTYPE_UNKNOWN;
727 /* Check references to assumed size arrays. The flag need_full_assumed_size
728 is nonzero when matching actual arguments. */
730 static int need_full_assumed_size = 0;
733 check_assumed_size_reference (gfc_symbol * sym, gfc_expr * e)
739 if (need_full_assumed_size
740 || !(sym->as && sym->as->type == AS_ASSUMED_SIZE))
743 for (ref = e->ref; ref; ref = ref->next)
744 if (ref->type == REF_ARRAY)
745 for (dim = 0; dim < ref->u.ar.as->rank; dim++)
746 last = (ref->u.ar.end[dim] == NULL) && (ref->u.ar.type == DIMEN_ELEMENT);
750 gfc_error ("The upper bound in the last dimension must "
751 "appear in the reference to the assumed size "
752 "array '%s' at %L.", sym->name, &e->where);
759 /* Look for bad assumed size array references in argument expressions
760 of elemental and array valued intrinsic procedures. Since this is
761 called from procedure resolution functions, it only recurses at
765 resolve_assumed_size_actual (gfc_expr *e)
770 switch (e->expr_type)
774 && check_assumed_size_reference (e->symtree->n.sym, e))
779 if (resolve_assumed_size_actual (e->value.op.op1)
780 || resolve_assumed_size_actual (e->value.op.op2))
791 /* Resolve an actual argument list. Most of the time, this is just
792 resolving the expressions in the list.
793 The exception is that we sometimes have to decide whether arguments
794 that look like procedure arguments are really simple variable
798 resolve_actual_arglist (gfc_actual_arglist * arg)
801 gfc_symtree *parent_st;
804 for (; arg; arg = arg->next)
810 /* Check the label is a valid branching target. */
813 if (arg->label->defined == ST_LABEL_UNKNOWN)
815 gfc_error ("Label %d referenced at %L is never defined",
816 arg->label->value, &arg->label->where);
823 if (e->ts.type != BT_PROCEDURE)
825 if (gfc_resolve_expr (e) != SUCCESS)
830 /* See if the expression node should really be a variable
833 sym = e->symtree->n.sym;
835 if (sym->attr.flavor == FL_PROCEDURE
836 || sym->attr.intrinsic
837 || sym->attr.external)
840 /* If a procedure is not already determined to be something else
841 check if it is intrinsic. */
842 if (!sym->attr.intrinsic
843 && !(sym->attr.external || sym->attr.use_assoc
844 || sym->attr.if_source == IFSRC_IFBODY)
845 && gfc_intrinsic_name (sym->name, sym->attr.subroutine))
846 sym->attr.intrinsic = 1;
848 if (sym->attr.proc == PROC_ST_FUNCTION)
850 gfc_error ("Statement function '%s' at %L is not allowed as an "
851 "actual argument", sym->name, &e->where);
854 if (sym->attr.contained && !sym->attr.use_assoc
855 && sym->ns->proc_name->attr.flavor != FL_MODULE)
857 gfc_error ("Internal procedure '%s' is not allowed as an "
858 "actual argument at %L", sym->name, &e->where);
861 if (sym->attr.elemental && !sym->attr.intrinsic)
863 gfc_error ("ELEMENTAL non-INTRINSIC procedure '%s' is not "
864 "allowed as an actual argument at %L", sym->name,
868 if (sym->attr.generic)
870 gfc_error ("GENERIC non-INTRINSIC procedure '%s' is not "
871 "allowed as an actual argument at %L", sym->name,
875 /* If the symbol is the function that names the current (or
876 parent) scope, then we really have a variable reference. */
878 if (sym->attr.function && sym->result == sym
879 && (sym->ns->proc_name == sym
880 || (sym->ns->parent != NULL
881 && sym->ns->parent->proc_name == sym)))
887 /* See if the name is a module procedure in a parent unit. */
889 if (was_declared (sym) || sym->ns->parent == NULL)
892 if (gfc_find_sym_tree (sym->name, sym->ns->parent, 1, &parent_st))
894 gfc_error ("Symbol '%s' at %L is ambiguous", sym->name, &e->where);
898 if (parent_st == NULL)
901 sym = parent_st->n.sym;
902 e->symtree = parent_st; /* Point to the right thing. */
904 if (sym->attr.flavor == FL_PROCEDURE
905 || sym->attr.intrinsic
906 || sym->attr.external)
912 e->expr_type = EXPR_VARIABLE;
916 e->rank = sym->as->rank;
917 e->ref = gfc_get_ref ();
918 e->ref->type = REF_ARRAY;
919 e->ref->u.ar.type = AR_FULL;
920 e->ref->u.ar.as = sym->as;
928 /* Do the checks of the actual argument list that are specific to elemental
929 procedures. If called with c == NULL, we have a function, otherwise if
930 expr == NULL, we have a subroutine. */
932 resolve_elemental_actual (gfc_expr *expr, gfc_code *c)
934 gfc_actual_arglist *arg0;
935 gfc_actual_arglist *arg;
936 gfc_symbol *esym = NULL;
937 gfc_intrinsic_sym *isym = NULL;
939 gfc_intrinsic_arg *iformal = NULL;
940 gfc_formal_arglist *eformal = NULL;
941 bool formal_optional = false;
942 bool set_by_optional = false;
946 /* Is this an elemental procedure? */
947 if (expr && expr->value.function.actual != NULL)
949 if (expr->value.function.esym != NULL
950 && expr->value.function.esym->attr.elemental)
952 arg0 = expr->value.function.actual;
953 esym = expr->value.function.esym;
955 else if (expr->value.function.isym != NULL
956 && expr->value.function.isym->elemental)
958 arg0 = expr->value.function.actual;
959 isym = expr->value.function.isym;
964 else if (c && c->ext.actual != NULL
965 && c->symtree->n.sym->attr.elemental)
967 arg0 = c->ext.actual;
968 esym = c->symtree->n.sym;
973 /* The rank of an elemental is the rank of its array argument(s). */
974 for (arg = arg0; arg; arg = arg->next)
976 if (arg->expr != NULL && arg->expr->rank > 0)
978 rank = arg->expr->rank;
979 if (arg->expr->expr_type == EXPR_VARIABLE
980 && arg->expr->symtree->n.sym->attr.optional)
981 set_by_optional = true;
983 /* Function specific; set the result rank and shape. */
987 if (!expr->shape && arg->expr->shape)
989 expr->shape = gfc_get_shape (rank);
990 for (i = 0; i < rank; i++)
991 mpz_init_set (expr->shape[i], arg->expr->shape[i]);
998 /* If it is an array, it shall not be supplied as an actual argument
999 to an elemental procedure unless an array of the same rank is supplied
1000 as an actual argument corresponding to a nonoptional dummy argument of
1001 that elemental procedure(12.4.1.5). */
1002 formal_optional = false;
1004 iformal = isym->formal;
1006 eformal = esym->formal;
1008 for (arg = arg0; arg; arg = arg->next)
1012 if (eformal->sym && eformal->sym->attr.optional)
1013 formal_optional = true;
1014 eformal = eformal->next;
1016 else if (isym && iformal)
1018 if (iformal->optional)
1019 formal_optional = true;
1020 iformal = iformal->next;
1023 formal_optional = true;
1025 if (pedantic && arg->expr != NULL
1026 && arg->expr->expr_type == EXPR_VARIABLE
1027 && arg->expr->symtree->n.sym->attr.optional
1030 && (set_by_optional || arg->expr->rank != rank)
1031 && !(isym && isym->generic_id == GFC_ISYM_CONVERSION))
1033 gfc_warning ("'%s' at %L is an array and OPTIONAL; IF IT IS "
1034 "MISSING, it cannot be the actual argument of an "
1035 "ELEMENTAL procedure unless there is a non-optional"
1036 "argument with the same rank (12.4.1.5)",
1037 arg->expr->symtree->n.sym->name, &arg->expr->where);
1042 for (arg = arg0; arg; arg = arg->next)
1044 if (arg->expr == NULL || arg->expr->rank == 0)
1047 /* Being elemental, the last upper bound of an assumed size array
1048 argument must be present. */
1049 if (resolve_assumed_size_actual (arg->expr))
1055 /* Elemental subroutine array actual arguments must conform. */
1058 if (gfc_check_conformance ("elemental subroutine", arg->expr, e)
1070 /* Go through each actual argument in ACTUAL and see if it can be
1071 implemented as an inlined, non-copying intrinsic. FNSYM is the
1072 function being called, or NULL if not known. */
1075 find_noncopying_intrinsics (gfc_symbol * fnsym, gfc_actual_arglist * actual)
1077 gfc_actual_arglist *ap;
1080 for (ap = actual; ap; ap = ap->next)
1082 && (expr = gfc_get_noncopying_intrinsic_argument (ap->expr))
1083 && !gfc_check_fncall_dependency (expr, INTENT_IN, fnsym, actual))
1084 ap->expr->inline_noncopying_intrinsic = 1;
1087 /* This function does the checking of references to global procedures
1088 as defined in sections 18.1 and 14.1, respectively, of the Fortran
1089 77 and 95 standards. It checks for a gsymbol for the name, making
1090 one if it does not already exist. If it already exists, then the
1091 reference being resolved must correspond to the type of gsymbol.
1092 Otherwise, the new symbol is equipped with the attributes of the
1093 reference. The corresponding code that is called in creating
1094 global entities is parse.c. */
1097 resolve_global_procedure (gfc_symbol *sym, locus *where, int sub)
1102 type = sub ? GSYM_SUBROUTINE : GSYM_FUNCTION;
1104 gsym = gfc_get_gsymbol (sym->name);
1106 if ((gsym->type != GSYM_UNKNOWN && gsym->type != type))
1107 global_used (gsym, where);
1109 if (gsym->type == GSYM_UNKNOWN)
1112 gsym->where = *where;
1118 /************* Function resolution *************/
1120 /* Resolve a function call known to be generic.
1121 Section 14.1.2.4.1. */
1124 resolve_generic_f0 (gfc_expr * expr, gfc_symbol * sym)
1128 if (sym->attr.generic)
1131 gfc_search_interface (sym->generic, 0, &expr->value.function.actual);
1134 expr->value.function.name = s->name;
1135 expr->value.function.esym = s;
1137 if (s->ts.type != BT_UNKNOWN)
1139 else if (s->result != NULL && s->result->ts.type != BT_UNKNOWN)
1140 expr->ts = s->result->ts;
1143 expr->rank = s->as->rank;
1144 else if (s->result != NULL && s->result->as != NULL)
1145 expr->rank = s->result->as->rank;
1150 /* TODO: Need to search for elemental references in generic interface */
1153 if (sym->attr.intrinsic)
1154 return gfc_intrinsic_func_interface (expr, 0);
1161 resolve_generic_f (gfc_expr * expr)
1166 sym = expr->symtree->n.sym;
1170 m = resolve_generic_f0 (expr, sym);
1173 else if (m == MATCH_ERROR)
1177 if (sym->ns->parent == NULL)
1179 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
1183 if (!generic_sym (sym))
1187 /* Last ditch attempt. */
1189 if (!gfc_generic_intrinsic (expr->symtree->n.sym->name))
1191 gfc_error ("There is no specific function for the generic '%s' at %L",
1192 expr->symtree->n.sym->name, &expr->where);
1196 m = gfc_intrinsic_func_interface (expr, 0);
1201 ("Generic function '%s' at %L is not consistent with a specific "
1202 "intrinsic interface", expr->symtree->n.sym->name, &expr->where);
1208 /* Resolve a function call known to be specific. */
1211 resolve_specific_f0 (gfc_symbol * sym, gfc_expr * expr)
1215 if (sym->attr.external || sym->attr.if_source == IFSRC_IFBODY)
1217 if (sym->attr.dummy)
1219 sym->attr.proc = PROC_DUMMY;
1223 sym->attr.proc = PROC_EXTERNAL;
1227 if (sym->attr.proc == PROC_MODULE
1228 || sym->attr.proc == PROC_ST_FUNCTION
1229 || sym->attr.proc == PROC_INTERNAL)
1232 if (sym->attr.intrinsic)
1234 m = gfc_intrinsic_func_interface (expr, 1);
1239 ("Function '%s' at %L is INTRINSIC but is not compatible with "
1240 "an intrinsic", sym->name, &expr->where);
1248 gfc_procedure_use (sym, &expr->value.function.actual, &expr->where);
1251 expr->value.function.name = sym->name;
1252 expr->value.function.esym = sym;
1253 if (sym->as != NULL)
1254 expr->rank = sym->as->rank;
1261 resolve_specific_f (gfc_expr * expr)
1266 sym = expr->symtree->n.sym;
1270 m = resolve_specific_f0 (sym, expr);
1273 if (m == MATCH_ERROR)
1276 if (sym->ns->parent == NULL)
1279 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
1285 gfc_error ("Unable to resolve the specific function '%s' at %L",
1286 expr->symtree->n.sym->name, &expr->where);
1292 /* Resolve a procedure call not known to be generic nor specific. */
1295 resolve_unknown_f (gfc_expr * expr)
1300 sym = expr->symtree->n.sym;
1302 if (sym->attr.dummy)
1304 sym->attr.proc = PROC_DUMMY;
1305 expr->value.function.name = sym->name;
1309 /* See if we have an intrinsic function reference. */
1311 if (gfc_intrinsic_name (sym->name, 0))
1313 if (gfc_intrinsic_func_interface (expr, 1) == MATCH_YES)
1318 /* The reference is to an external name. */
1320 sym->attr.proc = PROC_EXTERNAL;
1321 expr->value.function.name = sym->name;
1322 expr->value.function.esym = expr->symtree->n.sym;
1324 if (sym->as != NULL)
1325 expr->rank = sym->as->rank;
1327 /* Type of the expression is either the type of the symbol or the
1328 default type of the symbol. */
1331 gfc_procedure_use (sym, &expr->value.function.actual, &expr->where);
1333 if (sym->ts.type != BT_UNKNOWN)
1337 ts = gfc_get_default_type (sym, sym->ns);
1339 if (ts->type == BT_UNKNOWN)
1341 gfc_error ("Function '%s' at %L has no IMPLICIT type",
1342 sym->name, &expr->where);
1353 /* Figure out if a function reference is pure or not. Also set the name
1354 of the function for a potential error message. Return nonzero if the
1355 function is PURE, zero if not. */
1358 pure_function (gfc_expr * e, const char **name)
1362 if (e->value.function.esym)
1364 pure = gfc_pure (e->value.function.esym);
1365 *name = e->value.function.esym->name;
1367 else if (e->value.function.isym)
1369 pure = e->value.function.isym->pure
1370 || e->value.function.isym->elemental;
1371 *name = e->value.function.isym->name;
1375 /* Implicit functions are not pure. */
1377 *name = e->value.function.name;
1384 /* Resolve a function call, which means resolving the arguments, then figuring
1385 out which entity the name refers to. */
1386 /* TODO: Check procedure arguments so that an INTENT(IN) isn't passed
1387 to INTENT(OUT) or INTENT(INOUT). */
1390 resolve_function (gfc_expr * expr)
1392 gfc_actual_arglist *arg;
1400 sym = expr->symtree->n.sym;
1402 /* If the procedure is not internal, a statement function or a module
1403 procedure,it must be external and should be checked for usage. */
1404 if (sym && !sym->attr.dummy && !sym->attr.contained
1405 && sym->attr.proc != PROC_ST_FUNCTION
1406 && !sym->attr.use_assoc)
1407 resolve_global_procedure (sym, &expr->where, 0);
1409 /* Switch off assumed size checking and do this again for certain kinds
1410 of procedure, once the procedure itself is resolved. */
1411 need_full_assumed_size++;
1413 if (resolve_actual_arglist (expr->value.function.actual) == FAILURE)
1416 /* Resume assumed_size checking. */
1417 need_full_assumed_size--;
1419 if (sym && sym->ts.type == BT_CHARACTER
1421 && sym->ts.cl->length == NULL
1423 && expr->value.function.esym == NULL
1424 && !sym->attr.contained)
1426 /* Internal procedures are taken care of in resolve_contained_fntype. */
1427 gfc_error ("Function '%s' is declared CHARACTER(*) and cannot "
1428 "be used at %L since it is not a dummy argument",
1429 sym->name, &expr->where);
1433 /* See if function is already resolved. */
1435 if (expr->value.function.name != NULL)
1437 if (expr->ts.type == BT_UNKNOWN)
1443 /* Apply the rules of section 14.1.2. */
1445 switch (procedure_kind (sym))
1448 t = resolve_generic_f (expr);
1451 case PTYPE_SPECIFIC:
1452 t = resolve_specific_f (expr);
1456 t = resolve_unknown_f (expr);
1460 gfc_internal_error ("resolve_function(): bad function type");
1464 /* If the expression is still a function (it might have simplified),
1465 then we check to see if we are calling an elemental function. */
1467 if (expr->expr_type != EXPR_FUNCTION)
1470 temp = need_full_assumed_size;
1471 need_full_assumed_size = 0;
1473 if (resolve_elemental_actual (expr, NULL) == FAILURE)
1476 if (omp_workshare_flag
1477 && expr->value.function.esym
1478 && ! gfc_elemental (expr->value.function.esym))
1480 gfc_error ("User defined non-ELEMENTAL function '%s' at %L not allowed"
1481 " in WORKSHARE construct", expr->value.function.esym->name,
1486 else if (expr->value.function.actual != NULL
1487 && expr->value.function.isym != NULL
1488 && expr->value.function.isym->generic_id != GFC_ISYM_LBOUND
1489 && expr->value.function.isym->generic_id != GFC_ISYM_LOC
1490 && expr->value.function.isym->generic_id != GFC_ISYM_PRESENT)
1492 /* Array instrinsics must also have the last upper bound of an
1493 assumed size array argument. UBOUND and SIZE have to be
1494 excluded from the check if the second argument is anything
1497 inquiry = expr->value.function.isym->generic_id == GFC_ISYM_UBOUND
1498 || expr->value.function.isym->generic_id == GFC_ISYM_SIZE;
1500 for (arg = expr->value.function.actual; arg; arg = arg->next)
1502 if (inquiry && arg->next != NULL && arg->next->expr
1503 && arg->next->expr->expr_type != EXPR_CONSTANT)
1506 if (arg->expr != NULL
1507 && arg->expr->rank > 0
1508 && resolve_assumed_size_actual (arg->expr))
1513 need_full_assumed_size = temp;
1515 if (!pure_function (expr, &name) && name)
1520 ("reference to non-PURE function '%s' at %L inside a "
1521 "FORALL %s", name, &expr->where, forall_flag == 2 ?
1525 else if (gfc_pure (NULL))
1527 gfc_error ("Function reference to '%s' at %L is to a non-PURE "
1528 "procedure within a PURE procedure", name, &expr->where);
1533 /* Functions without the RECURSIVE attribution are not allowed to
1534 * call themselves. */
1535 if (expr->value.function.esym && !expr->value.function.esym->attr.recursive)
1537 gfc_symbol *esym, *proc;
1538 esym = expr->value.function.esym;
1539 proc = gfc_current_ns->proc_name;
1542 gfc_error ("Function '%s' at %L cannot call itself, as it is not "
1543 "RECURSIVE", name, &expr->where);
1547 if (esym->attr.entry && esym->ns->entries && proc->ns->entries
1548 && esym->ns->entries->sym == proc->ns->entries->sym)
1550 gfc_error ("Call to ENTRY '%s' at %L is recursive, but function "
1551 "'%s' is not declared as RECURSIVE",
1552 esym->name, &expr->where, esym->ns->entries->sym->name);
1557 /* Character lengths of use associated functions may contains references to
1558 symbols not referenced from the current program unit otherwise. Make sure
1559 those symbols are marked as referenced. */
1561 if (expr->ts.type == BT_CHARACTER && expr->value.function.esym
1562 && expr->value.function.esym->attr.use_assoc)
1564 gfc_expr_set_symbols_referenced (expr->ts.cl->length);
1568 find_noncopying_intrinsics (expr->value.function.esym,
1569 expr->value.function.actual);
1574 /************* Subroutine resolution *************/
1577 pure_subroutine (gfc_code * c, gfc_symbol * sym)
1584 gfc_error ("Subroutine call to '%s' in FORALL block at %L is not PURE",
1585 sym->name, &c->loc);
1586 else if (gfc_pure (NULL))
1587 gfc_error ("Subroutine call to '%s' at %L is not PURE", sym->name,
1593 resolve_generic_s0 (gfc_code * c, gfc_symbol * sym)
1597 if (sym->attr.generic)
1599 s = gfc_search_interface (sym->generic, 1, &c->ext.actual);
1602 c->resolved_sym = s;
1603 pure_subroutine (c, s);
1607 /* TODO: Need to search for elemental references in generic interface. */
1610 if (sym->attr.intrinsic)
1611 return gfc_intrinsic_sub_interface (c, 0);
1618 resolve_generic_s (gfc_code * c)
1623 sym = c->symtree->n.sym;
1627 m = resolve_generic_s0 (c, sym);
1630 else if (m == MATCH_ERROR)
1634 if (sym->ns->parent == NULL)
1636 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
1640 if (!generic_sym (sym))
1644 /* Last ditch attempt. */
1645 sym = c->symtree->n.sym;
1646 if (!gfc_generic_intrinsic (sym->name))
1649 ("There is no specific subroutine for the generic '%s' at %L",
1650 sym->name, &c->loc);
1654 m = gfc_intrinsic_sub_interface (c, 0);
1658 gfc_error ("Generic subroutine '%s' at %L is not consistent with an "
1659 "intrinsic subroutine interface", sym->name, &c->loc);
1665 /* Resolve a subroutine call known to be specific. */
1668 resolve_specific_s0 (gfc_code * c, gfc_symbol * sym)
1672 if (sym->attr.external || sym->attr.if_source == IFSRC_IFBODY)
1674 if (sym->attr.dummy)
1676 sym->attr.proc = PROC_DUMMY;
1680 sym->attr.proc = PROC_EXTERNAL;
1684 if (sym->attr.proc == PROC_MODULE || sym->attr.proc == PROC_INTERNAL)
1687 if (sym->attr.intrinsic)
1689 m = gfc_intrinsic_sub_interface (c, 1);
1693 gfc_error ("Subroutine '%s' at %L is INTRINSIC but is not compatible "
1694 "with an intrinsic", sym->name, &c->loc);
1702 gfc_procedure_use (sym, &c->ext.actual, &c->loc);
1704 c->resolved_sym = sym;
1705 pure_subroutine (c, sym);
1712 resolve_specific_s (gfc_code * c)
1717 sym = c->symtree->n.sym;
1721 m = resolve_specific_s0 (c, sym);
1724 if (m == MATCH_ERROR)
1727 if (sym->ns->parent == NULL)
1730 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
1736 sym = c->symtree->n.sym;
1737 gfc_error ("Unable to resolve the specific subroutine '%s' at %L",
1738 sym->name, &c->loc);
1744 /* Resolve a subroutine call not known to be generic nor specific. */
1747 resolve_unknown_s (gfc_code * c)
1751 sym = c->symtree->n.sym;
1753 if (sym->attr.dummy)
1755 sym->attr.proc = PROC_DUMMY;
1759 /* See if we have an intrinsic function reference. */
1761 if (gfc_intrinsic_name (sym->name, 1))
1763 if (gfc_intrinsic_sub_interface (c, 1) == MATCH_YES)
1768 /* The reference is to an external name. */
1771 gfc_procedure_use (sym, &c->ext.actual, &c->loc);
1773 c->resolved_sym = sym;
1775 pure_subroutine (c, sym);
1781 /* Resolve a subroutine call. Although it was tempting to use the same code
1782 for functions, subroutines and functions are stored differently and this
1783 makes things awkward. */
1786 resolve_call (gfc_code * c)
1790 if (c->symtree && c->symtree->n.sym
1791 && c->symtree->n.sym->ts.type != BT_UNKNOWN)
1793 gfc_error ("'%s' at %L has a type, which is not consistent with "
1794 "the CALL at %L", c->symtree->n.sym->name,
1795 &c->symtree->n.sym->declared_at, &c->loc);
1799 /* If the procedure is not internal or module, it must be external and
1800 should be checked for usage. */
1801 if (c->symtree && c->symtree->n.sym
1802 && !c->symtree->n.sym->attr.dummy
1803 && !c->symtree->n.sym->attr.contained
1804 && !c->symtree->n.sym->attr.use_assoc)
1805 resolve_global_procedure (c->symtree->n.sym, &c->loc, 1);
1807 /* Subroutines without the RECURSIVE attribution are not allowed to
1808 * call themselves. */
1809 if (c->symtree && c->symtree->n.sym && !c->symtree->n.sym->attr.recursive)
1811 gfc_symbol *csym, *proc;
1812 csym = c->symtree->n.sym;
1813 proc = gfc_current_ns->proc_name;
1816 gfc_error ("SUBROUTINE '%s' at %L cannot call itself, as it is not "
1817 "RECURSIVE", csym->name, &c->loc);
1821 if (csym->attr.entry && csym->ns->entries && proc->ns->entries
1822 && csym->ns->entries->sym == proc->ns->entries->sym)
1824 gfc_error ("Call to ENTRY '%s' at %L is recursive, but subroutine "
1825 "'%s' is not declared as RECURSIVE",
1826 csym->name, &c->loc, csym->ns->entries->sym->name);
1831 /* Switch off assumed size checking and do this again for certain kinds
1832 of procedure, once the procedure itself is resolved. */
1833 need_full_assumed_size++;
1835 if (resolve_actual_arglist (c->ext.actual) == FAILURE)
1838 /* Resume assumed_size checking. */
1839 need_full_assumed_size--;
1843 if (c->resolved_sym == NULL)
1844 switch (procedure_kind (c->symtree->n.sym))
1847 t = resolve_generic_s (c);
1850 case PTYPE_SPECIFIC:
1851 t = resolve_specific_s (c);
1855 t = resolve_unknown_s (c);
1859 gfc_internal_error ("resolve_subroutine(): bad function type");
1862 /* Some checks of elemental subroutine actual arguments. */
1863 if (resolve_elemental_actual (NULL, c) == FAILURE)
1867 find_noncopying_intrinsics (c->resolved_sym, c->ext.actual);
1871 /* Compare the shapes of two arrays that have non-NULL shapes. If both
1872 op1->shape and op2->shape are non-NULL return SUCCESS if their shapes
1873 match. If both op1->shape and op2->shape are non-NULL return FAILURE
1874 if their shapes do not match. If either op1->shape or op2->shape is
1875 NULL, return SUCCESS. */
1878 compare_shapes (gfc_expr * op1, gfc_expr * op2)
1885 if (op1->shape != NULL && op2->shape != NULL)
1887 for (i = 0; i < op1->rank; i++)
1889 if (mpz_cmp (op1->shape[i], op2->shape[i]) != 0)
1891 gfc_error ("Shapes for operands at %L and %L are not conformable",
1892 &op1->where, &op2->where);
1902 /* Resolve an operator expression node. This can involve replacing the
1903 operation with a user defined function call. */
1906 resolve_operator (gfc_expr * e)
1908 gfc_expr *op1, *op2;
1912 /* Resolve all subnodes-- give them types. */
1914 switch (e->value.op.operator)
1917 if (gfc_resolve_expr (e->value.op.op2) == FAILURE)
1920 /* Fall through... */
1923 case INTRINSIC_UPLUS:
1924 case INTRINSIC_UMINUS:
1925 case INTRINSIC_PARENTHESES:
1926 if (gfc_resolve_expr (e->value.op.op1) == FAILURE)
1931 /* Typecheck the new node. */
1933 op1 = e->value.op.op1;
1934 op2 = e->value.op.op2;
1936 switch (e->value.op.operator)
1938 case INTRINSIC_UPLUS:
1939 case INTRINSIC_UMINUS:
1940 if (op1->ts.type == BT_INTEGER
1941 || op1->ts.type == BT_REAL
1942 || op1->ts.type == BT_COMPLEX)
1948 sprintf (msg, _("Operand of unary numeric operator '%s' at %%L is %s"),
1949 gfc_op2string (e->value.op.operator), gfc_typename (&e->ts));
1952 case INTRINSIC_PLUS:
1953 case INTRINSIC_MINUS:
1954 case INTRINSIC_TIMES:
1955 case INTRINSIC_DIVIDE:
1956 case INTRINSIC_POWER:
1957 if (gfc_numeric_ts (&op1->ts) && gfc_numeric_ts (&op2->ts))
1959 gfc_type_convert_binary (e);
1964 _("Operands of binary numeric operator '%s' at %%L are %s/%s"),
1965 gfc_op2string (e->value.op.operator), gfc_typename (&op1->ts),
1966 gfc_typename (&op2->ts));
1969 case INTRINSIC_CONCAT:
1970 if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER)
1972 e->ts.type = BT_CHARACTER;
1973 e->ts.kind = op1->ts.kind;
1978 _("Operands of string concatenation operator at %%L are %s/%s"),
1979 gfc_typename (&op1->ts), gfc_typename (&op2->ts));
1985 case INTRINSIC_NEQV:
1986 if (op1->ts.type == BT_LOGICAL && op2->ts.type == BT_LOGICAL)
1988 e->ts.type = BT_LOGICAL;
1989 e->ts.kind = gfc_kind_max (op1, op2);
1990 if (op1->ts.kind < e->ts.kind)
1991 gfc_convert_type (op1, &e->ts, 2);
1992 else if (op2->ts.kind < e->ts.kind)
1993 gfc_convert_type (op2, &e->ts, 2);
1997 sprintf (msg, _("Operands of logical operator '%s' at %%L are %s/%s"),
1998 gfc_op2string (e->value.op.operator), gfc_typename (&op1->ts),
1999 gfc_typename (&op2->ts));
2004 if (op1->ts.type == BT_LOGICAL)
2006 e->ts.type = BT_LOGICAL;
2007 e->ts.kind = op1->ts.kind;
2011 sprintf (msg, _("Operand of .NOT. operator at %%L is %s"),
2012 gfc_typename (&op1->ts));
2019 if (op1->ts.type == BT_COMPLEX || op2->ts.type == BT_COMPLEX)
2021 strcpy (msg, _("COMPLEX quantities cannot be compared at %L"));
2025 /* Fall through... */
2029 if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER)
2031 e->ts.type = BT_LOGICAL;
2032 e->ts.kind = gfc_default_logical_kind;
2036 if (gfc_numeric_ts (&op1->ts) && gfc_numeric_ts (&op2->ts))
2038 gfc_type_convert_binary (e);
2040 e->ts.type = BT_LOGICAL;
2041 e->ts.kind = gfc_default_logical_kind;
2045 if (op1->ts.type == BT_LOGICAL && op2->ts.type == BT_LOGICAL)
2047 _("Logicals at %%L must be compared with %s instead of %s"),
2048 e->value.op.operator == INTRINSIC_EQ ? ".EQV." : ".NEQV.",
2049 gfc_op2string (e->value.op.operator));
2052 _("Operands of comparison operator '%s' at %%L are %s/%s"),
2053 gfc_op2string (e->value.op.operator), gfc_typename (&op1->ts),
2054 gfc_typename (&op2->ts));
2058 case INTRINSIC_USER:
2060 sprintf (msg, _("Operand of user operator '%s' at %%L is %s"),
2061 e->value.op.uop->name, gfc_typename (&op1->ts));
2063 sprintf (msg, _("Operands of user operator '%s' at %%L are %s/%s"),
2064 e->value.op.uop->name, gfc_typename (&op1->ts),
2065 gfc_typename (&op2->ts));
2069 case INTRINSIC_PARENTHESES:
2073 gfc_internal_error ("resolve_operator(): Bad intrinsic");
2076 /* Deal with arrayness of an operand through an operator. */
2080 switch (e->value.op.operator)
2082 case INTRINSIC_PLUS:
2083 case INTRINSIC_MINUS:
2084 case INTRINSIC_TIMES:
2085 case INTRINSIC_DIVIDE:
2086 case INTRINSIC_POWER:
2087 case INTRINSIC_CONCAT:
2091 case INTRINSIC_NEQV:
2099 if (op1->rank == 0 && op2->rank == 0)
2102 if (op1->rank == 0 && op2->rank != 0)
2104 e->rank = op2->rank;
2106 if (e->shape == NULL)
2107 e->shape = gfc_copy_shape (op2->shape, op2->rank);
2110 if (op1->rank != 0 && op2->rank == 0)
2112 e->rank = op1->rank;
2114 if (e->shape == NULL)
2115 e->shape = gfc_copy_shape (op1->shape, op1->rank);
2118 if (op1->rank != 0 && op2->rank != 0)
2120 if (op1->rank == op2->rank)
2122 e->rank = op1->rank;
2123 if (e->shape == NULL)
2125 t = compare_shapes(op1, op2);
2129 e->shape = gfc_copy_shape (op1->shape, op1->rank);
2134 gfc_error ("Inconsistent ranks for operator at %L and %L",
2135 &op1->where, &op2->where);
2138 /* Allow higher level expressions to work. */
2146 case INTRINSIC_UPLUS:
2147 case INTRINSIC_UMINUS:
2148 case INTRINSIC_PARENTHESES:
2149 e->rank = op1->rank;
2151 if (e->shape == NULL)
2152 e->shape = gfc_copy_shape (op1->shape, op1->rank);
2154 /* Simply copy arrayness attribute */
2161 /* Attempt to simplify the expression. */
2163 t = gfc_simplify_expr (e, 0);
2168 if (gfc_extend_expr (e) == SUCCESS)
2171 gfc_error (msg, &e->where);
2177 /************** Array resolution subroutines **************/
2181 { CMP_LT, CMP_EQ, CMP_GT, CMP_UNKNOWN }
2184 /* Compare two integer expressions. */
2187 compare_bound (gfc_expr * a, gfc_expr * b)
2191 if (a == NULL || a->expr_type != EXPR_CONSTANT
2192 || b == NULL || b->expr_type != EXPR_CONSTANT)
2195 if (a->ts.type != BT_INTEGER || b->ts.type != BT_INTEGER)
2196 gfc_internal_error ("compare_bound(): Bad expression");
2198 i = mpz_cmp (a->value.integer, b->value.integer);
2208 /* Compare an integer expression with an integer. */
2211 compare_bound_int (gfc_expr * a, int b)
2215 if (a == NULL || a->expr_type != EXPR_CONSTANT)
2218 if (a->ts.type != BT_INTEGER)
2219 gfc_internal_error ("compare_bound_int(): Bad expression");
2221 i = mpz_cmp_si (a->value.integer, b);
2231 /* Compare an integer expression with a mpz_t. */
2234 compare_bound_mpz_t (gfc_expr * a, mpz_t b)
2238 if (a == NULL || a->expr_type != EXPR_CONSTANT)
2241 if (a->ts.type != BT_INTEGER)
2242 gfc_internal_error ("compare_bound_int(): Bad expression");
2244 i = mpz_cmp (a->value.integer, b);
2254 /* Compute the last value of a sequence given by a triplet.
2255 Return 0 if it wasn't able to compute the last value, or if the
2256 sequence if empty, and 1 otherwise. */
2259 compute_last_value_for_triplet (gfc_expr * start, gfc_expr * end,
2260 gfc_expr * stride, mpz_t last)
2264 if (start == NULL || start->expr_type != EXPR_CONSTANT
2265 || end == NULL || end->expr_type != EXPR_CONSTANT
2266 || (stride != NULL && stride->expr_type != EXPR_CONSTANT))
2269 if (start->ts.type != BT_INTEGER || end->ts.type != BT_INTEGER
2270 || (stride != NULL && stride->ts.type != BT_INTEGER))
2273 if (stride == NULL || compare_bound_int(stride, 1) == CMP_EQ)
2275 if (compare_bound (start, end) == CMP_GT)
2277 mpz_set (last, end->value.integer);
2281 if (compare_bound_int (stride, 0) == CMP_GT)
2283 /* Stride is positive */
2284 if (mpz_cmp (start->value.integer, end->value.integer) > 0)
2289 /* Stride is negative */
2290 if (mpz_cmp (start->value.integer, end->value.integer) < 0)
2295 mpz_sub (rem, end->value.integer, start->value.integer);
2296 mpz_tdiv_r (rem, rem, stride->value.integer);
2297 mpz_sub (last, end->value.integer, rem);
2304 /* Compare a single dimension of an array reference to the array
2308 check_dimension (int i, gfc_array_ref * ar, gfc_array_spec * as)
2312 /* Given start, end and stride values, calculate the minimum and
2313 maximum referenced indexes. */
2321 if (compare_bound (ar->start[i], as->lower[i]) == CMP_LT)
2323 if (compare_bound (ar->start[i], as->upper[i]) == CMP_GT)
2329 if (compare_bound_int (ar->stride[i], 0) == CMP_EQ)
2331 gfc_error ("Illegal stride of zero at %L", &ar->c_where[i]);
2335 #define AR_START (ar->start[i] ? ar->start[i] : as->lower[i])
2336 #define AR_END (ar->end[i] ? ar->end[i] : as->upper[i])
2338 if (compare_bound (AR_START, AR_END) == CMP_EQ
2339 && (compare_bound (AR_START, as->lower[i]) == CMP_LT
2340 || compare_bound (AR_START, as->upper[i]) == CMP_GT))
2343 if (((compare_bound_int (ar->stride[i], 0) == CMP_GT
2344 || ar->stride[i] == NULL)
2345 && compare_bound (AR_START, AR_END) != CMP_GT)
2346 || (compare_bound_int (ar->stride[i], 0) == CMP_LT
2347 && compare_bound (AR_START, AR_END) != CMP_LT))
2349 if (compare_bound (AR_START, as->lower[i]) == CMP_LT)
2351 if (compare_bound (AR_START, as->upper[i]) == CMP_GT)
2355 mpz_init (last_value);
2356 if (compute_last_value_for_triplet (AR_START, AR_END, ar->stride[i],
2359 if (compare_bound_mpz_t (as->lower[i], last_value) == CMP_GT
2360 || compare_bound_mpz_t (as->upper[i], last_value) == CMP_LT)
2362 mpz_clear (last_value);
2366 mpz_clear (last_value);
2374 gfc_internal_error ("check_dimension(): Bad array reference");
2380 gfc_warning ("Array reference at %L is out of bounds", &ar->c_where[i]);
2385 /* Compare an array reference with an array specification. */
2388 compare_spec_to_ref (gfc_array_ref * ar)
2395 /* TODO: Full array sections are only allowed as actual parameters. */
2396 if (as->type == AS_ASSUMED_SIZE
2397 && (/*ar->type == AR_FULL
2398 ||*/ (ar->type == AR_SECTION
2399 && ar->dimen_type[i] == DIMEN_RANGE && ar->end[i] == NULL)))
2401 gfc_error ("Rightmost upper bound of assumed size array section"
2402 " not specified at %L", &ar->where);
2406 if (ar->type == AR_FULL)
2409 if (as->rank != ar->dimen)
2411 gfc_error ("Rank mismatch in array reference at %L (%d/%d)",
2412 &ar->where, ar->dimen, as->rank);
2416 for (i = 0; i < as->rank; i++)
2417 if (check_dimension (i, ar, as) == FAILURE)
2424 /* Resolve one part of an array index. */
2427 gfc_resolve_index (gfc_expr * index, int check_scalar)
2434 if (gfc_resolve_expr (index) == FAILURE)
2437 if (check_scalar && index->rank != 0)
2439 gfc_error ("Array index at %L must be scalar", &index->where);
2443 if (index->ts.type != BT_INTEGER && index->ts.type != BT_REAL)
2445 gfc_error ("Array index at %L must be of INTEGER type",
2450 if (index->ts.type == BT_REAL)
2451 if (gfc_notify_std (GFC_STD_LEGACY, "Extension: REAL array index at %L",
2452 &index->where) == FAILURE)
2455 if (index->ts.kind != gfc_index_integer_kind
2456 || index->ts.type != BT_INTEGER)
2459 ts.type = BT_INTEGER;
2460 ts.kind = gfc_index_integer_kind;
2462 gfc_convert_type_warn (index, &ts, 2, 0);
2468 /* Resolve a dim argument to an intrinsic function. */
2471 gfc_resolve_dim_arg (gfc_expr *dim)
2476 if (gfc_resolve_expr (dim) == FAILURE)
2481 gfc_error ("Argument dim at %L must be scalar", &dim->where);
2485 if (dim->ts.type != BT_INTEGER)
2487 gfc_error ("Argument dim at %L must be of INTEGER type", &dim->where);
2490 if (dim->ts.kind != gfc_index_integer_kind)
2494 ts.type = BT_INTEGER;
2495 ts.kind = gfc_index_integer_kind;
2497 gfc_convert_type_warn (dim, &ts, 2, 0);
2503 /* Given an expression that contains array references, update those array
2504 references to point to the right array specifications. While this is
2505 filled in during matching, this information is difficult to save and load
2506 in a module, so we take care of it here.
2508 The idea here is that the original array reference comes from the
2509 base symbol. We traverse the list of reference structures, setting
2510 the stored reference to references. Component references can
2511 provide an additional array specification. */
2514 find_array_spec (gfc_expr * e)
2518 gfc_symbol *derived;
2521 as = e->symtree->n.sym->as;
2524 for (ref = e->ref; ref; ref = ref->next)
2529 gfc_internal_error ("find_array_spec(): Missing spec");
2536 if (derived == NULL)
2537 derived = e->symtree->n.sym->ts.derived;
2539 c = derived->components;
2541 for (; c; c = c->next)
2542 if (c == ref->u.c.component)
2544 /* Track the sequence of component references. */
2545 if (c->ts.type == BT_DERIVED)
2546 derived = c->ts.derived;
2551 gfc_internal_error ("find_array_spec(): Component not found");
2556 gfc_internal_error ("find_array_spec(): unused as(1)");
2567 gfc_internal_error ("find_array_spec(): unused as(2)");
2571 /* Resolve an array reference. */
2574 resolve_array_ref (gfc_array_ref * ar)
2576 int i, check_scalar;
2579 for (i = 0; i < ar->dimen; i++)
2581 check_scalar = ar->dimen_type[i] == DIMEN_RANGE;
2583 if (gfc_resolve_index (ar->start[i], check_scalar) == FAILURE)
2585 if (gfc_resolve_index (ar->end[i], check_scalar) == FAILURE)
2587 if (gfc_resolve_index (ar->stride[i], check_scalar) == FAILURE)
2592 if (ar->dimen_type[i] == DIMEN_UNKNOWN)
2596 ar->dimen_type[i] = DIMEN_ELEMENT;
2600 ar->dimen_type[i] = DIMEN_VECTOR;
2601 if (e->expr_type == EXPR_VARIABLE
2602 && e->symtree->n.sym->ts.type == BT_DERIVED)
2603 ar->start[i] = gfc_get_parentheses (e);
2607 gfc_error ("Array index at %L is an array of rank %d",
2608 &ar->c_where[i], e->rank);
2613 /* If the reference type is unknown, figure out what kind it is. */
2615 if (ar->type == AR_UNKNOWN)
2617 ar->type = AR_ELEMENT;
2618 for (i = 0; i < ar->dimen; i++)
2619 if (ar->dimen_type[i] == DIMEN_RANGE
2620 || ar->dimen_type[i] == DIMEN_VECTOR)
2622 ar->type = AR_SECTION;
2627 if (!ar->as->cray_pointee && compare_spec_to_ref (ar) == FAILURE)
2635 resolve_substring (gfc_ref * ref)
2638 if (ref->u.ss.start != NULL)
2640 if (gfc_resolve_expr (ref->u.ss.start) == FAILURE)
2643 if (ref->u.ss.start->ts.type != BT_INTEGER)
2645 gfc_error ("Substring start index at %L must be of type INTEGER",
2646 &ref->u.ss.start->where);
2650 if (ref->u.ss.start->rank != 0)
2652 gfc_error ("Substring start index at %L must be scalar",
2653 &ref->u.ss.start->where);
2657 if (compare_bound_int (ref->u.ss.start, 1) == CMP_LT
2658 && (compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_EQ
2659 || compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_GT))
2661 gfc_error ("Substring start index at %L is less than one",
2662 &ref->u.ss.start->where);
2667 if (ref->u.ss.end != NULL)
2669 if (gfc_resolve_expr (ref->u.ss.end) == FAILURE)
2672 if (ref->u.ss.end->ts.type != BT_INTEGER)
2674 gfc_error ("Substring end index at %L must be of type INTEGER",
2675 &ref->u.ss.end->where);
2679 if (ref->u.ss.end->rank != 0)
2681 gfc_error ("Substring end index at %L must be scalar",
2682 &ref->u.ss.end->where);
2686 if (ref->u.ss.length != NULL
2687 && compare_bound (ref->u.ss.end, ref->u.ss.length->length) == CMP_GT
2688 && (compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_EQ
2689 || compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_GT))
2691 gfc_error ("Substring end index at %L exceeds the string length",
2692 &ref->u.ss.start->where);
2701 /* Resolve subtype references. */
2704 resolve_ref (gfc_expr * expr)
2706 int current_part_dimension, n_components, seen_part_dimension;
2709 for (ref = expr->ref; ref; ref = ref->next)
2710 if (ref->type == REF_ARRAY && ref->u.ar.as == NULL)
2712 find_array_spec (expr);
2716 for (ref = expr->ref; ref; ref = ref->next)
2720 if (resolve_array_ref (&ref->u.ar) == FAILURE)
2728 resolve_substring (ref);
2732 /* Check constraints on part references. */
2734 current_part_dimension = 0;
2735 seen_part_dimension = 0;
2738 for (ref = expr->ref; ref; ref = ref->next)
2743 switch (ref->u.ar.type)
2747 current_part_dimension = 1;
2751 current_part_dimension = 0;
2755 gfc_internal_error ("resolve_ref(): Bad array reference");
2761 if ((current_part_dimension || seen_part_dimension)
2762 && ref->u.c.component->pointer)
2765 ("Component to the right of a part reference with nonzero "
2766 "rank must not have the POINTER attribute at %L",
2778 if (((ref->type == REF_COMPONENT && n_components > 1)
2779 || ref->next == NULL)
2780 && current_part_dimension
2781 && seen_part_dimension)
2784 gfc_error ("Two or more part references with nonzero rank must "
2785 "not be specified at %L", &expr->where);
2789 if (ref->type == REF_COMPONENT)
2791 if (current_part_dimension)
2792 seen_part_dimension = 1;
2794 /* reset to make sure */
2795 current_part_dimension = 0;
2803 /* Given an expression, determine its shape. This is easier than it sounds.
2804 Leaves the shape array NULL if it is not possible to determine the shape. */
2807 expression_shape (gfc_expr * e)
2809 mpz_t array[GFC_MAX_DIMENSIONS];
2812 if (e->rank == 0 || e->shape != NULL)
2815 for (i = 0; i < e->rank; i++)
2816 if (gfc_array_dimen_size (e, i, &array[i]) == FAILURE)
2819 e->shape = gfc_get_shape (e->rank);
2821 memcpy (e->shape, array, e->rank * sizeof (mpz_t));
2826 for (i--; i >= 0; i--)
2827 mpz_clear (array[i]);
2831 /* Given a variable expression node, compute the rank of the expression by
2832 examining the base symbol and any reference structures it may have. */
2835 expression_rank (gfc_expr * e)
2842 if (e->expr_type == EXPR_ARRAY)
2844 /* Constructors can have a rank different from one via RESHAPE(). */
2846 if (e->symtree == NULL)
2852 e->rank = (e->symtree->n.sym->as == NULL)
2853 ? 0 : e->symtree->n.sym->as->rank;
2859 for (ref = e->ref; ref; ref = ref->next)
2861 if (ref->type != REF_ARRAY)
2864 if (ref->u.ar.type == AR_FULL)
2866 rank = ref->u.ar.as->rank;
2870 if (ref->u.ar.type == AR_SECTION)
2872 /* Figure out the rank of the section. */
2874 gfc_internal_error ("expression_rank(): Two array specs");
2876 for (i = 0; i < ref->u.ar.dimen; i++)
2877 if (ref->u.ar.dimen_type[i] == DIMEN_RANGE
2878 || ref->u.ar.dimen_type[i] == DIMEN_VECTOR)
2888 expression_shape (e);
2892 /* Resolve a variable expression. */
2895 resolve_variable (gfc_expr * e)
2902 if (e->symtree == NULL)
2905 if (e->ref && resolve_ref (e) == FAILURE)
2908 sym = e->symtree->n.sym;
2909 if (sym->attr.flavor == FL_PROCEDURE && !sym->attr.function)
2911 e->ts.type = BT_PROCEDURE;
2915 if (sym->ts.type != BT_UNKNOWN)
2916 gfc_variable_attr (e, &e->ts);
2919 /* Must be a simple variable reference. */
2920 if (gfc_set_default_type (sym, 1, NULL) == FAILURE)
2925 if (check_assumed_size_reference (sym, e))
2928 /* Deal with forward references to entries during resolve_code, to
2929 satisfy, at least partially, 12.5.2.5. */
2930 if (gfc_current_ns->entries
2931 && current_entry_id == sym->entry_id
2934 && cs_base->current->op != EXEC_ENTRY)
2936 gfc_entry_list *entry;
2937 gfc_formal_arglist *formal;
2941 /* If the symbol is a dummy... */
2942 if (sym->attr.dummy)
2944 entry = gfc_current_ns->entries;
2947 /* ...test if the symbol is a parameter of previous entries. */
2948 for (; entry && entry->id <= current_entry_id; entry = entry->next)
2949 for (formal = entry->sym->formal; formal; formal = formal->next)
2951 if (formal->sym && sym->name == formal->sym->name)
2955 /* If it has not been seen as a dummy, this is an error. */
2958 if (specification_expr)
2959 gfc_error ("Variable '%s',used in a specification expression, "
2960 "is referenced at %L before the ENTRY statement "
2961 "in which it is a parameter",
2962 sym->name, &cs_base->current->loc);
2964 gfc_error ("Variable '%s' is used at %L before the ENTRY "
2965 "statement in which it is a parameter",
2966 sym->name, &cs_base->current->loc);
2971 /* Now do the same check on the specification expressions. */
2972 specification_expr = 1;
2973 if (sym->ts.type == BT_CHARACTER
2974 && gfc_resolve_expr (sym->ts.cl->length) == FAILURE)
2978 for (n = 0; n < sym->as->rank; n++)
2980 specification_expr = 1;
2981 if (gfc_resolve_expr (sym->as->lower[n]) == FAILURE)
2983 specification_expr = 1;
2984 if (gfc_resolve_expr (sym->as->upper[n]) == FAILURE)
2987 specification_expr = 0;
2990 /* Update the symbol's entry level. */
2991 sym->entry_id = current_entry_id + 1;
2998 /* Resolve an expression. That is, make sure that types of operands agree
2999 with their operators, intrinsic operators are converted to function calls
3000 for overloaded types and unresolved function references are resolved. */
3003 gfc_resolve_expr (gfc_expr * e)
3010 switch (e->expr_type)
3013 t = resolve_operator (e);
3017 t = resolve_function (e);
3021 t = resolve_variable (e);
3023 expression_rank (e);
3026 case EXPR_SUBSTRING:
3027 t = resolve_ref (e);
3037 if (resolve_ref (e) == FAILURE)
3040 t = gfc_resolve_array_constructor (e);
3041 /* Also try to expand a constructor. */
3044 expression_rank (e);
3045 gfc_expand_constructor (e);
3048 /* This provides the opportunity for the length of constructors with character
3049 valued function elements to propogate the string length to the expression. */
3050 if (e->ts.type == BT_CHARACTER)
3051 gfc_resolve_character_array_constructor (e);
3055 case EXPR_STRUCTURE:
3056 t = resolve_ref (e);
3060 t = resolve_structure_cons (e);
3064 t = gfc_simplify_expr (e, 0);
3068 gfc_internal_error ("gfc_resolve_expr(): Bad expression type");
3075 /* Resolve an expression from an iterator. They must be scalar and have
3076 INTEGER or (optionally) REAL type. */
3079 gfc_resolve_iterator_expr (gfc_expr * expr, bool real_ok,
3080 const char * name_msgid)
3082 if (gfc_resolve_expr (expr) == FAILURE)
3085 if (expr->rank != 0)
3087 gfc_error ("%s at %L must be a scalar", _(name_msgid), &expr->where);
3091 if (!(expr->ts.type == BT_INTEGER
3092 || (expr->ts.type == BT_REAL && real_ok)))
3095 gfc_error ("%s at %L must be INTEGER or REAL", _(name_msgid),
3098 gfc_error ("%s at %L must be INTEGER", _(name_msgid), &expr->where);
3105 /* Resolve the expressions in an iterator structure. If REAL_OK is
3106 false allow only INTEGER type iterators, otherwise allow REAL types. */
3109 gfc_resolve_iterator (gfc_iterator * iter, bool real_ok)
3112 if (iter->var->ts.type == BT_REAL)
3113 gfc_notify_std (GFC_STD_F95_DEL,
3114 "Obsolete: REAL DO loop iterator at %L",
3117 if (gfc_resolve_iterator_expr (iter->var, real_ok, "Loop variable")
3121 if (gfc_pure (NULL) && gfc_impure_variable (iter->var->symtree->n.sym))
3123 gfc_error ("Cannot assign to loop variable in PURE procedure at %L",
3128 if (gfc_resolve_iterator_expr (iter->start, real_ok,
3129 "Start expression in DO loop") == FAILURE)
3132 if (gfc_resolve_iterator_expr (iter->end, real_ok,
3133 "End expression in DO loop") == FAILURE)
3136 if (gfc_resolve_iterator_expr (iter->step, real_ok,
3137 "Step expression in DO loop") == FAILURE)
3140 if (iter->step->expr_type == EXPR_CONSTANT)
3142 if ((iter->step->ts.type == BT_INTEGER
3143 && mpz_cmp_ui (iter->step->value.integer, 0) == 0)
3144 || (iter->step->ts.type == BT_REAL
3145 && mpfr_sgn (iter->step->value.real) == 0))
3147 gfc_error ("Step expression in DO loop at %L cannot be zero",
3148 &iter->step->where);
3153 /* Convert start, end, and step to the same type as var. */
3154 if (iter->start->ts.kind != iter->var->ts.kind
3155 || iter->start->ts.type != iter->var->ts.type)
3156 gfc_convert_type (iter->start, &iter->var->ts, 2);
3158 if (iter->end->ts.kind != iter->var->ts.kind
3159 || iter->end->ts.type != iter->var->ts.type)
3160 gfc_convert_type (iter->end, &iter->var->ts, 2);
3162 if (iter->step->ts.kind != iter->var->ts.kind
3163 || iter->step->ts.type != iter->var->ts.type)
3164 gfc_convert_type (iter->step, &iter->var->ts, 2);
3170 /* Resolve a list of FORALL iterators. The FORALL index-name is constrained
3171 to be a scalar INTEGER variable. The subscripts and stride are scalar
3172 INTEGERs, and if stride is a constant it must be nonzero. */
3175 resolve_forall_iterators (gfc_forall_iterator * iter)
3180 if (gfc_resolve_expr (iter->var) == SUCCESS
3181 && (iter->var->ts.type != BT_INTEGER || iter->var->rank != 0))
3182 gfc_error ("FORALL index-name at %L must be a scalar INTEGER",
3185 if (gfc_resolve_expr (iter->start) == SUCCESS
3186 && (iter->start->ts.type != BT_INTEGER || iter->start->rank != 0))
3187 gfc_error ("FORALL start expression at %L must be a scalar INTEGER",
3188 &iter->start->where);
3189 if (iter->var->ts.kind != iter->start->ts.kind)
3190 gfc_convert_type (iter->start, &iter->var->ts, 2);
3192 if (gfc_resolve_expr (iter->end) == SUCCESS
3193 && (iter->end->ts.type != BT_INTEGER || iter->end->rank != 0))
3194 gfc_error ("FORALL end expression at %L must be a scalar INTEGER",
3196 if (iter->var->ts.kind != iter->end->ts.kind)
3197 gfc_convert_type (iter->end, &iter->var->ts, 2);
3199 if (gfc_resolve_expr (iter->stride) == SUCCESS)
3201 if (iter->stride->ts.type != BT_INTEGER || iter->stride->rank != 0)
3202 gfc_error ("FORALL stride expression at %L must be a scalar %s",
3203 &iter->stride->where, "INTEGER");
3205 if (iter->stride->expr_type == EXPR_CONSTANT
3206 && mpz_cmp_ui(iter->stride->value.integer, 0) == 0)
3207 gfc_error ("FORALL stride expression at %L cannot be zero",
3208 &iter->stride->where);
3210 if (iter->var->ts.kind != iter->stride->ts.kind)
3211 gfc_convert_type (iter->stride, &iter->var->ts, 2);
3218 /* Given a pointer to a symbol that is a derived type, see if any components
3219 have the POINTER attribute. The search is recursive if necessary.
3220 Returns zero if no pointer components are found, nonzero otherwise. */
3223 derived_pointer (gfc_symbol * sym)
3227 for (c = sym->components; c; c = c->next)
3232 if (c->ts.type == BT_DERIVED && derived_pointer (c->ts.derived))
3240 /* Given a pointer to a symbol that is a derived type, see if it's
3241 inaccessible, i.e. if it's defined in another module and the components are
3242 PRIVATE. The search is recursive if necessary. Returns zero if no
3243 inaccessible components are found, nonzero otherwise. */
3246 derived_inaccessible (gfc_symbol *sym)
3250 if (sym->attr.use_assoc && sym->component_access == ACCESS_PRIVATE)
3253 for (c = sym->components; c; c = c->next)
3255 if (c->ts.type == BT_DERIVED && derived_inaccessible (c->ts.derived))
3263 /* Resolve the argument of a deallocate expression. The expression must be
3264 a pointer or a full array. */
3267 resolve_deallocate_expr (gfc_expr * e)
3269 symbol_attribute attr;
3273 if (gfc_resolve_expr (e) == FAILURE)
3276 attr = gfc_expr_attr (e);
3280 if (e->expr_type != EXPR_VARIABLE)
3283 allocatable = e->symtree->n.sym->attr.allocatable;
3284 for (ref = e->ref; ref; ref = ref->next)
3288 if (ref->u.ar.type != AR_FULL)
3293 allocatable = (ref->u.c.component->as != NULL
3294 && ref->u.c.component->as->type == AS_DEFERRED);
3302 if (allocatable == 0)
3305 gfc_error ("Expression in DEALLOCATE statement at %L must be "
3306 "ALLOCATABLE or a POINTER", &e->where);
3309 if (e->symtree->n.sym->attr.intent == INTENT_IN)
3311 gfc_error ("Can't deallocate INTENT(IN) variable '%s' at %L",
3312 e->symtree->n.sym->name, &e->where);
3319 /* Returns true if the expression e contains a reference the symbol sym. */
3321 find_sym_in_expr (gfc_symbol *sym, gfc_expr *e)
3323 gfc_actual_arglist *arg;
3331 switch (e->expr_type)
3334 for (arg = e->value.function.actual; arg; arg = arg->next)
3335 rv = rv || find_sym_in_expr (sym, arg->expr);
3338 /* If the variable is not the same as the dependent, 'sym', and
3339 it is not marked as being declared and it is in the same
3340 namespace as 'sym', add it to the local declarations. */
3342 if (sym == e->symtree->n.sym)
3347 rv = rv || find_sym_in_expr (sym, e->value.op.op1);
3348 rv = rv || find_sym_in_expr (sym, e->value.op.op2);
3357 for (ref = e->ref; ref; ref = ref->next)
3362 for (i = 0; i < ref->u.ar.dimen; i++)
3364 rv = rv || find_sym_in_expr (sym, ref->u.ar.start[i]);
3365 rv = rv || find_sym_in_expr (sym, ref->u.ar.end[i]);
3366 rv = rv || find_sym_in_expr (sym, ref->u.ar.stride[i]);
3371 rv = rv || find_sym_in_expr (sym, ref->u.ss.start);
3372 rv = rv || find_sym_in_expr (sym, ref->u.ss.end);
3376 if (ref->u.c.component->ts.type == BT_CHARACTER
3377 && ref->u.c.component->ts.cl->length->expr_type
3379 rv = rv || find_sym_in_expr (sym, ref->u.c.component->ts.cl->length);
3381 if (ref->u.c.component->as)
3382 for (i = 0; i < ref->u.c.component->as->rank; i++)
3384 rv = rv || find_sym_in_expr (sym, ref->u.c.component->as->lower[i]);
3385 rv = rv || find_sym_in_expr (sym, ref->u.c.component->as->upper[i]);
3395 /* Given the expression node e for an allocatable/pointer of derived type to be
3396 allocated, get the expression node to be initialized afterwards (needed for
3397 derived types with default initializers). */
3400 expr_to_initialize (gfc_expr * e)
3406 result = gfc_copy_expr (e);
3408 /* Change the last array reference from AR_ELEMENT to AR_FULL. */
3409 for (ref = result->ref; ref; ref = ref->next)
3410 if (ref->type == REF_ARRAY && ref->next == NULL)
3412 ref->u.ar.type = AR_FULL;
3414 for (i = 0; i < ref->u.ar.dimen; i++)
3415 ref->u.ar.start[i] = ref->u.ar.end[i] = ref->u.ar.stride[i] = NULL;
3417 result->rank = ref->u.ar.dimen;
3425 /* Resolve the expression in an ALLOCATE statement, doing the additional
3426 checks to see whether the expression is OK or not. The expression must
3427 have a trailing array reference that gives the size of the array. */
3430 resolve_allocate_expr (gfc_expr * e, gfc_code * code)
3432 int i, pointer, allocatable, dimension;
3433 symbol_attribute attr;
3434 gfc_ref *ref, *ref2;
3441 if (gfc_resolve_expr (e) == FAILURE)
3444 if (code->expr && code->expr->expr_type == EXPR_VARIABLE)
3445 sym = code->expr->symtree->n.sym;
3449 /* Make sure the expression is allocatable or a pointer. If it is
3450 pointer, the next-to-last reference must be a pointer. */
3454 if (e->expr_type != EXPR_VARIABLE)
3458 attr = gfc_expr_attr (e);
3459 pointer = attr.pointer;
3460 dimension = attr.dimension;
3465 allocatable = e->symtree->n.sym->attr.allocatable;
3466 pointer = e->symtree->n.sym->attr.pointer;
3467 dimension = e->symtree->n.sym->attr.dimension;
3469 if (sym == e->symtree->n.sym && sym->ts.type != BT_DERIVED)
3471 gfc_error ("The STAT variable '%s' in an ALLOCATE statement must "
3472 "not be allocated in the same statement at %L",
3473 sym->name, &e->where);
3477 for (ref = e->ref; ref; ref2 = ref, ref = ref->next)
3481 if (ref->next != NULL)
3486 allocatable = (ref->u.c.component->as != NULL
3487 && ref->u.c.component->as->type == AS_DEFERRED);
3489 pointer = ref->u.c.component->pointer;
3490 dimension = ref->u.c.component->dimension;
3500 if (allocatable == 0 && pointer == 0)
3502 gfc_error ("Expression in ALLOCATE statement at %L must be "
3503 "ALLOCATABLE or a POINTER", &e->where);
3507 if (e->symtree->n.sym->attr.intent == INTENT_IN)
3509 gfc_error ("Can't allocate INTENT(IN) variable '%s' at %L",
3510 e->symtree->n.sym->name, &e->where);
3514 /* Add default initializer for those derived types that need them. */
3515 if (e->ts.type == BT_DERIVED && (init_e = gfc_default_initializer (&e->ts)))
3517 init_st = gfc_get_code ();
3518 init_st->loc = code->loc;
3519 init_st->op = EXEC_ASSIGN;
3520 init_st->expr = expr_to_initialize (e);
3521 init_st->expr2 = init_e;
3523 init_st->next = code->next;
3524 code->next = init_st;
3527 if (pointer && dimension == 0)
3530 /* Make sure the next-to-last reference node is an array specification. */
3532 if (ref2 == NULL || ref2->type != REF_ARRAY || ref2->u.ar.type == AR_FULL)
3534 gfc_error ("Array specification required in ALLOCATE statement "
3535 "at %L", &e->where);
3539 /* Make sure that the array section reference makes sense in the
3540 context of an ALLOCATE specification. */
3544 for (i = 0; i < ar->dimen; i++)
3546 if (ref2->u.ar.type == AR_ELEMENT)
3549 switch (ar->dimen_type[i])
3555 if (ar->start[i] != NULL
3556 && ar->end[i] != NULL
3557 && ar->stride[i] == NULL)
3560 /* Fall Through... */
3564 gfc_error ("Bad array specification in ALLOCATE statement at %L",
3571 for (a = code->ext.alloc_list; a; a = a->next)
3573 sym = a->expr->symtree->n.sym;
3575 /* TODO - check derived type components. */
3576 if (sym->ts.type == BT_DERIVED)
3579 if ((ar->start[i] != NULL && find_sym_in_expr (sym, ar->start[i]))
3580 || (ar->end[i] != NULL && find_sym_in_expr (sym, ar->end[i])))
3582 gfc_error ("'%s' must not appear an the array specification at "
3583 "%L in the same ALLOCATE statement where it is "
3584 "itself allocated", sym->name, &ar->where);
3594 /************ SELECT CASE resolution subroutines ************/
3596 /* Callback function for our mergesort variant. Determines interval
3597 overlaps for CASEs. Return <0 if op1 < op2, 0 for overlap, >0 for
3598 op1 > op2. Assumes we're not dealing with the default case.
3599 We have op1 = (:L), (K:L) or (K:) and op2 = (:N), (M:N) or (M:).
3600 There are nine situations to check. */
3603 compare_cases (const gfc_case * op1, const gfc_case * op2)
3607 if (op1->low == NULL) /* op1 = (:L) */
3609 /* op2 = (:N), so overlap. */
3611 /* op2 = (M:) or (M:N), L < M */
3612 if (op2->low != NULL
3613 && gfc_compare_expr (op1->high, op2->low) < 0)
3616 else if (op1->high == NULL) /* op1 = (K:) */
3618 /* op2 = (M:), so overlap. */
3620 /* op2 = (:N) or (M:N), K > N */
3621 if (op2->high != NULL
3622 && gfc_compare_expr (op1->low, op2->high) > 0)
3625 else /* op1 = (K:L) */
3627 if (op2->low == NULL) /* op2 = (:N), K > N */
3628 retval = (gfc_compare_expr (op1->low, op2->high) > 0) ? 1 : 0;
3629 else if (op2->high == NULL) /* op2 = (M:), L < M */
3630 retval = (gfc_compare_expr (op1->high, op2->low) < 0) ? -1 : 0;
3631 else /* op2 = (M:N) */
3635 if (gfc_compare_expr (op1->high, op2->low) < 0)
3638 else if (gfc_compare_expr (op1->low, op2->high) > 0)
3647 /* Merge-sort a double linked case list, detecting overlap in the
3648 process. LIST is the head of the double linked case list before it
3649 is sorted. Returns the head of the sorted list if we don't see any
3650 overlap, or NULL otherwise. */
3653 check_case_overlap (gfc_case * list)
3655 gfc_case *p, *q, *e, *tail;
3656 int insize, nmerges, psize, qsize, cmp, overlap_seen;
3658 /* If the passed list was empty, return immediately. */
3665 /* Loop unconditionally. The only exit from this loop is a return
3666 statement, when we've finished sorting the case list. */
3673 /* Count the number of merges we do in this pass. */
3676 /* Loop while there exists a merge to be done. */
3681 /* Count this merge. */
3684 /* Cut the list in two pieces by stepping INSIZE places
3685 forward in the list, starting from P. */
3688 for (i = 0; i < insize; i++)
3697 /* Now we have two lists. Merge them! */
3698 while (psize > 0 || (qsize > 0 && q != NULL))
3701 /* See from which the next case to merge comes from. */
3704 /* P is empty so the next case must come from Q. */
3709 else if (qsize == 0 || q == NULL)
3718 cmp = compare_cases (p, q);
3721 /* The whole case range for P is less than the
3729 /* The whole case range for Q is greater than
3730 the case range for P. */
3737 /* The cases overlap, or they are the same
3738 element in the list. Either way, we must
3739 issue an error and get the next case from P. */
3740 /* FIXME: Sort P and Q by line number. */
3741 gfc_error ("CASE label at %L overlaps with CASE "
3742 "label at %L", &p->where, &q->where);
3750 /* Add the next element to the merged list. */
3759 /* P has now stepped INSIZE places along, and so has Q. So
3760 they're the same. */
3765 /* If we have done only one merge or none at all, we've
3766 finished sorting the cases. */
3775 /* Otherwise repeat, merging lists twice the size. */
3781 /* Check to see if an expression is suitable for use in a CASE statement.
3782 Makes sure that all case expressions are scalar constants of the same
3783 type. Return FAILURE if anything is wrong. */
3786 validate_case_label_expr (gfc_expr * e, gfc_expr * case_expr)
3788 if (e == NULL) return SUCCESS;
3790 if (e->ts.type != case_expr->ts.type)
3792 gfc_error ("Expression in CASE statement at %L must be of type %s",
3793 &e->where, gfc_basic_typename (case_expr->ts.type));
3797 /* C805 (R808) For a given case-construct, each case-value shall be of
3798 the same type as case-expr. For character type, length differences
3799 are allowed, but the kind type parameters shall be the same. */
3801 if (case_expr->ts.type == BT_CHARACTER && e->ts.kind != case_expr->ts.kind)
3803 gfc_error("Expression in CASE statement at %L must be kind %d",
3804 &e->where, case_expr->ts.kind);
3808 /* Convert the case value kind to that of case expression kind, if needed.
3809 FIXME: Should a warning be issued? */
3810 if (e->ts.kind != case_expr->ts.kind)
3811 gfc_convert_type_warn (e, &case_expr->ts, 2, 0);
3815 gfc_error ("Expression in CASE statement at %L must be scalar",
3824 /* Given a completely parsed select statement, we:
3826 - Validate all expressions and code within the SELECT.
3827 - Make sure that the selection expression is not of the wrong type.
3828 - Make sure that no case ranges overlap.
3829 - Eliminate unreachable cases and unreachable code resulting from
3830 removing case labels.
3832 The standard does allow unreachable cases, e.g. CASE (5:3). But
3833 they are a hassle for code generation, and to prevent that, we just
3834 cut them out here. This is not necessary for overlapping cases
3835 because they are illegal and we never even try to generate code.
3837 We have the additional caveat that a SELECT construct could have
3838 been a computed GOTO in the source code. Fortunately we can fairly
3839 easily work around that here: The case_expr for a "real" SELECT CASE
3840 is in code->expr1, but for a computed GOTO it is in code->expr2. All
3841 we have to do is make sure that the case_expr is a scalar integer
3845 resolve_select (gfc_code * code)
3848 gfc_expr *case_expr;
3849 gfc_case *cp, *default_case, *tail, *head;
3850 int seen_unreachable;
3856 if (code->expr == NULL)
3858 /* This was actually a computed GOTO statement. */
3859 case_expr = code->expr2;
3860 if (case_expr->ts.type != BT_INTEGER
3861 || case_expr->rank != 0)
3862 gfc_error ("Selection expression in computed GOTO statement "
3863 "at %L must be a scalar integer expression",
3866 /* Further checking is not necessary because this SELECT was built
3867 by the compiler, so it should always be OK. Just move the
3868 case_expr from expr2 to expr so that we can handle computed
3869 GOTOs as normal SELECTs from here on. */
3870 code->expr = code->expr2;
3875 case_expr = code->expr;
3877 type = case_expr->ts.type;
3878 if (type != BT_LOGICAL && type != BT_INTEGER && type != BT_CHARACTER)
3880 gfc_error ("Argument of SELECT statement at %L cannot be %s",
3881 &case_expr->where, gfc_typename (&case_expr->ts));
3883 /* Punt. Going on here just produce more garbage error messages. */
3887 if (case_expr->rank != 0)
3889 gfc_error ("Argument of SELECT statement at %L must be a scalar "
3890 "expression", &case_expr->where);
3896 /* PR 19168 has a long discussion concerning a mismatch of the kinds
3897 of the SELECT CASE expression and its CASE values. Walk the lists
3898 of case values, and if we find a mismatch, promote case_expr to
3899 the appropriate kind. */
3901 if (type == BT_LOGICAL || type == BT_INTEGER)
3903 for (body = code->block; body; body = body->block)
3905 /* Walk the case label list. */
3906 for (cp = body->ext.case_list; cp; cp = cp->next)
3908 /* Intercept the DEFAULT case. It does not have a kind. */
3909 if (cp->low == NULL && cp->high == NULL)
3912 /* Unreachable case ranges are discarded, so ignore. */
3913 if (cp->low != NULL && cp->high != NULL
3914 && cp->low != cp->high
3915 && gfc_compare_expr (cp->low, cp->high) > 0)
3918 /* FIXME: Should a warning be issued? */
3920 && case_expr->ts.kind != gfc_kind_max(case_expr, cp->low))
3921 gfc_convert_type_warn (case_expr, &cp->low->ts, 2, 0);
3923 if (cp->high != NULL
3924 && case_expr->ts.kind != gfc_kind_max(case_expr, cp->high))
3925 gfc_convert_type_warn (case_expr, &cp->high->ts, 2, 0);
3930 /* Assume there is no DEFAULT case. */
3931 default_case = NULL;
3936 for (body = code->block; body; body = body->block)
3938 /* Assume the CASE list is OK, and all CASE labels can be matched. */
3940 seen_unreachable = 0;
3942 /* Walk the case label list, making sure that all case labels
3944 for (cp = body->ext.case_list; cp; cp = cp->next)
3946 /* Count the number of cases in the whole construct. */
3949 /* Intercept the DEFAULT case. */
3950 if (cp->low == NULL && cp->high == NULL)
3952 if (default_case != NULL)
3954 gfc_error ("The DEFAULT CASE at %L cannot be followed "
3955 "by a second DEFAULT CASE at %L",
3956 &default_case->where, &cp->where);
3967 /* Deal with single value cases and case ranges. Errors are
3968 issued from the validation function. */
3969 if(validate_case_label_expr (cp->low, case_expr) != SUCCESS
3970 || validate_case_label_expr (cp->high, case_expr) != SUCCESS)
3976 if (type == BT_LOGICAL
3977 && ((cp->low == NULL || cp->high == NULL)
3978 || cp->low != cp->high))
3981 ("Logical range in CASE statement at %L is not allowed",
3987 if (type == BT_LOGICAL && cp->low->expr_type == EXPR_CONSTANT)
3990 value = cp->low->value.logical == 0 ? 2 : 1;
3991 if (value & seen_logical)
3993 gfc_error ("constant logical value in CASE statement "
3994 "is repeated at %L",
3999 seen_logical |= value;
4002 if (cp->low != NULL && cp->high != NULL
4003 && cp->low != cp->high
4004 && gfc_compare_expr (cp->low, cp->high) > 0)
4006 if (gfc_option.warn_surprising)
4007 gfc_warning ("Range specification at %L can never "
4008 "be matched", &cp->where);
4010 cp->unreachable = 1;
4011 seen_unreachable = 1;
4015 /* If the case range can be matched, it can also overlap with
4016 other cases. To make sure it does not, we put it in a
4017 double linked list here. We sort that with a merge sort
4018 later on to detect any overlapping cases. */
4022 head->right = head->left = NULL;
4027 tail->right->left = tail;
4034 /* It there was a failure in the previous case label, give up
4035 for this case label list. Continue with the next block. */
4039 /* See if any case labels that are unreachable have been seen.
4040 If so, we eliminate them. This is a bit of a kludge because
4041 the case lists for a single case statement (label) is a
4042 single forward linked lists. */
4043 if (seen_unreachable)
4045 /* Advance until the first case in the list is reachable. */
4046 while (body->ext.case_list != NULL
4047 && body->ext.case_list->unreachable)
4049 gfc_case *n = body->ext.case_list;
4050 body->ext.case_list = body->ext.case_list->next;
4052 gfc_free_case_list (n);
4055 /* Strip all other unreachable cases. */
4056 if (body->ext.case_list)
4058 for (cp = body->ext.case_list; cp->next; cp = cp->next)
4060 if (cp->next->unreachable)
4062 gfc_case *n = cp->next;
4063 cp->next = cp->next->next;
4065 gfc_free_case_list (n);
4072 /* See if there were overlapping cases. If the check returns NULL,
4073 there was overlap. In that case we don't do anything. If head
4074 is non-NULL, we prepend the DEFAULT case. The sorted list can
4075 then used during code generation for SELECT CASE constructs with
4076 a case expression of a CHARACTER type. */
4079 head = check_case_overlap (head);
4081 /* Prepend the default_case if it is there. */
4082 if (head != NULL && default_case)
4084 default_case->left = NULL;
4085 default_case->right = head;
4086 head->left = default_case;
4090 /* Eliminate dead blocks that may be the result if we've seen
4091 unreachable case labels for a block. */
4092 for (body = code; body && body->block; body = body->block)
4094 if (body->block->ext.case_list == NULL)
4096 /* Cut the unreachable block from the code chain. */
4097 gfc_code *c = body->block;
4098 body->block = c->block;
4100 /* Kill the dead block, but not the blocks below it. */
4102 gfc_free_statements (c);
4106 /* More than two cases is legal but insane for logical selects.
4107 Issue a warning for it. */
4108 if (gfc_option.warn_surprising && type == BT_LOGICAL
4110 gfc_warning ("Logical SELECT CASE block at %L has more that two cases",
4115 /* Resolve a transfer statement. This is making sure that:
4116 -- a derived type being transferred has only non-pointer components
4117 -- a derived type being transferred doesn't have private components, unless
4118 it's being transferred from the module where the type was defined
4119 -- we're not trying to transfer a whole assumed size array. */
4122 resolve_transfer (gfc_code * code)
4131 if (exp->expr_type != EXPR_VARIABLE)
4134 sym = exp->symtree->n.sym;
4137 /* Go to actual component transferred. */
4138 for (ref = code->expr->ref; ref; ref = ref->next)
4139 if (ref->type == REF_COMPONENT)
4140 ts = &ref->u.c.component->ts;
4142 if (ts->type == BT_DERIVED)
4144 /* Check that transferred derived type doesn't contain POINTER
4146 if (derived_pointer (ts->derived))
4148 gfc_error ("Data transfer element at %L cannot have "
4149 "POINTER components", &code->loc);
4153 if (derived_inaccessible (ts->derived))
4155 gfc_error ("Data transfer element at %L cannot have "
4156 "PRIVATE components",&code->loc);
4161 if (sym->as != NULL && sym->as->type == AS_ASSUMED_SIZE
4162 && exp->ref->type == REF_ARRAY && exp->ref->u.ar.type == AR_FULL)
4164 gfc_error ("Data transfer element at %L cannot be a full reference to "
4165 "an assumed-size array", &code->loc);
4171 /*********** Toplevel code resolution subroutines ***********/
4173 /* Given a branch to a label and a namespace, if the branch is conforming.
4174 The code node described where the branch is located. */
4177 resolve_branch (gfc_st_label * label, gfc_code * code)
4179 gfc_code *block, *found;
4187 /* Step one: is this a valid branching target? */
4189 if (lp->defined == ST_LABEL_UNKNOWN)
4191 gfc_error ("Label %d referenced at %L is never defined", lp->value,
4196 if (lp->defined != ST_LABEL_TARGET)
4198 gfc_error ("Statement at %L is not a valid branch target statement "
4199 "for the branch statement at %L", &lp->where, &code->loc);
4203 /* Step two: make sure this branch is not a branch to itself ;-) */
4205 if (code->here == label)
4207 gfc_warning ("Branch at %L causes an infinite loop", &code->loc);
4211 /* Step three: Try to find the label in the parse tree. To do this,
4212 we traverse the tree block-by-block: first the block that
4213 contains this GOTO, then the block that it is nested in, etc. We
4214 can ignore other blocks because branching into another block is
4219 for (stack = cs_base; stack; stack = stack->prev)
4221 for (block = stack->head; block; block = block->next)
4223 if (block->here == label)
4236 /* The label is not in an enclosing block, so illegal. This was
4237 allowed in Fortran 66, so we allow it as extension. We also
4238 forego further checks if we run into this. */
4239 gfc_notify_std (GFC_STD_LEGACY,
4240 "Label at %L is not in the same block as the "
4241 "GOTO statement at %L", &lp->where, &code->loc);
4245 /* Step four: Make sure that the branching target is legal if
4246 the statement is an END {SELECT,DO,IF}. */
4248 if (found->op == EXEC_NOP)
4250 for (stack = cs_base; stack; stack = stack->prev)
4251 if (stack->current->next == found)
4255 gfc_notify_std (GFC_STD_F95_DEL,
4256 "Obsolete: GOTO at %L jumps to END of construct at %L",
4257 &code->loc, &found->loc);
4262 /* Check whether EXPR1 has the same shape as EXPR2. */
4265 resolve_where_shape (gfc_expr *expr1, gfc_expr *expr2)
4267 mpz_t shape[GFC_MAX_DIMENSIONS];
4268 mpz_t shape2[GFC_MAX_DIMENSIONS];
4269 try result = FAILURE;
4272 /* Compare the rank. */
4273 if (expr1->rank != expr2->rank)
4276 /* Compare the size of each dimension. */
4277 for (i=0; i<expr1->rank; i++)
4279 if (gfc_array_dimen_size (expr1, i, &shape[i]) == FAILURE)
4282 if (gfc_array_dimen_size (expr2, i, &shape2[i]) == FAILURE)
4285 if (mpz_cmp (shape[i], shape2[i]))
4289 /* When either of the two expression is an assumed size array, we
4290 ignore the comparison of dimension sizes. */
4295 for (i--; i>=0; i--)
4297 mpz_clear (shape[i]);
4298 mpz_clear (shape2[i]);
4304 /* Check whether a WHERE assignment target or a WHERE mask expression
4305 has the same shape as the outmost WHERE mask expression. */
4308 resolve_where (gfc_code *code, gfc_expr *mask)
4314 cblock = code->block;
4316 /* Store the first WHERE mask-expr of the WHERE statement or construct.
4317 In case of nested WHERE, only the outmost one is stored. */
4318 if (mask == NULL) /* outmost WHERE */
4320 else /* inner WHERE */
4327 /* Check if the mask-expr has a consistent shape with the
4328 outmost WHERE mask-expr. */
4329 if (resolve_where_shape (cblock->expr, e) == FAILURE)
4330 gfc_error ("WHERE mask at %L has inconsistent shape",
4331 &cblock->expr->where);
4334 /* the assignment statement of a WHERE statement, or the first
4335 statement in where-body-construct of a WHERE construct */
4336 cnext = cblock->next;
4341 /* WHERE assignment statement */
4344 /* Check shape consistent for WHERE assignment target. */
4345 if (e && resolve_where_shape (cnext->expr, e) == FAILURE)
4346 gfc_error ("WHERE assignment target at %L has "
4347 "inconsistent shape", &cnext->expr->where);
4350 /* WHERE or WHERE construct is part of a where-body-construct */
4352 resolve_where (cnext, e);
4356 gfc_error ("Unsupported statement inside WHERE at %L",
4359 /* the next statement within the same where-body-construct */
4360 cnext = cnext->next;
4362 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
4363 cblock = cblock->block;
4368 /* Check whether the FORALL index appears in the expression or not. */
4371 gfc_find_forall_index (gfc_expr *expr, gfc_symbol *symbol)
4375 gfc_actual_arglist *args;
4378 switch (expr->expr_type)
4381 gcc_assert (expr->symtree->n.sym);
4383 /* A scalar assignment */
4386 if (expr->symtree->n.sym == symbol)
4392 /* the expr is array ref, substring or struct component. */
4399 /* Check if the symbol appears in the array subscript. */
4401 for (i = 0; i < GFC_MAX_DIMENSIONS; i++)
4404 if (gfc_find_forall_index (ar.start[i], symbol) == SUCCESS)
4408 if (gfc_find_forall_index (ar.end[i], symbol) == SUCCESS)
4412 if (gfc_find_forall_index (ar.stride[i], symbol) == SUCCESS)
4418 if (expr->symtree->n.sym == symbol)
4421 /* Check if the symbol appears in the substring section. */
4422 if (gfc_find_forall_index (tmp->u.ss.start, symbol) == SUCCESS)
4424 if (gfc_find_forall_index (tmp->u.ss.end, symbol) == SUCCESS)
4432 gfc_error("expression reference type error at %L", &expr->where);
4438 /* If the expression is a function call, then check if the symbol
4439 appears in the actual arglist of the function. */
4441 for (args = expr->value.function.actual; args; args = args->next)
4443 if (gfc_find_forall_index(args->expr,symbol) == SUCCESS)
4448 /* It seems not to happen. */
4449 case EXPR_SUBSTRING:
4453 gcc_assert (expr->ref->type == REF_SUBSTRING);
4454 if (gfc_find_forall_index (tmp->u.ss.start, symbol) == SUCCESS)
4456 if (gfc_find_forall_index (tmp->u.ss.end, symbol) == SUCCESS)
4461 /* It seems not to happen. */
4462 case EXPR_STRUCTURE:
4464 gfc_error ("Unsupported statement while finding forall index in "
4469 /* Find the FORALL index in the first operand. */
4470 if (expr->value.op.op1)
4472 if (gfc_find_forall_index (expr->value.op.op1, symbol) == SUCCESS)
4476 /* Find the FORALL index in the second operand. */
4477 if (expr->value.op.op2)
4479 if (gfc_find_forall_index (expr->value.op.op2, symbol) == SUCCESS)
4492 /* Resolve assignment in FORALL construct.
4493 NVAR is the number of FORALL index variables, and VAR_EXPR records the
4494 FORALL index variables. */
4497 gfc_resolve_assign_in_forall (gfc_code *code, int nvar, gfc_expr **var_expr)
4501 for (n = 0; n < nvar; n++)
4503 gfc_symbol *forall_index;
4505 forall_index = var_expr[n]->symtree->n.sym;
4507 /* Check whether the assignment target is one of the FORALL index
4509 if ((code->expr->expr_type == EXPR_VARIABLE)
4510 && (code->expr->symtree->n.sym == forall_index))
4511 gfc_error ("Assignment to a FORALL index variable at %L",
4512 &code->expr->where);
4515 /* If one of the FORALL index variables doesn't appear in the
4516 assignment target, then there will be a many-to-one
4518 if (gfc_find_forall_index (code->expr, forall_index) == FAILURE)
4519 gfc_error ("The FORALL with index '%s' cause more than one "
4520 "assignment to this object at %L",
4521 var_expr[n]->symtree->name, &code->expr->where);
4527 /* Resolve WHERE statement in FORALL construct. */
4530 gfc_resolve_where_code_in_forall (gfc_code *code, int nvar, gfc_expr **var_expr){
4534 cblock = code->block;
4537 /* the assignment statement of a WHERE statement, or the first
4538 statement in where-body-construct of a WHERE construct */
4539 cnext = cblock->next;
4544 /* WHERE assignment statement */
4546 gfc_resolve_assign_in_forall (cnext, nvar, var_expr);
4549 /* WHERE or WHERE construct is part of a where-body-construct */
4551 gfc_resolve_where_code_in_forall (cnext, nvar, var_expr);
4555 gfc_error ("Unsupported statement inside WHERE at %L",
4558 /* the next statement within the same where-body-construct */
4559 cnext = cnext->next;
4561 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
4562 cblock = cblock->block;
4567 /* Traverse the FORALL body to check whether the following errors exist:
4568 1. For assignment, check if a many-to-one assignment happens.
4569 2. For WHERE statement, check the WHERE body to see if there is any
4570 many-to-one assignment. */
4573 gfc_resolve_forall_body (gfc_code *code, int nvar, gfc_expr **var_expr)
4577 c = code->block->next;
4583 case EXEC_POINTER_ASSIGN:
4584 gfc_resolve_assign_in_forall (c, nvar, var_expr);
4587 /* Because the gfc_resolve_blocks() will handle the nested FORALL,
4588 there is no need to handle it here. */
4592 gfc_resolve_where_code_in_forall(c, nvar, var_expr);
4597 /* The next statement in the FORALL body. */
4603 /* Given a FORALL construct, first resolve the FORALL iterator, then call
4604 gfc_resolve_forall_body to resolve the FORALL body. */
4607 gfc_resolve_forall (gfc_code *code, gfc_namespace *ns, int forall_save)
4609 static gfc_expr **var_expr;
4610 static int total_var = 0;
4611 static int nvar = 0;
4612 gfc_forall_iterator *fa;
4613 gfc_symbol *forall_index;
4617 /* Start to resolve a FORALL construct */
4618 if (forall_save == 0)
4620 /* Count the total number of FORALL index in the nested FORALL
4621 construct in order to allocate the VAR_EXPR with proper size. */
4623 while ((next != NULL) && (next->op == EXEC_FORALL))
4625 for (fa = next->ext.forall_iterator; fa; fa = fa->next)
4627 next = next->block->next;
4630 /* Allocate VAR_EXPR with NUMBER_OF_FORALL_INDEX elements. */
4631 var_expr = (gfc_expr **) gfc_getmem (total_var * sizeof (gfc_expr *));
4634 /* The information about FORALL iterator, including FORALL index start, end
4635 and stride. The FORALL index can not appear in start, end or stride. */
4636 for (fa = code->ext.forall_iterator; fa; fa = fa->next)
4638 /* Check if any outer FORALL index name is the same as the current
4640 for (i = 0; i < nvar; i++)
4642 if (fa->var->symtree->n.sym == var_expr[i]->symtree->n.sym)
4644 gfc_error ("An outer FORALL construct already has an index "
4645 "with this name %L", &fa->var->where);
4649 /* Record the current FORALL index. */
4650 var_expr[nvar] = gfc_copy_expr (fa->var);
4652 forall_index = fa->var->symtree->n.sym;
4654 /* Check if the FORALL index appears in start, end or stride. */
4655 if (gfc_find_forall_index (fa->start, forall_index) == SUCCESS)
4656 gfc_error ("A FORALL index must not appear in a limit or stride "
4657 "expression in the same FORALL at %L", &fa->start->where);
4658 if (gfc_find_forall_index (fa->end, forall_index) == SUCCESS)
4659 gfc_error ("A FORALL index must not appear in a limit or stride "
4660 "expression in the same FORALL at %L", &fa->end->where);
4661 if (gfc_find_forall_index (fa->stride, forall_index) == SUCCESS)
4662 gfc_error ("A FORALL index must not appear in a limit or stride "
4663 "expression in the same FORALL at %L", &fa->stride->where);
4667 /* Resolve the FORALL body. */
4668 gfc_resolve_forall_body (code, nvar, var_expr);
4670 /* May call gfc_resolve_forall to resolve the inner FORALL loop. */
4671 gfc_resolve_blocks (code->block, ns);
4673 /* Free VAR_EXPR after the whole FORALL construct resolved. */
4674 for (i = 0; i < total_var; i++)
4675 gfc_free_expr (var_expr[i]);
4677 /* Reset the counters. */
4683 /* Resolve lists of blocks found in IF, SELECT CASE, WHERE, FORALL ,GOTO and
4686 static void resolve_code (gfc_code *, gfc_namespace *);
4689 gfc_resolve_blocks (gfc_code * b, gfc_namespace * ns)
4693 for (; b; b = b->block)
4695 t = gfc_resolve_expr (b->expr);
4696 if (gfc_resolve_expr (b->expr2) == FAILURE)
4702 if (t == SUCCESS && b->expr != NULL
4703 && (b->expr->ts.type != BT_LOGICAL || b->expr->rank != 0))
4705 ("ELSE IF clause at %L requires a scalar LOGICAL expression",
4712 && (b->expr->ts.type != BT_LOGICAL
4713 || b->expr->rank == 0))
4715 ("WHERE/ELSEWHERE clause at %L requires a LOGICAL array",
4720 resolve_branch (b->label, b);
4732 case EXEC_OMP_ATOMIC:
4733 case EXEC_OMP_CRITICAL:
4735 case EXEC_OMP_MASTER:
4736 case EXEC_OMP_ORDERED:
4737 case EXEC_OMP_PARALLEL:
4738 case EXEC_OMP_PARALLEL_DO:
4739 case EXEC_OMP_PARALLEL_SECTIONS:
4740 case EXEC_OMP_PARALLEL_WORKSHARE:
4741 case EXEC_OMP_SECTIONS:
4742 case EXEC_OMP_SINGLE:
4743 case EXEC_OMP_WORKSHARE:
4747 gfc_internal_error ("resolve_block(): Bad block type");
4750 resolve_code (b->next, ns);
4755 /* Given a block of code, recursively resolve everything pointed to by this
4759 resolve_code (gfc_code * code, gfc_namespace * ns)
4761 int omp_workshare_save;
4767 frame.prev = cs_base;
4771 for (; code; code = code->next)
4773 frame.current = code;
4774 forall_save = forall_flag;
4776 if (code->op == EXEC_FORALL)
4779 gfc_resolve_forall (code, ns, forall_save);
4782 else if (code->block)
4784 omp_workshare_save = -1;
4787 case EXEC_OMP_PARALLEL_WORKSHARE:
4788 omp_workshare_save = omp_workshare_flag;
4789 omp_workshare_flag = 1;
4790 gfc_resolve_omp_parallel_blocks (code, ns);
4792 case EXEC_OMP_PARALLEL:
4793 case EXEC_OMP_PARALLEL_DO:
4794 case EXEC_OMP_PARALLEL_SECTIONS:
4795 omp_workshare_save = omp_workshare_flag;
4796 omp_workshare_flag = 0;
4797 gfc_resolve_omp_parallel_blocks (code, ns);
4800 gfc_resolve_omp_do_blocks (code, ns);
4802 case EXEC_OMP_WORKSHARE:
4803 omp_workshare_save = omp_workshare_flag;
4804 omp_workshare_flag = 1;
4807 gfc_resolve_blocks (code->block, ns);
4811 if (omp_workshare_save != -1)
4812 omp_workshare_flag = omp_workshare_save;
4815 t = gfc_resolve_expr (code->expr);
4816 forall_flag = forall_save;
4818 if (gfc_resolve_expr (code->expr2) == FAILURE)
4833 /* Keep track of which entry we are up to. */
4834 current_entry_id = code->ext.entry->id;
4838 resolve_where (code, NULL);
4842 if (code->expr != NULL)
4844 if (code->expr->ts.type != BT_INTEGER)
4845 gfc_error ("ASSIGNED GOTO statement at %L requires an INTEGER "
4846 "variable", &code->expr->where);
4847 else if (code->expr->symtree->n.sym->attr.assign != 1)
4848 gfc_error ("Variable '%s' has not been assigned a target label "
4849 "at %L", code->expr->symtree->n.sym->name,
4850 &code->expr->where);
4853 resolve_branch (code->label, code);
4857 if (code->expr != NULL
4858 && (code->expr->ts.type != BT_INTEGER || code->expr->rank))
4859 gfc_error ("Alternate RETURN statement at %L requires a SCALAR-"
4860 "INTEGER return specifier", &code->expr->where);
4867 if (gfc_extend_assign (code, ns) == SUCCESS)
4869 if (gfc_pure (NULL) && !gfc_pure (code->symtree->n.sym))
4871 gfc_error ("Subroutine '%s' called instead of assignment at "
4872 "%L must be PURE", code->symtree->n.sym->name,
4879 if (gfc_pure (NULL))
4881 if (gfc_impure_variable (code->expr->symtree->n.sym))
4884 ("Cannot assign to variable '%s' in PURE procedure at %L",
4885 code->expr->symtree->n.sym->name, &code->expr->where);
4889 if (code->expr2->ts.type == BT_DERIVED
4890 && derived_pointer (code->expr2->ts.derived))
4893 ("Right side of assignment at %L is a derived type "
4894 "containing a POINTER in a PURE procedure",
4895 &code->expr2->where);
4900 gfc_check_assign (code->expr, code->expr2, 1);
4903 case EXEC_LABEL_ASSIGN:
4904 if (code->label->defined == ST_LABEL_UNKNOWN)
4905 gfc_error ("Label %d referenced at %L is never defined",
4906 code->label->value, &code->label->where);
4908 && (code->expr->expr_type != EXPR_VARIABLE
4909 || code->expr->symtree->n.sym->ts.type != BT_INTEGER
4910 || code->expr->symtree->n.sym->ts.kind
4911 != gfc_default_integer_kind
4912 || code->expr->symtree->n.sym->as != NULL))
4913 gfc_error ("ASSIGN statement at %L requires a scalar "
4914 "default INTEGER variable", &code->expr->where);
4917 case EXEC_POINTER_ASSIGN:
4921 gfc_check_pointer_assign (code->expr, code->expr2);
4924 case EXEC_ARITHMETIC_IF:
4926 && code->expr->ts.type != BT_INTEGER
4927 && code->expr->ts.type != BT_REAL)
4928 gfc_error ("Arithmetic IF statement at %L requires a numeric "
4929 "expression", &code->expr->where);
4931 resolve_branch (code->label, code);
4932 resolve_branch (code->label2, code);
4933 resolve_branch (code->label3, code);
4937 if (t == SUCCESS && code->expr != NULL
4938 && (code->expr->ts.type != BT_LOGICAL
4939 || code->expr->rank != 0))
4940 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
4941 &code->expr->where);
4946 resolve_call (code);
4950 /* Select is complicated. Also, a SELECT construct could be
4951 a transformed computed GOTO. */
4952 resolve_select (code);
4956 if (code->ext.iterator != NULL)
4958 gfc_iterator *iter = code->ext.iterator;
4959 if (gfc_resolve_iterator (iter, true) != FAILURE)
4960 gfc_resolve_do_iterator (code, iter->var->symtree->n.sym);
4965 if (code->expr == NULL)
4966 gfc_internal_error ("resolve_code(): No expression on DO WHILE");
4968 && (code->expr->rank != 0
4969 || code->expr->ts.type != BT_LOGICAL))
4970 gfc_error ("Exit condition of DO WHILE loop at %L must be "
4971 "a scalar LOGICAL expression", &code->expr->where);
4975 if (t == SUCCESS && code->expr != NULL
4976 && code->expr->ts.type != BT_INTEGER)
4977 gfc_error ("STAT tag in ALLOCATE statement at %L must be "
4978 "of type INTEGER", &code->expr->where);
4980 for (a = code->ext.alloc_list; a; a = a->next)
4981 resolve_allocate_expr (a->expr, code);
4985 case EXEC_DEALLOCATE:
4986 if (t == SUCCESS && code->expr != NULL
4987 && code->expr->ts.type != BT_INTEGER)
4989 ("STAT tag in DEALLOCATE statement at %L must be of type "
4990 "INTEGER", &code->expr->where);
4992 for (a = code->ext.alloc_list; a; a = a->next)
4993 resolve_deallocate_expr (a->expr);
4998 if (gfc_resolve_open (code->ext.open) == FAILURE)
5001 resolve_branch (code->ext.open->err, code);
5005 if (gfc_resolve_close (code->ext.close) == FAILURE)
5008 resolve_branch (code->ext.close->err, code);
5011 case EXEC_BACKSPACE:
5015 if (gfc_resolve_filepos (code->ext.filepos) == FAILURE)
5018 resolve_branch (code->ext.filepos->err, code);
5022 if (gfc_resolve_inquire (code->ext.inquire) == FAILURE)
5025 resolve_branch (code->ext.inquire->err, code);
5029 gcc_assert (code->ext.inquire != NULL);
5030 if (gfc_resolve_inquire (code->ext.inquire) == FAILURE)
5033 resolve_branch (code->ext.inquire->err, code);
5038 if (gfc_resolve_dt (code->ext.dt) == FAILURE)
5041 resolve_branch (code->ext.dt->err, code);
5042 resolve_branch (code->ext.dt->end, code);
5043 resolve_branch (code->ext.dt->eor, code);
5047 resolve_transfer (code);
5051 resolve_forall_iterators (code->ext.forall_iterator);
5053 if (code->expr != NULL && code->expr->ts.type != BT_LOGICAL)
5055 ("FORALL mask clause at %L requires a LOGICAL expression",
5056 &code->expr->where);
5059 case EXEC_OMP_ATOMIC:
5060 case EXEC_OMP_BARRIER:
5061 case EXEC_OMP_CRITICAL:
5062 case EXEC_OMP_FLUSH:
5064 case EXEC_OMP_MASTER:
5065 case EXEC_OMP_ORDERED:
5066 case EXEC_OMP_SECTIONS:
5067 case EXEC_OMP_SINGLE:
5068 case EXEC_OMP_WORKSHARE:
5069 gfc_resolve_omp_directive (code, ns);
5072 case EXEC_OMP_PARALLEL:
5073 case EXEC_OMP_PARALLEL_DO:
5074 case EXEC_OMP_PARALLEL_SECTIONS:
5075 case EXEC_OMP_PARALLEL_WORKSHARE:
5076 omp_workshare_save = omp_workshare_flag;
5077 omp_workshare_flag = 0;
5078 gfc_resolve_omp_directive (code, ns);
5079 omp_workshare_flag = omp_workshare_save;
5083 gfc_internal_error ("resolve_code(): Bad statement code");
5087 cs_base = frame.prev;
5091 /* Resolve initial values and make sure they are compatible with
5095 resolve_values (gfc_symbol * sym)
5098 if (sym->value == NULL)
5101 if (gfc_resolve_expr (sym->value) == FAILURE)
5104 gfc_check_assign_symbol (sym, sym->value);
5108 /* Resolve an index expression. */
5111 resolve_index_expr (gfc_expr * e)
5113 if (gfc_resolve_expr (e) == FAILURE)
5116 if (gfc_simplify_expr (e, 0) == FAILURE)
5119 if (gfc_specification_expr (e) == FAILURE)
5125 /* Resolve a charlen structure. */
5128 resolve_charlen (gfc_charlen *cl)
5135 specification_expr = 1;
5137 if (resolve_index_expr (cl->length) == FAILURE)
5139 specification_expr = 0;
5147 /* Test for non-constant shape arrays. */
5150 is_non_constant_shape_array (gfc_symbol *sym)
5156 not_constant = false;
5157 if (sym->as != NULL)
5159 /* Unfortunately, !gfc_is_compile_time_shape hits a legal case that
5160 has not been simplified; parameter array references. Do the
5161 simplification now. */
5162 for (i = 0; i < sym->as->rank; i++)
5164 e = sym->as->lower[i];
5165 if (e && (resolve_index_expr (e) == FAILURE
5166 || !gfc_is_constant_expr (e)))
5167 not_constant = true;
5169 e = sym->as->upper[i];
5170 if (e && (resolve_index_expr (e) == FAILURE
5171 || !gfc_is_constant_expr (e)))
5172 not_constant = true;
5175 return not_constant;
5178 /* Resolution of common features of flavors variable and procedure. */
5181 resolve_fl_var_and_proc (gfc_symbol *sym, int mp_flag)
5183 /* Constraints on deferred shape variable. */
5184 if (sym->as == NULL || sym->as->type != AS_DEFERRED)
5186 if (sym->attr.allocatable)
5188 if (sym->attr.dimension)
5189 gfc_error ("Allocatable array '%s' at %L must have "
5190 "a deferred shape", sym->name, &sym->declared_at);
5192 gfc_error ("Scalar object '%s' at %L may not be ALLOCATABLE",
5193 sym->name, &sym->declared_at);
5197 if (sym->attr.pointer && sym->attr.dimension)
5199 gfc_error ("Array pointer '%s' at %L must have a deferred shape",
5200 sym->name, &sym->declared_at);
5207 if (!mp_flag && !sym->attr.allocatable
5208 && !sym->attr.pointer && !sym->attr.dummy)
5210 gfc_error ("Array '%s' at %L cannot have a deferred shape",
5211 sym->name, &sym->declared_at);
5218 /* Resolve symbols with flavor variable. */
5221 resolve_fl_variable (gfc_symbol *sym, int mp_flag)
5226 gfc_expr *constructor_expr;
5227 const char * auto_save_msg;
5229 auto_save_msg = "automatic object '%s' at %L cannot have the "
5232 if (resolve_fl_var_and_proc (sym, mp_flag) == FAILURE)
5235 /* Set this flag to check that variables are parameters of all entries.
5236 This check is effected by the call to gfc_resolve_expr through
5237 is_non_constant_shape_array. */
5238 specification_expr = 1;
5240 if (!sym->attr.use_assoc
5241 && !sym->attr.allocatable
5242 && !sym->attr.pointer
5243 && is_non_constant_shape_array (sym))
5245 /* The shape of a main program or module array needs to be constant. */
5246 if (sym->ns->proc_name
5247 && (sym->ns->proc_name->attr.flavor == FL_MODULE
5248 || sym->ns->proc_name->attr.is_main_program))
5250 gfc_error ("The module or main program array '%s' at %L must "
5251 "have constant shape", sym->name, &sym->declared_at);
5252 specification_expr = 0;
5257 if (sym->ts.type == BT_CHARACTER)
5259 /* Make sure that character string variables with assumed length are
5261 e = sym->ts.cl->length;
5262 if (e == NULL && !sym->attr.dummy && !sym->attr.result)
5264 gfc_error ("Entity with assumed character length at %L must be a "
5265 "dummy argument or a PARAMETER", &sym->declared_at);
5269 if (e && sym->attr.save && !gfc_is_constant_expr (e))
5271 gfc_error (auto_save_msg, sym->name, &sym->declared_at);
5275 if (!gfc_is_constant_expr (e)
5276 && !(e->expr_type == EXPR_VARIABLE
5277 && e->symtree->n.sym->attr.flavor == FL_PARAMETER)
5278 && sym->ns->proc_name
5279 && (sym->ns->proc_name->attr.flavor == FL_MODULE
5280 || sym->ns->proc_name->attr.is_main_program)
5281 && !sym->attr.use_assoc)
5283 gfc_error ("'%s' at %L must have constant character length "
5284 "in this context", sym->name, &sym->declared_at);
5289 /* Can the symbol have an initializer? */
5291 if (sym->attr.allocatable || sym->attr.external || sym->attr.dummy
5292 || sym->attr.intrinsic || sym->attr.result)
5294 else if (sym->attr.dimension && !sym->attr.pointer)
5296 /* Don't allow initialization of automatic arrays. */
5297 for (i = 0; i < sym->as->rank; i++)
5299 if (sym->as->lower[i] == NULL
5300 || sym->as->lower[i]->expr_type != EXPR_CONSTANT
5301 || sym->as->upper[i] == NULL
5302 || sym->as->upper[i]->expr_type != EXPR_CONSTANT)
5309 /* Also, they must not have the SAVE attribute. */
5310 if (flag && sym->attr.save)
5312 gfc_error (auto_save_msg, sym->name, &sym->declared_at);
5317 /* Reject illegal initializers. */
5318 if (sym->value && flag)
5320 if (sym->attr.allocatable)
5321 gfc_error ("Allocatable '%s' at %L cannot have an initializer",
5322 sym->name, &sym->declared_at);
5323 else if (sym->attr.external)
5324 gfc_error ("External '%s' at %L cannot have an initializer",
5325 sym->name, &sym->declared_at);
5326 else if (sym->attr.dummy)
5327 gfc_error ("Dummy '%s' at %L cannot have an initializer",
5328 sym->name, &sym->declared_at);
5329 else if (sym->attr.intrinsic)
5330 gfc_error ("Intrinsic '%s' at %L cannot have an initializer",
5331 sym->name, &sym->declared_at);
5332 else if (sym->attr.result)
5333 gfc_error ("Function result '%s' at %L cannot have an initializer",
5334 sym->name, &sym->declared_at);
5336 gfc_error ("Automatic array '%s' at %L cannot have an initializer",
5337 sym->name, &sym->declared_at);
5341 /* 4th constraint in section 11.3: "If an object of a type for which
5342 component-initialization is specified (R429) appears in the
5343 specification-part of a module and does not have the ALLOCATABLE
5344 or POINTER attribute, the object shall have the SAVE attribute." */
5346 constructor_expr = NULL;
5347 if (sym->ts.type == BT_DERIVED && !(sym->value || flag))
5348 constructor_expr = gfc_default_initializer (&sym->ts);
5350 if (sym->ns->proc_name
5351 && sym->ns->proc_name->attr.flavor == FL_MODULE
5353 && !sym->ns->save_all && !sym->attr.save
5354 && !sym->attr.pointer && !sym->attr.allocatable)
5356 gfc_error("Object '%s' at %L must have the SAVE attribute %s",
5357 sym->name, &sym->declared_at,
5358 "for default initialization of a component");
5362 /* Assign default initializer. */
5363 if (sym->ts.type == BT_DERIVED && !sym->value && !sym->attr.pointer
5364 && !sym->attr.allocatable && (!flag || sym->attr.intent == INTENT_OUT))
5365 sym->value = gfc_default_initializer (&sym->ts);
5371 /* Resolve a procedure. */
5374 resolve_fl_procedure (gfc_symbol *sym, int mp_flag)
5376 gfc_formal_arglist *arg;
5378 if (sym->attr.function
5379 && resolve_fl_var_and_proc (sym, mp_flag) == FAILURE)
5382 if (sym->attr.proc == PROC_ST_FUNCTION)
5384 if (sym->ts.type == BT_CHARACTER)
5386 gfc_charlen *cl = sym->ts.cl;
5387 if (!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT)
5389 gfc_error ("Character-valued statement function '%s' at %L must "
5390 "have constant length", sym->name, &sym->declared_at);
5396 /* Ensure that derived type for are not of a private type. Internal
5397 module procedures are excluded by 2.2.3.3 - ie. they are not
5398 externally accessible and can access all the objects accessible in
5400 if (!(sym->ns->parent
5401 && sym->ns->parent->proc_name->attr.flavor == FL_MODULE)
5402 && gfc_check_access(sym->attr.access, sym->ns->default_access))
5404 for (arg = sym->formal; arg; arg = arg->next)
5407 && arg->sym->ts.type == BT_DERIVED
5408 && !arg->sym->ts.derived->attr.use_assoc
5409 && !gfc_check_access(arg->sym->ts.derived->attr.access,
5410 arg->sym->ts.derived->ns->default_access))
5412 gfc_error_now ("'%s' is of a PRIVATE type and cannot be "
5413 "a dummy argument of '%s', which is "
5414 "PUBLIC at %L", arg->sym->name, sym->name,
5416 /* Stop this message from recurring. */
5417 arg->sym->ts.derived->attr.access = ACCESS_PUBLIC;
5423 /* An external symbol may not have an initializer because it is taken to be
5425 if (sym->attr.external && sym->value)
5427 gfc_error ("External object '%s' at %L may not have an initializer",
5428 sym->name, &sym->declared_at);
5432 /* An elemental function is required to return a scalar 12.7.1 */
5433 if (sym->attr.elemental && sym->attr.function && sym->as)
5435 gfc_error ("ELEMENTAL function '%s' at %L must have a scalar "
5436 "result", sym->name, &sym->declared_at);
5437 /* Reset so that the error only occurs once. */
5438 sym->attr.elemental = 0;
5442 /* 5.1.1.5 of the Standard: A function name declared with an asterisk
5443 char-len-param shall not be array-valued, pointer-valued, recursive
5444 or pure. ....snip... A character value of * may only be used in the
5445 following ways: (i) Dummy arg of procedure - dummy associates with
5446 actual length; (ii) To declare a named constant; or (iii) External
5447 function - but length must be declared in calling scoping unit. */
5448 if (sym->attr.function
5449 && sym->ts.type == BT_CHARACTER
5450 && sym->ts.cl && sym->ts.cl->length == NULL)
5452 if ((sym->as && sym->as->rank) || (sym->attr.pointer)
5453 || (sym->attr.recursive) || (sym->attr.pure))
5455 if (sym->as && sym->as->rank)
5456 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
5457 "array-valued", sym->name, &sym->declared_at);
5459 if (sym->attr.pointer)
5460 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
5461 "pointer-valued", sym->name, &sym->declared_at);
5464 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
5465 "pure", sym->name, &sym->declared_at);
5467 if (sym->attr.recursive)
5468 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
5469 "recursive", sym->name, &sym->declared_at);
5474 /* Appendix B.2 of the standard. Contained functions give an
5475 error anyway. Fixed-form is likely to be F77/legacy. */
5476 if (!sym->attr.contained && gfc_current_form != FORM_FIXED)
5477 gfc_notify_std (GFC_STD_F95_OBS, "CHARACTER(*) function "
5478 "'%s' at %L is obsolescent in fortran 95",
5479 sym->name, &sym->declared_at);
5485 /* Resolve the components of a derived type. */
5488 resolve_fl_derived (gfc_symbol *sym)
5491 gfc_dt_list * dt_list;
5494 for (c = sym->components; c != NULL; c = c->next)
5496 if (c->ts.type == BT_CHARACTER)
5498 if (c->ts.cl->length == NULL
5499 || (resolve_charlen (c->ts.cl) == FAILURE)
5500 || !gfc_is_constant_expr (c->ts.cl->length))
5502 gfc_error ("Character length of component '%s' needs to "
5503 "be a constant specification expression at %L.",
5505 c->ts.cl->length ? &c->ts.cl->length->where : &c->loc);
5510 if (c->ts.type == BT_DERIVED
5511 && sym->component_access != ACCESS_PRIVATE
5512 && gfc_check_access(sym->attr.access, sym->ns->default_access)
5513 && !c->ts.derived->attr.use_assoc
5514 && !gfc_check_access(c->ts.derived->attr.access,
5515 c->ts.derived->ns->default_access))
5517 gfc_error ("The component '%s' is a PRIVATE type and cannot be "
5518 "a component of '%s', which is PUBLIC at %L",
5519 c->name, sym->name, &sym->declared_at);
5523 if (sym->attr.sequence)
5525 if (c->ts.type == BT_DERIVED && c->ts.derived->attr.sequence == 0)
5527 gfc_error ("Component %s of SEQUENCE type declared at %L does "
5528 "not have the SEQUENCE attribute",
5529 c->ts.derived->name, &sym->declared_at);
5534 if (c->pointer || c->as == NULL)
5537 for (i = 0; i < c->as->rank; i++)
5539 if (c->as->lower[i] == NULL
5540 || !gfc_is_constant_expr (c->as->lower[i])
5541 || (resolve_index_expr (c->as->lower[i]) == FAILURE)
5542 || c->as->upper[i] == NULL
5543 || (resolve_index_expr (c->as->upper[i]) == FAILURE)
5544 || !gfc_is_constant_expr (c->as->upper[i]))
5546 gfc_error ("Component '%s' of '%s' at %L must have "
5547 "constant array bounds.",
5548 c->name, sym->name, &c->loc);
5554 /* Add derived type to the derived type list. */
5555 for (dt_list = sym->ns->derived_types; dt_list; dt_list = dt_list->next)
5556 if (sym == dt_list->derived)
5559 if (dt_list == NULL)
5561 dt_list = gfc_get_dt_list ();
5562 dt_list->next = sym->ns->derived_types;
5563 dt_list->derived = sym;
5564 sym->ns->derived_types = dt_list;
5572 resolve_fl_namelist (gfc_symbol *sym)
5577 /* Reject PRIVATE objects in a PUBLIC namelist. */
5578 if (gfc_check_access(sym->attr.access, sym->ns->default_access))
5580 for (nl = sym->namelist; nl; nl = nl->next)
5582 if (!nl->sym->attr.use_assoc
5583 && !(sym->ns->parent == nl->sym->ns)
5584 && !gfc_check_access(nl->sym->attr.access,
5585 nl->sym->ns->default_access))
5587 gfc_error ("PRIVATE symbol '%s' cannot be member of "
5588 "PUBLIC namelist at %L", nl->sym->name,
5595 /* Reject namelist arrays that are not constant shape. */
5596 for (nl = sym->namelist; nl; nl = nl->next)
5598 if (is_non_constant_shape_array (nl->sym))
5600 gfc_error ("The array '%s' must have constant shape to be "
5601 "a NAMELIST object at %L", nl->sym->name,
5607 /* 14.1.2 A module or internal procedure represent local entities
5608 of the same type as a namelist member and so are not allowed.
5609 Note that this is sometimes caught by check_conflict so the
5610 same message has been used. */
5611 for (nl = sym->namelist; nl; nl = nl->next)
5614 if (sym->ns->parent && nl->sym && nl->sym->name)
5615 gfc_find_symbol (nl->sym->name, sym->ns->parent, 0, &nlsym);
5616 if (nlsym && nlsym->attr.flavor == FL_PROCEDURE)
5618 gfc_error ("PROCEDURE attribute conflicts with NAMELIST "
5619 "attribute in '%s' at %L", nlsym->name,
5630 resolve_fl_parameter (gfc_symbol *sym)
5632 /* A parameter array's shape needs to be constant. */
5633 if (sym->as != NULL && !gfc_is_compile_time_shape (sym->as))
5635 gfc_error ("Parameter array '%s' at %L cannot be automatic "
5636 "or assumed shape", sym->name, &sym->declared_at);
5640 /* Make sure a parameter that has been implicitly typed still
5641 matches the implicit type, since PARAMETER statements can precede
5642 IMPLICIT statements. */
5643 if (sym->attr.implicit_type
5644 && !gfc_compare_types (&sym->ts,
5645 gfc_get_default_type (sym, sym->ns)))
5647 gfc_error ("Implicitly typed PARAMETER '%s' at %L doesn't match a "
5648 "later IMPLICIT type", sym->name, &sym->declared_at);
5652 /* Make sure the types of derived parameters are consistent. This
5653 type checking is deferred until resolution because the type may
5654 refer to a derived type from the host. */
5655 if (sym->ts.type == BT_DERIVED
5656 && !gfc_compare_types (&sym->ts, &sym->value->ts))
5658 gfc_error ("Incompatible derived type in PARAMETER at %L",
5659 &sym->value->where);
5666 /* Do anything necessary to resolve a symbol. Right now, we just
5667 assume that an otherwise unknown symbol is a variable. This sort
5668 of thing commonly happens for symbols in module. */
5671 resolve_symbol (gfc_symbol * sym)
5673 /* Zero if we are checking a formal namespace. */
5674 static int formal_ns_flag = 1;
5675 int formal_ns_save, check_constant, mp_flag;
5676 gfc_symtree *symtree;
5677 gfc_symtree *this_symtree;
5681 if (sym->attr.flavor == FL_UNKNOWN)
5684 /* If we find that a flavorless symbol is an interface in one of the
5685 parent namespaces, find its symtree in this namespace, free the
5686 symbol and set the symtree to point to the interface symbol. */
5687 for (ns = gfc_current_ns->parent; ns; ns = ns->parent)
5689 symtree = gfc_find_symtree (ns->sym_root, sym->name);
5690 if (symtree && symtree->n.sym->generic)
5692 this_symtree = gfc_find_symtree (gfc_current_ns->sym_root,
5696 gfc_free_symbol (sym);
5697 symtree->n.sym->refs++;
5698 this_symtree->n.sym = symtree->n.sym;
5703 /* Otherwise give it a flavor according to such attributes as
5705 if (sym->attr.external == 0 && sym->attr.intrinsic == 0)
5706 sym->attr.flavor = FL_VARIABLE;
5709 sym->attr.flavor = FL_PROCEDURE;
5710 if (sym->attr.dimension)
5711 sym->attr.function = 1;
5715 if (sym->attr.flavor == FL_DERIVED && resolve_fl_derived (sym) == FAILURE)
5718 /* Symbols that are module procedures with results (functions) have
5719 the types and array specification copied for type checking in
5720 procedures that call them, as well as for saving to a module
5721 file. These symbols can't stand the scrutiny that their results
5723 mp_flag = (sym->result != NULL && sym->result != sym);
5725 /* Assign default type to symbols that need one and don't have one. */
5726 if (sym->ts.type == BT_UNKNOWN)
5728 if (sym->attr.flavor == FL_VARIABLE || sym->attr.flavor == FL_PARAMETER)
5729 gfc_set_default_type (sym, 1, NULL);
5731 if (sym->attr.flavor == FL_PROCEDURE && sym->attr.function)
5733 /* The specific case of an external procedure should emit an error
5734 in the case that there is no implicit type. */
5736 gfc_set_default_type (sym, sym->attr.external, NULL);
5739 /* Result may be in another namespace. */
5740 resolve_symbol (sym->result);
5742 sym->ts = sym->result->ts;
5743 sym->as = gfc_copy_array_spec (sym->result->as);
5744 sym->attr.dimension = sym->result->attr.dimension;
5745 sym->attr.pointer = sym->result->attr.pointer;
5746 sym->attr.allocatable = sym->result->attr.allocatable;
5751 /* Assumed size arrays and assumed shape arrays must be dummy
5755 && (sym->as->type == AS_ASSUMED_SIZE
5756 || sym->as->type == AS_ASSUMED_SHAPE)
5757 && sym->attr.dummy == 0)
5759 if (sym->as->type == AS_ASSUMED_SIZE)
5760 gfc_error ("Assumed size array at %L must be a dummy argument",
5763 gfc_error ("Assumed shape array at %L must be a dummy argument",
5768 /* Make sure symbols with known intent or optional are really dummy
5769 variable. Because of ENTRY statement, this has to be deferred
5770 until resolution time. */
5772 if (!sym->attr.dummy
5773 && (sym->attr.optional
5774 || sym->attr.intent != INTENT_UNKNOWN))
5776 gfc_error ("Symbol at %L is not a DUMMY variable", &sym->declared_at);
5780 /* If a derived type symbol has reached this point, without its
5781 type being declared, we have an error. Notice that most
5782 conditions that produce undefined derived types have already
5783 been dealt with. However, the likes of:
5784 implicit type(t) (t) ..... call foo (t) will get us here if
5785 the type is not declared in the scope of the implicit
5786 statement. Change the type to BT_UNKNOWN, both because it is so
5787 and to prevent an ICE. */
5788 if (sym->ts.type == BT_DERIVED
5789 && sym->ts.derived->components == NULL)
5791 gfc_error ("The derived type '%s' at %L is of type '%s', "
5792 "which has not been defined.", sym->name,
5793 &sym->declared_at, sym->ts.derived->name);
5794 sym->ts.type = BT_UNKNOWN;
5798 /* An assumed-size array with INTENT(OUT) shall not be of a type for which
5799 default initialization is defined (5.1.2.4.4). */
5800 if (sym->ts.type == BT_DERIVED
5802 && sym->attr.intent == INTENT_OUT
5804 && sym->as->type == AS_ASSUMED_SIZE)
5806 for (c = sym->ts.derived->components; c; c = c->next)
5810 gfc_error ("The INTENT(OUT) dummy argument '%s' at %L is "
5811 "ASSUMED SIZE and so cannot have a default initializer",
5812 sym->name, &sym->declared_at);
5818 switch (sym->attr.flavor)
5821 if (resolve_fl_variable (sym, mp_flag) == FAILURE)
5826 if (resolve_fl_procedure (sym, mp_flag) == FAILURE)
5831 if (resolve_fl_namelist (sym) == FAILURE)
5836 if (resolve_fl_parameter (sym) == FAILURE)
5846 /* Make sure that intrinsic exist */
5847 if (sym->attr.intrinsic
5848 && ! gfc_intrinsic_name(sym->name, 0)
5849 && ! gfc_intrinsic_name(sym->name, 1))
5850 gfc_error("Intrinsic at %L does not exist", &sym->declared_at);
5852 /* Resolve array specifier. Check as well some constraints
5853 on COMMON blocks. */
5855 check_constant = sym->attr.in_common && !sym->attr.pointer;
5856 gfc_resolve_array_spec (sym->as, check_constant);
5858 /* Resolve formal namespaces. */
5860 if (formal_ns_flag && sym != NULL && sym->formal_ns != NULL)
5862 formal_ns_save = formal_ns_flag;
5864 gfc_resolve (sym->formal_ns);
5865 formal_ns_flag = formal_ns_save;
5868 /* Check threadprivate restrictions. */
5869 if (sym->attr.threadprivate && !sym->attr.save
5870 && (!sym->attr.in_common
5871 && sym->module == NULL
5872 && (sym->ns->proc_name == NULL
5873 || sym->ns->proc_name->attr.flavor != FL_MODULE)))
5874 gfc_error ("Threadprivate at %L isn't SAVEd", &sym->declared_at);
5879 /************* Resolve DATA statements *************/
5883 gfc_data_value *vnode;
5889 /* Advance the values structure to point to the next value in the data list. */
5892 next_data_value (void)
5894 while (values.left == 0)
5896 if (values.vnode->next == NULL)
5899 values.vnode = values.vnode->next;
5900 values.left = values.vnode->repeat;
5908 check_data_variable (gfc_data_variable * var, locus * where)
5914 ar_type mark = AR_UNKNOWN;
5916 mpz_t section_index[GFC_MAX_DIMENSIONS];
5920 if (gfc_resolve_expr (var->expr) == FAILURE)
5924 mpz_init_set_si (offset, 0);
5927 if (e->expr_type != EXPR_VARIABLE)
5928 gfc_internal_error ("check_data_variable(): Bad expression");
5930 if (e->symtree->n.sym->ns->is_block_data
5931 && !e->symtree->n.sym->attr.in_common)
5933 gfc_error ("BLOCK DATA element '%s' at %L must be in COMMON",
5934 e->symtree->n.sym->name, &e->symtree->n.sym->declared_at);
5939 mpz_init_set_ui (size, 1);
5946 /* Find the array section reference. */
5947 for (ref = e->ref; ref; ref = ref->next)
5949 if (ref->type != REF_ARRAY)
5951 if (ref->u.ar.type == AR_ELEMENT)
5957 /* Set marks according to the reference pattern. */
5958 switch (ref->u.ar.type)
5966 /* Get the start position of array section. */
5967 gfc_get_section_index (ar, section_index, &offset);
5975 if (gfc_array_size (e, &size) == FAILURE)
5977 gfc_error ("Nonconstant array section at %L in DATA statement",
5986 while (mpz_cmp_ui (size, 0) > 0)
5988 if (next_data_value () == FAILURE)
5990 gfc_error ("DATA statement at %L has more variables than values",
5996 t = gfc_check_assign (var->expr, values.vnode->expr, 0);
6000 /* If we have more than one element left in the repeat count,
6001 and we have more than one element left in the target variable,
6002 then create a range assignment. */
6003 /* ??? Only done for full arrays for now, since array sections
6005 if (mark == AR_FULL && ref && ref->next == NULL
6006 && values.left > 1 && mpz_cmp_ui (size, 1) > 0)
6010 if (mpz_cmp_ui (size, values.left) >= 0)
6012 mpz_init_set_ui (range, values.left);
6013 mpz_sub_ui (size, size, values.left);
6018 mpz_init_set (range, size);
6019 values.left -= mpz_get_ui (size);
6020 mpz_set_ui (size, 0);
6023 gfc_assign_data_value_range (var->expr, values.vnode->expr,
6026 mpz_add (offset, offset, range);
6030 /* Assign initial value to symbol. */
6034 mpz_sub_ui (size, size, 1);
6036 gfc_assign_data_value (var->expr, values.vnode->expr, offset);
6038 if (mark == AR_FULL)
6039 mpz_add_ui (offset, offset, 1);
6041 /* Modify the array section indexes and recalculate the offset
6042 for next element. */
6043 else if (mark == AR_SECTION)
6044 gfc_advance_section (section_index, ar, &offset);
6048 if (mark == AR_SECTION)
6050 for (i = 0; i < ar->dimen; i++)
6051 mpz_clear (section_index[i]);
6061 static try traverse_data_var (gfc_data_variable *, locus *);
6063 /* Iterate over a list of elements in a DATA statement. */
6066 traverse_data_list (gfc_data_variable * var, locus * where)
6069 iterator_stack frame;
6072 mpz_init (frame.value);
6074 mpz_init_set (trip, var->iter.end->value.integer);
6075 mpz_sub (trip, trip, var->iter.start->value.integer);
6076 mpz_add (trip, trip, var->iter.step->value.integer);
6078 mpz_div (trip, trip, var->iter.step->value.integer);
6080 mpz_set (frame.value, var->iter.start->value.integer);
6082 frame.prev = iter_stack;
6083 frame.variable = var->iter.var->symtree;
6084 iter_stack = &frame;
6086 while (mpz_cmp_ui (trip, 0) > 0)
6088 if (traverse_data_var (var->list, where) == FAILURE)
6094 e = gfc_copy_expr (var->expr);
6095 if (gfc_simplify_expr (e, 1) == FAILURE)
6101 mpz_add (frame.value, frame.value, var->iter.step->value.integer);
6103 mpz_sub_ui (trip, trip, 1);
6107 mpz_clear (frame.value);
6109 iter_stack = frame.prev;
6114 /* Type resolve variables in the variable list of a DATA statement. */
6117 traverse_data_var (gfc_data_variable * var, locus * where)
6121 for (; var; var = var->next)
6123 if (var->expr == NULL)
6124 t = traverse_data_list (var, where);
6126 t = check_data_variable (var, where);
6136 /* Resolve the expressions and iterators associated with a data statement.
6137 This is separate from the assignment checking because data lists should
6138 only be resolved once. */
6141 resolve_data_variables (gfc_data_variable * d)
6143 for (; d; d = d->next)
6145 if (d->list == NULL)
6147 if (gfc_resolve_expr (d->expr) == FAILURE)
6152 if (gfc_resolve_iterator (&d->iter, false) == FAILURE)
6155 if (d->iter.start->expr_type != EXPR_CONSTANT
6156 || d->iter.end->expr_type != EXPR_CONSTANT
6157 || d->iter.step->expr_type != EXPR_CONSTANT)
6158 gfc_internal_error ("resolve_data_variables(): Bad iterator");
6160 if (resolve_data_variables (d->list) == FAILURE)
6169 /* Resolve a single DATA statement. We implement this by storing a pointer to
6170 the value list into static variables, and then recursively traversing the
6171 variables list, expanding iterators and such. */
6174 resolve_data (gfc_data * d)
6176 if (resolve_data_variables (d->var) == FAILURE)
6179 values.vnode = d->value;
6180 values.left = (d->value == NULL) ? 0 : d->value->repeat;
6182 if (traverse_data_var (d->var, &d->where) == FAILURE)
6185 /* At this point, we better not have any values left. */
6187 if (next_data_value () == SUCCESS)
6188 gfc_error ("DATA statement at %L has more values than variables",
6193 /* Determines if a variable is not 'pure', ie not assignable within a pure
6194 procedure. Returns zero if assignment is OK, nonzero if there is a problem.
6198 gfc_impure_variable (gfc_symbol * sym)
6200 if (sym->attr.use_assoc || sym->attr.in_common)
6203 if (sym->ns != gfc_current_ns)
6204 return !sym->attr.function;
6206 /* TODO: Check storage association through EQUIVALENCE statements */
6212 /* Test whether a symbol is pure or not. For a NULL pointer, checks the
6213 symbol of the current procedure. */
6216 gfc_pure (gfc_symbol * sym)
6218 symbol_attribute attr;
6221 sym = gfc_current_ns->proc_name;
6227 return attr.flavor == FL_PROCEDURE && (attr.pure || attr.elemental);
6231 /* Test whether the current procedure is elemental or not. */
6234 gfc_elemental (gfc_symbol * sym)
6236 symbol_attribute attr;
6239 sym = gfc_current_ns->proc_name;
6244 return attr.flavor == FL_PROCEDURE && attr.elemental;
6248 /* Warn about unused labels. */
6251 warn_unused_fortran_label (gfc_st_label * label)
6256 warn_unused_fortran_label (label->left);
6258 if (label->defined == ST_LABEL_UNKNOWN)
6261 switch (label->referenced)
6263 case ST_LABEL_UNKNOWN:
6264 gfc_warning ("Label %d at %L defined but not used", label->value,
6268 case ST_LABEL_BAD_TARGET:
6269 gfc_warning ("Label %d at %L defined but cannot be used",
6270 label->value, &label->where);
6277 warn_unused_fortran_label (label->right);
6281 /* Returns the sequence type of a symbol or sequence. */
6284 sequence_type (gfc_typespec ts)
6293 if (ts.derived->components == NULL)
6294 return SEQ_NONDEFAULT;
6296 result = sequence_type (ts.derived->components->ts);
6297 for (c = ts.derived->components->next; c; c = c->next)
6298 if (sequence_type (c->ts) != result)
6304 if (ts.kind != gfc_default_character_kind)
6305 return SEQ_NONDEFAULT;
6307 return SEQ_CHARACTER;
6310 if (ts.kind != gfc_default_integer_kind)
6311 return SEQ_NONDEFAULT;
6316 if (!(ts.kind == gfc_default_real_kind
6317 || ts.kind == gfc_default_double_kind))
6318 return SEQ_NONDEFAULT;
6323 if (ts.kind != gfc_default_complex_kind)
6324 return SEQ_NONDEFAULT;
6329 if (ts.kind != gfc_default_logical_kind)
6330 return SEQ_NONDEFAULT;
6335 return SEQ_NONDEFAULT;
6340 /* Resolve derived type EQUIVALENCE object. */
6343 resolve_equivalence_derived (gfc_symbol *derived, gfc_symbol *sym, gfc_expr *e)
6346 gfc_component *c = derived->components;
6351 /* Shall not be an object of nonsequence derived type. */
6352 if (!derived->attr.sequence)
6354 gfc_error ("Derived type variable '%s' at %L must have SEQUENCE "
6355 "attribute to be an EQUIVALENCE object", sym->name, &e->where);
6359 for (; c ; c = c->next)
6362 if (d && (resolve_equivalence_derived (c->ts.derived, sym, e) == FAILURE))
6365 /* Shall not be an object of sequence derived type containing a pointer
6366 in the structure. */
6369 gfc_error ("Derived type variable '%s' at %L with pointer component(s) "
6370 "cannot be an EQUIVALENCE object", sym->name, &e->where);
6376 gfc_error ("Derived type variable '%s' at %L with default initializer "
6377 "cannot be an EQUIVALENCE object", sym->name, &e->where);
6385 /* Resolve equivalence object.
6386 An EQUIVALENCE object shall not be a dummy argument, a pointer, a target,
6387 an allocatable array, an object of nonsequence derived type, an object of
6388 sequence derived type containing a pointer at any level of component
6389 selection, an automatic object, a function name, an entry name, a result
6390 name, a named constant, a structure component, or a subobject of any of
6391 the preceding objects. A substring shall not have length zero. A
6392 derived type shall not have components with default initialization nor
6393 shall two objects of an equivalence group be initialized.
6394 The simple constraints are done in symbol.c(check_conflict) and the rest
6395 are implemented here. */
6398 resolve_equivalence (gfc_equiv *eq)
6401 gfc_symbol *derived;
6402 gfc_symbol *first_sym;
6405 locus *last_where = NULL;
6406 seq_type eq_type, last_eq_type;
6407 gfc_typespec *last_ts;
6409 const char *value_name;
6413 last_ts = &eq->expr->symtree->n.sym->ts;
6415 first_sym = eq->expr->symtree->n.sym;
6417 for (object = 1; eq; eq = eq->eq, object++)
6421 e->ts = e->symtree->n.sym->ts;
6422 /* match_varspec might not know yet if it is seeing
6423 array reference or substring reference, as it doesn't
6425 if (e->ref && e->ref->type == REF_ARRAY)
6427 gfc_ref *ref = e->ref;
6428 sym = e->symtree->n.sym;
6430 if (sym->attr.dimension)
6432 ref->u.ar.as = sym->as;
6436 /* For substrings, convert REF_ARRAY into REF_SUBSTRING. */
6437 if (e->ts.type == BT_CHARACTER
6439 && ref->type == REF_ARRAY
6440 && ref->u.ar.dimen == 1
6441 && ref->u.ar.dimen_type[0] == DIMEN_RANGE
6442 && ref->u.ar.stride[0] == NULL)
6444 gfc_expr *start = ref->u.ar.start[0];
6445 gfc_expr *end = ref->u.ar.end[0];
6448 /* Optimize away the (:) reference. */
6449 if (start == NULL && end == NULL)
6454 e->ref->next = ref->next;
6459 ref->type = REF_SUBSTRING;
6461 start = gfc_int_expr (1);
6462 ref->u.ss.start = start;
6463 if (end == NULL && e->ts.cl)
6464 end = gfc_copy_expr (e->ts.cl->length);
6465 ref->u.ss.end = end;
6466 ref->u.ss.length = e->ts.cl;
6473 /* Any further ref is an error. */
6476 gcc_assert (ref->type == REF_ARRAY);
6477 gfc_error ("Syntax error in EQUIVALENCE statement at %L",
6483 if (gfc_resolve_expr (e) == FAILURE)
6486 sym = e->symtree->n.sym;
6488 /* An equivalence statement cannot have more than one initialized
6492 if (value_name != NULL)
6494 gfc_error ("Initialized objects '%s' and '%s' cannot both "
6495 "be in the EQUIVALENCE statement at %L",
6496 value_name, sym->name, &e->where);
6500 value_name = sym->name;
6503 /* Shall not equivalence common block variables in a PURE procedure. */
6504 if (sym->ns->proc_name
6505 && sym->ns->proc_name->attr.pure
6506 && sym->attr.in_common)
6508 gfc_error ("Common block member '%s' at %L cannot be an EQUIVALENCE "
6509 "object in the pure procedure '%s'",
6510 sym->name, &e->where, sym->ns->proc_name->name);
6514 /* Shall not be a named constant. */
6515 if (e->expr_type == EXPR_CONSTANT)
6517 gfc_error ("Named constant '%s' at %L cannot be an EQUIVALENCE "
6518 "object", sym->name, &e->where);
6522 derived = e->ts.derived;
6523 if (derived && resolve_equivalence_derived (derived, sym, e) == FAILURE)
6526 /* Check that the types correspond correctly:
6528 A numeric sequence structure may be equivalenced to another sequence
6529 structure, an object of default integer type, default real type, double
6530 precision real type, default logical type such that components of the
6531 structure ultimately only become associated to objects of the same
6532 kind. A character sequence structure may be equivalenced to an object
6533 of default character kind or another character sequence structure.
6534 Other objects may be equivalenced only to objects of the same type and
6537 /* Identical types are unconditionally OK. */
6538 if (object == 1 || gfc_compare_types (last_ts, &sym->ts))
6539 goto identical_types;
6541 last_eq_type = sequence_type (*last_ts);
6542 eq_type = sequence_type (sym->ts);
6544 /* Since the pair of objects is not of the same type, mixed or
6545 non-default sequences can be rejected. */
6547 msg = "Sequence %s with mixed components in EQUIVALENCE "
6548 "statement at %L with different type objects";
6550 && last_eq_type == SEQ_MIXED
6551 && gfc_notify_std (GFC_STD_GNU, msg, first_sym->name,
6552 last_where) == FAILURE)
6553 || (eq_type == SEQ_MIXED
6554 && gfc_notify_std (GFC_STD_GNU, msg,sym->name,
6555 &e->where) == FAILURE))
6558 msg = "Non-default type object or sequence %s in EQUIVALENCE "
6559 "statement at %L with objects of different type";
6561 && last_eq_type == SEQ_NONDEFAULT
6562 && gfc_notify_std (GFC_STD_GNU, msg, first_sym->name,
6563 last_where) == FAILURE)
6564 || (eq_type == SEQ_NONDEFAULT
6565 && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
6566 &e->where) == FAILURE))
6569 msg ="Non-CHARACTER object '%s' in default CHARACTER "
6570 "EQUIVALENCE statement at %L";
6571 if (last_eq_type == SEQ_CHARACTER
6572 && eq_type != SEQ_CHARACTER
6573 && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
6574 &e->where) == FAILURE)
6577 msg ="Non-NUMERIC object '%s' in default NUMERIC "
6578 "EQUIVALENCE statement at %L";
6579 if (last_eq_type == SEQ_NUMERIC
6580 && eq_type != SEQ_NUMERIC
6581 && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
6582 &e->where) == FAILURE)
6587 last_where = &e->where;
6592 /* Shall not be an automatic array. */
6593 if (e->ref->type == REF_ARRAY
6594 && gfc_resolve_array_spec (e->ref->u.ar.as, 1) == FAILURE)
6596 gfc_error ("Array '%s' at %L with non-constant bounds cannot be "
6597 "an EQUIVALENCE object", sym->name, &e->where);
6604 /* Shall not be a structure component. */
6605 if (r->type == REF_COMPONENT)
6607 gfc_error ("Structure component '%s' at %L cannot be an "
6608 "EQUIVALENCE object",
6609 r->u.c.component->name, &e->where);
6613 /* A substring shall not have length zero. */
6614 if (r->type == REF_SUBSTRING)
6616 if (compare_bound (r->u.ss.start, r->u.ss.end) == CMP_GT)
6618 gfc_error ("Substring at %L has length zero",
6619 &r->u.ss.start->where);
6629 /* Resolve function and ENTRY types, issue diagnostics if needed. */
6632 resolve_fntype (gfc_namespace * ns)
6637 if (ns->proc_name == NULL || !ns->proc_name->attr.function)
6640 /* If there are any entries, ns->proc_name is the entry master
6641 synthetic symbol and ns->entries->sym actual FUNCTION symbol. */
6643 sym = ns->entries->sym;
6645 sym = ns->proc_name;
6646 if (sym->result == sym
6647 && sym->ts.type == BT_UNKNOWN
6648 && gfc_set_default_type (sym, 0, NULL) == FAILURE
6649 && !sym->attr.untyped)
6651 gfc_error ("Function '%s' at %L has no IMPLICIT type",
6652 sym->name, &sym->declared_at);
6653 sym->attr.untyped = 1;
6656 if (sym->ts.type == BT_DERIVED && !sym->ts.derived->attr.use_assoc
6657 && !gfc_check_access (sym->ts.derived->attr.access,
6658 sym->ts.derived->ns->default_access)
6659 && gfc_check_access (sym->attr.access, sym->ns->default_access))
6661 gfc_error ("PUBLIC function '%s' at %L cannot be of PRIVATE type '%s'",
6662 sym->name, &sym->declared_at, sym->ts.derived->name);
6665 /* Make sure that the type of a module derived type function is in the
6666 module namespace, by copying it from the namespace's derived type
6667 list, if necessary. */
6668 if (sym->ts.type == BT_DERIVED
6669 && sym->ns->proc_name->attr.flavor == FL_MODULE
6670 && sym->ts.derived->ns
6671 && sym->ns != sym->ts.derived->ns)
6673 gfc_dt_list *dt = sym->ns->derived_types;
6675 for (; dt; dt = dt->next)
6676 if (gfc_compare_derived_types (sym->ts.derived, dt->derived))
6677 sym->ts.derived = dt->derived;
6681 for (el = ns->entries->next; el; el = el->next)
6683 if (el->sym->result == el->sym
6684 && el->sym->ts.type == BT_UNKNOWN
6685 && gfc_set_default_type (el->sym, 0, NULL) == FAILURE
6686 && !el->sym->attr.untyped)
6688 gfc_error ("ENTRY '%s' at %L has no IMPLICIT type",
6689 el->sym->name, &el->sym->declared_at);
6690 el->sym->attr.untyped = 1;
6695 /* 12.3.2.1.1 Defined operators. */
6698 gfc_resolve_uops(gfc_symtree *symtree)
6702 gfc_formal_arglist *formal;
6704 if (symtree == NULL)
6707 gfc_resolve_uops (symtree->left);
6708 gfc_resolve_uops (symtree->right);
6710 for (itr = symtree->n.uop->operator; itr; itr = itr->next)
6713 if (!sym->attr.function)
6714 gfc_error("User operator procedure '%s' at %L must be a FUNCTION",
6715 sym->name, &sym->declared_at);
6717 if (sym->ts.type == BT_CHARACTER
6718 && !(sym->ts.cl && sym->ts.cl->length)
6719 && !(sym->result && sym->result->ts.cl && sym->result->ts.cl->length))
6720 gfc_error("User operator procedure '%s' at %L cannot be assumed character "
6721 "length", sym->name, &sym->declared_at);
6723 formal = sym->formal;
6724 if (!formal || !formal->sym)
6726 gfc_error("User operator procedure '%s' at %L must have at least "
6727 "one argument", sym->name, &sym->declared_at);
6731 if (formal->sym->attr.intent != INTENT_IN)
6732 gfc_error ("First argument of operator interface at %L must be "
6733 "INTENT(IN)", &sym->declared_at);
6735 if (formal->sym->attr.optional)
6736 gfc_error ("First argument of operator interface at %L cannot be "
6737 "optional", &sym->declared_at);
6739 formal = formal->next;
6740 if (!formal || !formal->sym)
6743 if (formal->sym->attr.intent != INTENT_IN)
6744 gfc_error ("Second argument of operator interface at %L must be "
6745 "INTENT(IN)", &sym->declared_at);
6747 if (formal->sym->attr.optional)
6748 gfc_error ("Second argument of operator interface at %L cannot be "
6749 "optional", &sym->declared_at);
6752 gfc_error ("Operator interface at %L must have, at most, two "
6753 "arguments", &sym->declared_at);
6758 /* Examine all of the expressions associated with a program unit,
6759 assign types to all intermediate expressions, make sure that all
6760 assignments are to compatible types and figure out which names
6761 refer to which functions or subroutines. It doesn't check code
6762 block, which is handled by resolve_code. */
6765 resolve_types (gfc_namespace * ns)
6772 gfc_current_ns = ns;
6774 resolve_entries (ns);
6776 resolve_contained_functions (ns);
6778 gfc_traverse_ns (ns, resolve_symbol);
6780 resolve_fntype (ns);
6782 for (n = ns->contained; n; n = n->sibling)
6784 if (gfc_pure (ns->proc_name) && !gfc_pure (n->proc_name))
6785 gfc_error ("Contained procedure '%s' at %L of a PURE procedure must "
6786 "also be PURE", n->proc_name->name,
6787 &n->proc_name->declared_at);
6793 gfc_check_interfaces (ns);
6795 for (cl = ns->cl_list; cl; cl = cl->next)
6796 resolve_charlen (cl);
6798 gfc_traverse_ns (ns, resolve_values);
6804 for (d = ns->data; d; d = d->next)
6808 gfc_traverse_ns (ns, gfc_formalize_init_value);
6810 for (eq = ns->equiv; eq; eq = eq->next)
6811 resolve_equivalence (eq);
6813 /* Warn about unused labels. */
6814 if (gfc_option.warn_unused_labels)
6815 warn_unused_fortran_label (ns->st_labels);
6817 gfc_resolve_uops (ns->uop_root);
6821 /* Call resolve_code recursively. */
6824 resolve_codes (gfc_namespace * ns)
6828 for (n = ns->contained; n; n = n->sibling)
6831 gfc_current_ns = ns;
6833 /* Set to an out of range value. */
6834 current_entry_id = -1;
6835 resolve_code (ns->code, ns);
6839 /* This function is called after a complete program unit has been compiled.
6840 Its purpose is to examine all of the expressions associated with a program
6841 unit, assign types to all intermediate expressions, make sure that all
6842 assignments are to compatible types and figure out which names refer to
6843 which functions or subroutines. */
6846 gfc_resolve (gfc_namespace * ns)
6848 gfc_namespace *old_ns;
6850 old_ns = gfc_current_ns;
6855 gfc_current_ns = old_ns;