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 ths 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;
423 gfc_add_function (&proc->attr, proc->name, NULL);
425 fts = &ns->entries->sym->result->ts;
426 if (fts->type == BT_UNKNOWN)
427 fts = gfc_get_default_type (ns->entries->sym->result, NULL);
428 for (el = ns->entries->next; el; el = el->next)
430 ts = &el->sym->result->ts;
431 if (ts->type == BT_UNKNOWN)
432 ts = gfc_get_default_type (el->sym->result, NULL);
433 if (! gfc_compare_types (ts, fts)
434 || (el->sym->result->attr.dimension
435 != ns->entries->sym->result->attr.dimension)
436 || (el->sym->result->attr.pointer
437 != ns->entries->sym->result->attr.pointer))
443 sym = ns->entries->sym->result;
444 /* All result types the same. */
446 if (sym->attr.dimension)
447 gfc_set_array_spec (proc, gfc_copy_array_spec (sym->as), NULL);
448 if (sym->attr.pointer)
449 gfc_add_pointer (&proc->attr, NULL);
453 /* Otherwise the result will be passed through a union by
455 proc->attr.mixed_entry_master = 1;
456 for (el = ns->entries; el; el = el->next)
458 sym = el->sym->result;
459 if (sym->attr.dimension)
461 if (el == ns->entries)
463 ("FUNCTION result %s can't be an array in FUNCTION %s at %L",
464 sym->name, ns->entries->sym->name, &sym->declared_at);
467 ("ENTRY result %s can't be an array in FUNCTION %s at %L",
468 sym->name, ns->entries->sym->name, &sym->declared_at);
470 else if (sym->attr.pointer)
472 if (el == ns->entries)
474 ("FUNCTION result %s can't be a POINTER in FUNCTION %s at %L",
475 sym->name, ns->entries->sym->name, &sym->declared_at);
478 ("ENTRY result %s can't be a POINTER in FUNCTION %s at %L",
479 sym->name, ns->entries->sym->name, &sym->declared_at);
484 if (ts->type == BT_UNKNOWN)
485 ts = gfc_get_default_type (sym, NULL);
489 if (ts->kind == gfc_default_integer_kind)
493 if (ts->kind == gfc_default_real_kind
494 || ts->kind == gfc_default_double_kind)
498 if (ts->kind == gfc_default_complex_kind)
502 if (ts->kind == gfc_default_logical_kind)
506 /* We will issue error elsewhere. */
514 if (el == ns->entries)
516 ("FUNCTION result %s can't be of type %s in FUNCTION %s at %L",
517 sym->name, gfc_typename (ts), ns->entries->sym->name,
521 ("ENTRY result %s can't be of type %s in FUNCTION %s at %L",
522 sym->name, gfc_typename (ts), ns->entries->sym->name,
529 proc->attr.access = ACCESS_PRIVATE;
530 proc->attr.entry_master = 1;
532 /* Merge all the entry point arguments. */
533 for (el = ns->entries; el; el = el->next)
534 merge_argument_lists (proc, el->sym->formal);
536 /* Use the master function for the function body. */
537 ns->proc_name = proc;
539 /* Finalize the new symbols. */
540 gfc_commit_symbols ();
542 /* Restore the original namespace. */
543 gfc_current_ns = old_ns;
547 /* Resolve contained function types. Because contained functions can call one
548 another, they have to be worked out before any of the contained procedures
551 The good news is that if a function doesn't already have a type, the only
552 way it can get one is through an IMPLICIT type or a RESULT variable, because
553 by definition contained functions are contained namespace they're contained
554 in, not in a sibling or parent namespace. */
557 resolve_contained_functions (gfc_namespace * ns)
559 gfc_namespace *child;
562 resolve_formal_arglists (ns);
564 for (child = ns->contained; child; child = child->sibling)
566 /* Resolve alternate entry points first. */
567 resolve_entries (child);
569 /* Then check function return types. */
570 resolve_contained_fntype (child->proc_name, child);
571 for (el = child->entries; el; el = el->next)
572 resolve_contained_fntype (el->sym, child);
577 /* Resolve all of the elements of a structure constructor and make sure that
578 the types are correct. */
581 resolve_structure_cons (gfc_expr * expr)
583 gfc_constructor *cons;
588 cons = expr->value.constructor;
589 /* A constructor may have references if it is the result of substituting a
590 parameter variable. In this case we just pull out the component we
593 comp = expr->ref->u.c.sym->components;
595 comp = expr->ts.derived->components;
597 for (; comp; comp = comp->next, cons = cons->next)
605 if (gfc_resolve_expr (cons->expr) == FAILURE)
611 /* If we don't have the right type, try to convert it. */
613 if (!gfc_compare_types (&cons->expr->ts, &comp->ts))
616 if (comp->pointer && cons->expr->ts.type != BT_UNKNOWN)
617 gfc_error ("The element in the derived type constructor at %L, "
618 "for pointer component '%s', is %s but should be %s",
619 &cons->expr->where, comp->name,
620 gfc_basic_typename (cons->expr->ts.type),
621 gfc_basic_typename (comp->ts.type));
623 t = gfc_convert_type (cons->expr, &comp->ts, 1);
632 /****************** Expression name resolution ******************/
634 /* Returns 0 if a symbol was not declared with a type or
635 attribute declaration statement, nonzero otherwise. */
638 was_declared (gfc_symbol * sym)
644 if (!a.implicit_type && sym->ts.type != BT_UNKNOWN)
647 if (a.allocatable || a.dimension || a.dummy || a.external || a.intrinsic
648 || a.optional || a.pointer || a.save || a.target
649 || a.access != ACCESS_UNKNOWN || a.intent != INTENT_UNKNOWN)
656 /* Determine if a symbol is generic or not. */
659 generic_sym (gfc_symbol * sym)
663 if (sym->attr.generic ||
664 (sym->attr.intrinsic && gfc_generic_intrinsic (sym->name)))
667 if (was_declared (sym) || sym->ns->parent == NULL)
670 gfc_find_symbol (sym->name, sym->ns->parent, 1, &s);
672 return (s == NULL) ? 0 : generic_sym (s);
676 /* Determine if a symbol is specific or not. */
679 specific_sym (gfc_symbol * sym)
683 if (sym->attr.if_source == IFSRC_IFBODY
684 || sym->attr.proc == PROC_MODULE
685 || sym->attr.proc == PROC_INTERNAL
686 || sym->attr.proc == PROC_ST_FUNCTION
687 || (sym->attr.intrinsic &&
688 gfc_specific_intrinsic (sym->name))
689 || sym->attr.external)
692 if (was_declared (sym) || sym->ns->parent == NULL)
695 gfc_find_symbol (sym->name, sym->ns->parent, 1, &s);
697 return (s == NULL) ? 0 : specific_sym (s);
701 /* Figure out if the procedure is specific, generic or unknown. */
704 { PTYPE_GENERIC = 1, PTYPE_SPECIFIC, PTYPE_UNKNOWN }
708 procedure_kind (gfc_symbol * sym)
711 if (generic_sym (sym))
712 return PTYPE_GENERIC;
714 if (specific_sym (sym))
715 return PTYPE_SPECIFIC;
717 return PTYPE_UNKNOWN;
720 /* Check references to assumed size arrays. The flag need_full_assumed_size
721 is nonzero when matching actual arguments. */
723 static int need_full_assumed_size = 0;
726 check_assumed_size_reference (gfc_symbol * sym, gfc_expr * e)
732 if (need_full_assumed_size
733 || !(sym->as && sym->as->type == AS_ASSUMED_SIZE))
736 for (ref = e->ref; ref; ref = ref->next)
737 if (ref->type == REF_ARRAY)
738 for (dim = 0; dim < ref->u.ar.as->rank; dim++)
739 last = (ref->u.ar.end[dim] == NULL) && (ref->u.ar.type == DIMEN_ELEMENT);
743 gfc_error ("The upper bound in the last dimension must "
744 "appear in the reference to the assumed size "
745 "array '%s' at %L.", sym->name, &e->where);
752 /* Look for bad assumed size array references in argument expressions
753 of elemental and array valued intrinsic procedures. Since this is
754 called from procedure resolution functions, it only recurses at
758 resolve_assumed_size_actual (gfc_expr *e)
763 switch (e->expr_type)
767 && check_assumed_size_reference (e->symtree->n.sym, e))
772 if (resolve_assumed_size_actual (e->value.op.op1)
773 || resolve_assumed_size_actual (e->value.op.op2))
784 /* Resolve an actual argument list. Most of the time, this is just
785 resolving the expressions in the list.
786 The exception is that we sometimes have to decide whether arguments
787 that look like procedure arguments are really simple variable
791 resolve_actual_arglist (gfc_actual_arglist * arg)
794 gfc_symtree *parent_st;
797 for (; arg; arg = arg->next)
803 /* Check the label is a valid branching target. */
806 if (arg->label->defined == ST_LABEL_UNKNOWN)
808 gfc_error ("Label %d referenced at %L is never defined",
809 arg->label->value, &arg->label->where);
816 if (e->ts.type != BT_PROCEDURE)
818 if (gfc_resolve_expr (e) != SUCCESS)
823 /* See if the expression node should really be a variable
826 sym = e->symtree->n.sym;
828 if (sym->attr.flavor == FL_PROCEDURE
829 || sym->attr.intrinsic
830 || sym->attr.external)
833 /* If a procedure is not already determined to be something else
834 check if it is intrinsic. */
835 if (!sym->attr.intrinsic
836 && !(sym->attr.external || sym->attr.use_assoc
837 || sym->attr.if_source == IFSRC_IFBODY)
838 && gfc_intrinsic_name (sym->name, sym->attr.subroutine))
839 sym->attr.intrinsic = 1;
841 if (sym->attr.proc == PROC_ST_FUNCTION)
843 gfc_error ("Statement function '%s' at %L is not allowed as an "
844 "actual argument", sym->name, &e->where);
847 if (sym->attr.contained && !sym->attr.use_assoc
848 && sym->ns->proc_name->attr.flavor != FL_MODULE)
850 gfc_error ("Internal procedure '%s' is not allowed as an "
851 "actual argument at %L", sym->name, &e->where);
854 if (sym->attr.elemental && !sym->attr.intrinsic)
856 gfc_error ("ELEMENTAL non-INTRINSIC procedure '%s' is not "
857 "allowed as an actual argument at %L", sym->name,
861 if (sym->attr.generic)
863 gfc_error ("GENERIC non-INTRINSIC procedure '%s' is not "
864 "allowed as an actual argument at %L", sym->name,
868 /* If the symbol is the function that names the current (or
869 parent) scope, then we really have a variable reference. */
871 if (sym->attr.function && sym->result == sym
872 && (sym->ns->proc_name == sym
873 || (sym->ns->parent != NULL
874 && sym->ns->parent->proc_name == sym)))
880 /* See if the name is a module procedure in a parent unit. */
882 if (was_declared (sym) || sym->ns->parent == NULL)
885 if (gfc_find_sym_tree (sym->name, sym->ns->parent, 1, &parent_st))
887 gfc_error ("Symbol '%s' at %L is ambiguous", sym->name, &e->where);
891 if (parent_st == NULL)
894 sym = parent_st->n.sym;
895 e->symtree = parent_st; /* Point to the right thing. */
897 if (sym->attr.flavor == FL_PROCEDURE
898 || sym->attr.intrinsic
899 || sym->attr.external)
905 e->expr_type = EXPR_VARIABLE;
909 e->rank = sym->as->rank;
910 e->ref = gfc_get_ref ();
911 e->ref->type = REF_ARRAY;
912 e->ref->u.ar.type = AR_FULL;
913 e->ref->u.ar.as = sym->as;
921 /* Do the checks of the actual argument list that are specific to elemental
922 procedures. If called with c == NULL, we have a function, otherwise if
923 expr == NULL, we have a subroutine. */
925 resolve_elemental_actual (gfc_expr *expr, gfc_code *c)
927 gfc_actual_arglist *arg0;
928 gfc_actual_arglist *arg;
929 gfc_symbol *esym = NULL;
930 gfc_intrinsic_sym *isym = NULL;
932 gfc_intrinsic_arg *iformal = NULL;
933 gfc_formal_arglist *eformal = NULL;
934 bool formal_optional = false;
935 bool set_by_optional = false;
939 /* Is this an elemental procedure? */
940 if (expr && expr->value.function.actual != NULL)
942 if (expr->value.function.esym != NULL
943 && expr->value.function.esym->attr.elemental)
945 arg0 = expr->value.function.actual;
946 esym = expr->value.function.esym;
948 else if (expr->value.function.isym != NULL
949 && expr->value.function.isym->elemental)
951 arg0 = expr->value.function.actual;
952 isym = expr->value.function.isym;
957 else if (c && c->ext.actual != NULL
958 && c->symtree->n.sym->attr.elemental)
960 arg0 = c->ext.actual;
961 esym = c->symtree->n.sym;
966 /* The rank of an elemental is the rank of its array argument(s). */
967 for (arg = arg0; arg; arg = arg->next)
969 if (arg->expr != NULL && arg->expr->rank > 0)
971 rank = arg->expr->rank;
972 if (arg->expr->expr_type == EXPR_VARIABLE
973 && arg->expr->symtree->n.sym->attr.optional)
974 set_by_optional = true;
976 /* Function specific; set the result rank and shape. */
980 if (!expr->shape && arg->expr->shape)
982 expr->shape = gfc_get_shape (rank);
983 for (i = 0; i < rank; i++)
984 mpz_init_set (expr->shape[i], arg->expr->shape[i]);
991 /* If it is an array, it shall not be supplied as an actual argument
992 to an elemental procedure unless an array of the same rank is supplied
993 as an actual argument corresponding to a nonoptional dummy argument of
994 that elemental procedure(12.4.1.5). */
995 formal_optional = false;
997 iformal = isym->formal;
999 eformal = esym->formal;
1001 for (arg = arg0; arg; arg = arg->next)
1005 if (eformal->sym && eformal->sym->attr.optional)
1006 formal_optional = true;
1007 eformal = eformal->next;
1009 else if (isym && iformal)
1011 if (iformal->optional)
1012 formal_optional = true;
1013 iformal = iformal->next;
1016 formal_optional = true;
1018 if (pedantic && arg->expr != NULL
1019 && arg->expr->expr_type == EXPR_VARIABLE
1020 && arg->expr->symtree->n.sym->attr.optional
1023 && (set_by_optional || arg->expr->rank != rank)
1024 && !(isym && isym->generic_id == GFC_ISYM_CONVERSION))
1026 gfc_warning ("'%s' at %L is an array and OPTIONAL; IF IT IS "
1027 "MISSING, it cannot be the actual argument of an "
1028 "ELEMENTAL procedure unless there is a non-optional"
1029 "argument with the same rank (12.4.1.5)",
1030 arg->expr->symtree->n.sym->name, &arg->expr->where);
1035 for (arg = arg0; arg; arg = arg->next)
1037 if (arg->expr == NULL || arg->expr->rank == 0)
1040 /* Being elemental, the last upper bound of an assumed size array
1041 argument must be present. */
1042 if (resolve_assumed_size_actual (arg->expr))
1048 /* Elemental subroutine array actual arguments must conform. */
1051 if (gfc_check_conformance ("elemental subroutine", arg->expr, e)
1063 /* Go through each actual argument in ACTUAL and see if it can be
1064 implemented as an inlined, non-copying intrinsic. FNSYM is the
1065 function being called, or NULL if not known. */
1068 find_noncopying_intrinsics (gfc_symbol * fnsym, gfc_actual_arglist * actual)
1070 gfc_actual_arglist *ap;
1073 for (ap = actual; ap; ap = ap->next)
1075 && (expr = gfc_get_noncopying_intrinsic_argument (ap->expr))
1076 && !gfc_check_fncall_dependency (expr, INTENT_IN, fnsym, actual))
1077 ap->expr->inline_noncopying_intrinsic = 1;
1080 /* This function does the checking of references to global procedures
1081 as defined in sections 18.1 and 14.1, respectively, of the Fortran
1082 77 and 95 standards. It checks for a gsymbol for the name, making
1083 one if it does not already exist. If it already exists, then the
1084 reference being resolved must correspond to the type of gsymbol.
1085 Otherwise, the new symbol is equipped with the attributes of the
1086 reference. The corresponding code that is called in creating
1087 global entities is parse.c. */
1090 resolve_global_procedure (gfc_symbol *sym, locus *where, int sub)
1095 type = sub ? GSYM_SUBROUTINE : GSYM_FUNCTION;
1097 gsym = gfc_get_gsymbol (sym->name);
1099 if ((gsym->type != GSYM_UNKNOWN && gsym->type != type))
1100 global_used (gsym, where);
1102 if (gsym->type == GSYM_UNKNOWN)
1105 gsym->where = *where;
1111 /************* Function resolution *************/
1113 /* Resolve a function call known to be generic.
1114 Section 14.1.2.4.1. */
1117 resolve_generic_f0 (gfc_expr * expr, gfc_symbol * sym)
1121 if (sym->attr.generic)
1124 gfc_search_interface (sym->generic, 0, &expr->value.function.actual);
1127 expr->value.function.name = s->name;
1128 expr->value.function.esym = s;
1130 if (s->ts.type != BT_UNKNOWN)
1132 else if (s->result != NULL && s->result->ts.type != BT_UNKNOWN)
1133 expr->ts = s->result->ts;
1136 expr->rank = s->as->rank;
1137 else if (s->result != NULL && s->result->as != NULL)
1138 expr->rank = s->result->as->rank;
1143 /* TODO: Need to search for elemental references in generic interface */
1146 if (sym->attr.intrinsic)
1147 return gfc_intrinsic_func_interface (expr, 0);
1154 resolve_generic_f (gfc_expr * expr)
1159 sym = expr->symtree->n.sym;
1163 m = resolve_generic_f0 (expr, sym);
1166 else if (m == MATCH_ERROR)
1170 if (sym->ns->parent == NULL)
1172 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
1176 if (!generic_sym (sym))
1180 /* Last ditch attempt. */
1182 if (!gfc_generic_intrinsic (expr->symtree->n.sym->name))
1184 gfc_error ("Generic function '%s' at %L is not an intrinsic function",
1185 expr->symtree->n.sym->name, &expr->where);
1189 m = gfc_intrinsic_func_interface (expr, 0);
1194 ("Generic function '%s' at %L is not consistent with a specific "
1195 "intrinsic interface", expr->symtree->n.sym->name, &expr->where);
1201 /* Resolve a function call known to be specific. */
1204 resolve_specific_f0 (gfc_symbol * sym, gfc_expr * expr)
1208 if (sym->attr.external || sym->attr.if_source == IFSRC_IFBODY)
1210 if (sym->attr.dummy)
1212 sym->attr.proc = PROC_DUMMY;
1216 sym->attr.proc = PROC_EXTERNAL;
1220 if (sym->attr.proc == PROC_MODULE
1221 || sym->attr.proc == PROC_ST_FUNCTION
1222 || sym->attr.proc == PROC_INTERNAL)
1225 if (sym->attr.intrinsic)
1227 m = gfc_intrinsic_func_interface (expr, 1);
1232 ("Function '%s' at %L is INTRINSIC but is not compatible with "
1233 "an intrinsic", sym->name, &expr->where);
1241 gfc_procedure_use (sym, &expr->value.function.actual, &expr->where);
1244 expr->value.function.name = sym->name;
1245 expr->value.function.esym = sym;
1246 if (sym->as != NULL)
1247 expr->rank = sym->as->rank;
1254 resolve_specific_f (gfc_expr * expr)
1259 sym = expr->symtree->n.sym;
1263 m = resolve_specific_f0 (sym, expr);
1266 if (m == MATCH_ERROR)
1269 if (sym->ns->parent == NULL)
1272 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
1278 gfc_error ("Unable to resolve the specific function '%s' at %L",
1279 expr->symtree->n.sym->name, &expr->where);
1285 /* Resolve a procedure call not known to be generic nor specific. */
1288 resolve_unknown_f (gfc_expr * expr)
1293 sym = expr->symtree->n.sym;
1295 if (sym->attr.dummy)
1297 sym->attr.proc = PROC_DUMMY;
1298 expr->value.function.name = sym->name;
1302 /* See if we have an intrinsic function reference. */
1304 if (gfc_intrinsic_name (sym->name, 0))
1306 if (gfc_intrinsic_func_interface (expr, 1) == MATCH_YES)
1311 /* The reference is to an external name. */
1313 sym->attr.proc = PROC_EXTERNAL;
1314 expr->value.function.name = sym->name;
1315 expr->value.function.esym = expr->symtree->n.sym;
1317 if (sym->as != NULL)
1318 expr->rank = sym->as->rank;
1320 /* Type of the expression is either the type of the symbol or the
1321 default type of the symbol. */
1324 gfc_procedure_use (sym, &expr->value.function.actual, &expr->where);
1326 if (sym->ts.type != BT_UNKNOWN)
1330 ts = gfc_get_default_type (sym, sym->ns);
1332 if (ts->type == BT_UNKNOWN)
1334 gfc_error ("Function '%s' at %L has no IMPLICIT type",
1335 sym->name, &expr->where);
1346 /* Figure out if a function reference is pure or not. Also set the name
1347 of the function for a potential error message. Return nonzero if the
1348 function is PURE, zero if not. */
1351 pure_function (gfc_expr * e, const char **name)
1355 if (e->value.function.esym)
1357 pure = gfc_pure (e->value.function.esym);
1358 *name = e->value.function.esym->name;
1360 else if (e->value.function.isym)
1362 pure = e->value.function.isym->pure
1363 || e->value.function.isym->elemental;
1364 *name = e->value.function.isym->name;
1368 /* Implicit functions are not pure. */
1370 *name = e->value.function.name;
1377 /* Resolve a function call, which means resolving the arguments, then figuring
1378 out which entity the name refers to. */
1379 /* TODO: Check procedure arguments so that an INTENT(IN) isn't passed
1380 to INTENT(OUT) or INTENT(INOUT). */
1383 resolve_function (gfc_expr * expr)
1385 gfc_actual_arglist *arg;
1393 sym = expr->symtree->n.sym;
1395 /* If the procedure is not internal, a statement function or a module
1396 procedure,it must be external and should be checked for usage. */
1397 if (sym && !sym->attr.dummy && !sym->attr.contained
1398 && sym->attr.proc != PROC_ST_FUNCTION
1399 && !sym->attr.use_assoc)
1400 resolve_global_procedure (sym, &expr->where, 0);
1402 /* Switch off assumed size checking and do this again for certain kinds
1403 of procedure, once the procedure itself is resolved. */
1404 need_full_assumed_size++;
1406 if (resolve_actual_arglist (expr->value.function.actual) == FAILURE)
1409 /* Resume assumed_size checking. */
1410 need_full_assumed_size--;
1412 if (sym && sym->ts.type == BT_CHARACTER
1414 && sym->ts.cl->length == NULL
1416 && !sym->attr.contained)
1418 /* Internal procedures are taken care of in resolve_contained_fntype. */
1419 gfc_error ("Function '%s' is declared CHARACTER(*) and cannot "
1420 "be used at %L since it is not a dummy argument",
1421 sym->name, &expr->where);
1425 /* See if function is already resolved. */
1427 if (expr->value.function.name != NULL)
1429 if (expr->ts.type == BT_UNKNOWN)
1435 /* Apply the rules of section 14.1.2. */
1437 switch (procedure_kind (sym))
1440 t = resolve_generic_f (expr);
1443 case PTYPE_SPECIFIC:
1444 t = resolve_specific_f (expr);
1448 t = resolve_unknown_f (expr);
1452 gfc_internal_error ("resolve_function(): bad function type");
1456 /* If the expression is still a function (it might have simplified),
1457 then we check to see if we are calling an elemental function. */
1459 if (expr->expr_type != EXPR_FUNCTION)
1462 temp = need_full_assumed_size;
1463 need_full_assumed_size = 0;
1465 if (resolve_elemental_actual (expr, NULL) == FAILURE)
1468 if (omp_workshare_flag
1469 && expr->value.function.esym
1470 && ! gfc_elemental (expr->value.function.esym))
1472 gfc_error ("User defined non-ELEMENTAL function '%s' at %L not allowed"
1473 " in WORKSHARE construct", expr->value.function.esym->name,
1478 else if (expr->value.function.actual != NULL
1479 && expr->value.function.isym != NULL
1480 && expr->value.function.isym->generic_id != GFC_ISYM_LBOUND
1481 && expr->value.function.isym->generic_id != GFC_ISYM_LOC
1482 && expr->value.function.isym->generic_id != GFC_ISYM_PRESENT)
1484 /* Array instrinsics must also have the last upper bound of an
1485 assumed size array argument. UBOUND and SIZE have to be
1486 excluded from the check if the second argument is anything
1489 inquiry = expr->value.function.isym->generic_id == GFC_ISYM_UBOUND
1490 || expr->value.function.isym->generic_id == GFC_ISYM_SIZE;
1492 for (arg = expr->value.function.actual; arg; arg = arg->next)
1494 if (inquiry && arg->next != NULL && arg->next->expr
1495 && arg->next->expr->expr_type != EXPR_CONSTANT)
1498 if (arg->expr != NULL
1499 && arg->expr->rank > 0
1500 && resolve_assumed_size_actual (arg->expr))
1505 need_full_assumed_size = temp;
1507 if (!pure_function (expr, &name) && name)
1512 ("reference to non-PURE function '%s' at %L inside a "
1513 "FORALL %s", name, &expr->where, forall_flag == 2 ?
1517 else if (gfc_pure (NULL))
1519 gfc_error ("Function reference to '%s' at %L is to a non-PURE "
1520 "procedure within a PURE procedure", name, &expr->where);
1525 /* Functions without the RECURSIVE attribution are not allowed to
1526 * call themselves. */
1527 if (expr->value.function.esym && !expr->value.function.esym->attr.recursive)
1529 gfc_symbol *esym, *proc;
1530 esym = expr->value.function.esym;
1531 proc = gfc_current_ns->proc_name;
1534 gfc_error ("Function '%s' at %L cannot call itself, as it is not "
1535 "RECURSIVE", name, &expr->where);
1539 if (esym->attr.entry && esym->ns->entries && proc->ns->entries
1540 && esym->ns->entries->sym == proc->ns->entries->sym)
1542 gfc_error ("Call to ENTRY '%s' at %L is recursive, but function "
1543 "'%s' is not declared as RECURSIVE",
1544 esym->name, &expr->where, esym->ns->entries->sym->name);
1549 /* Character lengths of use associated functions may contains references to
1550 symbols not referenced from the current program unit otherwise. Make sure
1551 those symbols are marked as referenced. */
1553 if (expr->ts.type == BT_CHARACTER && expr->value.function.esym
1554 && expr->value.function.esym->attr.use_assoc)
1556 gfc_expr_set_symbols_referenced (expr->ts.cl->length);
1560 find_noncopying_intrinsics (expr->value.function.esym,
1561 expr->value.function.actual);
1566 /************* Subroutine resolution *************/
1569 pure_subroutine (gfc_code * c, gfc_symbol * sym)
1576 gfc_error ("Subroutine call to '%s' in FORALL block at %L is not PURE",
1577 sym->name, &c->loc);
1578 else if (gfc_pure (NULL))
1579 gfc_error ("Subroutine call to '%s' at %L is not PURE", sym->name,
1585 resolve_generic_s0 (gfc_code * c, gfc_symbol * sym)
1589 if (sym->attr.generic)
1591 s = gfc_search_interface (sym->generic, 1, &c->ext.actual);
1594 c->resolved_sym = s;
1595 pure_subroutine (c, s);
1599 /* TODO: Need to search for elemental references in generic interface. */
1602 if (sym->attr.intrinsic)
1603 return gfc_intrinsic_sub_interface (c, 0);
1610 resolve_generic_s (gfc_code * c)
1615 sym = c->symtree->n.sym;
1617 m = resolve_generic_s0 (c, sym);
1620 if (m == MATCH_ERROR)
1623 if (sym->ns->parent != NULL && !sym->attr.use_assoc)
1625 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
1628 m = resolve_generic_s0 (c, sym);
1631 if (m == MATCH_ERROR)
1636 /* Last ditch attempt. */
1638 if (!gfc_generic_intrinsic (sym->name))
1641 ("Generic subroutine '%s' at %L is not an intrinsic subroutine",
1642 sym->name, &c->loc);
1646 m = gfc_intrinsic_sub_interface (c, 0);
1650 gfc_error ("Generic subroutine '%s' at %L is not consistent with an "
1651 "intrinsic subroutine interface", sym->name, &c->loc);
1657 /* Resolve a subroutine call known to be specific. */
1660 resolve_specific_s0 (gfc_code * c, gfc_symbol * sym)
1664 if (sym->attr.external || sym->attr.if_source == IFSRC_IFBODY)
1666 if (sym->attr.dummy)
1668 sym->attr.proc = PROC_DUMMY;
1672 sym->attr.proc = PROC_EXTERNAL;
1676 if (sym->attr.proc == PROC_MODULE || sym->attr.proc == PROC_INTERNAL)
1679 if (sym->attr.intrinsic)
1681 m = gfc_intrinsic_sub_interface (c, 1);
1685 gfc_error ("Subroutine '%s' at %L is INTRINSIC but is not compatible "
1686 "with an intrinsic", sym->name, &c->loc);
1694 gfc_procedure_use (sym, &c->ext.actual, &c->loc);
1696 c->resolved_sym = sym;
1697 pure_subroutine (c, sym);
1704 resolve_specific_s (gfc_code * c)
1709 sym = c->symtree->n.sym;
1711 m = resolve_specific_s0 (c, sym);
1714 if (m == MATCH_ERROR)
1717 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
1721 m = resolve_specific_s0 (c, sym);
1724 if (m == MATCH_ERROR)
1728 gfc_error ("Unable to resolve the specific subroutine '%s' at %L",
1729 sym->name, &c->loc);
1735 /* Resolve a subroutine call not known to be generic nor specific. */
1738 resolve_unknown_s (gfc_code * c)
1742 sym = c->symtree->n.sym;
1744 if (sym->attr.dummy)
1746 sym->attr.proc = PROC_DUMMY;
1750 /* See if we have an intrinsic function reference. */
1752 if (gfc_intrinsic_name (sym->name, 1))
1754 if (gfc_intrinsic_sub_interface (c, 1) == MATCH_YES)
1759 /* The reference is to an external name. */
1762 gfc_procedure_use (sym, &c->ext.actual, &c->loc);
1764 c->resolved_sym = sym;
1766 pure_subroutine (c, sym);
1772 /* Resolve a subroutine call. Although it was tempting to use the same code
1773 for functions, subroutines and functions are stored differently and this
1774 makes things awkward. */
1777 resolve_call (gfc_code * c)
1781 if (c->symtree && c->symtree->n.sym
1782 && c->symtree->n.sym->ts.type != BT_UNKNOWN)
1784 gfc_error ("'%s' at %L has a type, which is not consistent with "
1785 "the CALL at %L", c->symtree->n.sym->name,
1786 &c->symtree->n.sym->declared_at, &c->loc);
1790 /* If the procedure is not internal or module, it must be external and
1791 should be checked for usage. */
1792 if (c->symtree && c->symtree->n.sym
1793 && !c->symtree->n.sym->attr.dummy
1794 && !c->symtree->n.sym->attr.contained
1795 && !c->symtree->n.sym->attr.use_assoc)
1796 resolve_global_procedure (c->symtree->n.sym, &c->loc, 1);
1798 /* Subroutines without the RECURSIVE attribution are not allowed to
1799 * call themselves. */
1800 if (c->symtree && c->symtree->n.sym && !c->symtree->n.sym->attr.recursive)
1802 gfc_symbol *csym, *proc;
1803 csym = c->symtree->n.sym;
1804 proc = gfc_current_ns->proc_name;
1807 gfc_error ("SUBROUTINE '%s' at %L cannot call itself, as it is not "
1808 "RECURSIVE", csym->name, &c->loc);
1812 if (csym->attr.entry && csym->ns->entries && proc->ns->entries
1813 && csym->ns->entries->sym == proc->ns->entries->sym)
1815 gfc_error ("Call to ENTRY '%s' at %L is recursive, but subroutine "
1816 "'%s' is not declared as RECURSIVE",
1817 csym->name, &c->loc, csym->ns->entries->sym->name);
1822 /* Switch off assumed size checking and do this again for certain kinds
1823 of procedure, once the procedure itself is resolved. */
1824 need_full_assumed_size++;
1826 if (resolve_actual_arglist (c->ext.actual) == FAILURE)
1829 /* Resume assumed_size checking. */
1830 need_full_assumed_size--;
1834 if (c->resolved_sym == NULL)
1835 switch (procedure_kind (c->symtree->n.sym))
1838 t = resolve_generic_s (c);
1841 case PTYPE_SPECIFIC:
1842 t = resolve_specific_s (c);
1846 t = resolve_unknown_s (c);
1850 gfc_internal_error ("resolve_subroutine(): bad function type");
1853 /* Some checks of elemental subroutine actual arguments. */
1854 if (resolve_elemental_actual (NULL, c) == FAILURE)
1858 find_noncopying_intrinsics (c->resolved_sym, c->ext.actual);
1862 /* Compare the shapes of two arrays that have non-NULL shapes. If both
1863 op1->shape and op2->shape are non-NULL return SUCCESS if their shapes
1864 match. If both op1->shape and op2->shape are non-NULL return FAILURE
1865 if their shapes do not match. If either op1->shape or op2->shape is
1866 NULL, return SUCCESS. */
1869 compare_shapes (gfc_expr * op1, gfc_expr * op2)
1876 if (op1->shape != NULL && op2->shape != NULL)
1878 for (i = 0; i < op1->rank; i++)
1880 if (mpz_cmp (op1->shape[i], op2->shape[i]) != 0)
1882 gfc_error ("Shapes for operands at %L and %L are not conformable",
1883 &op1->where, &op2->where);
1893 /* Resolve an operator expression node. This can involve replacing the
1894 operation with a user defined function call. */
1897 resolve_operator (gfc_expr * e)
1899 gfc_expr *op1, *op2;
1903 /* Resolve all subnodes-- give them types. */
1905 switch (e->value.op.operator)
1908 if (gfc_resolve_expr (e->value.op.op2) == FAILURE)
1911 /* Fall through... */
1914 case INTRINSIC_UPLUS:
1915 case INTRINSIC_UMINUS:
1916 case INTRINSIC_PARENTHESES:
1917 if (gfc_resolve_expr (e->value.op.op1) == FAILURE)
1922 /* Typecheck the new node. */
1924 op1 = e->value.op.op1;
1925 op2 = e->value.op.op2;
1927 switch (e->value.op.operator)
1929 case INTRINSIC_UPLUS:
1930 case INTRINSIC_UMINUS:
1931 if (op1->ts.type == BT_INTEGER
1932 || op1->ts.type == BT_REAL
1933 || op1->ts.type == BT_COMPLEX)
1939 sprintf (msg, _("Operand of unary numeric operator '%s' at %%L is %s"),
1940 gfc_op2string (e->value.op.operator), gfc_typename (&e->ts));
1943 case INTRINSIC_PLUS:
1944 case INTRINSIC_MINUS:
1945 case INTRINSIC_TIMES:
1946 case INTRINSIC_DIVIDE:
1947 case INTRINSIC_POWER:
1948 if (gfc_numeric_ts (&op1->ts) && gfc_numeric_ts (&op2->ts))
1950 gfc_type_convert_binary (e);
1955 _("Operands of binary numeric operator '%s' at %%L are %s/%s"),
1956 gfc_op2string (e->value.op.operator), gfc_typename (&op1->ts),
1957 gfc_typename (&op2->ts));
1960 case INTRINSIC_CONCAT:
1961 if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER)
1963 e->ts.type = BT_CHARACTER;
1964 e->ts.kind = op1->ts.kind;
1969 _("Operands of string concatenation operator at %%L are %s/%s"),
1970 gfc_typename (&op1->ts), gfc_typename (&op2->ts));
1976 case INTRINSIC_NEQV:
1977 if (op1->ts.type == BT_LOGICAL && op2->ts.type == BT_LOGICAL)
1979 e->ts.type = BT_LOGICAL;
1980 e->ts.kind = gfc_kind_max (op1, op2);
1981 if (op1->ts.kind < e->ts.kind)
1982 gfc_convert_type (op1, &e->ts, 2);
1983 else if (op2->ts.kind < e->ts.kind)
1984 gfc_convert_type (op2, &e->ts, 2);
1988 sprintf (msg, _("Operands of logical operator '%s' at %%L are %s/%s"),
1989 gfc_op2string (e->value.op.operator), gfc_typename (&op1->ts),
1990 gfc_typename (&op2->ts));
1995 if (op1->ts.type == BT_LOGICAL)
1997 e->ts.type = BT_LOGICAL;
1998 e->ts.kind = op1->ts.kind;
2002 sprintf (msg, _("Operand of .NOT. operator at %%L is %s"),
2003 gfc_typename (&op1->ts));
2010 if (op1->ts.type == BT_COMPLEX || op2->ts.type == BT_COMPLEX)
2012 strcpy (msg, _("COMPLEX quantities cannot be compared at %L"));
2016 /* Fall through... */
2020 if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER)
2022 e->ts.type = BT_LOGICAL;
2023 e->ts.kind = gfc_default_logical_kind;
2027 if (gfc_numeric_ts (&op1->ts) && gfc_numeric_ts (&op2->ts))
2029 gfc_type_convert_binary (e);
2031 e->ts.type = BT_LOGICAL;
2032 e->ts.kind = gfc_default_logical_kind;
2036 if (op1->ts.type == BT_LOGICAL && op2->ts.type == BT_LOGICAL)
2038 _("Logicals at %%L must be compared with %s instead of %s"),
2039 e->value.op.operator == INTRINSIC_EQ ? ".EQV." : ".NEQV.",
2040 gfc_op2string (e->value.op.operator));
2043 _("Operands of comparison operator '%s' at %%L are %s/%s"),
2044 gfc_op2string (e->value.op.operator), gfc_typename (&op1->ts),
2045 gfc_typename (&op2->ts));
2049 case INTRINSIC_USER:
2051 sprintf (msg, _("Operand of user operator '%s' at %%L is %s"),
2052 e->value.op.uop->name, gfc_typename (&op1->ts));
2054 sprintf (msg, _("Operands of user operator '%s' at %%L are %s/%s"),
2055 e->value.op.uop->name, gfc_typename (&op1->ts),
2056 gfc_typename (&op2->ts));
2060 case INTRINSIC_PARENTHESES:
2064 gfc_internal_error ("resolve_operator(): Bad intrinsic");
2067 /* Deal with arrayness of an operand through an operator. */
2071 switch (e->value.op.operator)
2073 case INTRINSIC_PLUS:
2074 case INTRINSIC_MINUS:
2075 case INTRINSIC_TIMES:
2076 case INTRINSIC_DIVIDE:
2077 case INTRINSIC_POWER:
2078 case INTRINSIC_CONCAT:
2082 case INTRINSIC_NEQV:
2090 if (op1->rank == 0 && op2->rank == 0)
2093 if (op1->rank == 0 && op2->rank != 0)
2095 e->rank = op2->rank;
2097 if (e->shape == NULL)
2098 e->shape = gfc_copy_shape (op2->shape, op2->rank);
2101 if (op1->rank != 0 && op2->rank == 0)
2103 e->rank = op1->rank;
2105 if (e->shape == NULL)
2106 e->shape = gfc_copy_shape (op1->shape, op1->rank);
2109 if (op1->rank != 0 && op2->rank != 0)
2111 if (op1->rank == op2->rank)
2113 e->rank = op1->rank;
2114 if (e->shape == NULL)
2116 t = compare_shapes(op1, op2);
2120 e->shape = gfc_copy_shape (op1->shape, op1->rank);
2125 gfc_error ("Inconsistent ranks for operator at %L and %L",
2126 &op1->where, &op2->where);
2129 /* Allow higher level expressions to work. */
2137 case INTRINSIC_UPLUS:
2138 case INTRINSIC_UMINUS:
2139 case INTRINSIC_PARENTHESES:
2140 e->rank = op1->rank;
2142 if (e->shape == NULL)
2143 e->shape = gfc_copy_shape (op1->shape, op1->rank);
2145 /* Simply copy arrayness attribute */
2152 /* Attempt to simplify the expression. */
2154 t = gfc_simplify_expr (e, 0);
2159 if (gfc_extend_expr (e) == SUCCESS)
2162 gfc_error (msg, &e->where);
2168 /************** Array resolution subroutines **************/
2172 { CMP_LT, CMP_EQ, CMP_GT, CMP_UNKNOWN }
2175 /* Compare two integer expressions. */
2178 compare_bound (gfc_expr * a, gfc_expr * b)
2182 if (a == NULL || a->expr_type != EXPR_CONSTANT
2183 || b == NULL || b->expr_type != EXPR_CONSTANT)
2186 if (a->ts.type != BT_INTEGER || b->ts.type != BT_INTEGER)
2187 gfc_internal_error ("compare_bound(): Bad expression");
2189 i = mpz_cmp (a->value.integer, b->value.integer);
2199 /* Compare an integer expression with an integer. */
2202 compare_bound_int (gfc_expr * a, int b)
2206 if (a == NULL || a->expr_type != EXPR_CONSTANT)
2209 if (a->ts.type != BT_INTEGER)
2210 gfc_internal_error ("compare_bound_int(): Bad expression");
2212 i = mpz_cmp_si (a->value.integer, b);
2222 /* Compare an integer expression with a mpz_t. */
2225 compare_bound_mpz_t (gfc_expr * a, mpz_t b)
2229 if (a == NULL || a->expr_type != EXPR_CONSTANT)
2232 if (a->ts.type != BT_INTEGER)
2233 gfc_internal_error ("compare_bound_int(): Bad expression");
2235 i = mpz_cmp (a->value.integer, b);
2245 /* Compute the last value of a sequence given by a triplet.
2246 Return 0 if it wasn't able to compute the last value, or if the
2247 sequence if empty, and 1 otherwise. */
2250 compute_last_value_for_triplet (gfc_expr * start, gfc_expr * end,
2251 gfc_expr * stride, mpz_t last)
2255 if (start == NULL || start->expr_type != EXPR_CONSTANT
2256 || end == NULL || end->expr_type != EXPR_CONSTANT
2257 || (stride != NULL && stride->expr_type != EXPR_CONSTANT))
2260 if (start->ts.type != BT_INTEGER || end->ts.type != BT_INTEGER
2261 || (stride != NULL && stride->ts.type != BT_INTEGER))
2264 if (stride == NULL || compare_bound_int(stride, 1) == CMP_EQ)
2266 if (compare_bound (start, end) == CMP_GT)
2268 mpz_set (last, end->value.integer);
2272 if (compare_bound_int (stride, 0) == CMP_GT)
2274 /* Stride is positive */
2275 if (mpz_cmp (start->value.integer, end->value.integer) > 0)
2280 /* Stride is negative */
2281 if (mpz_cmp (start->value.integer, end->value.integer) < 0)
2286 mpz_sub (rem, end->value.integer, start->value.integer);
2287 mpz_tdiv_r (rem, rem, stride->value.integer);
2288 mpz_sub (last, end->value.integer, rem);
2295 /* Compare a single dimension of an array reference to the array
2299 check_dimension (int i, gfc_array_ref * ar, gfc_array_spec * as)
2303 /* Given start, end and stride values, calculate the minimum and
2304 maximum referenced indexes. */
2312 if (compare_bound (ar->start[i], as->lower[i]) == CMP_LT)
2314 if (compare_bound (ar->start[i], as->upper[i]) == CMP_GT)
2320 if (compare_bound_int (ar->stride[i], 0) == CMP_EQ)
2322 gfc_error ("Illegal stride of zero at %L", &ar->c_where[i]);
2326 #define AR_START (ar->start[i] ? ar->start[i] : as->lower[i])
2327 #define AR_END (ar->end[i] ? ar->end[i] : as->upper[i])
2329 if (compare_bound (AR_START, AR_END) == CMP_EQ
2330 && (compare_bound (AR_START, as->lower[i]) == CMP_LT
2331 || compare_bound (AR_START, as->upper[i]) == CMP_GT))
2334 if (((compare_bound_int (ar->stride[i], 0) == CMP_GT
2335 || ar->stride[i] == NULL)
2336 && compare_bound (AR_START, AR_END) != CMP_GT)
2337 || (compare_bound_int (ar->stride[i], 0) == CMP_LT
2338 && compare_bound (AR_START, AR_END) != CMP_LT))
2340 if (compare_bound (AR_START, as->lower[i]) == CMP_LT)
2342 if (compare_bound (AR_START, as->upper[i]) == CMP_GT)
2346 mpz_init (last_value);
2347 if (compute_last_value_for_triplet (AR_START, AR_END, ar->stride[i],
2350 if (compare_bound_mpz_t (as->lower[i], last_value) == CMP_GT
2351 || compare_bound_mpz_t (as->upper[i], last_value) == CMP_LT)
2353 mpz_clear (last_value);
2357 mpz_clear (last_value);
2365 gfc_internal_error ("check_dimension(): Bad array reference");
2371 gfc_warning ("Array reference at %L is out of bounds", &ar->c_where[i]);
2376 /* Compare an array reference with an array specification. */
2379 compare_spec_to_ref (gfc_array_ref * ar)
2386 /* TODO: Full array sections are only allowed as actual parameters. */
2387 if (as->type == AS_ASSUMED_SIZE
2388 && (/*ar->type == AR_FULL
2389 ||*/ (ar->type == AR_SECTION
2390 && ar->dimen_type[i] == DIMEN_RANGE && ar->end[i] == NULL)))
2392 gfc_error ("Rightmost upper bound of assumed size array section"
2393 " not specified at %L", &ar->where);
2397 if (ar->type == AR_FULL)
2400 if (as->rank != ar->dimen)
2402 gfc_error ("Rank mismatch in array reference at %L (%d/%d)",
2403 &ar->where, ar->dimen, as->rank);
2407 for (i = 0; i < as->rank; i++)
2408 if (check_dimension (i, ar, as) == FAILURE)
2415 /* Resolve one part of an array index. */
2418 gfc_resolve_index (gfc_expr * index, int check_scalar)
2425 if (gfc_resolve_expr (index) == FAILURE)
2428 if (check_scalar && index->rank != 0)
2430 gfc_error ("Array index at %L must be scalar", &index->where);
2434 if (index->ts.type != BT_INTEGER && index->ts.type != BT_REAL)
2436 gfc_error ("Array index at %L must be of INTEGER type",
2441 if (index->ts.type == BT_REAL)
2442 if (gfc_notify_std (GFC_STD_LEGACY, "Extension: REAL array index at %L",
2443 &index->where) == FAILURE)
2446 if (index->ts.kind != gfc_index_integer_kind
2447 || index->ts.type != BT_INTEGER)
2450 ts.type = BT_INTEGER;
2451 ts.kind = gfc_index_integer_kind;
2453 gfc_convert_type_warn (index, &ts, 2, 0);
2459 /* Resolve a dim argument to an intrinsic function. */
2462 gfc_resolve_dim_arg (gfc_expr *dim)
2467 if (gfc_resolve_expr (dim) == FAILURE)
2472 gfc_error ("Argument dim at %L must be scalar", &dim->where);
2476 if (dim->ts.type != BT_INTEGER)
2478 gfc_error ("Argument dim at %L must be of INTEGER type", &dim->where);
2481 if (dim->ts.kind != gfc_index_integer_kind)
2485 ts.type = BT_INTEGER;
2486 ts.kind = gfc_index_integer_kind;
2488 gfc_convert_type_warn (dim, &ts, 2, 0);
2494 /* Given an expression that contains array references, update those array
2495 references to point to the right array specifications. While this is
2496 filled in during matching, this information is difficult to save and load
2497 in a module, so we take care of it here.
2499 The idea here is that the original array reference comes from the
2500 base symbol. We traverse the list of reference structures, setting
2501 the stored reference to references. Component references can
2502 provide an additional array specification. */
2505 find_array_spec (gfc_expr * e)
2509 gfc_symbol *derived;
2512 as = e->symtree->n.sym->as;
2515 for (ref = e->ref; ref; ref = ref->next)
2520 gfc_internal_error ("find_array_spec(): Missing spec");
2527 if (derived == NULL)
2528 derived = e->symtree->n.sym->ts.derived;
2530 c = derived->components;
2532 for (; c; c = c->next)
2533 if (c == ref->u.c.component)
2535 /* Track the sequence of component references. */
2536 if (c->ts.type == BT_DERIVED)
2537 derived = c->ts.derived;
2542 gfc_internal_error ("find_array_spec(): Component not found");
2547 gfc_internal_error ("find_array_spec(): unused as(1)");
2558 gfc_internal_error ("find_array_spec(): unused as(2)");
2562 /* Resolve an array reference. */
2565 resolve_array_ref (gfc_array_ref * ar)
2567 int i, check_scalar;
2570 for (i = 0; i < ar->dimen; i++)
2572 check_scalar = ar->dimen_type[i] == DIMEN_RANGE;
2574 if (gfc_resolve_index (ar->start[i], check_scalar) == FAILURE)
2576 if (gfc_resolve_index (ar->end[i], check_scalar) == FAILURE)
2578 if (gfc_resolve_index (ar->stride[i], check_scalar) == FAILURE)
2583 if (ar->dimen_type[i] == DIMEN_UNKNOWN)
2587 ar->dimen_type[i] = DIMEN_ELEMENT;
2591 ar->dimen_type[i] = DIMEN_VECTOR;
2592 if (e->expr_type == EXPR_VARIABLE
2593 && e->symtree->n.sym->ts.type == BT_DERIVED)
2594 ar->start[i] = gfc_get_parentheses (e);
2598 gfc_error ("Array index at %L is an array of rank %d",
2599 &ar->c_where[i], e->rank);
2604 /* If the reference type is unknown, figure out what kind it is. */
2606 if (ar->type == AR_UNKNOWN)
2608 ar->type = AR_ELEMENT;
2609 for (i = 0; i < ar->dimen; i++)
2610 if (ar->dimen_type[i] == DIMEN_RANGE
2611 || ar->dimen_type[i] == DIMEN_VECTOR)
2613 ar->type = AR_SECTION;
2618 if (!ar->as->cray_pointee && compare_spec_to_ref (ar) == FAILURE)
2626 resolve_substring (gfc_ref * ref)
2629 if (ref->u.ss.start != NULL)
2631 if (gfc_resolve_expr (ref->u.ss.start) == FAILURE)
2634 if (ref->u.ss.start->ts.type != BT_INTEGER)
2636 gfc_error ("Substring start index at %L must be of type INTEGER",
2637 &ref->u.ss.start->where);
2641 if (ref->u.ss.start->rank != 0)
2643 gfc_error ("Substring start index at %L must be scalar",
2644 &ref->u.ss.start->where);
2648 if (compare_bound_int (ref->u.ss.start, 1) == CMP_LT
2649 && (compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_EQ
2650 || compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_GT))
2652 gfc_error ("Substring start index at %L is less than one",
2653 &ref->u.ss.start->where);
2658 if (ref->u.ss.end != NULL)
2660 if (gfc_resolve_expr (ref->u.ss.end) == FAILURE)
2663 if (ref->u.ss.end->ts.type != BT_INTEGER)
2665 gfc_error ("Substring end index at %L must be of type INTEGER",
2666 &ref->u.ss.end->where);
2670 if (ref->u.ss.end->rank != 0)
2672 gfc_error ("Substring end index at %L must be scalar",
2673 &ref->u.ss.end->where);
2677 if (ref->u.ss.length != NULL
2678 && compare_bound (ref->u.ss.end, ref->u.ss.length->length) == CMP_GT
2679 && (compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_EQ
2680 || compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_GT))
2682 gfc_error ("Substring end index at %L exceeds the string length",
2683 &ref->u.ss.start->where);
2692 /* Resolve subtype references. */
2695 resolve_ref (gfc_expr * expr)
2697 int current_part_dimension, n_components, seen_part_dimension;
2700 for (ref = expr->ref; ref; ref = ref->next)
2701 if (ref->type == REF_ARRAY && ref->u.ar.as == NULL)
2703 find_array_spec (expr);
2707 for (ref = expr->ref; ref; ref = ref->next)
2711 if (resolve_array_ref (&ref->u.ar) == FAILURE)
2719 resolve_substring (ref);
2723 /* Check constraints on part references. */
2725 current_part_dimension = 0;
2726 seen_part_dimension = 0;
2729 for (ref = expr->ref; ref; ref = ref->next)
2734 switch (ref->u.ar.type)
2738 current_part_dimension = 1;
2742 current_part_dimension = 0;
2746 gfc_internal_error ("resolve_ref(): Bad array reference");
2752 if ((current_part_dimension || seen_part_dimension)
2753 && ref->u.c.component->pointer)
2756 ("Component to the right of a part reference with nonzero "
2757 "rank must not have the POINTER attribute at %L",
2769 if (((ref->type == REF_COMPONENT && n_components > 1)
2770 || ref->next == NULL)
2771 && current_part_dimension
2772 && seen_part_dimension)
2775 gfc_error ("Two or more part references with nonzero rank must "
2776 "not be specified at %L", &expr->where);
2780 if (ref->type == REF_COMPONENT)
2782 if (current_part_dimension)
2783 seen_part_dimension = 1;
2785 /* reset to make sure */
2786 current_part_dimension = 0;
2794 /* Given an expression, determine its shape. This is easier than it sounds.
2795 Leaves the shape array NULL if it is not possible to determine the shape. */
2798 expression_shape (gfc_expr * e)
2800 mpz_t array[GFC_MAX_DIMENSIONS];
2803 if (e->rank == 0 || e->shape != NULL)
2806 for (i = 0; i < e->rank; i++)
2807 if (gfc_array_dimen_size (e, i, &array[i]) == FAILURE)
2810 e->shape = gfc_get_shape (e->rank);
2812 memcpy (e->shape, array, e->rank * sizeof (mpz_t));
2817 for (i--; i >= 0; i--)
2818 mpz_clear (array[i]);
2822 /* Given a variable expression node, compute the rank of the expression by
2823 examining the base symbol and any reference structures it may have. */
2826 expression_rank (gfc_expr * e)
2833 if (e->expr_type == EXPR_ARRAY)
2835 /* Constructors can have a rank different from one via RESHAPE(). */
2837 if (e->symtree == NULL)
2843 e->rank = (e->symtree->n.sym->as == NULL)
2844 ? 0 : e->symtree->n.sym->as->rank;
2850 for (ref = e->ref; ref; ref = ref->next)
2852 if (ref->type != REF_ARRAY)
2855 if (ref->u.ar.type == AR_FULL)
2857 rank = ref->u.ar.as->rank;
2861 if (ref->u.ar.type == AR_SECTION)
2863 /* Figure out the rank of the section. */
2865 gfc_internal_error ("expression_rank(): Two array specs");
2867 for (i = 0; i < ref->u.ar.dimen; i++)
2868 if (ref->u.ar.dimen_type[i] == DIMEN_RANGE
2869 || ref->u.ar.dimen_type[i] == DIMEN_VECTOR)
2879 expression_shape (e);
2883 /* Resolve a variable expression. */
2886 resolve_variable (gfc_expr * e)
2893 if (e->symtree == NULL)
2896 if (e->ref && resolve_ref (e) == FAILURE)
2899 sym = e->symtree->n.sym;
2900 if (sym->attr.flavor == FL_PROCEDURE && !sym->attr.function)
2902 e->ts.type = BT_PROCEDURE;
2906 if (sym->ts.type != BT_UNKNOWN)
2907 gfc_variable_attr (e, &e->ts);
2910 /* Must be a simple variable reference. */
2911 if (gfc_set_default_type (sym, 1, NULL) == FAILURE)
2916 if (check_assumed_size_reference (sym, e))
2919 /* Deal with forward references to entries during resolve_code, to
2920 satisfy, at least partially, 12.5.2.5. */
2921 if (gfc_current_ns->entries
2922 && current_entry_id == sym->entry_id
2925 && cs_base->current->op != EXEC_ENTRY)
2927 gfc_entry_list *entry;
2928 gfc_formal_arglist *formal;
2932 /* If the symbol is a dummy... */
2933 if (sym->attr.dummy)
2935 entry = gfc_current_ns->entries;
2938 /* ...test if the symbol is a parameter of previous entries. */
2939 for (; entry && entry->id <= current_entry_id; entry = entry->next)
2940 for (formal = entry->sym->formal; formal; formal = formal->next)
2942 if (formal->sym && sym->name == formal->sym->name)
2946 /* If it has not been seen as a dummy, this is an error. */
2949 if (specification_expr)
2950 gfc_error ("Variable '%s',used in a specification expression, "
2951 "is referenced at %L before the ENTRY statement "
2952 "in which it is a parameter",
2953 sym->name, &cs_base->current->loc);
2955 gfc_error ("Variable '%s' is used at %L before the ENTRY "
2956 "statement in which it is a parameter",
2957 sym->name, &cs_base->current->loc);
2962 /* Now do the same check on the specification expressions. */
2963 specification_expr = 1;
2964 if (sym->ts.type == BT_CHARACTER
2965 && gfc_resolve_expr (sym->ts.cl->length) == FAILURE)
2969 for (n = 0; n < sym->as->rank; n++)
2971 specification_expr = 1;
2972 if (gfc_resolve_expr (sym->as->lower[n]) == FAILURE)
2974 specification_expr = 1;
2975 if (gfc_resolve_expr (sym->as->upper[n]) == FAILURE)
2978 specification_expr = 0;
2981 /* Update the symbol's entry level. */
2982 sym->entry_id = current_entry_id + 1;
2989 /* Resolve an expression. That is, make sure that types of operands agree
2990 with their operators, intrinsic operators are converted to function calls
2991 for overloaded types and unresolved function references are resolved. */
2994 gfc_resolve_expr (gfc_expr * e)
3001 switch (e->expr_type)
3004 t = resolve_operator (e);
3008 t = resolve_function (e);
3012 t = resolve_variable (e);
3014 expression_rank (e);
3017 case EXPR_SUBSTRING:
3018 t = resolve_ref (e);
3028 if (resolve_ref (e) == FAILURE)
3031 t = gfc_resolve_array_constructor (e);
3032 /* Also try to expand a constructor. */
3035 expression_rank (e);
3036 gfc_expand_constructor (e);
3039 /* This provides the opportunity for the length of constructors with character
3040 valued function elements to propogate the string length to the expression. */
3041 if (e->ts.type == BT_CHARACTER)
3042 gfc_resolve_character_array_constructor (e);
3046 case EXPR_STRUCTURE:
3047 t = resolve_ref (e);
3051 t = resolve_structure_cons (e);
3055 t = gfc_simplify_expr (e, 0);
3059 gfc_internal_error ("gfc_resolve_expr(): Bad expression type");
3066 /* Resolve an expression from an iterator. They must be scalar and have
3067 INTEGER or (optionally) REAL type. */
3070 gfc_resolve_iterator_expr (gfc_expr * expr, bool real_ok,
3071 const char * name_msgid)
3073 if (gfc_resolve_expr (expr) == FAILURE)
3076 if (expr->rank != 0)
3078 gfc_error ("%s at %L must be a scalar", _(name_msgid), &expr->where);
3082 if (!(expr->ts.type == BT_INTEGER
3083 || (expr->ts.type == BT_REAL && real_ok)))
3086 gfc_error ("%s at %L must be INTEGER or REAL", _(name_msgid),
3089 gfc_error ("%s at %L must be INTEGER", _(name_msgid), &expr->where);
3096 /* Resolve the expressions in an iterator structure. If REAL_OK is
3097 false allow only INTEGER type iterators, otherwise allow REAL types. */
3100 gfc_resolve_iterator (gfc_iterator * iter, bool real_ok)
3103 if (iter->var->ts.type == BT_REAL)
3104 gfc_notify_std (GFC_STD_F95_DEL,
3105 "Obsolete: REAL DO loop iterator at %L",
3108 if (gfc_resolve_iterator_expr (iter->var, real_ok, "Loop variable")
3112 if (gfc_pure (NULL) && gfc_impure_variable (iter->var->symtree->n.sym))
3114 gfc_error ("Cannot assign to loop variable in PURE procedure at %L",
3119 if (gfc_resolve_iterator_expr (iter->start, real_ok,
3120 "Start expression in DO loop") == FAILURE)
3123 if (gfc_resolve_iterator_expr (iter->end, real_ok,
3124 "End expression in DO loop") == FAILURE)
3127 if (gfc_resolve_iterator_expr (iter->step, real_ok,
3128 "Step expression in DO loop") == FAILURE)
3131 if (iter->step->expr_type == EXPR_CONSTANT)
3133 if ((iter->step->ts.type == BT_INTEGER
3134 && mpz_cmp_ui (iter->step->value.integer, 0) == 0)
3135 || (iter->step->ts.type == BT_REAL
3136 && mpfr_sgn (iter->step->value.real) == 0))
3138 gfc_error ("Step expression in DO loop at %L cannot be zero",
3139 &iter->step->where);
3144 /* Convert start, end, and step to the same type as var. */
3145 if (iter->start->ts.kind != iter->var->ts.kind
3146 || iter->start->ts.type != iter->var->ts.type)
3147 gfc_convert_type (iter->start, &iter->var->ts, 2);
3149 if (iter->end->ts.kind != iter->var->ts.kind
3150 || iter->end->ts.type != iter->var->ts.type)
3151 gfc_convert_type (iter->end, &iter->var->ts, 2);
3153 if (iter->step->ts.kind != iter->var->ts.kind
3154 || iter->step->ts.type != iter->var->ts.type)
3155 gfc_convert_type (iter->step, &iter->var->ts, 2);
3161 /* Resolve a list of FORALL iterators. The FORALL index-name is constrained
3162 to be a scalar INTEGER variable. The subscripts and stride are scalar
3163 INTEGERs, and if stride is a constant it must be nonzero. */
3166 resolve_forall_iterators (gfc_forall_iterator * iter)
3171 if (gfc_resolve_expr (iter->var) == SUCCESS
3172 && (iter->var->ts.type != BT_INTEGER || iter->var->rank != 0))
3173 gfc_error ("FORALL index-name at %L must be a scalar INTEGER",
3176 if (gfc_resolve_expr (iter->start) == SUCCESS
3177 && (iter->start->ts.type != BT_INTEGER || iter->start->rank != 0))
3178 gfc_error ("FORALL start expression at %L must be a scalar INTEGER",
3179 &iter->start->where);
3180 if (iter->var->ts.kind != iter->start->ts.kind)
3181 gfc_convert_type (iter->start, &iter->var->ts, 2);
3183 if (gfc_resolve_expr (iter->end) == SUCCESS
3184 && (iter->end->ts.type != BT_INTEGER || iter->end->rank != 0))
3185 gfc_error ("FORALL end expression at %L must be a scalar INTEGER",
3187 if (iter->var->ts.kind != iter->end->ts.kind)
3188 gfc_convert_type (iter->end, &iter->var->ts, 2);
3190 if (gfc_resolve_expr (iter->stride) == SUCCESS)
3192 if (iter->stride->ts.type != BT_INTEGER || iter->stride->rank != 0)
3193 gfc_error ("FORALL stride expression at %L must be a scalar %s",
3194 &iter->stride->where, "INTEGER");
3196 if (iter->stride->expr_type == EXPR_CONSTANT
3197 && mpz_cmp_ui(iter->stride->value.integer, 0) == 0)
3198 gfc_error ("FORALL stride expression at %L cannot be zero",
3199 &iter->stride->where);
3201 if (iter->var->ts.kind != iter->stride->ts.kind)
3202 gfc_convert_type (iter->stride, &iter->var->ts, 2);
3209 /* Given a pointer to a symbol that is a derived type, see if any components
3210 have the POINTER attribute. The search is recursive if necessary.
3211 Returns zero if no pointer components are found, nonzero otherwise. */
3214 derived_pointer (gfc_symbol * sym)
3218 for (c = sym->components; c; c = c->next)
3223 if (c->ts.type == BT_DERIVED && derived_pointer (c->ts.derived))
3231 /* Given a pointer to a symbol that is a derived type, see if it's
3232 inaccessible, i.e. if it's defined in another module and the components are
3233 PRIVATE. The search is recursive if necessary. Returns zero if no
3234 inaccessible components are found, nonzero otherwise. */
3237 derived_inaccessible (gfc_symbol *sym)
3241 if (sym->attr.use_assoc && sym->component_access == ACCESS_PRIVATE)
3244 for (c = sym->components; c; c = c->next)
3246 if (c->ts.type == BT_DERIVED && derived_inaccessible (c->ts.derived))
3254 /* Resolve the argument of a deallocate expression. The expression must be
3255 a pointer or a full array. */
3258 resolve_deallocate_expr (gfc_expr * e)
3260 symbol_attribute attr;
3264 if (gfc_resolve_expr (e) == FAILURE)
3267 attr = gfc_expr_attr (e);
3271 if (e->expr_type != EXPR_VARIABLE)
3274 allocatable = e->symtree->n.sym->attr.allocatable;
3275 for (ref = e->ref; ref; ref = ref->next)
3279 if (ref->u.ar.type != AR_FULL)
3284 allocatable = (ref->u.c.component->as != NULL
3285 && ref->u.c.component->as->type == AS_DEFERRED);
3293 if (allocatable == 0)
3296 gfc_error ("Expression in DEALLOCATE statement at %L must be "
3297 "ALLOCATABLE or a POINTER", &e->where);
3300 if (e->symtree->n.sym->attr.intent == INTENT_IN)
3302 gfc_error ("Can't deallocate INTENT(IN) variable '%s' at %L",
3303 e->symtree->n.sym->name, &e->where);
3311 /* Given the expression node e for an allocatable/pointer of derived type to be
3312 allocated, get the expression node to be initialized afterwards (needed for
3313 derived types with default initializers). */
3316 expr_to_initialize (gfc_expr * e)
3322 result = gfc_copy_expr (e);
3324 /* Change the last array reference from AR_ELEMENT to AR_FULL. */
3325 for (ref = result->ref; ref; ref = ref->next)
3326 if (ref->type == REF_ARRAY && ref->next == NULL)
3328 ref->u.ar.type = AR_FULL;
3330 for (i = 0; i < ref->u.ar.dimen; i++)
3331 ref->u.ar.start[i] = ref->u.ar.end[i] = ref->u.ar.stride[i] = NULL;
3333 result->rank = ref->u.ar.dimen;
3341 /* Resolve the expression in an ALLOCATE statement, doing the additional
3342 checks to see whether the expression is OK or not. The expression must
3343 have a trailing array reference that gives the size of the array. */
3346 resolve_allocate_expr (gfc_expr * e, gfc_code * code)
3348 int i, pointer, allocatable, dimension;
3349 symbol_attribute attr;
3350 gfc_ref *ref, *ref2;
3355 if (gfc_resolve_expr (e) == FAILURE)
3358 /* Make sure the expression is allocatable or a pointer. If it is
3359 pointer, the next-to-last reference must be a pointer. */
3363 if (e->expr_type != EXPR_VARIABLE)
3367 attr = gfc_expr_attr (e);
3368 pointer = attr.pointer;
3369 dimension = attr.dimension;
3374 allocatable = e->symtree->n.sym->attr.allocatable;
3375 pointer = e->symtree->n.sym->attr.pointer;
3376 dimension = e->symtree->n.sym->attr.dimension;
3378 for (ref = e->ref; ref; ref2 = ref, ref = ref->next)
3382 if (ref->next != NULL)
3387 allocatable = (ref->u.c.component->as != NULL
3388 && ref->u.c.component->as->type == AS_DEFERRED);
3390 pointer = ref->u.c.component->pointer;
3391 dimension = ref->u.c.component->dimension;
3401 if (allocatable == 0 && pointer == 0)
3403 gfc_error ("Expression in ALLOCATE statement at %L must be "
3404 "ALLOCATABLE or a POINTER", &e->where);
3408 if (e->symtree->n.sym->attr.intent == INTENT_IN)
3410 gfc_error ("Can't allocate INTENT(IN) variable '%s' at %L",
3411 e->symtree->n.sym->name, &e->where);
3415 /* Add default initializer for those derived types that need them. */
3416 if (e->ts.type == BT_DERIVED && (init_e = gfc_default_initializer (&e->ts)))
3418 init_st = gfc_get_code ();
3419 init_st->loc = code->loc;
3420 init_st->op = EXEC_ASSIGN;
3421 init_st->expr = expr_to_initialize (e);
3422 init_st->expr2 = init_e;
3424 init_st->next = code->next;
3425 code->next = init_st;
3428 if (pointer && dimension == 0)
3431 /* Make sure the next-to-last reference node is an array specification. */
3433 if (ref2 == NULL || ref2->type != REF_ARRAY || ref2->u.ar.type == AR_FULL)
3435 gfc_error ("Array specification required in ALLOCATE statement "
3436 "at %L", &e->where);
3440 if (ref2->u.ar.type == AR_ELEMENT)
3443 /* Make sure that the array section reference makes sense in the
3444 context of an ALLOCATE specification. */
3448 for (i = 0; i < ar->dimen; i++)
3449 switch (ar->dimen_type[i])
3455 if (ar->start[i] != NULL
3456 && ar->end[i] != NULL
3457 && ar->stride[i] == NULL)
3460 /* Fall Through... */
3464 gfc_error ("Bad array specification in ALLOCATE statement at %L",
3473 /************ SELECT CASE resolution subroutines ************/
3475 /* Callback function for our mergesort variant. Determines interval
3476 overlaps for CASEs. Return <0 if op1 < op2, 0 for overlap, >0 for
3477 op1 > op2. Assumes we're not dealing with the default case.
3478 We have op1 = (:L), (K:L) or (K:) and op2 = (:N), (M:N) or (M:).
3479 There are nine situations to check. */
3482 compare_cases (const gfc_case * op1, const gfc_case * op2)
3486 if (op1->low == NULL) /* op1 = (:L) */
3488 /* op2 = (:N), so overlap. */
3490 /* op2 = (M:) or (M:N), L < M */
3491 if (op2->low != NULL
3492 && gfc_compare_expr (op1->high, op2->low) < 0)
3495 else if (op1->high == NULL) /* op1 = (K:) */
3497 /* op2 = (M:), so overlap. */
3499 /* op2 = (:N) or (M:N), K > N */
3500 if (op2->high != NULL
3501 && gfc_compare_expr (op1->low, op2->high) > 0)
3504 else /* op1 = (K:L) */
3506 if (op2->low == NULL) /* op2 = (:N), K > N */
3507 retval = (gfc_compare_expr (op1->low, op2->high) > 0) ? 1 : 0;
3508 else if (op2->high == NULL) /* op2 = (M:), L < M */
3509 retval = (gfc_compare_expr (op1->high, op2->low) < 0) ? -1 : 0;
3510 else /* op2 = (M:N) */
3514 if (gfc_compare_expr (op1->high, op2->low) < 0)
3517 else if (gfc_compare_expr (op1->low, op2->high) > 0)
3526 /* Merge-sort a double linked case list, detecting overlap in the
3527 process. LIST is the head of the double linked case list before it
3528 is sorted. Returns the head of the sorted list if we don't see any
3529 overlap, or NULL otherwise. */
3532 check_case_overlap (gfc_case * list)
3534 gfc_case *p, *q, *e, *tail;
3535 int insize, nmerges, psize, qsize, cmp, overlap_seen;
3537 /* If the passed list was empty, return immediately. */
3544 /* Loop unconditionally. The only exit from this loop is a return
3545 statement, when we've finished sorting the case list. */
3552 /* Count the number of merges we do in this pass. */
3555 /* Loop while there exists a merge to be done. */
3560 /* Count this merge. */
3563 /* Cut the list in two pieces by stepping INSIZE places
3564 forward in the list, starting from P. */
3567 for (i = 0; i < insize; i++)
3576 /* Now we have two lists. Merge them! */
3577 while (psize > 0 || (qsize > 0 && q != NULL))
3580 /* See from which the next case to merge comes from. */
3583 /* P is empty so the next case must come from Q. */
3588 else if (qsize == 0 || q == NULL)
3597 cmp = compare_cases (p, q);
3600 /* The whole case range for P is less than the
3608 /* The whole case range for Q is greater than
3609 the case range for P. */
3616 /* The cases overlap, or they are the same
3617 element in the list. Either way, we must
3618 issue an error and get the next case from P. */
3619 /* FIXME: Sort P and Q by line number. */
3620 gfc_error ("CASE label at %L overlaps with CASE "
3621 "label at %L", &p->where, &q->where);
3629 /* Add the next element to the merged list. */
3638 /* P has now stepped INSIZE places along, and so has Q. So
3639 they're the same. */
3644 /* If we have done only one merge or none at all, we've
3645 finished sorting the cases. */
3654 /* Otherwise repeat, merging lists twice the size. */
3660 /* Check to see if an expression is suitable for use in a CASE statement.
3661 Makes sure that all case expressions are scalar constants of the same
3662 type. Return FAILURE if anything is wrong. */
3665 validate_case_label_expr (gfc_expr * e, gfc_expr * case_expr)
3667 if (e == NULL) return SUCCESS;
3669 if (e->ts.type != case_expr->ts.type)
3671 gfc_error ("Expression in CASE statement at %L must be of type %s",
3672 &e->where, gfc_basic_typename (case_expr->ts.type));
3676 /* C805 (R808) For a given case-construct, each case-value shall be of
3677 the same type as case-expr. For character type, length differences
3678 are allowed, but the kind type parameters shall be the same. */
3680 if (case_expr->ts.type == BT_CHARACTER && e->ts.kind != case_expr->ts.kind)
3682 gfc_error("Expression in CASE statement at %L must be kind %d",
3683 &e->where, case_expr->ts.kind);
3687 /* Convert the case value kind to that of case expression kind, if needed.
3688 FIXME: Should a warning be issued? */
3689 if (e->ts.kind != case_expr->ts.kind)
3690 gfc_convert_type_warn (e, &case_expr->ts, 2, 0);
3694 gfc_error ("Expression in CASE statement at %L must be scalar",
3703 /* Given a completely parsed select statement, we:
3705 - Validate all expressions and code within the SELECT.
3706 - Make sure that the selection expression is not of the wrong type.
3707 - Make sure that no case ranges overlap.
3708 - Eliminate unreachable cases and unreachable code resulting from
3709 removing case labels.
3711 The standard does allow unreachable cases, e.g. CASE (5:3). But
3712 they are a hassle for code generation, and to prevent that, we just
3713 cut them out here. This is not necessary for overlapping cases
3714 because they are illegal and we never even try to generate code.
3716 We have the additional caveat that a SELECT construct could have
3717 been a computed GOTO in the source code. Fortunately we can fairly
3718 easily work around that here: The case_expr for a "real" SELECT CASE
3719 is in code->expr1, but for a computed GOTO it is in code->expr2. All
3720 we have to do is make sure that the case_expr is a scalar integer
3724 resolve_select (gfc_code * code)
3727 gfc_expr *case_expr;
3728 gfc_case *cp, *default_case, *tail, *head;
3729 int seen_unreachable;
3735 if (code->expr == NULL)
3737 /* This was actually a computed GOTO statement. */
3738 case_expr = code->expr2;
3739 if (case_expr->ts.type != BT_INTEGER
3740 || case_expr->rank != 0)
3741 gfc_error ("Selection expression in computed GOTO statement "
3742 "at %L must be a scalar integer expression",
3745 /* Further checking is not necessary because this SELECT was built
3746 by the compiler, so it should always be OK. Just move the
3747 case_expr from expr2 to expr so that we can handle computed
3748 GOTOs as normal SELECTs from here on. */
3749 code->expr = code->expr2;
3754 case_expr = code->expr;
3756 type = case_expr->ts.type;
3757 if (type != BT_LOGICAL && type != BT_INTEGER && type != BT_CHARACTER)
3759 gfc_error ("Argument of SELECT statement at %L cannot be %s",
3760 &case_expr->where, gfc_typename (&case_expr->ts));
3762 /* Punt. Going on here just produce more garbage error messages. */
3766 if (case_expr->rank != 0)
3768 gfc_error ("Argument of SELECT statement at %L must be a scalar "
3769 "expression", &case_expr->where);
3775 /* PR 19168 has a long discussion concerning a mismatch of the kinds
3776 of the SELECT CASE expression and its CASE values. Walk the lists
3777 of case values, and if we find a mismatch, promote case_expr to
3778 the appropriate kind. */
3780 if (type == BT_LOGICAL || type == BT_INTEGER)
3782 for (body = code->block; body; body = body->block)
3784 /* Walk the case label list. */
3785 for (cp = body->ext.case_list; cp; cp = cp->next)
3787 /* Intercept the DEFAULT case. It does not have a kind. */
3788 if (cp->low == NULL && cp->high == NULL)
3791 /* Unreachable case ranges are discarded, so ignore. */
3792 if (cp->low != NULL && cp->high != NULL
3793 && cp->low != cp->high
3794 && gfc_compare_expr (cp->low, cp->high) > 0)
3797 /* FIXME: Should a warning be issued? */
3799 && case_expr->ts.kind != gfc_kind_max(case_expr, cp->low))
3800 gfc_convert_type_warn (case_expr, &cp->low->ts, 2, 0);
3802 if (cp->high != NULL
3803 && case_expr->ts.kind != gfc_kind_max(case_expr, cp->high))
3804 gfc_convert_type_warn (case_expr, &cp->high->ts, 2, 0);
3809 /* Assume there is no DEFAULT case. */
3810 default_case = NULL;
3815 for (body = code->block; body; body = body->block)
3817 /* Assume the CASE list is OK, and all CASE labels can be matched. */
3819 seen_unreachable = 0;
3821 /* Walk the case label list, making sure that all case labels
3823 for (cp = body->ext.case_list; cp; cp = cp->next)
3825 /* Count the number of cases in the whole construct. */
3828 /* Intercept the DEFAULT case. */
3829 if (cp->low == NULL && cp->high == NULL)
3831 if (default_case != NULL)
3833 gfc_error ("The DEFAULT CASE at %L cannot be followed "
3834 "by a second DEFAULT CASE at %L",
3835 &default_case->where, &cp->where);
3846 /* Deal with single value cases and case ranges. Errors are
3847 issued from the validation function. */
3848 if(validate_case_label_expr (cp->low, case_expr) != SUCCESS
3849 || validate_case_label_expr (cp->high, case_expr) != SUCCESS)
3855 if (type == BT_LOGICAL
3856 && ((cp->low == NULL || cp->high == NULL)
3857 || cp->low != cp->high))
3860 ("Logical range in CASE statement at %L is not allowed",
3866 if (type == BT_LOGICAL && cp->low->expr_type == EXPR_CONSTANT)
3869 value = cp->low->value.logical == 0 ? 2 : 1;
3870 if (value & seen_logical)
3872 gfc_error ("constant logical value in CASE statement "
3873 "is repeated at %L",
3878 seen_logical |= value;
3881 if (cp->low != NULL && cp->high != NULL
3882 && cp->low != cp->high
3883 && gfc_compare_expr (cp->low, cp->high) > 0)
3885 if (gfc_option.warn_surprising)
3886 gfc_warning ("Range specification at %L can never "
3887 "be matched", &cp->where);
3889 cp->unreachable = 1;
3890 seen_unreachable = 1;
3894 /* If the case range can be matched, it can also overlap with
3895 other cases. To make sure it does not, we put it in a
3896 double linked list here. We sort that with a merge sort
3897 later on to detect any overlapping cases. */
3901 head->right = head->left = NULL;
3906 tail->right->left = tail;
3913 /* It there was a failure in the previous case label, give up
3914 for this case label list. Continue with the next block. */
3918 /* See if any case labels that are unreachable have been seen.
3919 If so, we eliminate them. This is a bit of a kludge because
3920 the case lists for a single case statement (label) is a
3921 single forward linked lists. */
3922 if (seen_unreachable)
3924 /* Advance until the first case in the list is reachable. */
3925 while (body->ext.case_list != NULL
3926 && body->ext.case_list->unreachable)
3928 gfc_case *n = body->ext.case_list;
3929 body->ext.case_list = body->ext.case_list->next;
3931 gfc_free_case_list (n);
3934 /* Strip all other unreachable cases. */
3935 if (body->ext.case_list)
3937 for (cp = body->ext.case_list; cp->next; cp = cp->next)
3939 if (cp->next->unreachable)
3941 gfc_case *n = cp->next;
3942 cp->next = cp->next->next;
3944 gfc_free_case_list (n);
3951 /* See if there were overlapping cases. If the check returns NULL,
3952 there was overlap. In that case we don't do anything. If head
3953 is non-NULL, we prepend the DEFAULT case. The sorted list can
3954 then used during code generation for SELECT CASE constructs with
3955 a case expression of a CHARACTER type. */
3958 head = check_case_overlap (head);
3960 /* Prepend the default_case if it is there. */
3961 if (head != NULL && default_case)
3963 default_case->left = NULL;
3964 default_case->right = head;
3965 head->left = default_case;
3969 /* Eliminate dead blocks that may be the result if we've seen
3970 unreachable case labels for a block. */
3971 for (body = code; body && body->block; body = body->block)
3973 if (body->block->ext.case_list == NULL)
3975 /* Cut the unreachable block from the code chain. */
3976 gfc_code *c = body->block;
3977 body->block = c->block;
3979 /* Kill the dead block, but not the blocks below it. */
3981 gfc_free_statements (c);
3985 /* More than two cases is legal but insane for logical selects.
3986 Issue a warning for it. */
3987 if (gfc_option.warn_surprising && type == BT_LOGICAL
3989 gfc_warning ("Logical SELECT CASE block at %L has more that two cases",
3994 /* Resolve a transfer statement. This is making sure that:
3995 -- a derived type being transferred has only non-pointer components
3996 -- a derived type being transferred doesn't have private components, unless
3997 it's being transferred from the module where the type was defined
3998 -- we're not trying to transfer a whole assumed size array. */
4001 resolve_transfer (gfc_code * code)
4010 if (exp->expr_type != EXPR_VARIABLE)
4013 sym = exp->symtree->n.sym;
4016 /* Go to actual component transferred. */
4017 for (ref = code->expr->ref; ref; ref = ref->next)
4018 if (ref->type == REF_COMPONENT)
4019 ts = &ref->u.c.component->ts;
4021 if (ts->type == BT_DERIVED)
4023 /* Check that transferred derived type doesn't contain POINTER
4025 if (derived_pointer (ts->derived))
4027 gfc_error ("Data transfer element at %L cannot have "
4028 "POINTER components", &code->loc);
4032 if (derived_inaccessible (ts->derived))
4034 gfc_error ("Data transfer element at %L cannot have "
4035 "PRIVATE components",&code->loc);
4040 if (sym->as != NULL && sym->as->type == AS_ASSUMED_SIZE
4041 && exp->ref->type == REF_ARRAY && exp->ref->u.ar.type == AR_FULL)
4043 gfc_error ("Data transfer element at %L cannot be a full reference to "
4044 "an assumed-size array", &code->loc);
4050 /*********** Toplevel code resolution subroutines ***********/
4052 /* Given a branch to a label and a namespace, if the branch is conforming.
4053 The code node described where the branch is located. */
4056 resolve_branch (gfc_st_label * label, gfc_code * code)
4058 gfc_code *block, *found;
4066 /* Step one: is this a valid branching target? */
4068 if (lp->defined == ST_LABEL_UNKNOWN)
4070 gfc_error ("Label %d referenced at %L is never defined", lp->value,
4075 if (lp->defined != ST_LABEL_TARGET)
4077 gfc_error ("Statement at %L is not a valid branch target statement "
4078 "for the branch statement at %L", &lp->where, &code->loc);
4082 /* Step two: make sure this branch is not a branch to itself ;-) */
4084 if (code->here == label)
4086 gfc_warning ("Branch at %L causes an infinite loop", &code->loc);
4090 /* Step three: Try to find the label in the parse tree. To do this,
4091 we traverse the tree block-by-block: first the block that
4092 contains this GOTO, then the block that it is nested in, etc. We
4093 can ignore other blocks because branching into another block is
4098 for (stack = cs_base; stack; stack = stack->prev)
4100 for (block = stack->head; block; block = block->next)
4102 if (block->here == label)
4115 /* The label is not in an enclosing block, so illegal. This was
4116 allowed in Fortran 66, so we allow it as extension. We also
4117 forego further checks if we run into this. */
4118 gfc_notify_std (GFC_STD_LEGACY,
4119 "Label at %L is not in the same block as the "
4120 "GOTO statement at %L", &lp->where, &code->loc);
4124 /* Step four: Make sure that the branching target is legal if
4125 the statement is an END {SELECT,DO,IF}. */
4127 if (found->op == EXEC_NOP)
4129 for (stack = cs_base; stack; stack = stack->prev)
4130 if (stack->current->next == found)
4134 gfc_notify_std (GFC_STD_F95_DEL,
4135 "Obsolete: GOTO at %L jumps to END of construct at %L",
4136 &code->loc, &found->loc);
4141 /* Check whether EXPR1 has the same shape as EXPR2. */
4144 resolve_where_shape (gfc_expr *expr1, gfc_expr *expr2)
4146 mpz_t shape[GFC_MAX_DIMENSIONS];
4147 mpz_t shape2[GFC_MAX_DIMENSIONS];
4148 try result = FAILURE;
4151 /* Compare the rank. */
4152 if (expr1->rank != expr2->rank)
4155 /* Compare the size of each dimension. */
4156 for (i=0; i<expr1->rank; i++)
4158 if (gfc_array_dimen_size (expr1, i, &shape[i]) == FAILURE)
4161 if (gfc_array_dimen_size (expr2, i, &shape2[i]) == FAILURE)
4164 if (mpz_cmp (shape[i], shape2[i]))
4168 /* When either of the two expression is an assumed size array, we
4169 ignore the comparison of dimension sizes. */
4174 for (i--; i>=0; i--)
4176 mpz_clear (shape[i]);
4177 mpz_clear (shape2[i]);
4183 /* Check whether a WHERE assignment target or a WHERE mask expression
4184 has the same shape as the outmost WHERE mask expression. */
4187 resolve_where (gfc_code *code, gfc_expr *mask)
4193 cblock = code->block;
4195 /* Store the first WHERE mask-expr of the WHERE statement or construct.
4196 In case of nested WHERE, only the outmost one is stored. */
4197 if (mask == NULL) /* outmost WHERE */
4199 else /* inner WHERE */
4206 /* Check if the mask-expr has a consistent shape with the
4207 outmost WHERE mask-expr. */
4208 if (resolve_where_shape (cblock->expr, e) == FAILURE)
4209 gfc_error ("WHERE mask at %L has inconsistent shape",
4210 &cblock->expr->where);
4213 /* the assignment statement of a WHERE statement, or the first
4214 statement in where-body-construct of a WHERE construct */
4215 cnext = cblock->next;
4220 /* WHERE assignment statement */
4223 /* Check shape consistent for WHERE assignment target. */
4224 if (e && resolve_where_shape (cnext->expr, e) == FAILURE)
4225 gfc_error ("WHERE assignment target at %L has "
4226 "inconsistent shape", &cnext->expr->where);
4229 /* WHERE or WHERE construct is part of a where-body-construct */
4231 resolve_where (cnext, e);
4235 gfc_error ("Unsupported statement inside WHERE at %L",
4238 /* the next statement within the same where-body-construct */
4239 cnext = cnext->next;
4241 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
4242 cblock = cblock->block;
4247 /* Check whether the FORALL index appears in the expression or not. */
4250 gfc_find_forall_index (gfc_expr *expr, gfc_symbol *symbol)
4254 gfc_actual_arglist *args;
4257 switch (expr->expr_type)
4260 gcc_assert (expr->symtree->n.sym);
4262 /* A scalar assignment */
4265 if (expr->symtree->n.sym == symbol)
4271 /* the expr is array ref, substring or struct component. */
4278 /* Check if the symbol appears in the array subscript. */
4280 for (i = 0; i < GFC_MAX_DIMENSIONS; i++)
4283 if (gfc_find_forall_index (ar.start[i], symbol) == SUCCESS)
4287 if (gfc_find_forall_index (ar.end[i], symbol) == SUCCESS)
4291 if (gfc_find_forall_index (ar.stride[i], symbol) == SUCCESS)
4297 if (expr->symtree->n.sym == symbol)
4300 /* Check if the symbol appears in the substring section. */
4301 if (gfc_find_forall_index (tmp->u.ss.start, symbol) == SUCCESS)
4303 if (gfc_find_forall_index (tmp->u.ss.end, symbol) == SUCCESS)
4311 gfc_error("expression reference type error at %L", &expr->where);
4317 /* If the expression is a function call, then check if the symbol
4318 appears in the actual arglist of the function. */
4320 for (args = expr->value.function.actual; args; args = args->next)
4322 if (gfc_find_forall_index(args->expr,symbol) == SUCCESS)
4327 /* It seems not to happen. */
4328 case EXPR_SUBSTRING:
4332 gcc_assert (expr->ref->type == REF_SUBSTRING);
4333 if (gfc_find_forall_index (tmp->u.ss.start, symbol) == SUCCESS)
4335 if (gfc_find_forall_index (tmp->u.ss.end, symbol) == SUCCESS)
4340 /* It seems not to happen. */
4341 case EXPR_STRUCTURE:
4343 gfc_error ("Unsupported statement while finding forall index in "
4348 /* Find the FORALL index in the first operand. */
4349 if (expr->value.op.op1)
4351 if (gfc_find_forall_index (expr->value.op.op1, symbol) == SUCCESS)
4355 /* Find the FORALL index in the second operand. */
4356 if (expr->value.op.op2)
4358 if (gfc_find_forall_index (expr->value.op.op2, symbol) == SUCCESS)
4371 /* Resolve assignment in FORALL construct.
4372 NVAR is the number of FORALL index variables, and VAR_EXPR records the
4373 FORALL index variables. */
4376 gfc_resolve_assign_in_forall (gfc_code *code, int nvar, gfc_expr **var_expr)
4380 for (n = 0; n < nvar; n++)
4382 gfc_symbol *forall_index;
4384 forall_index = var_expr[n]->symtree->n.sym;
4386 /* Check whether the assignment target is one of the FORALL index
4388 if ((code->expr->expr_type == EXPR_VARIABLE)
4389 && (code->expr->symtree->n.sym == forall_index))
4390 gfc_error ("Assignment to a FORALL index variable at %L",
4391 &code->expr->where);
4394 /* If one of the FORALL index variables doesn't appear in the
4395 assignment target, then there will be a many-to-one
4397 if (gfc_find_forall_index (code->expr, forall_index) == FAILURE)
4398 gfc_error ("The FORALL with index '%s' cause more than one "
4399 "assignment to this object at %L",
4400 var_expr[n]->symtree->name, &code->expr->where);
4406 /* Resolve WHERE statement in FORALL construct. */
4409 gfc_resolve_where_code_in_forall (gfc_code *code, int nvar, gfc_expr **var_expr){
4413 cblock = code->block;
4416 /* the assignment statement of a WHERE statement, or the first
4417 statement in where-body-construct of a WHERE construct */
4418 cnext = cblock->next;
4423 /* WHERE assignment statement */
4425 gfc_resolve_assign_in_forall (cnext, nvar, var_expr);
4428 /* WHERE or WHERE construct is part of a where-body-construct */
4430 gfc_resolve_where_code_in_forall (cnext, nvar, var_expr);
4434 gfc_error ("Unsupported statement inside WHERE at %L",
4437 /* the next statement within the same where-body-construct */
4438 cnext = cnext->next;
4440 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
4441 cblock = cblock->block;
4446 /* Traverse the FORALL body to check whether the following errors exist:
4447 1. For assignment, check if a many-to-one assignment happens.
4448 2. For WHERE statement, check the WHERE body to see if there is any
4449 many-to-one assignment. */
4452 gfc_resolve_forall_body (gfc_code *code, int nvar, gfc_expr **var_expr)
4456 c = code->block->next;
4462 case EXEC_POINTER_ASSIGN:
4463 gfc_resolve_assign_in_forall (c, nvar, var_expr);
4466 /* Because the gfc_resolve_blocks() will handle the nested FORALL,
4467 there is no need to handle it here. */
4471 gfc_resolve_where_code_in_forall(c, nvar, var_expr);
4476 /* The next statement in the FORALL body. */
4482 /* Given a FORALL construct, first resolve the FORALL iterator, then call
4483 gfc_resolve_forall_body to resolve the FORALL body. */
4486 gfc_resolve_forall (gfc_code *code, gfc_namespace *ns, int forall_save)
4488 static gfc_expr **var_expr;
4489 static int total_var = 0;
4490 static int nvar = 0;
4491 gfc_forall_iterator *fa;
4492 gfc_symbol *forall_index;
4496 /* Start to resolve a FORALL construct */
4497 if (forall_save == 0)
4499 /* Count the total number of FORALL index in the nested FORALL
4500 construct in order to allocate the VAR_EXPR with proper size. */
4502 while ((next != NULL) && (next->op == EXEC_FORALL))
4504 for (fa = next->ext.forall_iterator; fa; fa = fa->next)
4506 next = next->block->next;
4509 /* Allocate VAR_EXPR with NUMBER_OF_FORALL_INDEX elements. */
4510 var_expr = (gfc_expr **) gfc_getmem (total_var * sizeof (gfc_expr *));
4513 /* The information about FORALL iterator, including FORALL index start, end
4514 and stride. The FORALL index can not appear in start, end or stride. */
4515 for (fa = code->ext.forall_iterator; fa; fa = fa->next)
4517 /* Check if any outer FORALL index name is the same as the current
4519 for (i = 0; i < nvar; i++)
4521 if (fa->var->symtree->n.sym == var_expr[i]->symtree->n.sym)
4523 gfc_error ("An outer FORALL construct already has an index "
4524 "with this name %L", &fa->var->where);
4528 /* Record the current FORALL index. */
4529 var_expr[nvar] = gfc_copy_expr (fa->var);
4531 forall_index = fa->var->symtree->n.sym;
4533 /* Check if the FORALL index appears in start, end or stride. */
4534 if (gfc_find_forall_index (fa->start, forall_index) == SUCCESS)
4535 gfc_error ("A FORALL index must not appear in a limit or stride "
4536 "expression in the same FORALL at %L", &fa->start->where);
4537 if (gfc_find_forall_index (fa->end, forall_index) == SUCCESS)
4538 gfc_error ("A FORALL index must not appear in a limit or stride "
4539 "expression in the same FORALL at %L", &fa->end->where);
4540 if (gfc_find_forall_index (fa->stride, forall_index) == SUCCESS)
4541 gfc_error ("A FORALL index must not appear in a limit or stride "
4542 "expression in the same FORALL at %L", &fa->stride->where);
4546 /* Resolve the FORALL body. */
4547 gfc_resolve_forall_body (code, nvar, var_expr);
4549 /* May call gfc_resolve_forall to resolve the inner FORALL loop. */
4550 gfc_resolve_blocks (code->block, ns);
4552 /* Free VAR_EXPR after the whole FORALL construct resolved. */
4553 for (i = 0; i < total_var; i++)
4554 gfc_free_expr (var_expr[i]);
4556 /* Reset the counters. */
4562 /* Resolve lists of blocks found in IF, SELECT CASE, WHERE, FORALL ,GOTO and
4565 static void resolve_code (gfc_code *, gfc_namespace *);
4568 gfc_resolve_blocks (gfc_code * b, gfc_namespace * ns)
4572 for (; b; b = b->block)
4574 t = gfc_resolve_expr (b->expr);
4575 if (gfc_resolve_expr (b->expr2) == FAILURE)
4581 if (t == SUCCESS && b->expr != NULL
4582 && (b->expr->ts.type != BT_LOGICAL || b->expr->rank != 0))
4584 ("ELSE IF clause at %L requires a scalar LOGICAL expression",
4591 && (b->expr->ts.type != BT_LOGICAL
4592 || b->expr->rank == 0))
4594 ("WHERE/ELSEWHERE clause at %L requires a LOGICAL array",
4599 resolve_branch (b->label, b);
4611 case EXEC_OMP_ATOMIC:
4612 case EXEC_OMP_CRITICAL:
4614 case EXEC_OMP_MASTER:
4615 case EXEC_OMP_ORDERED:
4616 case EXEC_OMP_PARALLEL:
4617 case EXEC_OMP_PARALLEL_DO:
4618 case EXEC_OMP_PARALLEL_SECTIONS:
4619 case EXEC_OMP_PARALLEL_WORKSHARE:
4620 case EXEC_OMP_SECTIONS:
4621 case EXEC_OMP_SINGLE:
4622 case EXEC_OMP_WORKSHARE:
4626 gfc_internal_error ("resolve_block(): Bad block type");
4629 resolve_code (b->next, ns);
4634 /* Given a block of code, recursively resolve everything pointed to by this
4638 resolve_code (gfc_code * code, gfc_namespace * ns)
4640 int omp_workshare_save;
4646 frame.prev = cs_base;
4650 for (; code; code = code->next)
4652 frame.current = code;
4653 forall_save = forall_flag;
4655 if (code->op == EXEC_FORALL)
4658 gfc_resolve_forall (code, ns, forall_save);
4661 else if (code->block)
4663 omp_workshare_save = -1;
4666 case EXEC_OMP_PARALLEL_WORKSHARE:
4667 omp_workshare_save = omp_workshare_flag;
4668 omp_workshare_flag = 1;
4669 gfc_resolve_omp_parallel_blocks (code, ns);
4671 case EXEC_OMP_PARALLEL:
4672 case EXEC_OMP_PARALLEL_DO:
4673 case EXEC_OMP_PARALLEL_SECTIONS:
4674 omp_workshare_save = omp_workshare_flag;
4675 omp_workshare_flag = 0;
4676 gfc_resolve_omp_parallel_blocks (code, ns);
4679 gfc_resolve_omp_do_blocks (code, ns);
4681 case EXEC_OMP_WORKSHARE:
4682 omp_workshare_save = omp_workshare_flag;
4683 omp_workshare_flag = 1;
4686 gfc_resolve_blocks (code->block, ns);
4690 if (omp_workshare_save != -1)
4691 omp_workshare_flag = omp_workshare_save;
4694 t = gfc_resolve_expr (code->expr);
4695 forall_flag = forall_save;
4697 if (gfc_resolve_expr (code->expr2) == FAILURE)
4712 /* Keep track of which entry we are up to. */
4713 current_entry_id = code->ext.entry->id;
4717 resolve_where (code, NULL);
4721 if (code->expr != NULL)
4723 if (code->expr->ts.type != BT_INTEGER)
4724 gfc_error ("ASSIGNED GOTO statement at %L requires an INTEGER "
4725 "variable", &code->expr->where);
4726 else if (code->expr->symtree->n.sym->attr.assign != 1)
4727 gfc_error ("Variable '%s' has not been assigned a target label "
4728 "at %L", code->expr->symtree->n.sym->name,
4729 &code->expr->where);
4732 resolve_branch (code->label, code);
4736 if (code->expr != NULL
4737 && (code->expr->ts.type != BT_INTEGER || code->expr->rank))
4738 gfc_error ("Alternate RETURN statement at %L requires a SCALAR-"
4739 "INTEGER return specifier", &code->expr->where);
4746 if (gfc_extend_assign (code, ns) == SUCCESS)
4748 if (gfc_pure (NULL) && !gfc_pure (code->symtree->n.sym))
4750 gfc_error ("Subroutine '%s' called instead of assignment at "
4751 "%L must be PURE", code->symtree->n.sym->name,
4758 if (gfc_pure (NULL))
4760 if (gfc_impure_variable (code->expr->symtree->n.sym))
4763 ("Cannot assign to variable '%s' in PURE procedure at %L",
4764 code->expr->symtree->n.sym->name, &code->expr->where);
4768 if (code->expr2->ts.type == BT_DERIVED
4769 && derived_pointer (code->expr2->ts.derived))
4772 ("Right side of assignment at %L is a derived type "
4773 "containing a POINTER in a PURE procedure",
4774 &code->expr2->where);
4779 gfc_check_assign (code->expr, code->expr2, 1);
4782 case EXEC_LABEL_ASSIGN:
4783 if (code->label->defined == ST_LABEL_UNKNOWN)
4784 gfc_error ("Label %d referenced at %L is never defined",
4785 code->label->value, &code->label->where);
4787 && (code->expr->expr_type != EXPR_VARIABLE
4788 || code->expr->symtree->n.sym->ts.type != BT_INTEGER
4789 || code->expr->symtree->n.sym->ts.kind
4790 != gfc_default_integer_kind
4791 || code->expr->symtree->n.sym->as != NULL))
4792 gfc_error ("ASSIGN statement at %L requires a scalar "
4793 "default INTEGER variable", &code->expr->where);
4796 case EXEC_POINTER_ASSIGN:
4800 gfc_check_pointer_assign (code->expr, code->expr2);
4803 case EXEC_ARITHMETIC_IF:
4805 && code->expr->ts.type != BT_INTEGER
4806 && code->expr->ts.type != BT_REAL)
4807 gfc_error ("Arithmetic IF statement at %L requires a numeric "
4808 "expression", &code->expr->where);
4810 resolve_branch (code->label, code);
4811 resolve_branch (code->label2, code);
4812 resolve_branch (code->label3, code);
4816 if (t == SUCCESS && code->expr != NULL
4817 && (code->expr->ts.type != BT_LOGICAL
4818 || code->expr->rank != 0))
4819 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
4820 &code->expr->where);
4825 resolve_call (code);
4829 /* Select is complicated. Also, a SELECT construct could be
4830 a transformed computed GOTO. */
4831 resolve_select (code);
4835 if (code->ext.iterator != NULL)
4837 gfc_iterator *iter = code->ext.iterator;
4838 if (gfc_resolve_iterator (iter, true) != FAILURE)
4839 gfc_resolve_do_iterator (code, iter->var->symtree->n.sym);
4844 if (code->expr == NULL)
4845 gfc_internal_error ("resolve_code(): No expression on DO WHILE");
4847 && (code->expr->rank != 0
4848 || code->expr->ts.type != BT_LOGICAL))
4849 gfc_error ("Exit condition of DO WHILE loop at %L must be "
4850 "a scalar LOGICAL expression", &code->expr->where);
4854 if (t == SUCCESS && code->expr != NULL
4855 && code->expr->ts.type != BT_INTEGER)
4856 gfc_error ("STAT tag in ALLOCATE statement at %L must be "
4857 "of type INTEGER", &code->expr->where);
4859 for (a = code->ext.alloc_list; a; a = a->next)
4860 resolve_allocate_expr (a->expr, code);
4864 case EXEC_DEALLOCATE:
4865 if (t == SUCCESS && code->expr != NULL
4866 && code->expr->ts.type != BT_INTEGER)
4868 ("STAT tag in DEALLOCATE statement at %L must be of type "
4869 "INTEGER", &code->expr->where);
4871 for (a = code->ext.alloc_list; a; a = a->next)
4872 resolve_deallocate_expr (a->expr);
4877 if (gfc_resolve_open (code->ext.open) == FAILURE)
4880 resolve_branch (code->ext.open->err, code);
4884 if (gfc_resolve_close (code->ext.close) == FAILURE)
4887 resolve_branch (code->ext.close->err, code);
4890 case EXEC_BACKSPACE:
4894 if (gfc_resolve_filepos (code->ext.filepos) == FAILURE)
4897 resolve_branch (code->ext.filepos->err, code);
4901 if (gfc_resolve_inquire (code->ext.inquire) == FAILURE)
4904 resolve_branch (code->ext.inquire->err, code);
4908 gcc_assert (code->ext.inquire != NULL);
4909 if (gfc_resolve_inquire (code->ext.inquire) == FAILURE)
4912 resolve_branch (code->ext.inquire->err, code);
4917 if (gfc_resolve_dt (code->ext.dt) == FAILURE)
4920 resolve_branch (code->ext.dt->err, code);
4921 resolve_branch (code->ext.dt->end, code);
4922 resolve_branch (code->ext.dt->eor, code);
4926 resolve_transfer (code);
4930 resolve_forall_iterators (code->ext.forall_iterator);
4932 if (code->expr != NULL && code->expr->ts.type != BT_LOGICAL)
4934 ("FORALL mask clause at %L requires a LOGICAL expression",
4935 &code->expr->where);
4938 case EXEC_OMP_ATOMIC:
4939 case EXEC_OMP_BARRIER:
4940 case EXEC_OMP_CRITICAL:
4941 case EXEC_OMP_FLUSH:
4943 case EXEC_OMP_MASTER:
4944 case EXEC_OMP_ORDERED:
4945 case EXEC_OMP_SECTIONS:
4946 case EXEC_OMP_SINGLE:
4947 case EXEC_OMP_WORKSHARE:
4948 gfc_resolve_omp_directive (code, ns);
4951 case EXEC_OMP_PARALLEL:
4952 case EXEC_OMP_PARALLEL_DO:
4953 case EXEC_OMP_PARALLEL_SECTIONS:
4954 case EXEC_OMP_PARALLEL_WORKSHARE:
4955 omp_workshare_save = omp_workshare_flag;
4956 omp_workshare_flag = 0;
4957 gfc_resolve_omp_directive (code, ns);
4958 omp_workshare_flag = omp_workshare_save;
4962 gfc_internal_error ("resolve_code(): Bad statement code");
4966 cs_base = frame.prev;
4970 /* Resolve initial values and make sure they are compatible with
4974 resolve_values (gfc_symbol * sym)
4977 if (sym->value == NULL)
4980 if (gfc_resolve_expr (sym->value) == FAILURE)
4983 gfc_check_assign_symbol (sym, sym->value);
4987 /* Resolve an index expression. */
4990 resolve_index_expr (gfc_expr * e)
4992 if (gfc_resolve_expr (e) == FAILURE)
4995 if (gfc_simplify_expr (e, 0) == FAILURE)
4998 if (gfc_specification_expr (e) == FAILURE)
5004 /* Resolve a charlen structure. */
5007 resolve_charlen (gfc_charlen *cl)
5014 specification_expr = 1;
5016 if (resolve_index_expr (cl->length) == FAILURE)
5018 specification_expr = 0;
5026 /* Test for non-constant shape arrays. */
5029 is_non_constant_shape_array (gfc_symbol *sym)
5035 not_constant = false;
5036 if (sym->as != NULL)
5038 /* Unfortunately, !gfc_is_compile_time_shape hits a legal case that
5039 has not been simplified; parameter array references. Do the
5040 simplification now. */
5041 for (i = 0; i < sym->as->rank; i++)
5043 e = sym->as->lower[i];
5044 if (e && (resolve_index_expr (e) == FAILURE
5045 || !gfc_is_constant_expr (e)))
5046 not_constant = true;
5048 e = sym->as->upper[i];
5049 if (e && (resolve_index_expr (e) == FAILURE
5050 || !gfc_is_constant_expr (e)))
5051 not_constant = true;
5054 return not_constant;
5057 /* Resolution of common features of flavors variable and procedure. */
5060 resolve_fl_var_and_proc (gfc_symbol *sym, int mp_flag)
5062 /* Constraints on deferred shape variable. */
5063 if (sym->as == NULL || sym->as->type != AS_DEFERRED)
5065 if (sym->attr.allocatable)
5067 if (sym->attr.dimension)
5068 gfc_error ("Allocatable array '%s' at %L must have "
5069 "a deferred shape", sym->name, &sym->declared_at);
5071 gfc_error ("Scalar object '%s' at %L may not be ALLOCATABLE",
5072 sym->name, &sym->declared_at);
5076 if (sym->attr.pointer && sym->attr.dimension)
5078 gfc_error ("Array pointer '%s' at %L must have a deferred shape",
5079 sym->name, &sym->declared_at);
5086 if (!mp_flag && !sym->attr.allocatable
5087 && !sym->attr.pointer && !sym->attr.dummy)
5089 gfc_error ("Array '%s' at %L cannot have a deferred shape",
5090 sym->name, &sym->declared_at);
5097 /* Resolve symbols with flavor variable. */
5100 resolve_fl_variable (gfc_symbol *sym, int mp_flag)
5105 gfc_expr *constructor_expr;
5106 const char * auto_save_msg;
5108 auto_save_msg = "automatic object '%s' at %L cannot have the "
5111 if (resolve_fl_var_and_proc (sym, mp_flag) == FAILURE)
5114 /* Set this flag to check that variables are parameters of all entries.
5115 This check is effected by the call to gfc_resolve_expr through
5116 is_non_constant_shape_array. */
5117 specification_expr = 1;
5119 if (!sym->attr.use_assoc
5120 && !sym->attr.allocatable
5121 && !sym->attr.pointer
5122 && is_non_constant_shape_array (sym))
5124 /* The shape of a main program or module array needs to be constant. */
5125 if (sym->ns->proc_name
5126 && (sym->ns->proc_name->attr.flavor == FL_MODULE
5127 || sym->ns->proc_name->attr.is_main_program))
5129 gfc_error ("The module or main program array '%s' at %L must "
5130 "have constant shape", sym->name, &sym->declared_at);
5131 specification_expr = 0;
5136 if (sym->ts.type == BT_CHARACTER)
5138 /* Make sure that character string variables with assumed length are
5140 e = sym->ts.cl->length;
5141 if (e == NULL && !sym->attr.dummy && !sym->attr.result)
5143 gfc_error ("Entity with assumed character length at %L must be a "
5144 "dummy argument or a PARAMETER", &sym->declared_at);
5148 if (e && sym->attr.save && !gfc_is_constant_expr (e))
5150 gfc_error (auto_save_msg, sym->name, &sym->declared_at);
5154 if (!gfc_is_constant_expr (e)
5155 && !(e->expr_type == EXPR_VARIABLE
5156 && e->symtree->n.sym->attr.flavor == FL_PARAMETER)
5157 && sym->ns->proc_name
5158 && (sym->ns->proc_name->attr.flavor == FL_MODULE
5159 || sym->ns->proc_name->attr.is_main_program)
5160 && !sym->attr.use_assoc)
5162 gfc_error ("'%s' at %L must have constant character length "
5163 "in this context", sym->name, &sym->declared_at);
5168 /* Can the symbol have an initializer? */
5170 if (sym->attr.allocatable || sym->attr.external || sym->attr.dummy
5171 || sym->attr.intrinsic || sym->attr.result)
5173 else if (sym->attr.dimension && !sym->attr.pointer)
5175 /* Don't allow initialization of automatic arrays. */
5176 for (i = 0; i < sym->as->rank; i++)
5178 if (sym->as->lower[i] == NULL
5179 || sym->as->lower[i]->expr_type != EXPR_CONSTANT
5180 || sym->as->upper[i] == NULL
5181 || sym->as->upper[i]->expr_type != EXPR_CONSTANT)
5188 /* Also, they must not have the SAVE attribute. */
5189 if (flag && sym->attr.save)
5191 gfc_error (auto_save_msg, sym->name, &sym->declared_at);
5196 /* Reject illegal initializers. */
5197 if (sym->value && flag)
5199 if (sym->attr.allocatable)
5200 gfc_error ("Allocatable '%s' at %L cannot have an initializer",
5201 sym->name, &sym->declared_at);
5202 else if (sym->attr.external)
5203 gfc_error ("External '%s' at %L cannot have an initializer",
5204 sym->name, &sym->declared_at);
5205 else if (sym->attr.dummy)
5206 gfc_error ("Dummy '%s' at %L cannot have an initializer",
5207 sym->name, &sym->declared_at);
5208 else if (sym->attr.intrinsic)
5209 gfc_error ("Intrinsic '%s' at %L cannot have an initializer",
5210 sym->name, &sym->declared_at);
5211 else if (sym->attr.result)
5212 gfc_error ("Function result '%s' at %L cannot have an initializer",
5213 sym->name, &sym->declared_at);
5215 gfc_error ("Automatic array '%s' at %L cannot have an initializer",
5216 sym->name, &sym->declared_at);
5220 /* 4th constraint in section 11.3: "If an object of a type for which
5221 component-initialization is specified (R429) appears in the
5222 specification-part of a module and does not have the ALLOCATABLE
5223 or POINTER attribute, the object shall have the SAVE attribute." */
5225 constructor_expr = NULL;
5226 if (sym->ts.type == BT_DERIVED && !(sym->value || flag))
5227 constructor_expr = gfc_default_initializer (&sym->ts);
5229 if (sym->ns->proc_name
5230 && sym->ns->proc_name->attr.flavor == FL_MODULE
5232 && !sym->ns->save_all && !sym->attr.save
5233 && !sym->attr.pointer && !sym->attr.allocatable)
5235 gfc_error("Object '%s' at %L must have the SAVE attribute %s",
5236 sym->name, &sym->declared_at,
5237 "for default initialization of a component");
5241 /* Assign default initializer. */
5242 if (sym->ts.type == BT_DERIVED && !sym->value && !sym->attr.pointer
5243 && !sym->attr.allocatable && (!flag || sym->attr.intent == INTENT_OUT))
5244 sym->value = gfc_default_initializer (&sym->ts);
5250 /* Resolve a procedure. */
5253 resolve_fl_procedure (gfc_symbol *sym, int mp_flag)
5255 gfc_formal_arglist *arg;
5257 if (sym->attr.function
5258 && resolve_fl_var_and_proc (sym, mp_flag) == FAILURE)
5261 if (sym->attr.proc == PROC_ST_FUNCTION)
5263 if (sym->ts.type == BT_CHARACTER)
5265 gfc_charlen *cl = sym->ts.cl;
5266 if (!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT)
5268 gfc_error ("Character-valued statement function '%s' at %L must "
5269 "have constant length", sym->name, &sym->declared_at);
5275 /* Ensure that derived type for are not of a private type. Internal
5276 module procedures are excluded by 2.2.3.3 - ie. they are not
5277 externally accessible and can access all the objects accessible in
5279 if (!(sym->ns->parent
5280 && sym->ns->parent->proc_name->attr.flavor == FL_MODULE)
5281 && gfc_check_access(sym->attr.access, sym->ns->default_access))
5283 for (arg = sym->formal; arg; arg = arg->next)
5286 && arg->sym->ts.type == BT_DERIVED
5287 && !arg->sym->ts.derived->attr.use_assoc
5288 && !gfc_check_access(arg->sym->ts.derived->attr.access,
5289 arg->sym->ts.derived->ns->default_access))
5291 gfc_error_now ("'%s' is of a PRIVATE type and cannot be "
5292 "a dummy argument of '%s', which is "
5293 "PUBLIC at %L", arg->sym->name, sym->name,
5295 /* Stop this message from recurring. */
5296 arg->sym->ts.derived->attr.access = ACCESS_PUBLIC;
5302 /* An external symbol may not have an initializer because it is taken to be
5304 if (sym->attr.external && sym->value)
5306 gfc_error ("External object '%s' at %L may not have an initializer",
5307 sym->name, &sym->declared_at);
5311 /* An elemental function is required to return a scalar 12.7.1 */
5312 if (sym->attr.elemental && sym->attr.function && sym->as)
5314 gfc_error ("ELEMENTAL function '%s' at %L must have a scalar "
5315 "result", sym->name, &sym->declared_at);
5316 /* Reset so that the error only occurs once. */
5317 sym->attr.elemental = 0;
5321 /* 5.1.1.5 of the Standard: A function name declared with an asterisk
5322 char-len-param shall not be array-valued, pointer-valued, recursive
5323 or pure. ....snip... A character value of * may only be used in the
5324 following ways: (i) Dummy arg of procedure - dummy associates with
5325 actual length; (ii) To declare a named constant; or (iii) External
5326 function - but length must be declared in calling scoping unit. */
5327 if (sym->attr.function
5328 && sym->ts.type == BT_CHARACTER
5329 && sym->ts.cl && sym->ts.cl->length == NULL)
5331 if ((sym->as && sym->as->rank) || (sym->attr.pointer)
5332 || (sym->attr.recursive) || (sym->attr.pure))
5334 if (sym->as && sym->as->rank)
5335 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
5336 "array-valued", sym->name, &sym->declared_at);
5338 if (sym->attr.pointer)
5339 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
5340 "pointer-valued", sym->name, &sym->declared_at);
5343 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
5344 "pure", sym->name, &sym->declared_at);
5346 if (sym->attr.recursive)
5347 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
5348 "recursive", sym->name, &sym->declared_at);
5353 /* Appendix B.2 of the standard. Contained functions give an
5354 error anyway. Fixed-form is likely to be F77/legacy. */
5355 if (!sym->attr.contained && gfc_current_form != FORM_FIXED)
5356 gfc_notify_std (GFC_STD_F95_OBS, "CHARACTER(*) function "
5357 "'%s' at %L is obsolescent in fortran 95",
5358 sym->name, &sym->declared_at);
5364 /* Resolve the components of a derived type. */
5367 resolve_fl_derived (gfc_symbol *sym)
5372 for (c = sym->components; c != NULL; c = c->next)
5374 if (c->ts.type == BT_CHARACTER)
5376 if (c->ts.cl->length == NULL
5377 || (resolve_charlen (c->ts.cl) == FAILURE)
5378 || !gfc_is_constant_expr (c->ts.cl->length))
5380 gfc_error ("Character length of component '%s' needs to "
5381 "be a constant specification expression at %L.",
5383 c->ts.cl->length ? &c->ts.cl->length->where : &c->loc);
5388 if (c->ts.type == BT_DERIVED
5389 && sym->component_access != ACCESS_PRIVATE
5390 && gfc_check_access(sym->attr.access, sym->ns->default_access)
5391 && !c->ts.derived->attr.use_assoc
5392 && !gfc_check_access(c->ts.derived->attr.access,
5393 c->ts.derived->ns->default_access))
5395 gfc_error ("The component '%s' is a PRIVATE type and cannot be "
5396 "a component of '%s', which is PUBLIC at %L",
5397 c->name, sym->name, &sym->declared_at);
5401 if (sym->attr.sequence)
5403 if (c->ts.type == BT_DERIVED && c->ts.derived->attr.sequence == 0)
5405 gfc_error ("Component %s of SEQUENCE type declared at %L does "
5406 "not have the SEQUENCE attribute",
5407 c->ts.derived->name, &sym->declared_at);
5412 if (c->pointer || c->as == NULL)
5415 for (i = 0; i < c->as->rank; i++)
5417 if (c->as->lower[i] == NULL
5418 || !gfc_is_constant_expr (c->as->lower[i])
5419 || (resolve_index_expr (c->as->lower[i]) == FAILURE)
5420 || c->as->upper[i] == NULL
5421 || (resolve_index_expr (c->as->upper[i]) == FAILURE)
5422 || !gfc_is_constant_expr (c->as->upper[i]))
5424 gfc_error ("Component '%s' of '%s' at %L must have "
5425 "constant array bounds.",
5426 c->name, sym->name, &c->loc);
5437 resolve_fl_namelist (gfc_symbol *sym)
5442 /* Reject PRIVATE objects in a PUBLIC namelist. */
5443 if (gfc_check_access(sym->attr.access, sym->ns->default_access))
5445 for (nl = sym->namelist; nl; nl = nl->next)
5447 if (!nl->sym->attr.use_assoc
5448 && !(sym->ns->parent == nl->sym->ns)
5449 && !gfc_check_access(nl->sym->attr.access,
5450 nl->sym->ns->default_access))
5452 gfc_error ("PRIVATE symbol '%s' cannot be member of "
5453 "PUBLIC namelist at %L", nl->sym->name,
5460 /* Reject namelist arrays that are not constant shape. */
5461 for (nl = sym->namelist; nl; nl = nl->next)
5463 if (is_non_constant_shape_array (nl->sym))
5465 gfc_error ("The array '%s' must have constant shape to be "
5466 "a NAMELIST object at %L", nl->sym->name,
5472 /* 14.1.2 A module or internal procedure represent local entities
5473 of the same type as a namelist member and so are not allowed.
5474 Note that this is sometimes caught by check_conflict so the
5475 same message has been used. */
5476 for (nl = sym->namelist; nl; nl = nl->next)
5479 if (sym->ns->parent && nl->sym && nl->sym->name)
5480 gfc_find_symbol (nl->sym->name, sym->ns->parent, 0, &nlsym);
5481 if (nlsym && nlsym->attr.flavor == FL_PROCEDURE)
5483 gfc_error ("PROCEDURE attribute conflicts with NAMELIST "
5484 "attribute in '%s' at %L", nlsym->name,
5495 resolve_fl_parameter (gfc_symbol *sym)
5497 /* A parameter array's shape needs to be constant. */
5498 if (sym->as != NULL && !gfc_is_compile_time_shape (sym->as))
5500 gfc_error ("Parameter array '%s' at %L cannot be automatic "
5501 "or assumed shape", sym->name, &sym->declared_at);
5505 /* Make sure a parameter that has been implicitly typed still
5506 matches the implicit type, since PARAMETER statements can precede
5507 IMPLICIT statements. */
5508 if (sym->attr.implicit_type
5509 && !gfc_compare_types (&sym->ts,
5510 gfc_get_default_type (sym, sym->ns)))
5512 gfc_error ("Implicitly typed PARAMETER '%s' at %L doesn't match a "
5513 "later IMPLICIT type", sym->name, &sym->declared_at);
5517 /* Make sure the types of derived parameters are consistent. This
5518 type checking is deferred until resolution because the type may
5519 refer to a derived type from the host. */
5520 if (sym->ts.type == BT_DERIVED
5521 && !gfc_compare_types (&sym->ts, &sym->value->ts))
5523 gfc_error ("Incompatible derived type in PARAMETER at %L",
5524 &sym->value->where);
5531 /* Do anything necessary to resolve a symbol. Right now, we just
5532 assume that an otherwise unknown symbol is a variable. This sort
5533 of thing commonly happens for symbols in module. */
5536 resolve_symbol (gfc_symbol * sym)
5538 /* Zero if we are checking a formal namespace. */
5539 static int formal_ns_flag = 1;
5540 int formal_ns_save, check_constant, mp_flag;
5541 gfc_symtree *symtree;
5542 gfc_symtree *this_symtree;
5546 if (sym->attr.flavor == FL_UNKNOWN)
5549 /* If we find that a flavorless symbol is an interface in one of the
5550 parent namespaces, find its symtree in this namespace, free the
5551 symbol and set the symtree to point to the interface symbol. */
5552 for (ns = gfc_current_ns->parent; ns; ns = ns->parent)
5554 symtree = gfc_find_symtree (ns->sym_root, sym->name);
5555 if (symtree && symtree->n.sym->generic)
5557 this_symtree = gfc_find_symtree (gfc_current_ns->sym_root,
5561 gfc_free_symbol (sym);
5562 symtree->n.sym->refs++;
5563 this_symtree->n.sym = symtree->n.sym;
5568 /* Otherwise give it a flavor according to such attributes as
5570 if (sym->attr.external == 0 && sym->attr.intrinsic == 0)
5571 sym->attr.flavor = FL_VARIABLE;
5574 sym->attr.flavor = FL_PROCEDURE;
5575 if (sym->attr.dimension)
5576 sym->attr.function = 1;
5580 if (sym->attr.flavor == FL_DERIVED && resolve_fl_derived (sym) == FAILURE)
5583 /* Symbols that are module procedures with results (functions) have
5584 the types and array specification copied for type checking in
5585 procedures that call them, as well as for saving to a module
5586 file. These symbols can't stand the scrutiny that their results
5588 mp_flag = (sym->result != NULL && sym->result != sym);
5590 /* Assign default type to symbols that need one and don't have one. */
5591 if (sym->ts.type == BT_UNKNOWN)
5593 if (sym->attr.flavor == FL_VARIABLE || sym->attr.flavor == FL_PARAMETER)
5594 gfc_set_default_type (sym, 1, NULL);
5596 if (sym->attr.flavor == FL_PROCEDURE && sym->attr.function)
5598 /* The specific case of an external procedure should emit an error
5599 in the case that there is no implicit type. */
5601 gfc_set_default_type (sym, sym->attr.external, NULL);
5604 /* Result may be in another namespace. */
5605 resolve_symbol (sym->result);
5607 sym->ts = sym->result->ts;
5608 sym->as = gfc_copy_array_spec (sym->result->as);
5609 sym->attr.dimension = sym->result->attr.dimension;
5610 sym->attr.pointer = sym->result->attr.pointer;
5611 sym->attr.allocatable = sym->result->attr.allocatable;
5616 /* Assumed size arrays and assumed shape arrays must be dummy
5620 && (sym->as->type == AS_ASSUMED_SIZE
5621 || sym->as->type == AS_ASSUMED_SHAPE)
5622 && sym->attr.dummy == 0)
5624 if (sym->as->type == AS_ASSUMED_SIZE)
5625 gfc_error ("Assumed size array at %L must be a dummy argument",
5628 gfc_error ("Assumed shape array at %L must be a dummy argument",
5633 /* Make sure symbols with known intent or optional are really dummy
5634 variable. Because of ENTRY statement, this has to be deferred
5635 until resolution time. */
5637 if (!sym->attr.dummy
5638 && (sym->attr.optional
5639 || sym->attr.intent != INTENT_UNKNOWN))
5641 gfc_error ("Symbol at %L is not a DUMMY variable", &sym->declared_at);
5645 /* If a derived type symbol has reached this point, without its
5646 type being declared, we have an error. Notice that most
5647 conditions that produce undefined derived types have already
5648 been dealt with. However, the likes of:
5649 implicit type(t) (t) ..... call foo (t) will get us here if
5650 the type is not declared in the scope of the implicit
5651 statement. Change the type to BT_UNKNOWN, both because it is so
5652 and to prevent an ICE. */
5653 if (sym->ts.type == BT_DERIVED
5654 && sym->ts.derived->components == NULL)
5656 gfc_error ("The derived type '%s' at %L is of type '%s', "
5657 "which has not been defined.", sym->name,
5658 &sym->declared_at, sym->ts.derived->name);
5659 sym->ts.type = BT_UNKNOWN;
5663 /* An assumed-size array with INTENT(OUT) shall not be of a type for which
5664 default initialization is defined (5.1.2.4.4). */
5665 if (sym->ts.type == BT_DERIVED
5667 && sym->attr.intent == INTENT_OUT
5669 && sym->as->type == AS_ASSUMED_SIZE)
5671 for (c = sym->ts.derived->components; c; c = c->next)
5675 gfc_error ("The INTENT(OUT) dummy argument '%s' at %L is "
5676 "ASSUMED SIZE and so cannot have a default initializer",
5677 sym->name, &sym->declared_at);
5683 switch (sym->attr.flavor)
5686 if (resolve_fl_variable (sym, mp_flag) == FAILURE)
5691 if (resolve_fl_procedure (sym, mp_flag) == FAILURE)
5696 if (resolve_fl_namelist (sym) == FAILURE)
5701 if (resolve_fl_parameter (sym) == FAILURE)
5711 /* Make sure that intrinsic exist */
5712 if (sym->attr.intrinsic
5713 && ! gfc_intrinsic_name(sym->name, 0)
5714 && ! gfc_intrinsic_name(sym->name, 1))
5715 gfc_error("Intrinsic at %L does not exist", &sym->declared_at);
5717 /* Resolve array specifier. Check as well some constraints
5718 on COMMON blocks. */
5720 check_constant = sym->attr.in_common && !sym->attr.pointer;
5721 gfc_resolve_array_spec (sym->as, check_constant);
5723 /* Resolve formal namespaces. */
5725 if (formal_ns_flag && sym != NULL && sym->formal_ns != NULL)
5727 formal_ns_save = formal_ns_flag;
5729 gfc_resolve (sym->formal_ns);
5730 formal_ns_flag = formal_ns_save;
5733 /* Check threadprivate restrictions. */
5734 if (sym->attr.threadprivate && !sym->attr.save
5735 && (!sym->attr.in_common
5736 && sym->module == NULL
5737 && (sym->ns->proc_name == NULL
5738 || sym->ns->proc_name->attr.flavor != FL_MODULE)))
5739 gfc_error ("Threadprivate at %L isn't SAVEd", &sym->declared_at);
5744 /************* Resolve DATA statements *************/
5748 gfc_data_value *vnode;
5754 /* Advance the values structure to point to the next value in the data list. */
5757 next_data_value (void)
5759 while (values.left == 0)
5761 if (values.vnode->next == NULL)
5764 values.vnode = values.vnode->next;
5765 values.left = values.vnode->repeat;
5773 check_data_variable (gfc_data_variable * var, locus * where)
5779 ar_type mark = AR_UNKNOWN;
5781 mpz_t section_index[GFC_MAX_DIMENSIONS];
5785 if (gfc_resolve_expr (var->expr) == FAILURE)
5789 mpz_init_set_si (offset, 0);
5792 if (e->expr_type != EXPR_VARIABLE)
5793 gfc_internal_error ("check_data_variable(): Bad expression");
5795 if (e->symtree->n.sym->ns->is_block_data
5796 && !e->symtree->n.sym->attr.in_common)
5798 gfc_error ("BLOCK DATA element '%s' at %L must be in COMMON",
5799 e->symtree->n.sym->name, &e->symtree->n.sym->declared_at);
5804 mpz_init_set_ui (size, 1);
5811 /* Find the array section reference. */
5812 for (ref = e->ref; ref; ref = ref->next)
5814 if (ref->type != REF_ARRAY)
5816 if (ref->u.ar.type == AR_ELEMENT)
5822 /* Set marks according to the reference pattern. */
5823 switch (ref->u.ar.type)
5831 /* Get the start position of array section. */
5832 gfc_get_section_index (ar, section_index, &offset);
5840 if (gfc_array_size (e, &size) == FAILURE)
5842 gfc_error ("Nonconstant array section at %L in DATA statement",
5851 while (mpz_cmp_ui (size, 0) > 0)
5853 if (next_data_value () == FAILURE)
5855 gfc_error ("DATA statement at %L has more variables than values",
5861 t = gfc_check_assign (var->expr, values.vnode->expr, 0);
5865 /* If we have more than one element left in the repeat count,
5866 and we have more than one element left in the target variable,
5867 then create a range assignment. */
5868 /* ??? Only done for full arrays for now, since array sections
5870 if (mark == AR_FULL && ref && ref->next == NULL
5871 && values.left > 1 && mpz_cmp_ui (size, 1) > 0)
5875 if (mpz_cmp_ui (size, values.left) >= 0)
5877 mpz_init_set_ui (range, values.left);
5878 mpz_sub_ui (size, size, values.left);
5883 mpz_init_set (range, size);
5884 values.left -= mpz_get_ui (size);
5885 mpz_set_ui (size, 0);
5888 gfc_assign_data_value_range (var->expr, values.vnode->expr,
5891 mpz_add (offset, offset, range);
5895 /* Assign initial value to symbol. */
5899 mpz_sub_ui (size, size, 1);
5901 gfc_assign_data_value (var->expr, values.vnode->expr, offset);
5903 if (mark == AR_FULL)
5904 mpz_add_ui (offset, offset, 1);
5906 /* Modify the array section indexes and recalculate the offset
5907 for next element. */
5908 else if (mark == AR_SECTION)
5909 gfc_advance_section (section_index, ar, &offset);
5913 if (mark == AR_SECTION)
5915 for (i = 0; i < ar->dimen; i++)
5916 mpz_clear (section_index[i]);
5926 static try traverse_data_var (gfc_data_variable *, locus *);
5928 /* Iterate over a list of elements in a DATA statement. */
5931 traverse_data_list (gfc_data_variable * var, locus * where)
5934 iterator_stack frame;
5937 mpz_init (frame.value);
5939 mpz_init_set (trip, var->iter.end->value.integer);
5940 mpz_sub (trip, trip, var->iter.start->value.integer);
5941 mpz_add (trip, trip, var->iter.step->value.integer);
5943 mpz_div (trip, trip, var->iter.step->value.integer);
5945 mpz_set (frame.value, var->iter.start->value.integer);
5947 frame.prev = iter_stack;
5948 frame.variable = var->iter.var->symtree;
5949 iter_stack = &frame;
5951 while (mpz_cmp_ui (trip, 0) > 0)
5953 if (traverse_data_var (var->list, where) == FAILURE)
5959 e = gfc_copy_expr (var->expr);
5960 if (gfc_simplify_expr (e, 1) == FAILURE)
5966 mpz_add (frame.value, frame.value, var->iter.step->value.integer);
5968 mpz_sub_ui (trip, trip, 1);
5972 mpz_clear (frame.value);
5974 iter_stack = frame.prev;
5979 /* Type resolve variables in the variable list of a DATA statement. */
5982 traverse_data_var (gfc_data_variable * var, locus * where)
5986 for (; var; var = var->next)
5988 if (var->expr == NULL)
5989 t = traverse_data_list (var, where);
5991 t = check_data_variable (var, where);
6001 /* Resolve the expressions and iterators associated with a data statement.
6002 This is separate from the assignment checking because data lists should
6003 only be resolved once. */
6006 resolve_data_variables (gfc_data_variable * d)
6008 for (; d; d = d->next)
6010 if (d->list == NULL)
6012 if (gfc_resolve_expr (d->expr) == FAILURE)
6017 if (gfc_resolve_iterator (&d->iter, false) == FAILURE)
6020 if (d->iter.start->expr_type != EXPR_CONSTANT
6021 || d->iter.end->expr_type != EXPR_CONSTANT
6022 || d->iter.step->expr_type != EXPR_CONSTANT)
6023 gfc_internal_error ("resolve_data_variables(): Bad iterator");
6025 if (resolve_data_variables (d->list) == FAILURE)
6034 /* Resolve a single DATA statement. We implement this by storing a pointer to
6035 the value list into static variables, and then recursively traversing the
6036 variables list, expanding iterators and such. */
6039 resolve_data (gfc_data * d)
6041 if (resolve_data_variables (d->var) == FAILURE)
6044 values.vnode = d->value;
6045 values.left = (d->value == NULL) ? 0 : d->value->repeat;
6047 if (traverse_data_var (d->var, &d->where) == FAILURE)
6050 /* At this point, we better not have any values left. */
6052 if (next_data_value () == SUCCESS)
6053 gfc_error ("DATA statement at %L has more values than variables",
6058 /* Determines if a variable is not 'pure', ie not assignable within a pure
6059 procedure. Returns zero if assignment is OK, nonzero if there is a problem.
6063 gfc_impure_variable (gfc_symbol * sym)
6065 if (sym->attr.use_assoc || sym->attr.in_common)
6068 if (sym->ns != gfc_current_ns)
6069 return !sym->attr.function;
6071 /* TODO: Check storage association through EQUIVALENCE statements */
6077 /* Test whether a symbol is pure or not. For a NULL pointer, checks the
6078 symbol of the current procedure. */
6081 gfc_pure (gfc_symbol * sym)
6083 symbol_attribute attr;
6086 sym = gfc_current_ns->proc_name;
6092 return attr.flavor == FL_PROCEDURE && (attr.pure || attr.elemental);
6096 /* Test whether the current procedure is elemental or not. */
6099 gfc_elemental (gfc_symbol * sym)
6101 symbol_attribute attr;
6104 sym = gfc_current_ns->proc_name;
6109 return attr.flavor == FL_PROCEDURE && attr.elemental;
6113 /* Warn about unused labels. */
6116 warn_unused_fortran_label (gfc_st_label * label)
6121 warn_unused_fortran_label (label->left);
6123 if (label->defined == ST_LABEL_UNKNOWN)
6126 switch (label->referenced)
6128 case ST_LABEL_UNKNOWN:
6129 gfc_warning ("Label %d at %L defined but not used", label->value,
6133 case ST_LABEL_BAD_TARGET:
6134 gfc_warning ("Label %d at %L defined but cannot be used",
6135 label->value, &label->where);
6142 warn_unused_fortran_label (label->right);
6146 /* Returns the sequence type of a symbol or sequence. */
6149 sequence_type (gfc_typespec ts)
6158 if (ts.derived->components == NULL)
6159 return SEQ_NONDEFAULT;
6161 result = sequence_type (ts.derived->components->ts);
6162 for (c = ts.derived->components->next; c; c = c->next)
6163 if (sequence_type (c->ts) != result)
6169 if (ts.kind != gfc_default_character_kind)
6170 return SEQ_NONDEFAULT;
6172 return SEQ_CHARACTER;
6175 if (ts.kind != gfc_default_integer_kind)
6176 return SEQ_NONDEFAULT;
6181 if (!(ts.kind == gfc_default_real_kind
6182 || ts.kind == gfc_default_double_kind))
6183 return SEQ_NONDEFAULT;
6188 if (ts.kind != gfc_default_complex_kind)
6189 return SEQ_NONDEFAULT;
6194 if (ts.kind != gfc_default_logical_kind)
6195 return SEQ_NONDEFAULT;
6200 return SEQ_NONDEFAULT;
6205 /* Resolve derived type EQUIVALENCE object. */
6208 resolve_equivalence_derived (gfc_symbol *derived, gfc_symbol *sym, gfc_expr *e)
6211 gfc_component *c = derived->components;
6216 /* Shall not be an object of nonsequence derived type. */
6217 if (!derived->attr.sequence)
6219 gfc_error ("Derived type variable '%s' at %L must have SEQUENCE "
6220 "attribute to be an EQUIVALENCE object", sym->name, &e->where);
6224 for (; c ; c = c->next)
6227 if (d && (resolve_equivalence_derived (c->ts.derived, sym, e) == FAILURE))
6230 /* Shall not be an object of sequence derived type containing a pointer
6231 in the structure. */
6234 gfc_error ("Derived type variable '%s' at %L with pointer component(s) "
6235 "cannot be an EQUIVALENCE object", sym->name, &e->where);
6241 gfc_error ("Derived type variable '%s' at %L with default initializer "
6242 "cannot be an EQUIVALENCE object", sym->name, &e->where);
6250 /* Resolve equivalence object.
6251 An EQUIVALENCE object shall not be a dummy argument, a pointer, a target,
6252 an allocatable array, an object of nonsequence derived type, an object of
6253 sequence derived type containing a pointer at any level of component
6254 selection, an automatic object, a function name, an entry name, a result
6255 name, a named constant, a structure component, or a subobject of any of
6256 the preceding objects. A substring shall not have length zero. A
6257 derived type shall not have components with default initialization nor
6258 shall two objects of an equivalence group be initialized.
6259 The simple constraints are done in symbol.c(check_conflict) and the rest
6260 are implemented here. */
6263 resolve_equivalence (gfc_equiv *eq)
6266 gfc_symbol *derived;
6267 gfc_symbol *first_sym;
6270 locus *last_where = NULL;
6271 seq_type eq_type, last_eq_type;
6272 gfc_typespec *last_ts;
6274 const char *value_name;
6278 last_ts = &eq->expr->symtree->n.sym->ts;
6280 first_sym = eq->expr->symtree->n.sym;
6282 for (object = 1; eq; eq = eq->eq, object++)
6286 e->ts = e->symtree->n.sym->ts;
6287 /* match_varspec might not know yet if it is seeing
6288 array reference or substring reference, as it doesn't
6290 if (e->ref && e->ref->type == REF_ARRAY)
6292 gfc_ref *ref = e->ref;
6293 sym = e->symtree->n.sym;
6295 if (sym->attr.dimension)
6297 ref->u.ar.as = sym->as;
6301 /* For substrings, convert REF_ARRAY into REF_SUBSTRING. */
6302 if (e->ts.type == BT_CHARACTER
6304 && ref->type == REF_ARRAY
6305 && ref->u.ar.dimen == 1
6306 && ref->u.ar.dimen_type[0] == DIMEN_RANGE
6307 && ref->u.ar.stride[0] == NULL)
6309 gfc_expr *start = ref->u.ar.start[0];
6310 gfc_expr *end = ref->u.ar.end[0];
6313 /* Optimize away the (:) reference. */
6314 if (start == NULL && end == NULL)
6319 e->ref->next = ref->next;
6324 ref->type = REF_SUBSTRING;
6326 start = gfc_int_expr (1);
6327 ref->u.ss.start = start;
6328 if (end == NULL && e->ts.cl)
6329 end = gfc_copy_expr (e->ts.cl->length);
6330 ref->u.ss.end = end;
6331 ref->u.ss.length = e->ts.cl;
6338 /* Any further ref is an error. */
6341 gcc_assert (ref->type == REF_ARRAY);
6342 gfc_error ("Syntax error in EQUIVALENCE statement at %L",
6348 if (gfc_resolve_expr (e) == FAILURE)
6351 sym = e->symtree->n.sym;
6353 /* An equivalence statement cannot have more than one initialized
6357 if (value_name != NULL)
6359 gfc_error ("Initialized objects '%s' and '%s' cannot both "
6360 "be in the EQUIVALENCE statement at %L",
6361 value_name, sym->name, &e->where);
6365 value_name = sym->name;
6368 /* Shall not equivalence common block variables in a PURE procedure. */
6369 if (sym->ns->proc_name
6370 && sym->ns->proc_name->attr.pure
6371 && sym->attr.in_common)
6373 gfc_error ("Common block member '%s' at %L cannot be an EQUIVALENCE "
6374 "object in the pure procedure '%s'",
6375 sym->name, &e->where, sym->ns->proc_name->name);
6379 /* Shall not be a named constant. */
6380 if (e->expr_type == EXPR_CONSTANT)
6382 gfc_error ("Named constant '%s' at %L cannot be an EQUIVALENCE "
6383 "object", sym->name, &e->where);
6387 derived = e->ts.derived;
6388 if (derived && resolve_equivalence_derived (derived, sym, e) == FAILURE)
6391 /* Check that the types correspond correctly:
6393 A numeric sequence structure may be equivalenced to another sequence
6394 structure, an object of default integer type, default real type, double
6395 precision real type, default logical type such that components of the
6396 structure ultimately only become associated to objects of the same
6397 kind. A character sequence structure may be equivalenced to an object
6398 of default character kind or another character sequence structure.
6399 Other objects may be equivalenced only to objects of the same type and
6402 /* Identical types are unconditionally OK. */
6403 if (object == 1 || gfc_compare_types (last_ts, &sym->ts))
6404 goto identical_types;
6406 last_eq_type = sequence_type (*last_ts);
6407 eq_type = sequence_type (sym->ts);
6409 /* Since the pair of objects is not of the same type, mixed or
6410 non-default sequences can be rejected. */
6412 msg = "Sequence %s with mixed components in EQUIVALENCE "
6413 "statement at %L with different type objects";
6415 && last_eq_type == SEQ_MIXED
6416 && gfc_notify_std (GFC_STD_GNU, msg, first_sym->name,
6417 last_where) == FAILURE)
6418 || (eq_type == SEQ_MIXED
6419 && gfc_notify_std (GFC_STD_GNU, msg,sym->name,
6420 &e->where) == FAILURE))
6423 msg = "Non-default type object or sequence %s in EQUIVALENCE "
6424 "statement at %L with objects of different type";
6426 && last_eq_type == SEQ_NONDEFAULT
6427 && gfc_notify_std (GFC_STD_GNU, msg, first_sym->name,
6428 last_where) == FAILURE)
6429 || (eq_type == SEQ_NONDEFAULT
6430 && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
6431 &e->where) == FAILURE))
6434 msg ="Non-CHARACTER object '%s' in default CHARACTER "
6435 "EQUIVALENCE statement at %L";
6436 if (last_eq_type == SEQ_CHARACTER
6437 && eq_type != SEQ_CHARACTER
6438 && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
6439 &e->where) == FAILURE)
6442 msg ="Non-NUMERIC object '%s' in default NUMERIC "
6443 "EQUIVALENCE statement at %L";
6444 if (last_eq_type == SEQ_NUMERIC
6445 && eq_type != SEQ_NUMERIC
6446 && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
6447 &e->where) == FAILURE)
6452 last_where = &e->where;
6457 /* Shall not be an automatic array. */
6458 if (e->ref->type == REF_ARRAY
6459 && gfc_resolve_array_spec (e->ref->u.ar.as, 1) == FAILURE)
6461 gfc_error ("Array '%s' at %L with non-constant bounds cannot be "
6462 "an EQUIVALENCE object", sym->name, &e->where);
6469 /* Shall not be a structure component. */
6470 if (r->type == REF_COMPONENT)
6472 gfc_error ("Structure component '%s' at %L cannot be an "
6473 "EQUIVALENCE object",
6474 r->u.c.component->name, &e->where);
6478 /* A substring shall not have length zero. */
6479 if (r->type == REF_SUBSTRING)
6481 if (compare_bound (r->u.ss.start, r->u.ss.end) == CMP_GT)
6483 gfc_error ("Substring at %L has length zero",
6484 &r->u.ss.start->where);
6494 /* Resolve function and ENTRY types, issue diagnostics if needed. */
6497 resolve_fntype (gfc_namespace * ns)
6502 if (ns->proc_name == NULL || !ns->proc_name->attr.function)
6505 /* If there are any entries, ns->proc_name is the entry master
6506 synthetic symbol and ns->entries->sym actual FUNCTION symbol. */
6508 sym = ns->entries->sym;
6510 sym = ns->proc_name;
6511 if (sym->result == sym
6512 && sym->ts.type == BT_UNKNOWN
6513 && gfc_set_default_type (sym, 0, NULL) == FAILURE
6514 && !sym->attr.untyped)
6516 gfc_error ("Function '%s' at %L has no IMPLICIT type",
6517 sym->name, &sym->declared_at);
6518 sym->attr.untyped = 1;
6521 if (sym->ts.type == BT_DERIVED && !sym->ts.derived->attr.use_assoc
6522 && !gfc_check_access (sym->ts.derived->attr.access,
6523 sym->ts.derived->ns->default_access)
6524 && gfc_check_access (sym->attr.access, sym->ns->default_access))
6526 gfc_error ("PUBLIC function '%s' at %L cannot be of PRIVATE type '%s'",
6527 sym->name, &sym->declared_at, sym->ts.derived->name);
6531 for (el = ns->entries->next; el; el = el->next)
6533 if (el->sym->result == el->sym
6534 && el->sym->ts.type == BT_UNKNOWN
6535 && gfc_set_default_type (el->sym, 0, NULL) == FAILURE
6536 && !el->sym->attr.untyped)
6538 gfc_error ("ENTRY '%s' at %L has no IMPLICIT type",
6539 el->sym->name, &el->sym->declared_at);
6540 el->sym->attr.untyped = 1;
6545 /* 12.3.2.1.1 Defined operators. */
6548 gfc_resolve_uops(gfc_symtree *symtree)
6552 gfc_formal_arglist *formal;
6554 if (symtree == NULL)
6557 gfc_resolve_uops (symtree->left);
6558 gfc_resolve_uops (symtree->right);
6560 for (itr = symtree->n.uop->operator; itr; itr = itr->next)
6563 if (!sym->attr.function)
6564 gfc_error("User operator procedure '%s' at %L must be a FUNCTION",
6565 sym->name, &sym->declared_at);
6567 if (sym->ts.type == BT_CHARACTER
6568 && !(sym->ts.cl && sym->ts.cl->length)
6569 && !(sym->result && sym->result->ts.cl && sym->result->ts.cl->length))
6570 gfc_error("User operator procedure '%s' at %L cannot be assumed character "
6571 "length", sym->name, &sym->declared_at);
6573 formal = sym->formal;
6574 if (!formal || !formal->sym)
6576 gfc_error("User operator procedure '%s' at %L must have at least "
6577 "one argument", sym->name, &sym->declared_at);
6581 if (formal->sym->attr.intent != INTENT_IN)
6582 gfc_error ("First argument of operator interface at %L must be "
6583 "INTENT(IN)", &sym->declared_at);
6585 if (formal->sym->attr.optional)
6586 gfc_error ("First argument of operator interface at %L cannot be "
6587 "optional", &sym->declared_at);
6589 formal = formal->next;
6590 if (!formal || !formal->sym)
6593 if (formal->sym->attr.intent != INTENT_IN)
6594 gfc_error ("Second argument of operator interface at %L must be "
6595 "INTENT(IN)", &sym->declared_at);
6597 if (formal->sym->attr.optional)
6598 gfc_error ("Second argument of operator interface at %L cannot be "
6599 "optional", &sym->declared_at);
6602 gfc_error ("Operator interface at %L must have, at most, two "
6603 "arguments", &sym->declared_at);
6608 /* Examine all of the expressions associated with a program unit,
6609 assign types to all intermediate expressions, make sure that all
6610 assignments are to compatible types and figure out which names
6611 refer to which functions or subroutines. It doesn't check code
6612 block, which is handled by resolve_code. */
6615 resolve_types (gfc_namespace * ns)
6622 gfc_current_ns = ns;
6624 resolve_entries (ns);
6626 resolve_contained_functions (ns);
6628 gfc_traverse_ns (ns, resolve_symbol);
6630 resolve_fntype (ns);
6632 for (n = ns->contained; n; n = n->sibling)
6634 if (gfc_pure (ns->proc_name) && !gfc_pure (n->proc_name))
6635 gfc_error ("Contained procedure '%s' at %L of a PURE procedure must "
6636 "also be PURE", n->proc_name->name,
6637 &n->proc_name->declared_at);
6643 gfc_check_interfaces (ns);
6645 for (cl = ns->cl_list; cl; cl = cl->next)
6646 resolve_charlen (cl);
6648 gfc_traverse_ns (ns, resolve_values);
6654 for (d = ns->data; d; d = d->next)
6658 gfc_traverse_ns (ns, gfc_formalize_init_value);
6660 for (eq = ns->equiv; eq; eq = eq->next)
6661 resolve_equivalence (eq);
6663 /* Warn about unused labels. */
6664 if (gfc_option.warn_unused_labels)
6665 warn_unused_fortran_label (ns->st_labels);
6667 gfc_resolve_uops (ns->uop_root);
6672 /* Call resolve_code recursively. */
6675 resolve_codes (gfc_namespace * ns)
6679 for (n = ns->contained; n; n = n->sibling)
6682 gfc_current_ns = ns;
6684 /* Set to an out of range value. */
6685 current_entry_id = -1;
6686 resolve_code (ns->code, ns);
6690 /* This function is called after a complete program unit has been compiled.
6691 Its purpose is to examine all of the expressions associated with a program
6692 unit, assign types to all intermediate expressions, make sure that all
6693 assignments are to compatible types and figure out which names refer to
6694 which functions or subroutines. */
6697 gfc_resolve (gfc_namespace * ns)
6699 gfc_namespace *old_ns;
6701 old_ns = gfc_current_ns;
6706 gfc_current_ns = old_ns;