1 /* Perform type resolution on the various stuctures.
2 Copyright (C) 2001, 2002, 2003, 2004, 2005, 2006, 2007
3 Free Software Foundation, Inc.
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
29 #include "arith.h" /* For gfc_compare_expr(). */
30 #include "dependency.h"
32 /* Types used in equivalence statements. */
36 SEQ_NONDEFAULT, SEQ_NUMERIC, SEQ_CHARACTER, SEQ_MIXED
40 /* Stack to keep track of the nesting of blocks as we move through the
41 code. See resolve_branch() and resolve_code(). */
43 typedef struct code_stack
45 struct gfc_code *head, *current, *tail;
46 struct code_stack *prev;
48 /* This bitmap keeps track of the targets valid for a branch from
50 bitmap reachable_labels;
54 static code_stack *cs_base = NULL;
57 /* Nonzero if we're inside a FORALL block. */
59 static int forall_flag;
61 /* Nonzero if we're inside a OpenMP WORKSHARE or PARALLEL WORKSHARE block. */
63 static int omp_workshare_flag;
65 /* Nonzero if we are processing a formal arglist. The corresponding function
66 resets the flag each time that it is read. */
67 static int formal_arg_flag = 0;
69 /* True if we are resolving a specification expression. */
70 static int specification_expr = 0;
72 /* The id of the last entry seen. */
73 static int current_entry_id;
75 /* We use bitmaps to determine if a branch target is valid. */
76 static bitmap_obstack labels_obstack;
79 gfc_is_formal_arg (void)
81 return formal_arg_flag;
84 /* Resolve types of formal argument lists. These have to be done early so that
85 the formal argument lists of module procedures can be copied to the
86 containing module before the individual procedures are resolved
87 individually. We also resolve argument lists of procedures in interface
88 blocks because they are self-contained scoping units.
90 Since a dummy argument cannot be a non-dummy procedure, the only
91 resort left for untyped names are the IMPLICIT types. */
94 resolve_formal_arglist (gfc_symbol *proc)
96 gfc_formal_arglist *f;
100 if (proc->result != NULL)
105 if (gfc_elemental (proc)
106 || sym->attr.pointer || sym->attr.allocatable
107 || (sym->as && sym->as->rank > 0))
108 proc->attr.always_explicit = 1;
112 for (f = proc->formal; f; f = f->next)
118 /* Alternate return placeholder. */
119 if (gfc_elemental (proc))
120 gfc_error ("Alternate return specifier in elemental subroutine "
121 "'%s' at %L is not allowed", proc->name,
123 if (proc->attr.function)
124 gfc_error ("Alternate return specifier in function "
125 "'%s' at %L is not allowed", proc->name,
130 if (sym->attr.if_source != IFSRC_UNKNOWN)
131 resolve_formal_arglist (sym);
133 if (sym->attr.subroutine || sym->attr.external || sym->attr.intrinsic)
135 if (gfc_pure (proc) && !gfc_pure (sym))
137 gfc_error ("Dummy procedure '%s' of PURE procedure at %L must "
138 "also be PURE", sym->name, &sym->declared_at);
142 if (gfc_elemental (proc))
144 gfc_error ("Dummy procedure at %L not allowed in ELEMENTAL "
145 "procedure", &sym->declared_at);
149 if (sym->attr.function
150 && sym->ts.type == BT_UNKNOWN
151 && sym->attr.intrinsic)
153 gfc_intrinsic_sym *isym;
154 isym = gfc_find_function (sym->name);
155 if (isym == NULL || !isym->specific)
157 gfc_error ("Unable to find a specific INTRINSIC procedure "
158 "for the reference '%s' at %L", sym->name,
167 if (sym->ts.type == BT_UNKNOWN)
169 if (!sym->attr.function || sym->result == sym)
170 gfc_set_default_type (sym, 1, sym->ns);
173 gfc_resolve_array_spec (sym->as, 0);
175 /* We can't tell if an array with dimension (:) is assumed or deferred
176 shape until we know if it has the pointer or allocatable attributes.
178 if (sym->as && sym->as->rank > 0 && sym->as->type == AS_DEFERRED
179 && !(sym->attr.pointer || sym->attr.allocatable))
181 sym->as->type = AS_ASSUMED_SHAPE;
182 for (i = 0; i < sym->as->rank; i++)
183 sym->as->lower[i] = gfc_int_expr (1);
186 if ((sym->as && sym->as->rank > 0 && sym->as->type == AS_ASSUMED_SHAPE)
187 || sym->attr.pointer || sym->attr.allocatable || sym->attr.target
188 || sym->attr.optional)
189 proc->attr.always_explicit = 1;
191 /* If the flavor is unknown at this point, it has to be a variable.
192 A procedure specification would have already set the type. */
194 if (sym->attr.flavor == FL_UNKNOWN)
195 gfc_add_flavor (&sym->attr, FL_VARIABLE, sym->name, &sym->declared_at);
197 if (gfc_pure (proc) && !sym->attr.pointer
198 && sym->attr.flavor != FL_PROCEDURE)
200 if (proc->attr.function && sym->attr.intent != INTENT_IN)
201 gfc_error ("Argument '%s' of pure function '%s' at %L must be "
202 "INTENT(IN)", sym->name, proc->name,
205 if (proc->attr.subroutine && sym->attr.intent == INTENT_UNKNOWN)
206 gfc_error ("Argument '%s' of pure subroutine '%s' at %L must "
207 "have its INTENT specified", sym->name, proc->name,
211 if (gfc_elemental (proc))
215 gfc_error ("Argument '%s' of elemental procedure at %L must "
216 "be scalar", sym->name, &sym->declared_at);
220 if (sym->attr.pointer)
222 gfc_error ("Argument '%s' of elemental procedure at %L cannot "
223 "have the POINTER attribute", sym->name,
229 /* Each dummy shall be specified to be scalar. */
230 if (proc->attr.proc == PROC_ST_FUNCTION)
234 gfc_error ("Argument '%s' of statement function at %L must "
235 "be scalar", sym->name, &sym->declared_at);
239 if (sym->ts.type == BT_CHARACTER)
241 gfc_charlen *cl = sym->ts.cl;
242 if (!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT)
244 gfc_error ("Character-valued argument '%s' of statement "
245 "function at %L must have constant length",
246 sym->name, &sym->declared_at);
256 /* Work function called when searching for symbols that have argument lists
257 associated with them. */
260 find_arglists (gfc_symbol *sym)
262 if (sym->attr.if_source == IFSRC_UNKNOWN || sym->ns != gfc_current_ns)
265 resolve_formal_arglist (sym);
269 /* Given a namespace, resolve all formal argument lists within the namespace.
273 resolve_formal_arglists (gfc_namespace *ns)
278 gfc_traverse_ns (ns, find_arglists);
283 resolve_contained_fntype (gfc_symbol *sym, gfc_namespace *ns)
287 /* If this namespace is not a function, ignore it. */
288 if (! sym || !(sym->attr.function || sym->attr.flavor == FL_VARIABLE))
291 /* Try to find out of what the return type is. */
292 if (sym->result != NULL)
295 if (sym->ts.type == BT_UNKNOWN)
297 t = gfc_set_default_type (sym, 0, ns);
299 if (t == FAILURE && !sym->attr.untyped)
301 gfc_error ("Contained function '%s' at %L has no IMPLICIT type",
302 sym->name, &sym->declared_at); /* FIXME */
303 sym->attr.untyped = 1;
307 /* Fortran 95 Draft Standard, page 51, Section 5.1.1.5, on the Character
308 type, lists the only ways a character length value of * can be used:
309 dummy arguments of procedures, named constants, and function results
310 in external functions. Internal function results are not on that list;
311 ergo, not permitted. */
313 if (sym->ts.type == BT_CHARACTER)
315 gfc_charlen *cl = sym->ts.cl;
316 if (!cl || !cl->length)
317 gfc_error ("Character-valued internal function '%s' at %L must "
318 "not be assumed length", sym->name, &sym->declared_at);
323 /* Add NEW_ARGS to the formal argument list of PROC, taking care not to
324 introduce duplicates. */
327 merge_argument_lists (gfc_symbol *proc, gfc_formal_arglist *new_args)
329 gfc_formal_arglist *f, *new_arglist;
332 for (; new_args != NULL; new_args = new_args->next)
334 new_sym = new_args->sym;
335 /* See if this arg is already in the formal argument list. */
336 for (f = proc->formal; f; f = f->next)
338 if (new_sym == f->sym)
345 /* Add a new argument. Argument order is not important. */
346 new_arglist = gfc_get_formal_arglist ();
347 new_arglist->sym = new_sym;
348 new_arglist->next = proc->formal;
349 proc->formal = new_arglist;
354 /* Flag the arguments that are not present in all entries. */
357 check_argument_lists (gfc_symbol *proc, gfc_formal_arglist *new_args)
359 gfc_formal_arglist *f, *head;
362 for (f = proc->formal; f; f = f->next)
367 for (new_args = head; new_args; new_args = new_args->next)
369 if (new_args->sym == f->sym)
376 f->sym->attr.not_always_present = 1;
381 /* Resolve alternate entry points. If a symbol has multiple entry points we
382 create a new master symbol for the main routine, and turn the existing
383 symbol into an entry point. */
386 resolve_entries (gfc_namespace *ns)
388 gfc_namespace *old_ns;
392 char name[GFC_MAX_SYMBOL_LEN + 1];
393 static int master_count = 0;
395 if (ns->proc_name == NULL)
398 /* No need to do anything if this procedure doesn't have alternate entry
403 /* We may already have resolved alternate entry points. */
404 if (ns->proc_name->attr.entry_master)
407 /* If this isn't a procedure something has gone horribly wrong. */
408 gcc_assert (ns->proc_name->attr.flavor == FL_PROCEDURE);
410 /* Remember the current namespace. */
411 old_ns = gfc_current_ns;
415 /* Add the main entry point to the list of entry points. */
416 el = gfc_get_entry_list ();
417 el->sym = ns->proc_name;
419 el->next = ns->entries;
421 ns->proc_name->attr.entry = 1;
423 /* If it is a module function, it needs to be in the right namespace
424 so that gfc_get_fake_result_decl can gather up the results. The
425 need for this arose in get_proc_name, where these beasts were
426 left in their own namespace, to keep prior references linked to
427 the entry declaration.*/
428 if (ns->proc_name->attr.function
429 && ns->parent && ns->parent->proc_name->attr.flavor == FL_MODULE)
432 /* Add an entry statement for it. */
439 /* Create a new symbol for the master function. */
440 /* Give the internal function a unique name (within this file).
441 Also include the function name so the user has some hope of figuring
442 out what is going on. */
443 snprintf (name, GFC_MAX_SYMBOL_LEN, "master.%d.%s",
444 master_count++, ns->proc_name->name);
445 gfc_get_ha_symbol (name, &proc);
446 gcc_assert (proc != NULL);
448 gfc_add_procedure (&proc->attr, PROC_INTERNAL, proc->name, NULL);
449 if (ns->proc_name->attr.subroutine)
450 gfc_add_subroutine (&proc->attr, proc->name, NULL);
454 gfc_typespec *ts, *fts;
455 gfc_array_spec *as, *fas;
456 gfc_add_function (&proc->attr, proc->name, NULL);
458 fas = ns->entries->sym->as;
459 fas = fas ? fas : ns->entries->sym->result->as;
460 fts = &ns->entries->sym->result->ts;
461 if (fts->type == BT_UNKNOWN)
462 fts = gfc_get_default_type (ns->entries->sym->result, NULL);
463 for (el = ns->entries->next; el; el = el->next)
465 ts = &el->sym->result->ts;
467 as = as ? as : el->sym->result->as;
468 if (ts->type == BT_UNKNOWN)
469 ts = gfc_get_default_type (el->sym->result, NULL);
471 if (! gfc_compare_types (ts, fts)
472 || (el->sym->result->attr.dimension
473 != ns->entries->sym->result->attr.dimension)
474 || (el->sym->result->attr.pointer
475 != ns->entries->sym->result->attr.pointer))
478 else if (as && fas && gfc_compare_array_spec (as, fas) == 0)
479 gfc_error ("Procedure %s at %L has entries with mismatched "
480 "array specifications", ns->entries->sym->name,
481 &ns->entries->sym->declared_at);
486 sym = ns->entries->sym->result;
487 /* All result types the same. */
489 if (sym->attr.dimension)
490 gfc_set_array_spec (proc, gfc_copy_array_spec (sym->as), NULL);
491 if (sym->attr.pointer)
492 gfc_add_pointer (&proc->attr, NULL);
496 /* Otherwise the result will be passed through a union by
498 proc->attr.mixed_entry_master = 1;
499 for (el = ns->entries; el; el = el->next)
501 sym = el->sym->result;
502 if (sym->attr.dimension)
504 if (el == ns->entries)
505 gfc_error ("FUNCTION result %s can't be an array in "
506 "FUNCTION %s at %L", sym->name,
507 ns->entries->sym->name, &sym->declared_at);
509 gfc_error ("ENTRY result %s can't be an array in "
510 "FUNCTION %s at %L", sym->name,
511 ns->entries->sym->name, &sym->declared_at);
513 else if (sym->attr.pointer)
515 if (el == ns->entries)
516 gfc_error ("FUNCTION result %s can't be a POINTER in "
517 "FUNCTION %s at %L", sym->name,
518 ns->entries->sym->name, &sym->declared_at);
520 gfc_error ("ENTRY result %s can't be a POINTER in "
521 "FUNCTION %s at %L", sym->name,
522 ns->entries->sym->name, &sym->declared_at);
527 if (ts->type == BT_UNKNOWN)
528 ts = gfc_get_default_type (sym, NULL);
532 if (ts->kind == gfc_default_integer_kind)
536 if (ts->kind == gfc_default_real_kind
537 || ts->kind == gfc_default_double_kind)
541 if (ts->kind == gfc_default_complex_kind)
545 if (ts->kind == gfc_default_logical_kind)
549 /* We will issue error elsewhere. */
557 if (el == ns->entries)
558 gfc_error ("FUNCTION result %s can't be of type %s "
559 "in FUNCTION %s at %L", sym->name,
560 gfc_typename (ts), ns->entries->sym->name,
563 gfc_error ("ENTRY result %s can't be of type %s "
564 "in FUNCTION %s at %L", sym->name,
565 gfc_typename (ts), ns->entries->sym->name,
572 proc->attr.access = ACCESS_PRIVATE;
573 proc->attr.entry_master = 1;
575 /* Merge all the entry point arguments. */
576 for (el = ns->entries; el; el = el->next)
577 merge_argument_lists (proc, el->sym->formal);
579 /* Check the master formal arguments for any that are not
580 present in all entry points. */
581 for (el = ns->entries; el; el = el->next)
582 check_argument_lists (proc, el->sym->formal);
584 /* Use the master function for the function body. */
585 ns->proc_name = proc;
587 /* Finalize the new symbols. */
588 gfc_commit_symbols ();
590 /* Restore the original namespace. */
591 gfc_current_ns = old_ns;
595 /* Resolve contained function types. Because contained functions can call one
596 another, they have to be worked out before any of the contained procedures
599 The good news is that if a function doesn't already have a type, the only
600 way it can get one is through an IMPLICIT type or a RESULT variable, because
601 by definition contained functions are contained namespace they're contained
602 in, not in a sibling or parent namespace. */
605 resolve_contained_functions (gfc_namespace *ns)
607 gfc_namespace *child;
610 resolve_formal_arglists (ns);
612 for (child = ns->contained; child; child = child->sibling)
614 /* Resolve alternate entry points first. */
615 resolve_entries (child);
617 /* Then check function return types. */
618 resolve_contained_fntype (child->proc_name, child);
619 for (el = child->entries; el; el = el->next)
620 resolve_contained_fntype (el->sym, child);
625 /* Resolve all of the elements of a structure constructor and make sure that
626 the types are correct. */
629 resolve_structure_cons (gfc_expr *expr)
631 gfc_constructor *cons;
637 cons = expr->value.constructor;
638 /* A constructor may have references if it is the result of substituting a
639 parameter variable. In this case we just pull out the component we
642 comp = expr->ref->u.c.sym->components;
644 comp = expr->ts.derived->components;
646 for (; comp; comp = comp->next, cons = cons->next)
651 if (gfc_resolve_expr (cons->expr) == FAILURE)
657 if (cons->expr->expr_type != EXPR_NULL
658 && comp->as && comp->as->rank != cons->expr->rank
659 && (comp->allocatable || cons->expr->rank))
661 gfc_error ("The rank of the element in the derived type "
662 "constructor at %L does not match that of the "
663 "component (%d/%d)", &cons->expr->where,
664 cons->expr->rank, comp->as ? comp->as->rank : 0);
668 /* If we don't have the right type, try to convert it. */
670 if (!gfc_compare_types (&cons->expr->ts, &comp->ts))
673 if (comp->pointer && cons->expr->ts.type != BT_UNKNOWN)
674 gfc_error ("The element in the derived type constructor at %L, "
675 "for pointer component '%s', is %s but should be %s",
676 &cons->expr->where, comp->name,
677 gfc_basic_typename (cons->expr->ts.type),
678 gfc_basic_typename (comp->ts.type));
680 t = gfc_convert_type (cons->expr, &comp->ts, 1);
683 if (!comp->pointer || cons->expr->expr_type == EXPR_NULL)
686 a = gfc_expr_attr (cons->expr);
688 if (!a.pointer && !a.target)
691 gfc_error ("The element in the derived type constructor at %L, "
692 "for pointer component '%s' should be a POINTER or "
693 "a TARGET", &cons->expr->where, comp->name);
701 /****************** Expression name resolution ******************/
703 /* Returns 0 if a symbol was not declared with a type or
704 attribute declaration statement, nonzero otherwise. */
707 was_declared (gfc_symbol *sym)
713 if (!a.implicit_type && sym->ts.type != BT_UNKNOWN)
716 if (a.allocatable || a.dimension || a.dummy || a.external || a.intrinsic
717 || a.optional || a.pointer || a.save || a.target || a.volatile_
718 || a.value || a.access != ACCESS_UNKNOWN || a.intent != INTENT_UNKNOWN)
725 /* Determine if a symbol is generic or not. */
728 generic_sym (gfc_symbol *sym)
732 if (sym->attr.generic ||
733 (sym->attr.intrinsic && gfc_generic_intrinsic (sym->name)))
736 if (was_declared (sym) || sym->ns->parent == NULL)
739 gfc_find_symbol (sym->name, sym->ns->parent, 1, &s);
741 return (s == NULL) ? 0 : generic_sym (s);
745 /* Determine if a symbol is specific or not. */
748 specific_sym (gfc_symbol *sym)
752 if (sym->attr.if_source == IFSRC_IFBODY
753 || sym->attr.proc == PROC_MODULE
754 || sym->attr.proc == PROC_INTERNAL
755 || sym->attr.proc == PROC_ST_FUNCTION
756 || (sym->attr.intrinsic && gfc_specific_intrinsic (sym->name))
757 || sym->attr.external)
760 if (was_declared (sym) || sym->ns->parent == NULL)
763 gfc_find_symbol (sym->name, sym->ns->parent, 1, &s);
765 return (s == NULL) ? 0 : specific_sym (s);
769 /* Figure out if the procedure is specific, generic or unknown. */
772 { PTYPE_GENERIC = 1, PTYPE_SPECIFIC, PTYPE_UNKNOWN }
776 procedure_kind (gfc_symbol *sym)
778 if (generic_sym (sym))
779 return PTYPE_GENERIC;
781 if (specific_sym (sym))
782 return PTYPE_SPECIFIC;
784 return PTYPE_UNKNOWN;
787 /* Check references to assumed size arrays. The flag need_full_assumed_size
788 is nonzero when matching actual arguments. */
790 static int need_full_assumed_size = 0;
793 check_assumed_size_reference (gfc_symbol *sym, gfc_expr *e)
799 if (need_full_assumed_size || !(sym->as && sym->as->type == AS_ASSUMED_SIZE))
802 for (ref = e->ref; ref; ref = ref->next)
803 if (ref->type == REF_ARRAY)
804 for (dim = 0; dim < ref->u.ar.as->rank; dim++)
805 last = (ref->u.ar.end[dim] == NULL)
806 && (ref->u.ar.type == DIMEN_ELEMENT);
810 gfc_error ("The upper bound in the last dimension must "
811 "appear in the reference to the assumed size "
812 "array '%s' at %L", sym->name, &e->where);
819 /* Look for bad assumed size array references in argument expressions
820 of elemental and array valued intrinsic procedures. Since this is
821 called from procedure resolution functions, it only recurses at
825 resolve_assumed_size_actual (gfc_expr *e)
830 switch (e->expr_type)
833 if (e->symtree && check_assumed_size_reference (e->symtree->n.sym, e))
838 if (resolve_assumed_size_actual (e->value.op.op1)
839 || resolve_assumed_size_actual (e->value.op.op2))
850 /* Resolve an actual argument list. Most of the time, this is just
851 resolving the expressions in the list.
852 The exception is that we sometimes have to decide whether arguments
853 that look like procedure arguments are really simple variable
857 resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype)
860 gfc_symtree *parent_st;
863 for (; arg; arg = arg->next)
868 /* Check the label is a valid branching target. */
871 if (arg->label->defined == ST_LABEL_UNKNOWN)
873 gfc_error ("Label %d referenced at %L is never defined",
874 arg->label->value, &arg->label->where);
881 if (e->ts.type != BT_PROCEDURE)
883 if (gfc_resolve_expr (e) != SUCCESS)
888 /* See if the expression node should really be a variable reference. */
890 sym = e->symtree->n.sym;
892 if (sym->attr.flavor == FL_PROCEDURE
893 || sym->attr.intrinsic
894 || sym->attr.external)
898 /* If a procedure is not already determined to be something else
899 check if it is intrinsic. */
900 if (!sym->attr.intrinsic
901 && !(sym->attr.external || sym->attr.use_assoc
902 || sym->attr.if_source == IFSRC_IFBODY)
903 && gfc_intrinsic_name (sym->name, sym->attr.subroutine))
904 sym->attr.intrinsic = 1;
906 if (sym->attr.proc == PROC_ST_FUNCTION)
908 gfc_error ("Statement function '%s' at %L is not allowed as an "
909 "actual argument", sym->name, &e->where);
912 actual_ok = gfc_intrinsic_actual_ok (sym->name,
913 sym->attr.subroutine);
914 if (sym->attr.intrinsic && actual_ok == 0)
916 gfc_error ("Intrinsic '%s' at %L is not allowed as an "
917 "actual argument", sym->name, &e->where);
920 if (sym->attr.contained && !sym->attr.use_assoc
921 && sym->ns->proc_name->attr.flavor != FL_MODULE)
923 gfc_error ("Internal procedure '%s' is not allowed as an "
924 "actual argument at %L", sym->name, &e->where);
927 if (sym->attr.elemental && !sym->attr.intrinsic)
929 gfc_error ("ELEMENTAL non-INTRINSIC procedure '%s' is not "
930 "allowed as an actual argument at %L", sym->name,
934 /* Check if a generic interface has a specific procedure
935 with the same name before emitting an error. */
936 if (sym->attr.generic)
939 for (p = sym->generic; p; p = p->next)
940 if (strcmp (sym->name, p->sym->name) == 0)
942 e->symtree = gfc_find_symtree
943 (p->sym->ns->sym_root, sym->name);
948 if (p == NULL || e->symtree == NULL)
949 gfc_error ("GENERIC non-INTRINSIC procedure '%s' is not "
950 "allowed as an actual argument at %L", sym->name,
954 /* If the symbol is the function that names the current (or
955 parent) scope, then we really have a variable reference. */
957 if (sym->attr.function && sym->result == sym
958 && (sym->ns->proc_name == sym
959 || (sym->ns->parent != NULL
960 && sym->ns->parent->proc_name == sym)))
963 /* If all else fails, see if we have a specific intrinsic. */
964 if (sym->attr.function
965 && sym->ts.type == BT_UNKNOWN && sym->attr.intrinsic)
967 gfc_intrinsic_sym *isym;
968 isym = gfc_find_function (sym->name);
969 if (isym == NULL || !isym->specific)
971 gfc_error ("Unable to find a specific INTRINSIC procedure "
972 "for the reference '%s' at %L", sym->name,
980 /* See if the name is a module procedure in a parent unit. */
982 if (was_declared (sym) || sym->ns->parent == NULL)
985 if (gfc_find_sym_tree (sym->name, sym->ns->parent, 1, &parent_st))
987 gfc_error ("Symbol '%s' at %L is ambiguous", sym->name, &e->where);
991 if (parent_st == NULL)
994 sym = parent_st->n.sym;
995 e->symtree = parent_st; /* Point to the right thing. */
997 if (sym->attr.flavor == FL_PROCEDURE
998 || sym->attr.intrinsic
999 || sym->attr.external)
1005 e->expr_type = EXPR_VARIABLE;
1007 if (sym->as != NULL)
1009 e->rank = sym->as->rank;
1010 e->ref = gfc_get_ref ();
1011 e->ref->type = REF_ARRAY;
1012 e->ref->u.ar.type = AR_FULL;
1013 e->ref->u.ar.as = sym->as;
1016 /* Expressions are assigned a default ts.type of BT_PROCEDURE in
1017 primary.c (match_actual_arg). If above code determines that it
1018 is a variable instead, it needs to be resolved as it was not
1019 done at the beginning of this function. */
1020 if (gfc_resolve_expr (e) != SUCCESS)
1024 /* Check argument list functions %VAL, %LOC and %REF. There is
1025 nothing to do for %REF. */
1026 if (arg->name && arg->name[0] == '%')
1028 if (strncmp ("%VAL", arg->name, 4) == 0)
1030 if (e->ts.type == BT_CHARACTER || e->ts.type == BT_DERIVED)
1032 gfc_error ("By-value argument at %L is not of numeric "
1039 gfc_error ("By-value argument at %L cannot be an array or "
1040 "an array section", &e->where);
1044 /* Intrinsics are still PROC_UNKNOWN here. However,
1045 since same file external procedures are not resolvable
1046 in gfortran, it is a good deal easier to leave them to
1048 if (ptype != PROC_UNKNOWN
1049 && ptype != PROC_DUMMY
1050 && ptype != PROC_EXTERNAL
1051 && ptype != PROC_MODULE)
1053 gfc_error ("By-value argument at %L is not allowed "
1054 "in this context", &e->where);
1059 /* Statement functions have already been excluded above. */
1060 else if (strncmp ("%LOC", arg->name, 4) == 0
1061 && e->ts.type == BT_PROCEDURE)
1063 if (e->symtree->n.sym->attr.proc == PROC_INTERNAL)
1065 gfc_error ("Passing internal procedure at %L by location "
1066 "not allowed", &e->where);
1077 /* Do the checks of the actual argument list that are specific to elemental
1078 procedures. If called with c == NULL, we have a function, otherwise if
1079 expr == NULL, we have a subroutine. */
1082 resolve_elemental_actual (gfc_expr *expr, gfc_code *c)
1084 gfc_actual_arglist *arg0;
1085 gfc_actual_arglist *arg;
1086 gfc_symbol *esym = NULL;
1087 gfc_intrinsic_sym *isym = NULL;
1089 gfc_intrinsic_arg *iformal = NULL;
1090 gfc_formal_arglist *eformal = NULL;
1091 bool formal_optional = false;
1092 bool set_by_optional = false;
1096 /* Is this an elemental procedure? */
1097 if (expr && expr->value.function.actual != NULL)
1099 if (expr->value.function.esym != NULL
1100 && expr->value.function.esym->attr.elemental)
1102 arg0 = expr->value.function.actual;
1103 esym = expr->value.function.esym;
1105 else if (expr->value.function.isym != NULL
1106 && expr->value.function.isym->elemental)
1108 arg0 = expr->value.function.actual;
1109 isym = expr->value.function.isym;
1114 else if (c && c->ext.actual != NULL && c->symtree->n.sym->attr.elemental)
1116 arg0 = c->ext.actual;
1117 esym = c->symtree->n.sym;
1122 /* The rank of an elemental is the rank of its array argument(s). */
1123 for (arg = arg0; arg; arg = arg->next)
1125 if (arg->expr != NULL && arg->expr->rank > 0)
1127 rank = arg->expr->rank;
1128 if (arg->expr->expr_type == EXPR_VARIABLE
1129 && arg->expr->symtree->n.sym->attr.optional)
1130 set_by_optional = true;
1132 /* Function specific; set the result rank and shape. */
1136 if (!expr->shape && arg->expr->shape)
1138 expr->shape = gfc_get_shape (rank);
1139 for (i = 0; i < rank; i++)
1140 mpz_init_set (expr->shape[i], arg->expr->shape[i]);
1147 /* If it is an array, it shall not be supplied as an actual argument
1148 to an elemental procedure unless an array of the same rank is supplied
1149 as an actual argument corresponding to a nonoptional dummy argument of
1150 that elemental procedure(12.4.1.5). */
1151 formal_optional = false;
1153 iformal = isym->formal;
1155 eformal = esym->formal;
1157 for (arg = arg0; arg; arg = arg->next)
1161 if (eformal->sym && eformal->sym->attr.optional)
1162 formal_optional = true;
1163 eformal = eformal->next;
1165 else if (isym && iformal)
1167 if (iformal->optional)
1168 formal_optional = true;
1169 iformal = iformal->next;
1172 formal_optional = true;
1174 if (pedantic && arg->expr != NULL
1175 && arg->expr->expr_type == EXPR_VARIABLE
1176 && arg->expr->symtree->n.sym->attr.optional
1179 && (set_by_optional || arg->expr->rank != rank)
1180 && !(isym && isym->generic_id == GFC_ISYM_CONVERSION))
1182 gfc_warning ("'%s' at %L is an array and OPTIONAL; IF IT IS "
1183 "MISSING, it cannot be the actual argument of an "
1184 "ELEMENTAL procedure unless there is a non-optional "
1185 "argument with the same rank (12.4.1.5)",
1186 arg->expr->symtree->n.sym->name, &arg->expr->where);
1191 for (arg = arg0; arg; arg = arg->next)
1193 if (arg->expr == NULL || arg->expr->rank == 0)
1196 /* Being elemental, the last upper bound of an assumed size array
1197 argument must be present. */
1198 if (resolve_assumed_size_actual (arg->expr))
1204 /* Elemental subroutine array actual arguments must conform. */
1207 if (gfc_check_conformance ("elemental subroutine", arg->expr, e)
1219 /* Go through each actual argument in ACTUAL and see if it can be
1220 implemented as an inlined, non-copying intrinsic. FNSYM is the
1221 function being called, or NULL if not known. */
1224 find_noncopying_intrinsics (gfc_symbol *fnsym, gfc_actual_arglist *actual)
1226 gfc_actual_arglist *ap;
1229 for (ap = actual; ap; ap = ap->next)
1231 && (expr = gfc_get_noncopying_intrinsic_argument (ap->expr))
1232 && !gfc_check_fncall_dependency (expr, INTENT_IN, fnsym, actual))
1233 ap->expr->inline_noncopying_intrinsic = 1;
1237 /* This function does the checking of references to global procedures
1238 as defined in sections 18.1 and 14.1, respectively, of the Fortran
1239 77 and 95 standards. It checks for a gsymbol for the name, making
1240 one if it does not already exist. If it already exists, then the
1241 reference being resolved must correspond to the type of gsymbol.
1242 Otherwise, the new symbol is equipped with the attributes of the
1243 reference. The corresponding code that is called in creating
1244 global entities is parse.c. */
1247 resolve_global_procedure (gfc_symbol *sym, locus *where, int sub)
1252 type = sub ? GSYM_SUBROUTINE : GSYM_FUNCTION;
1254 gsym = gfc_get_gsymbol (sym->name);
1256 if ((gsym->type != GSYM_UNKNOWN && gsym->type != type))
1257 global_used (gsym, where);
1259 if (gsym->type == GSYM_UNKNOWN)
1262 gsym->where = *where;
1269 /************* Function resolution *************/
1271 /* Resolve a function call known to be generic.
1272 Section 14.1.2.4.1. */
1275 resolve_generic_f0 (gfc_expr *expr, gfc_symbol *sym)
1279 if (sym->attr.generic)
1281 s = gfc_search_interface (sym->generic, 0, &expr->value.function.actual);
1284 expr->value.function.name = s->name;
1285 expr->value.function.esym = s;
1287 if (s->ts.type != BT_UNKNOWN)
1289 else if (s->result != NULL && s->result->ts.type != BT_UNKNOWN)
1290 expr->ts = s->result->ts;
1293 expr->rank = s->as->rank;
1294 else if (s->result != NULL && s->result->as != NULL)
1295 expr->rank = s->result->as->rank;
1300 /* TODO: Need to search for elemental references in generic
1304 if (sym->attr.intrinsic)
1305 return gfc_intrinsic_func_interface (expr, 0);
1312 resolve_generic_f (gfc_expr *expr)
1317 sym = expr->symtree->n.sym;
1321 m = resolve_generic_f0 (expr, sym);
1324 else if (m == MATCH_ERROR)
1328 if (sym->ns->parent == NULL)
1330 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
1334 if (!generic_sym (sym))
1338 /* Last ditch attempt. See if the reference is to an intrinsic
1339 that possesses a matching interface. 14.1.2.4 */
1340 if (sym && !gfc_intrinsic_name (sym->name, 0))
1342 gfc_error ("There is no specific function for the generic '%s' at %L",
1343 expr->symtree->n.sym->name, &expr->where);
1347 m = gfc_intrinsic_func_interface (expr, 0);
1351 gfc_error ("Generic function '%s' at %L is not consistent with a "
1352 "specific intrinsic interface", expr->symtree->n.sym->name,
1359 /* Resolve a function call known to be specific. */
1362 resolve_specific_f0 (gfc_symbol *sym, gfc_expr *expr)
1366 if (sym->attr.external || sym->attr.if_source == IFSRC_IFBODY)
1368 if (sym->attr.dummy)
1370 sym->attr.proc = PROC_DUMMY;
1374 sym->attr.proc = PROC_EXTERNAL;
1378 if (sym->attr.proc == PROC_MODULE
1379 || sym->attr.proc == PROC_ST_FUNCTION
1380 || sym->attr.proc == PROC_INTERNAL)
1383 if (sym->attr.intrinsic)
1385 m = gfc_intrinsic_func_interface (expr, 1);
1389 gfc_error ("Function '%s' at %L is INTRINSIC but is not compatible "
1390 "with an intrinsic", sym->name, &expr->where);
1398 gfc_procedure_use (sym, &expr->value.function.actual, &expr->where);
1401 expr->value.function.name = sym->name;
1402 expr->value.function.esym = sym;
1403 if (sym->as != NULL)
1404 expr->rank = sym->as->rank;
1411 resolve_specific_f (gfc_expr *expr)
1416 sym = expr->symtree->n.sym;
1420 m = resolve_specific_f0 (sym, expr);
1423 if (m == MATCH_ERROR)
1426 if (sym->ns->parent == NULL)
1429 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
1435 gfc_error ("Unable to resolve the specific function '%s' at %L",
1436 expr->symtree->n.sym->name, &expr->where);
1442 /* Resolve a procedure call not known to be generic nor specific. */
1445 resolve_unknown_f (gfc_expr *expr)
1450 sym = expr->symtree->n.sym;
1452 if (sym->attr.dummy)
1454 sym->attr.proc = PROC_DUMMY;
1455 expr->value.function.name = sym->name;
1459 /* See if we have an intrinsic function reference. */
1461 if (gfc_intrinsic_name (sym->name, 0))
1463 if (gfc_intrinsic_func_interface (expr, 1) == MATCH_YES)
1468 /* The reference is to an external name. */
1470 sym->attr.proc = PROC_EXTERNAL;
1471 expr->value.function.name = sym->name;
1472 expr->value.function.esym = expr->symtree->n.sym;
1474 if (sym->as != NULL)
1475 expr->rank = sym->as->rank;
1477 /* Type of the expression is either the type of the symbol or the
1478 default type of the symbol. */
1481 gfc_procedure_use (sym, &expr->value.function.actual, &expr->where);
1483 if (sym->ts.type != BT_UNKNOWN)
1487 ts = gfc_get_default_type (sym, sym->ns);
1489 if (ts->type == BT_UNKNOWN)
1491 gfc_error ("Function '%s' at %L has no IMPLICIT type",
1492 sym->name, &expr->where);
1503 /* Figure out if a function reference is pure or not. Also set the name
1504 of the function for a potential error message. Return nonzero if the
1505 function is PURE, zero if not. */
1508 pure_function (gfc_expr *e, const char **name)
1514 if (e->symtree != NULL
1515 && e->symtree->n.sym != NULL
1516 && e->symtree->n.sym->attr.proc == PROC_ST_FUNCTION)
1519 if (e->value.function.esym)
1521 pure = gfc_pure (e->value.function.esym);
1522 *name = e->value.function.esym->name;
1524 else if (e->value.function.isym)
1526 pure = e->value.function.isym->pure
1527 || e->value.function.isym->elemental;
1528 *name = e->value.function.isym->name;
1532 /* Implicit functions are not pure. */
1534 *name = e->value.function.name;
1541 /* Resolve a function call, which means resolving the arguments, then figuring
1542 out which entity the name refers to. */
1543 /* TODO: Check procedure arguments so that an INTENT(IN) isn't passed
1544 to INTENT(OUT) or INTENT(INOUT). */
1547 resolve_function (gfc_expr *expr)
1549 gfc_actual_arglist *arg;
1554 procedure_type p = PROC_INTRINSIC;
1558 sym = expr->symtree->n.sym;
1560 if (sym && sym->attr.flavor == FL_VARIABLE)
1562 gfc_error ("'%s' at %L is not a function", sym->name, &expr->where);
1566 /* If the procedure is not internal, a statement function or a module
1567 procedure,it must be external and should be checked for usage. */
1568 if (sym && !sym->attr.dummy && !sym->attr.contained
1569 && sym->attr.proc != PROC_ST_FUNCTION
1570 && !sym->attr.use_assoc)
1571 resolve_global_procedure (sym, &expr->where, 0);
1573 /* Switch off assumed size checking and do this again for certain kinds
1574 of procedure, once the procedure itself is resolved. */
1575 need_full_assumed_size++;
1577 if (expr->symtree && expr->symtree->n.sym)
1578 p = expr->symtree->n.sym->attr.proc;
1580 if (resolve_actual_arglist (expr->value.function.actual, p) == FAILURE)
1583 /* Resume assumed_size checking. */
1584 need_full_assumed_size--;
1586 if (sym && sym->ts.type == BT_CHARACTER
1588 && sym->ts.cl->length == NULL
1590 && expr->value.function.esym == NULL
1591 && !sym->attr.contained)
1593 /* Internal procedures are taken care of in resolve_contained_fntype. */
1594 gfc_error ("Function '%s' is declared CHARACTER(*) and cannot "
1595 "be used at %L since it is not a dummy argument",
1596 sym->name, &expr->where);
1600 /* See if function is already resolved. */
1602 if (expr->value.function.name != NULL)
1604 if (expr->ts.type == BT_UNKNOWN)
1610 /* Apply the rules of section 14.1.2. */
1612 switch (procedure_kind (sym))
1615 t = resolve_generic_f (expr);
1618 case PTYPE_SPECIFIC:
1619 t = resolve_specific_f (expr);
1623 t = resolve_unknown_f (expr);
1627 gfc_internal_error ("resolve_function(): bad function type");
1631 /* If the expression is still a function (it might have simplified),
1632 then we check to see if we are calling an elemental function. */
1634 if (expr->expr_type != EXPR_FUNCTION)
1637 temp = need_full_assumed_size;
1638 need_full_assumed_size = 0;
1640 if (resolve_elemental_actual (expr, NULL) == FAILURE)
1643 if (omp_workshare_flag
1644 && expr->value.function.esym
1645 && ! gfc_elemental (expr->value.function.esym))
1647 gfc_error ("User defined non-ELEMENTAL function '%s' at %L not allowed "
1648 "in WORKSHARE construct", expr->value.function.esym->name,
1653 #define GENERIC_ID expr->value.function.isym->generic_id
1654 else if (expr->value.function.actual != NULL
1655 && expr->value.function.isym != NULL
1656 && GENERIC_ID != GFC_ISYM_LBOUND
1657 && GENERIC_ID != GFC_ISYM_LEN
1658 && GENERIC_ID != GFC_ISYM_LOC
1659 && GENERIC_ID != GFC_ISYM_PRESENT)
1661 /* Array intrinsics must also have the last upper bound of an
1662 assumed size array argument. UBOUND and SIZE have to be
1663 excluded from the check if the second argument is anything
1666 inquiry = GENERIC_ID == GFC_ISYM_UBOUND
1667 || GENERIC_ID == GFC_ISYM_SIZE;
1669 for (arg = expr->value.function.actual; arg; arg = arg->next)
1671 if (inquiry && arg->next != NULL && arg->next->expr)
1673 if (arg->next->expr->expr_type != EXPR_CONSTANT)
1676 if ((int)mpz_get_si (arg->next->expr->value.integer)
1681 if (arg->expr != NULL
1682 && arg->expr->rank > 0
1683 && resolve_assumed_size_actual (arg->expr))
1689 need_full_assumed_size = temp;
1692 if (!pure_function (expr, &name) && name)
1696 gfc_error ("reference to non-PURE function '%s' at %L inside a "
1697 "FORALL %s", name, &expr->where,
1698 forall_flag == 2 ? "mask" : "block");
1701 else if (gfc_pure (NULL))
1703 gfc_error ("Function reference to '%s' at %L is to a non-PURE "
1704 "procedure within a PURE procedure", name, &expr->where);
1709 /* Functions without the RECURSIVE attribution are not allowed to
1710 * call themselves. */
1711 if (expr->value.function.esym && !expr->value.function.esym->attr.recursive)
1713 gfc_symbol *esym, *proc;
1714 esym = expr->value.function.esym;
1715 proc = gfc_current_ns->proc_name;
1718 gfc_error ("Function '%s' at %L cannot call itself, as it is not "
1719 "RECURSIVE", name, &expr->where);
1723 if (esym->attr.entry && esym->ns->entries && proc->ns->entries
1724 && esym->ns->entries->sym == proc->ns->entries->sym)
1726 gfc_error ("Call to ENTRY '%s' at %L is recursive, but function "
1727 "'%s' is not declared as RECURSIVE",
1728 esym->name, &expr->where, esym->ns->entries->sym->name);
1733 /* Character lengths of use associated functions may contains references to
1734 symbols not referenced from the current program unit otherwise. Make sure
1735 those symbols are marked as referenced. */
1737 if (expr->ts.type == BT_CHARACTER && expr->value.function.esym
1738 && expr->value.function.esym->attr.use_assoc)
1740 gfc_expr_set_symbols_referenced (expr->ts.cl->length);
1744 find_noncopying_intrinsics (expr->value.function.esym,
1745 expr->value.function.actual);
1747 /* Make sure that the expression has a typespec that works. */
1748 if (expr->ts.type == BT_UNKNOWN)
1750 if (expr->symtree->n.sym->result
1751 && expr->symtree->n.sym->result->ts.type != BT_UNKNOWN)
1752 expr->ts = expr->symtree->n.sym->result->ts;
1754 expr->ts = expr->symtree->n.sym->result->ts;
1761 /************* Subroutine resolution *************/
1764 pure_subroutine (gfc_code *c, gfc_symbol *sym)
1770 gfc_error ("Subroutine call to '%s' in FORALL block at %L is not PURE",
1771 sym->name, &c->loc);
1772 else if (gfc_pure (NULL))
1773 gfc_error ("Subroutine call to '%s' at %L is not PURE", sym->name,
1779 resolve_generic_s0 (gfc_code *c, gfc_symbol *sym)
1783 if (sym->attr.generic)
1785 s = gfc_search_interface (sym->generic, 1, &c->ext.actual);
1788 c->resolved_sym = s;
1789 pure_subroutine (c, s);
1793 /* TODO: Need to search for elemental references in generic interface. */
1796 if (sym->attr.intrinsic)
1797 return gfc_intrinsic_sub_interface (c, 0);
1804 resolve_generic_s (gfc_code *c)
1809 sym = c->symtree->n.sym;
1813 m = resolve_generic_s0 (c, sym);
1816 else if (m == MATCH_ERROR)
1820 if (sym->ns->parent == NULL)
1822 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
1826 if (!generic_sym (sym))
1830 /* Last ditch attempt. See if the reference is to an intrinsic
1831 that possesses a matching interface. 14.1.2.4 */
1832 sym = c->symtree->n.sym;
1834 if (!gfc_intrinsic_name (sym->name, 1))
1836 gfc_error ("There is no specific subroutine for the generic '%s' at %L",
1837 sym->name, &c->loc);
1841 m = gfc_intrinsic_sub_interface (c, 0);
1845 gfc_error ("Generic subroutine '%s' at %L is not consistent with an "
1846 "intrinsic subroutine interface", sym->name, &c->loc);
1852 /* Resolve a subroutine call known to be specific. */
1855 resolve_specific_s0 (gfc_code *c, gfc_symbol *sym)
1859 if (sym->attr.external || sym->attr.if_source == IFSRC_IFBODY)
1861 if (sym->attr.dummy)
1863 sym->attr.proc = PROC_DUMMY;
1867 sym->attr.proc = PROC_EXTERNAL;
1871 if (sym->attr.proc == PROC_MODULE || sym->attr.proc == PROC_INTERNAL)
1874 if (sym->attr.intrinsic)
1876 m = gfc_intrinsic_sub_interface (c, 1);
1880 gfc_error ("Subroutine '%s' at %L is INTRINSIC but is not compatible "
1881 "with an intrinsic", sym->name, &c->loc);
1889 gfc_procedure_use (sym, &c->ext.actual, &c->loc);
1891 c->resolved_sym = sym;
1892 pure_subroutine (c, sym);
1899 resolve_specific_s (gfc_code *c)
1904 sym = c->symtree->n.sym;
1908 m = resolve_specific_s0 (c, sym);
1911 if (m == MATCH_ERROR)
1914 if (sym->ns->parent == NULL)
1917 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
1923 sym = c->symtree->n.sym;
1924 gfc_error ("Unable to resolve the specific subroutine '%s' at %L",
1925 sym->name, &c->loc);
1931 /* Resolve a subroutine call not known to be generic nor specific. */
1934 resolve_unknown_s (gfc_code *c)
1938 sym = c->symtree->n.sym;
1940 if (sym->attr.dummy)
1942 sym->attr.proc = PROC_DUMMY;
1946 /* See if we have an intrinsic function reference. */
1948 if (gfc_intrinsic_name (sym->name, 1))
1950 if (gfc_intrinsic_sub_interface (c, 1) == MATCH_YES)
1955 /* The reference is to an external name. */
1958 gfc_procedure_use (sym, &c->ext.actual, &c->loc);
1960 c->resolved_sym = sym;
1962 pure_subroutine (c, sym);
1968 /* Resolve a subroutine call. Although it was tempting to use the same code
1969 for functions, subroutines and functions are stored differently and this
1970 makes things awkward. */
1973 resolve_call (gfc_code *c)
1976 procedure_type ptype = PROC_INTRINSIC;
1978 if (c->symtree && c->symtree->n.sym
1979 && c->symtree->n.sym->ts.type != BT_UNKNOWN)
1981 gfc_error ("'%s' at %L has a type, which is not consistent with "
1982 "the CALL at %L", c->symtree->n.sym->name,
1983 &c->symtree->n.sym->declared_at, &c->loc);
1987 /* If the procedure is not internal or module, it must be external and
1988 should be checked for usage. */
1989 if (c->symtree && c->symtree->n.sym
1990 && !c->symtree->n.sym->attr.dummy
1991 && !c->symtree->n.sym->attr.contained
1992 && !c->symtree->n.sym->attr.use_assoc)
1993 resolve_global_procedure (c->symtree->n.sym, &c->loc, 1);
1995 /* Subroutines without the RECURSIVE attribution are not allowed to
1996 * call themselves. */
1997 if (c->symtree && c->symtree->n.sym && !c->symtree->n.sym->attr.recursive)
1999 gfc_symbol *csym, *proc;
2000 csym = c->symtree->n.sym;
2001 proc = gfc_current_ns->proc_name;
2004 gfc_error ("SUBROUTINE '%s' at %L cannot call itself, as it is not "
2005 "RECURSIVE", csym->name, &c->loc);
2009 if (csym->attr.entry && csym->ns->entries && proc->ns->entries
2010 && csym->ns->entries->sym == proc->ns->entries->sym)
2012 gfc_error ("Call to ENTRY '%s' at %L is recursive, but subroutine "
2013 "'%s' is not declared as RECURSIVE",
2014 csym->name, &c->loc, csym->ns->entries->sym->name);
2019 /* Switch off assumed size checking and do this again for certain kinds
2020 of procedure, once the procedure itself is resolved. */
2021 need_full_assumed_size++;
2023 if (c->symtree && c->symtree->n.sym)
2024 ptype = c->symtree->n.sym->attr.proc;
2026 if (resolve_actual_arglist (c->ext.actual, ptype) == FAILURE)
2029 /* Resume assumed_size checking. */
2030 need_full_assumed_size--;
2033 if (c->resolved_sym == NULL)
2034 switch (procedure_kind (c->symtree->n.sym))
2037 t = resolve_generic_s (c);
2040 case PTYPE_SPECIFIC:
2041 t = resolve_specific_s (c);
2045 t = resolve_unknown_s (c);
2049 gfc_internal_error ("resolve_subroutine(): bad function type");
2052 /* Some checks of elemental subroutine actual arguments. */
2053 if (resolve_elemental_actual (NULL, c) == FAILURE)
2057 find_noncopying_intrinsics (c->resolved_sym, c->ext.actual);
2062 /* Compare the shapes of two arrays that have non-NULL shapes. If both
2063 op1->shape and op2->shape are non-NULL return SUCCESS if their shapes
2064 match. If both op1->shape and op2->shape are non-NULL return FAILURE
2065 if their shapes do not match. If either op1->shape or op2->shape is
2066 NULL, return SUCCESS. */
2069 compare_shapes (gfc_expr *op1, gfc_expr *op2)
2076 if (op1->shape != NULL && op2->shape != NULL)
2078 for (i = 0; i < op1->rank; i++)
2080 if (mpz_cmp (op1->shape[i], op2->shape[i]) != 0)
2082 gfc_error ("Shapes for operands at %L and %L are not conformable",
2083 &op1->where, &op2->where);
2094 /* Resolve an operator expression node. This can involve replacing the
2095 operation with a user defined function call. */
2098 resolve_operator (gfc_expr *e)
2100 gfc_expr *op1, *op2;
2102 bool dual_locus_error;
2105 /* Resolve all subnodes-- give them types. */
2107 switch (e->value.op.operator)
2110 if (gfc_resolve_expr (e->value.op.op2) == FAILURE)
2113 /* Fall through... */
2116 case INTRINSIC_UPLUS:
2117 case INTRINSIC_UMINUS:
2118 case INTRINSIC_PARENTHESES:
2119 if (gfc_resolve_expr (e->value.op.op1) == FAILURE)
2124 /* Typecheck the new node. */
2126 op1 = e->value.op.op1;
2127 op2 = e->value.op.op2;
2128 dual_locus_error = false;
2130 switch (e->value.op.operator)
2132 case INTRINSIC_UPLUS:
2133 case INTRINSIC_UMINUS:
2134 if (op1->ts.type == BT_INTEGER
2135 || op1->ts.type == BT_REAL
2136 || op1->ts.type == BT_COMPLEX)
2142 sprintf (msg, _("Operand of unary numeric operator '%s' at %%L is %s"),
2143 gfc_op2string (e->value.op.operator), gfc_typename (&e->ts));
2146 case INTRINSIC_PLUS:
2147 case INTRINSIC_MINUS:
2148 case INTRINSIC_TIMES:
2149 case INTRINSIC_DIVIDE:
2150 case INTRINSIC_POWER:
2151 if (gfc_numeric_ts (&op1->ts) && gfc_numeric_ts (&op2->ts))
2153 gfc_type_convert_binary (e);
2158 _("Operands of binary numeric operator '%s' at %%L are %s/%s"),
2159 gfc_op2string (e->value.op.operator), gfc_typename (&op1->ts),
2160 gfc_typename (&op2->ts));
2163 case INTRINSIC_CONCAT:
2164 if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER)
2166 e->ts.type = BT_CHARACTER;
2167 e->ts.kind = op1->ts.kind;
2172 _("Operands of string concatenation operator at %%L are %s/%s"),
2173 gfc_typename (&op1->ts), gfc_typename (&op2->ts));
2179 case INTRINSIC_NEQV:
2180 if (op1->ts.type == BT_LOGICAL && op2->ts.type == BT_LOGICAL)
2182 e->ts.type = BT_LOGICAL;
2183 e->ts.kind = gfc_kind_max (op1, op2);
2184 if (op1->ts.kind < e->ts.kind)
2185 gfc_convert_type (op1, &e->ts, 2);
2186 else if (op2->ts.kind < e->ts.kind)
2187 gfc_convert_type (op2, &e->ts, 2);
2191 sprintf (msg, _("Operands of logical operator '%s' at %%L are %s/%s"),
2192 gfc_op2string (e->value.op.operator), gfc_typename (&op1->ts),
2193 gfc_typename (&op2->ts));
2198 if (op1->ts.type == BT_LOGICAL)
2200 e->ts.type = BT_LOGICAL;
2201 e->ts.kind = op1->ts.kind;
2205 sprintf (msg, _("Operand of .NOT. operator at %%L is %s"),
2206 gfc_typename (&op1->ts));
2213 if (op1->ts.type == BT_COMPLEX || op2->ts.type == BT_COMPLEX)
2215 strcpy (msg, _("COMPLEX quantities cannot be compared at %L"));
2219 /* Fall through... */
2223 if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER)
2225 e->ts.type = BT_LOGICAL;
2226 e->ts.kind = gfc_default_logical_kind;
2230 if (gfc_numeric_ts (&op1->ts) && gfc_numeric_ts (&op2->ts))
2232 gfc_type_convert_binary (e);
2234 e->ts.type = BT_LOGICAL;
2235 e->ts.kind = gfc_default_logical_kind;
2239 if (op1->ts.type == BT_LOGICAL && op2->ts.type == BT_LOGICAL)
2241 _("Logicals at %%L must be compared with %s instead of %s"),
2242 e->value.op.operator == INTRINSIC_EQ ? ".EQV." : ".NEQV.",
2243 gfc_op2string (e->value.op.operator));
2246 _("Operands of comparison operator '%s' at %%L are %s/%s"),
2247 gfc_op2string (e->value.op.operator), gfc_typename (&op1->ts),
2248 gfc_typename (&op2->ts));
2252 case INTRINSIC_USER:
2254 sprintf (msg, _("Operand of user operator '%s' at %%L is %s"),
2255 e->value.op.uop->name, gfc_typename (&op1->ts));
2257 sprintf (msg, _("Operands of user operator '%s' at %%L are %s/%s"),
2258 e->value.op.uop->name, gfc_typename (&op1->ts),
2259 gfc_typename (&op2->ts));
2263 case INTRINSIC_PARENTHESES:
2267 gfc_internal_error ("resolve_operator(): Bad intrinsic");
2270 /* Deal with arrayness of an operand through an operator. */
2274 switch (e->value.op.operator)
2276 case INTRINSIC_PLUS:
2277 case INTRINSIC_MINUS:
2278 case INTRINSIC_TIMES:
2279 case INTRINSIC_DIVIDE:
2280 case INTRINSIC_POWER:
2281 case INTRINSIC_CONCAT:
2285 case INTRINSIC_NEQV:
2293 if (op1->rank == 0 && op2->rank == 0)
2296 if (op1->rank == 0 && op2->rank != 0)
2298 e->rank = op2->rank;
2300 if (e->shape == NULL)
2301 e->shape = gfc_copy_shape (op2->shape, op2->rank);
2304 if (op1->rank != 0 && op2->rank == 0)
2306 e->rank = op1->rank;
2308 if (e->shape == NULL)
2309 e->shape = gfc_copy_shape (op1->shape, op1->rank);
2312 if (op1->rank != 0 && op2->rank != 0)
2314 if (op1->rank == op2->rank)
2316 e->rank = op1->rank;
2317 if (e->shape == NULL)
2319 t = compare_shapes(op1, op2);
2323 e->shape = gfc_copy_shape (op1->shape, op1->rank);
2328 /* Allow higher level expressions to work. */
2331 /* Try user-defined operators, and otherwise throw an error. */
2332 dual_locus_error = true;
2334 _("Inconsistent ranks for operator at %%L and %%L"));
2342 case INTRINSIC_UPLUS:
2343 case INTRINSIC_UMINUS:
2344 case INTRINSIC_PARENTHESES:
2345 e->rank = op1->rank;
2347 if (e->shape == NULL)
2348 e->shape = gfc_copy_shape (op1->shape, op1->rank);
2350 /* Simply copy arrayness attribute */
2357 /* Attempt to simplify the expression. */
2360 t = gfc_simplify_expr (e, 0);
2361 /* Some calls do not succeed in simplification and return FAILURE
2362 even though there is no error; eg. variable references to
2363 PARAMETER arrays. */
2364 if (!gfc_is_constant_expr (e))
2371 if (gfc_extend_expr (e) == SUCCESS)
2374 if (dual_locus_error)
2375 gfc_error (msg, &op1->where, &op2->where);
2377 gfc_error (msg, &e->where);
2383 /************** Array resolution subroutines **************/
2386 { CMP_LT, CMP_EQ, CMP_GT, CMP_UNKNOWN }
2389 /* Compare two integer expressions. */
2392 compare_bound (gfc_expr *a, gfc_expr *b)
2396 if (a == NULL || a->expr_type != EXPR_CONSTANT
2397 || b == NULL || b->expr_type != EXPR_CONSTANT)
2400 if (a->ts.type != BT_INTEGER || b->ts.type != BT_INTEGER)
2401 gfc_internal_error ("compare_bound(): Bad expression");
2403 i = mpz_cmp (a->value.integer, b->value.integer);
2413 /* Compare an integer expression with an integer. */
2416 compare_bound_int (gfc_expr *a, int b)
2420 if (a == NULL || a->expr_type != EXPR_CONSTANT)
2423 if (a->ts.type != BT_INTEGER)
2424 gfc_internal_error ("compare_bound_int(): Bad expression");
2426 i = mpz_cmp_si (a->value.integer, b);
2436 /* Compare an integer expression with a mpz_t. */
2439 compare_bound_mpz_t (gfc_expr *a, mpz_t b)
2443 if (a == NULL || a->expr_type != EXPR_CONSTANT)
2446 if (a->ts.type != BT_INTEGER)
2447 gfc_internal_error ("compare_bound_int(): Bad expression");
2449 i = mpz_cmp (a->value.integer, b);
2459 /* Compute the last value of a sequence given by a triplet.
2460 Return 0 if it wasn't able to compute the last value, or if the
2461 sequence if empty, and 1 otherwise. */
2464 compute_last_value_for_triplet (gfc_expr *start, gfc_expr *end,
2465 gfc_expr *stride, mpz_t last)
2469 if (start == NULL || start->expr_type != EXPR_CONSTANT
2470 || end == NULL || end->expr_type != EXPR_CONSTANT
2471 || (stride != NULL && stride->expr_type != EXPR_CONSTANT))
2474 if (start->ts.type != BT_INTEGER || end->ts.type != BT_INTEGER
2475 || (stride != NULL && stride->ts.type != BT_INTEGER))
2478 if (stride == NULL || compare_bound_int(stride, 1) == CMP_EQ)
2480 if (compare_bound (start, end) == CMP_GT)
2482 mpz_set (last, end->value.integer);
2486 if (compare_bound_int (stride, 0) == CMP_GT)
2488 /* Stride is positive */
2489 if (mpz_cmp (start->value.integer, end->value.integer) > 0)
2494 /* Stride is negative */
2495 if (mpz_cmp (start->value.integer, end->value.integer) < 0)
2500 mpz_sub (rem, end->value.integer, start->value.integer);
2501 mpz_tdiv_r (rem, rem, stride->value.integer);
2502 mpz_sub (last, end->value.integer, rem);
2509 /* Compare a single dimension of an array reference to the array
2513 check_dimension (int i, gfc_array_ref *ar, gfc_array_spec *as)
2517 /* Given start, end and stride values, calculate the minimum and
2518 maximum referenced indexes. */
2526 if (compare_bound (ar->start[i], as->lower[i]) == CMP_LT)
2528 if (compare_bound (ar->start[i], as->upper[i]) == CMP_GT)
2535 #define AR_START (ar->start[i] ? ar->start[i] : as->lower[i])
2536 #define AR_END (ar->end[i] ? ar->end[i] : as->upper[i])
2538 comparison comp_start_end = compare_bound (AR_START, AR_END);
2540 /* Check for zero stride, which is not allowed. */
2541 if (compare_bound_int (ar->stride[i], 0) == CMP_EQ)
2543 gfc_error ("Illegal stride of zero at %L", &ar->c_where[i]);
2547 /* if start == len || (stride > 0 && start < len)
2548 || (stride < 0 && start > len),
2549 then the array section contains at least one element. In this
2550 case, there is an out-of-bounds access if
2551 (start < lower || start > upper). */
2552 if (compare_bound (AR_START, AR_END) == CMP_EQ
2553 || ((compare_bound_int (ar->stride[i], 0) == CMP_GT
2554 || ar->stride[i] == NULL) && comp_start_end == CMP_LT)
2555 || (compare_bound_int (ar->stride[i], 0) == CMP_LT
2556 && comp_start_end == CMP_GT))
2558 if (compare_bound (AR_START, as->lower[i]) == CMP_LT
2559 || compare_bound (AR_START, as->upper[i]) == CMP_GT)
2563 /* If we can compute the highest index of the array section,
2564 then it also has to be between lower and upper. */
2565 mpz_init (last_value);
2566 if (compute_last_value_for_triplet (AR_START, AR_END, ar->stride[i],
2569 if (compare_bound_mpz_t (as->lower[i], last_value) == CMP_GT
2570 || compare_bound_mpz_t (as->upper[i], last_value) == CMP_LT)
2572 mpz_clear (last_value);
2576 mpz_clear (last_value);
2584 gfc_internal_error ("check_dimension(): Bad array reference");
2590 gfc_warning ("Array reference at %L is out of bounds", &ar->c_where[i]);
2595 /* Compare an array reference with an array specification. */
2598 compare_spec_to_ref (gfc_array_ref *ar)
2605 /* TODO: Full array sections are only allowed as actual parameters. */
2606 if (as->type == AS_ASSUMED_SIZE
2607 && (/*ar->type == AR_FULL
2608 ||*/ (ar->type == AR_SECTION
2609 && ar->dimen_type[i] == DIMEN_RANGE && ar->end[i] == NULL)))
2611 gfc_error ("Rightmost upper bound of assumed size array section "
2612 "not specified at %L", &ar->where);
2616 if (ar->type == AR_FULL)
2619 if (as->rank != ar->dimen)
2621 gfc_error ("Rank mismatch in array reference at %L (%d/%d)",
2622 &ar->where, ar->dimen, as->rank);
2626 for (i = 0; i < as->rank; i++)
2627 if (check_dimension (i, ar, as) == FAILURE)
2634 /* Resolve one part of an array index. */
2637 gfc_resolve_index (gfc_expr *index, int check_scalar)
2644 if (gfc_resolve_expr (index) == FAILURE)
2647 if (check_scalar && index->rank != 0)
2649 gfc_error ("Array index at %L must be scalar", &index->where);
2653 if (index->ts.type != BT_INTEGER && index->ts.type != BT_REAL)
2655 gfc_error ("Array index at %L must be of INTEGER type",
2660 if (index->ts.type == BT_REAL)
2661 if (gfc_notify_std (GFC_STD_LEGACY, "Extension: REAL array index at %L",
2662 &index->where) == FAILURE)
2665 if (index->ts.kind != gfc_index_integer_kind
2666 || index->ts.type != BT_INTEGER)
2669 ts.type = BT_INTEGER;
2670 ts.kind = gfc_index_integer_kind;
2672 gfc_convert_type_warn (index, &ts, 2, 0);
2678 /* Resolve a dim argument to an intrinsic function. */
2681 gfc_resolve_dim_arg (gfc_expr *dim)
2686 if (gfc_resolve_expr (dim) == FAILURE)
2691 gfc_error ("Argument dim at %L must be scalar", &dim->where);
2695 if (dim->ts.type != BT_INTEGER)
2697 gfc_error ("Argument dim at %L must be of INTEGER type", &dim->where);
2700 if (dim->ts.kind != gfc_index_integer_kind)
2704 ts.type = BT_INTEGER;
2705 ts.kind = gfc_index_integer_kind;
2707 gfc_convert_type_warn (dim, &ts, 2, 0);
2713 /* Given an expression that contains array references, update those array
2714 references to point to the right array specifications. While this is
2715 filled in during matching, this information is difficult to save and load
2716 in a module, so we take care of it here.
2718 The idea here is that the original array reference comes from the
2719 base symbol. We traverse the list of reference structures, setting
2720 the stored reference to references. Component references can
2721 provide an additional array specification. */
2724 find_array_spec (gfc_expr *e)
2728 gfc_symbol *derived;
2731 as = e->symtree->n.sym->as;
2734 for (ref = e->ref; ref; ref = ref->next)
2739 gfc_internal_error ("find_array_spec(): Missing spec");
2746 if (derived == NULL)
2747 derived = e->symtree->n.sym->ts.derived;
2749 c = derived->components;
2751 for (; c; c = c->next)
2752 if (c == ref->u.c.component)
2754 /* Track the sequence of component references. */
2755 if (c->ts.type == BT_DERIVED)
2756 derived = c->ts.derived;
2761 gfc_internal_error ("find_array_spec(): Component not found");
2766 gfc_internal_error ("find_array_spec(): unused as(1)");
2777 gfc_internal_error ("find_array_spec(): unused as(2)");
2781 /* Resolve an array reference. */
2784 resolve_array_ref (gfc_array_ref *ar)
2786 int i, check_scalar;
2789 for (i = 0; i < ar->dimen; i++)
2791 check_scalar = ar->dimen_type[i] == DIMEN_RANGE;
2793 if (gfc_resolve_index (ar->start[i], check_scalar) == FAILURE)
2795 if (gfc_resolve_index (ar->end[i], check_scalar) == FAILURE)
2797 if (gfc_resolve_index (ar->stride[i], check_scalar) == FAILURE)
2802 if (ar->dimen_type[i] == DIMEN_UNKNOWN)
2806 ar->dimen_type[i] = DIMEN_ELEMENT;
2810 ar->dimen_type[i] = DIMEN_VECTOR;
2811 if (e->expr_type == EXPR_VARIABLE
2812 && e->symtree->n.sym->ts.type == BT_DERIVED)
2813 ar->start[i] = gfc_get_parentheses (e);
2817 gfc_error ("Array index at %L is an array of rank %d",
2818 &ar->c_where[i], e->rank);
2823 /* If the reference type is unknown, figure out what kind it is. */
2825 if (ar->type == AR_UNKNOWN)
2827 ar->type = AR_ELEMENT;
2828 for (i = 0; i < ar->dimen; i++)
2829 if (ar->dimen_type[i] == DIMEN_RANGE
2830 || ar->dimen_type[i] == DIMEN_VECTOR)
2832 ar->type = AR_SECTION;
2837 if (!ar->as->cray_pointee && compare_spec_to_ref (ar) == FAILURE)
2845 resolve_substring (gfc_ref *ref)
2847 if (ref->u.ss.start != NULL)
2849 if (gfc_resolve_expr (ref->u.ss.start) == FAILURE)
2852 if (ref->u.ss.start->ts.type != BT_INTEGER)
2854 gfc_error ("Substring start index at %L must be of type INTEGER",
2855 &ref->u.ss.start->where);
2859 if (ref->u.ss.start->rank != 0)
2861 gfc_error ("Substring start index at %L must be scalar",
2862 &ref->u.ss.start->where);
2866 if (compare_bound_int (ref->u.ss.start, 1) == CMP_LT
2867 && (compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_EQ
2868 || compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_GT))
2870 gfc_error ("Substring start index at %L is less than one",
2871 &ref->u.ss.start->where);
2876 if (ref->u.ss.end != NULL)
2878 if (gfc_resolve_expr (ref->u.ss.end) == FAILURE)
2881 if (ref->u.ss.end->ts.type != BT_INTEGER)
2883 gfc_error ("Substring end index at %L must be of type INTEGER",
2884 &ref->u.ss.end->where);
2888 if (ref->u.ss.end->rank != 0)
2890 gfc_error ("Substring end index at %L must be scalar",
2891 &ref->u.ss.end->where);
2895 if (ref->u.ss.length != NULL
2896 && compare_bound (ref->u.ss.end, ref->u.ss.length->length) == CMP_GT
2897 && (compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_EQ
2898 || compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_GT))
2900 gfc_error ("Substring end index at %L exceeds the string length",
2901 &ref->u.ss.start->where);
2910 /* Resolve subtype references. */
2913 resolve_ref (gfc_expr *expr)
2915 int current_part_dimension, n_components, seen_part_dimension;
2918 for (ref = expr->ref; ref; ref = ref->next)
2919 if (ref->type == REF_ARRAY && ref->u.ar.as == NULL)
2921 find_array_spec (expr);
2925 for (ref = expr->ref; ref; ref = ref->next)
2929 if (resolve_array_ref (&ref->u.ar) == FAILURE)
2937 resolve_substring (ref);
2941 /* Check constraints on part references. */
2943 current_part_dimension = 0;
2944 seen_part_dimension = 0;
2947 for (ref = expr->ref; ref; ref = ref->next)
2952 switch (ref->u.ar.type)
2956 current_part_dimension = 1;
2960 current_part_dimension = 0;
2964 gfc_internal_error ("resolve_ref(): Bad array reference");
2970 if (current_part_dimension || seen_part_dimension)
2972 if (ref->u.c.component->pointer)
2974 gfc_error ("Component to the right of a part reference "
2975 "with nonzero rank must not have the POINTER "
2976 "attribute at %L", &expr->where);
2979 else if (ref->u.c.component->allocatable)
2981 gfc_error ("Component to the right of a part reference "
2982 "with nonzero rank must not have the ALLOCATABLE "
2983 "attribute at %L", &expr->where);
2995 if (((ref->type == REF_COMPONENT && n_components > 1)
2996 || ref->next == NULL)
2997 && current_part_dimension
2998 && seen_part_dimension)
3000 gfc_error ("Two or more part references with nonzero rank must "
3001 "not be specified at %L", &expr->where);
3005 if (ref->type == REF_COMPONENT)
3007 if (current_part_dimension)
3008 seen_part_dimension = 1;
3010 /* reset to make sure */
3011 current_part_dimension = 0;
3019 /* Given an expression, determine its shape. This is easier than it sounds.
3020 Leaves the shape array NULL if it is not possible to determine the shape. */
3023 expression_shape (gfc_expr *e)
3025 mpz_t array[GFC_MAX_DIMENSIONS];
3028 if (e->rank == 0 || e->shape != NULL)
3031 for (i = 0; i < e->rank; i++)
3032 if (gfc_array_dimen_size (e, i, &array[i]) == FAILURE)
3035 e->shape = gfc_get_shape (e->rank);
3037 memcpy (e->shape, array, e->rank * sizeof (mpz_t));
3042 for (i--; i >= 0; i--)
3043 mpz_clear (array[i]);
3047 /* Given a variable expression node, compute the rank of the expression by
3048 examining the base symbol and any reference structures it may have. */
3051 expression_rank (gfc_expr *e)
3058 if (e->expr_type == EXPR_ARRAY)
3060 /* Constructors can have a rank different from one via RESHAPE(). */
3062 if (e->symtree == NULL)
3068 e->rank = (e->symtree->n.sym->as == NULL)
3069 ? 0 : e->symtree->n.sym->as->rank;
3075 for (ref = e->ref; ref; ref = ref->next)
3077 if (ref->type != REF_ARRAY)
3080 if (ref->u.ar.type == AR_FULL)
3082 rank = ref->u.ar.as->rank;
3086 if (ref->u.ar.type == AR_SECTION)
3088 /* Figure out the rank of the section. */
3090 gfc_internal_error ("expression_rank(): Two array specs");
3092 for (i = 0; i < ref->u.ar.dimen; i++)
3093 if (ref->u.ar.dimen_type[i] == DIMEN_RANGE
3094 || ref->u.ar.dimen_type[i] == DIMEN_VECTOR)
3104 expression_shape (e);
3108 /* Resolve a variable expression. */
3111 resolve_variable (gfc_expr *e)
3118 if (e->symtree == NULL)
3121 if (e->ref && resolve_ref (e) == FAILURE)
3124 sym = e->symtree->n.sym;
3125 if (sym->attr.flavor == FL_PROCEDURE && !sym->attr.function)
3127 e->ts.type = BT_PROCEDURE;
3131 if (sym->ts.type != BT_UNKNOWN)
3132 gfc_variable_attr (e, &e->ts);
3135 /* Must be a simple variable reference. */
3136 if (gfc_set_default_type (sym, 1, sym->ns) == FAILURE)
3141 if (check_assumed_size_reference (sym, e))
3144 /* Deal with forward references to entries during resolve_code, to
3145 satisfy, at least partially, 12.5.2.5. */
3146 if (gfc_current_ns->entries
3147 && current_entry_id == sym->entry_id
3150 && cs_base->current->op != EXEC_ENTRY)
3152 gfc_entry_list *entry;
3153 gfc_formal_arglist *formal;
3157 /* If the symbol is a dummy... */
3158 if (sym->attr.dummy)
3160 entry = gfc_current_ns->entries;
3163 /* ...test if the symbol is a parameter of previous entries. */
3164 for (; entry && entry->id <= current_entry_id; entry = entry->next)
3165 for (formal = entry->sym->formal; formal; formal = formal->next)
3167 if (formal->sym && sym->name == formal->sym->name)
3171 /* If it has not been seen as a dummy, this is an error. */
3174 if (specification_expr)
3175 gfc_error ("Variable '%s',used in a specification expression, "
3176 "is referenced at %L before the ENTRY statement "
3177 "in which it is a parameter",
3178 sym->name, &cs_base->current->loc);
3180 gfc_error ("Variable '%s' is used at %L before the ENTRY "
3181 "statement in which it is a parameter",
3182 sym->name, &cs_base->current->loc);
3187 /* Now do the same check on the specification expressions. */
3188 specification_expr = 1;
3189 if (sym->ts.type == BT_CHARACTER
3190 && gfc_resolve_expr (sym->ts.cl->length) == FAILURE)
3194 for (n = 0; n < sym->as->rank; n++)
3196 specification_expr = 1;
3197 if (gfc_resolve_expr (sym->as->lower[n]) == FAILURE)
3199 specification_expr = 1;
3200 if (gfc_resolve_expr (sym->as->upper[n]) == FAILURE)
3203 specification_expr = 0;
3206 /* Update the symbol's entry level. */
3207 sym->entry_id = current_entry_id + 1;
3214 /* Checks to see that the correct symbol has been host associated.
3215 The only situation where this arises is that in which a twice
3216 contained function is parsed after the host association is made.
3217 Therefore, on detecting this, the line is rematched, having got
3218 rid of the existing references and actual_arg_list. */
3220 check_host_association (gfc_expr *e)
3222 gfc_symbol *sym, *old_sym;
3227 if (e->symtree == NULL || e->symtree->n.sym == NULL)
3228 return e->expr_type == EXPR_FUNCTION;
3230 old_sym = e->symtree->n.sym;
3231 if (gfc_current_ns->parent
3232 && gfc_current_ns->parent->parent
3233 && old_sym->ns != gfc_current_ns)
3235 gfc_find_symbol (old_sym->name, gfc_current_ns->parent, 1, &sym);
3236 if (sym && old_sym != sym && sym->attr.flavor == FL_PROCEDURE)
3238 temp_locus = gfc_current_locus;
3239 gfc_current_locus = e->where;
3241 gfc_buffer_error (1);
3243 gfc_free_ref_list (e->ref);
3246 if (e->expr_type == EXPR_FUNCTION)
3248 gfc_free_actual_arglist (e->value.function.actual);
3249 e->value.function.actual = NULL;
3252 if (e->shape != NULL)
3254 for (n = 0; n < e->rank; n++)
3255 mpz_clear (e->shape[n]);
3257 gfc_free (e->shape);
3260 gfc_match_rvalue (&expr);
3262 gfc_buffer_error (0);
3264 gcc_assert (expr && sym == expr->symtree->n.sym);
3270 gfc_current_locus = temp_locus;
3274 return e->expr_type == EXPR_FUNCTION;
3278 /* Resolve an expression. That is, make sure that types of operands agree
3279 with their operators, intrinsic operators are converted to function calls
3280 for overloaded types and unresolved function references are resolved. */
3283 gfc_resolve_expr (gfc_expr *e)
3290 switch (e->expr_type)
3293 t = resolve_operator (e);
3299 if (check_host_association (e))
3300 t = resolve_function (e);
3303 t = resolve_variable (e);
3305 expression_rank (e);
3309 case EXPR_SUBSTRING:
3310 t = resolve_ref (e);
3320 if (resolve_ref (e) == FAILURE)
3323 t = gfc_resolve_array_constructor (e);
3324 /* Also try to expand a constructor. */
3327 expression_rank (e);
3328 gfc_expand_constructor (e);
3331 /* This provides the opportunity for the length of constructors with
3332 character valued function elements to propogate the string length
3333 to the expression. */
3334 if (e->ts.type == BT_CHARACTER)
3335 gfc_resolve_character_array_constructor (e);
3339 case EXPR_STRUCTURE:
3340 t = resolve_ref (e);
3344 t = resolve_structure_cons (e);
3348 t = gfc_simplify_expr (e, 0);
3352 gfc_internal_error ("gfc_resolve_expr(): Bad expression type");
3359 /* Resolve an expression from an iterator. They must be scalar and have
3360 INTEGER or (optionally) REAL type. */
3363 gfc_resolve_iterator_expr (gfc_expr *expr, bool real_ok,
3364 const char *name_msgid)
3366 if (gfc_resolve_expr (expr) == FAILURE)
3369 if (expr->rank != 0)
3371 gfc_error ("%s at %L must be a scalar", _(name_msgid), &expr->where);
3375 if (!(expr->ts.type == BT_INTEGER
3376 || (expr->ts.type == BT_REAL && real_ok)))
3379 gfc_error ("%s at %L must be INTEGER or REAL", _(name_msgid),
3382 gfc_error ("%s at %L must be INTEGER", _(name_msgid), &expr->where);
3389 /* Resolve the expressions in an iterator structure. If REAL_OK is
3390 false allow only INTEGER type iterators, otherwise allow REAL types. */
3393 gfc_resolve_iterator (gfc_iterator *iter, bool real_ok)
3396 if (iter->var->ts.type == BT_REAL)
3397 gfc_notify_std (GFC_STD_F95_DEL, "Obsolete: REAL DO loop iterator at %L",
3400 if (gfc_resolve_iterator_expr (iter->var, real_ok, "Loop variable")
3404 if (gfc_pure (NULL) && gfc_impure_variable (iter->var->symtree->n.sym))
3406 gfc_error ("Cannot assign to loop variable in PURE procedure at %L",
3411 if (gfc_resolve_iterator_expr (iter->start, real_ok,
3412 "Start expression in DO loop") == FAILURE)
3415 if (gfc_resolve_iterator_expr (iter->end, real_ok,
3416 "End expression in DO loop") == FAILURE)
3419 if (gfc_resolve_iterator_expr (iter->step, real_ok,
3420 "Step expression in DO loop") == FAILURE)
3423 if (iter->step->expr_type == EXPR_CONSTANT)
3425 if ((iter->step->ts.type == BT_INTEGER
3426 && mpz_cmp_ui (iter->step->value.integer, 0) == 0)
3427 || (iter->step->ts.type == BT_REAL
3428 && mpfr_sgn (iter->step->value.real) == 0))
3430 gfc_error ("Step expression in DO loop at %L cannot be zero",
3431 &iter->step->where);
3436 /* Convert start, end, and step to the same type as var. */
3437 if (iter->start->ts.kind != iter->var->ts.kind
3438 || iter->start->ts.type != iter->var->ts.type)
3439 gfc_convert_type (iter->start, &iter->var->ts, 2);
3441 if (iter->end->ts.kind != iter->var->ts.kind
3442 || iter->end->ts.type != iter->var->ts.type)
3443 gfc_convert_type (iter->end, &iter->var->ts, 2);
3445 if (iter->step->ts.kind != iter->var->ts.kind
3446 || iter->step->ts.type != iter->var->ts.type)
3447 gfc_convert_type (iter->step, &iter->var->ts, 2);
3453 /* Resolve a list of FORALL iterators. The FORALL index-name is constrained
3454 to be a scalar INTEGER variable. The subscripts and stride are scalar
3455 INTEGERs, and if stride is a constant it must be nonzero. */
3458 resolve_forall_iterators (gfc_forall_iterator *iter)
3462 if (gfc_resolve_expr (iter->var) == SUCCESS
3463 && (iter->var->ts.type != BT_INTEGER || iter->var->rank != 0))
3464 gfc_error ("FORALL index-name at %L must be a scalar INTEGER",
3467 if (gfc_resolve_expr (iter->start) == SUCCESS
3468 && (iter->start->ts.type != BT_INTEGER || iter->start->rank != 0))
3469 gfc_error ("FORALL start expression at %L must be a scalar INTEGER",
3470 &iter->start->where);
3471 if (iter->var->ts.kind != iter->start->ts.kind)
3472 gfc_convert_type (iter->start, &iter->var->ts, 2);
3474 if (gfc_resolve_expr (iter->end) == SUCCESS
3475 && (iter->end->ts.type != BT_INTEGER || iter->end->rank != 0))
3476 gfc_error ("FORALL end expression at %L must be a scalar INTEGER",
3478 if (iter->var->ts.kind != iter->end->ts.kind)
3479 gfc_convert_type (iter->end, &iter->var->ts, 2);
3481 if (gfc_resolve_expr (iter->stride) == SUCCESS)
3483 if (iter->stride->ts.type != BT_INTEGER || iter->stride->rank != 0)
3484 gfc_error ("FORALL stride expression at %L must be a scalar %s",
3485 &iter->stride->where, "INTEGER");
3487 if (iter->stride->expr_type == EXPR_CONSTANT
3488 && mpz_cmp_ui(iter->stride->value.integer, 0) == 0)
3489 gfc_error ("FORALL stride expression at %L cannot be zero",
3490 &iter->stride->where);
3492 if (iter->var->ts.kind != iter->stride->ts.kind)
3493 gfc_convert_type (iter->stride, &iter->var->ts, 2);
3500 /* Given a pointer to a symbol that is a derived type, see if any components
3501 have the POINTER attribute. The search is recursive if necessary.
3502 Returns zero if no pointer components are found, nonzero otherwise. */
3505 derived_pointer (gfc_symbol *sym)
3509 for (c = sym->components; c; c = c->next)
3514 if (c->ts.type == BT_DERIVED && derived_pointer (c->ts.derived))
3522 /* Given a pointer to a symbol that is a derived type, see if it's
3523 inaccessible, i.e. if it's defined in another module and the components are
3524 PRIVATE. The search is recursive if necessary. Returns zero if no
3525 inaccessible components are found, nonzero otherwise. */
3528 derived_inaccessible (gfc_symbol *sym)
3532 if (sym->attr.use_assoc && sym->component_access == ACCESS_PRIVATE)
3535 for (c = sym->components; c; c = c->next)
3537 if (c->ts.type == BT_DERIVED && derived_inaccessible (c->ts.derived))
3545 /* Resolve the argument of a deallocate expression. The expression must be
3546 a pointer or a full array. */
3549 resolve_deallocate_expr (gfc_expr *e)
3551 symbol_attribute attr;
3552 int allocatable, pointer, check_intent_in;
3555 /* Check INTENT(IN), unless the object is a sub-component of a pointer. */
3556 check_intent_in = 1;
3558 if (gfc_resolve_expr (e) == FAILURE)
3561 if (e->expr_type != EXPR_VARIABLE)
3564 allocatable = e->symtree->n.sym->attr.allocatable;
3565 pointer = e->symtree->n.sym->attr.pointer;
3566 for (ref = e->ref; ref; ref = ref->next)
3569 check_intent_in = 0;
3574 if (ref->u.ar.type != AR_FULL)
3579 allocatable = (ref->u.c.component->as != NULL
3580 && ref->u.c.component->as->type == AS_DEFERRED);
3581 pointer = ref->u.c.component->pointer;
3590 attr = gfc_expr_attr (e);
3592 if (allocatable == 0 && attr.pointer == 0)
3595 gfc_error ("Expression in DEALLOCATE statement at %L must be "
3596 "ALLOCATABLE or a POINTER", &e->where);
3600 && e->symtree->n.sym->attr.intent == INTENT_IN)
3602 gfc_error ("Cannot deallocate INTENT(IN) variable '%s' at %L",
3603 e->symtree->n.sym->name, &e->where);
3611 /* Returns true if the expression e contains a reference the symbol sym. */
3613 find_sym_in_expr (gfc_symbol *sym, gfc_expr *e)
3615 gfc_actual_arglist *arg;
3623 switch (e->expr_type)
3626 for (arg = e->value.function.actual; arg; arg = arg->next)
3627 rv = rv || find_sym_in_expr (sym, arg->expr);
3630 /* If the variable is not the same as the dependent, 'sym', and
3631 it is not marked as being declared and it is in the same
3632 namespace as 'sym', add it to the local declarations. */
3634 if (sym == e->symtree->n.sym)
3639 rv = rv || find_sym_in_expr (sym, e->value.op.op1);
3640 rv = rv || find_sym_in_expr (sym, e->value.op.op2);
3649 for (ref = e->ref; ref; ref = ref->next)
3654 for (i = 0; i < ref->u.ar.dimen; i++)
3656 rv = rv || find_sym_in_expr (sym, ref->u.ar.start[i]);
3657 rv = rv || find_sym_in_expr (sym, ref->u.ar.end[i]);
3658 rv = rv || find_sym_in_expr (sym, ref->u.ar.stride[i]);
3663 rv = rv || find_sym_in_expr (sym, ref->u.ss.start);
3664 rv = rv || find_sym_in_expr (sym, ref->u.ss.end);
3668 if (ref->u.c.component->ts.type == BT_CHARACTER
3669 && ref->u.c.component->ts.cl->length->expr_type
3672 || find_sym_in_expr (sym,
3673 ref->u.c.component->ts.cl->length);
3675 if (ref->u.c.component->as)
3676 for (i = 0; i < ref->u.c.component->as->rank; i++)
3679 || find_sym_in_expr (sym,
3680 ref->u.c.component->as->lower[i]);
3682 || find_sym_in_expr (sym,
3683 ref->u.c.component->as->upper[i]);
3693 /* Given the expression node e for an allocatable/pointer of derived type to be
3694 allocated, get the expression node to be initialized afterwards (needed for
3695 derived types with default initializers, and derived types with allocatable
3696 components that need nullification.) */
3699 expr_to_initialize (gfc_expr *e)
3705 result = gfc_copy_expr (e);
3707 /* Change the last array reference from AR_ELEMENT to AR_FULL. */
3708 for (ref = result->ref; ref; ref = ref->next)
3709 if (ref->type == REF_ARRAY && ref->next == NULL)
3711 ref->u.ar.type = AR_FULL;
3713 for (i = 0; i < ref->u.ar.dimen; i++)
3714 ref->u.ar.start[i] = ref->u.ar.end[i] = ref->u.ar.stride[i] = NULL;
3716 result->rank = ref->u.ar.dimen;
3724 /* Resolve the expression in an ALLOCATE statement, doing the additional
3725 checks to see whether the expression is OK or not. The expression must
3726 have a trailing array reference that gives the size of the array. */
3729 resolve_allocate_expr (gfc_expr *e, gfc_code *code)
3731 int i, pointer, allocatable, dimension, check_intent_in;
3732 symbol_attribute attr;
3733 gfc_ref *ref, *ref2;
3740 /* Check INTENT(IN), unless the object is a sub-component of a pointer. */
3741 check_intent_in = 1;
3743 if (gfc_resolve_expr (e) == FAILURE)
3746 if (code->expr && code->expr->expr_type == EXPR_VARIABLE)
3747 sym = code->expr->symtree->n.sym;
3751 /* Make sure the expression is allocatable or a pointer. If it is
3752 pointer, the next-to-last reference must be a pointer. */
3756 if (e->expr_type != EXPR_VARIABLE)
3759 attr = gfc_expr_attr (e);
3760 pointer = attr.pointer;
3761 dimension = attr.dimension;
3765 allocatable = e->symtree->n.sym->attr.allocatable;
3766 pointer = e->symtree->n.sym->attr.pointer;
3767 dimension = e->symtree->n.sym->attr.dimension;
3769 if (sym == e->symtree->n.sym && sym->ts.type != BT_DERIVED)
3771 gfc_error ("The STAT variable '%s' in an ALLOCATE statement must "
3772 "not be allocated in the same statement at %L",
3773 sym->name, &e->where);
3777 for (ref = e->ref; ref; ref2 = ref, ref = ref->next)
3780 check_intent_in = 0;
3785 if (ref->next != NULL)
3790 allocatable = (ref->u.c.component->as != NULL
3791 && ref->u.c.component->as->type == AS_DEFERRED);
3793 pointer = ref->u.c.component->pointer;
3794 dimension = ref->u.c.component->dimension;
3805 if (allocatable == 0 && pointer == 0)
3807 gfc_error ("Expression in ALLOCATE statement at %L must be "
3808 "ALLOCATABLE or a POINTER", &e->where);
3813 && e->symtree->n.sym->attr.intent == INTENT_IN)
3815 gfc_error ("Cannot allocate INTENT(IN) variable '%s' at %L",
3816 e->symtree->n.sym->name, &e->where);
3820 /* Add default initializer for those derived types that need them. */
3821 if (e->ts.type == BT_DERIVED && (init_e = gfc_default_initializer (&e->ts)))
3823 init_st = gfc_get_code ();
3824 init_st->loc = code->loc;
3825 init_st->op = EXEC_INIT_ASSIGN;
3826 init_st->expr = expr_to_initialize (e);
3827 init_st->expr2 = init_e;
3828 init_st->next = code->next;
3829 code->next = init_st;
3832 if (pointer && dimension == 0)
3835 /* Make sure the next-to-last reference node is an array specification. */
3837 if (ref2 == NULL || ref2->type != REF_ARRAY || ref2->u.ar.type == AR_FULL)
3839 gfc_error ("Array specification required in ALLOCATE statement "
3840 "at %L", &e->where);
3844 /* Make sure that the array section reference makes sense in the
3845 context of an ALLOCATE specification. */
3849 for (i = 0; i < ar->dimen; i++)
3851 if (ref2->u.ar.type == AR_ELEMENT)
3854 switch (ar->dimen_type[i])
3860 if (ar->start[i] != NULL
3861 && ar->end[i] != NULL
3862 && ar->stride[i] == NULL)
3865 /* Fall Through... */
3869 gfc_error ("Bad array specification in ALLOCATE statement at %L",
3876 for (a = code->ext.alloc_list; a; a = a->next)
3878 sym = a->expr->symtree->n.sym;
3880 /* TODO - check derived type components. */
3881 if (sym->ts.type == BT_DERIVED)
3884 if ((ar->start[i] != NULL && find_sym_in_expr (sym, ar->start[i]))
3885 || (ar->end[i] != NULL && find_sym_in_expr (sym, ar->end[i])))
3887 gfc_error ("'%s' must not appear an the array specification at "
3888 "%L in the same ALLOCATE statement where it is "
3889 "itself allocated", sym->name, &ar->where);
3899 /************ SELECT CASE resolution subroutines ************/
3901 /* Callback function for our mergesort variant. Determines interval
3902 overlaps for CASEs. Return <0 if op1 < op2, 0 for overlap, >0 for
3903 op1 > op2. Assumes we're not dealing with the default case.
3904 We have op1 = (:L), (K:L) or (K:) and op2 = (:N), (M:N) or (M:).
3905 There are nine situations to check. */
3908 compare_cases (const gfc_case *op1, const gfc_case *op2)
3912 if (op1->low == NULL) /* op1 = (:L) */
3914 /* op2 = (:N), so overlap. */
3916 /* op2 = (M:) or (M:N), L < M */
3917 if (op2->low != NULL
3918 && gfc_compare_expr (op1->high, op2->low) < 0)
3921 else if (op1->high == NULL) /* op1 = (K:) */
3923 /* op2 = (M:), so overlap. */
3925 /* op2 = (:N) or (M:N), K > N */
3926 if (op2->high != NULL
3927 && gfc_compare_expr (op1->low, op2->high) > 0)
3930 else /* op1 = (K:L) */
3932 if (op2->low == NULL) /* op2 = (:N), K > N */
3933 retval = (gfc_compare_expr (op1->low, op2->high) > 0) ? 1 : 0;
3934 else if (op2->high == NULL) /* op2 = (M:), L < M */
3935 retval = (gfc_compare_expr (op1->high, op2->low) < 0) ? -1 : 0;
3936 else /* op2 = (M:N) */
3940 if (gfc_compare_expr (op1->high, op2->low) < 0)
3943 else if (gfc_compare_expr (op1->low, op2->high) > 0)
3952 /* Merge-sort a double linked case list, detecting overlap in the
3953 process. LIST is the head of the double linked case list before it
3954 is sorted. Returns the head of the sorted list if we don't see any
3955 overlap, or NULL otherwise. */
3958 check_case_overlap (gfc_case *list)
3960 gfc_case *p, *q, *e, *tail;
3961 int insize, nmerges, psize, qsize, cmp, overlap_seen;
3963 /* If the passed list was empty, return immediately. */
3970 /* Loop unconditionally. The only exit from this loop is a return
3971 statement, when we've finished sorting the case list. */
3978 /* Count the number of merges we do in this pass. */
3981 /* Loop while there exists a merge to be done. */
3986 /* Count this merge. */
3989 /* Cut the list in two pieces by stepping INSIZE places
3990 forward in the list, starting from P. */
3993 for (i = 0; i < insize; i++)
4002 /* Now we have two lists. Merge them! */
4003 while (psize > 0 || (qsize > 0 && q != NULL))
4005 /* See from which the next case to merge comes from. */
4008 /* P is empty so the next case must come from Q. */
4013 else if (qsize == 0 || q == NULL)
4022 cmp = compare_cases (p, q);
4025 /* The whole case range for P is less than the
4033 /* The whole case range for Q is greater than
4034 the case range for P. */
4041 /* The cases overlap, or they are the same
4042 element in the list. Either way, we must
4043 issue an error and get the next case from P. */
4044 /* FIXME: Sort P and Q by line number. */
4045 gfc_error ("CASE label at %L overlaps with CASE "
4046 "label at %L", &p->where, &q->where);
4054 /* Add the next element to the merged list. */
4063 /* P has now stepped INSIZE places along, and so has Q. So
4064 they're the same. */
4069 /* If we have done only one merge or none at all, we've
4070 finished sorting the cases. */
4079 /* Otherwise repeat, merging lists twice the size. */
4085 /* Check to see if an expression is suitable for use in a CASE statement.
4086 Makes sure that all case expressions are scalar constants of the same
4087 type. Return FAILURE if anything is wrong. */
4090 validate_case_label_expr (gfc_expr *e, gfc_expr *case_expr)
4092 if (e == NULL) return SUCCESS;
4094 if (e->ts.type != case_expr->ts.type)
4096 gfc_error ("Expression in CASE statement at %L must be of type %s",
4097 &e->where, gfc_basic_typename (case_expr->ts.type));
4101 /* C805 (R808) For a given case-construct, each case-value shall be of
4102 the same type as case-expr. For character type, length differences
4103 are allowed, but the kind type parameters shall be the same. */
4105 if (case_expr->ts.type == BT_CHARACTER && e->ts.kind != case_expr->ts.kind)
4107 gfc_error("Expression in CASE statement at %L must be kind %d",
4108 &e->where, case_expr->ts.kind);
4112 /* Convert the case value kind to that of case expression kind, if needed.
4113 FIXME: Should a warning be issued? */
4114 if (e->ts.kind != case_expr->ts.kind)
4115 gfc_convert_type_warn (e, &case_expr->ts, 2, 0);
4119 gfc_error ("Expression in CASE statement at %L must be scalar",
4128 /* Given a completely parsed select statement, we:
4130 - Validate all expressions and code within the SELECT.
4131 - Make sure that the selection expression is not of the wrong type.
4132 - Make sure that no case ranges overlap.
4133 - Eliminate unreachable cases and unreachable code resulting from
4134 removing case labels.
4136 The standard does allow unreachable cases, e.g. CASE (5:3). But
4137 they are a hassle for code generation, and to prevent that, we just
4138 cut them out here. This is not necessary for overlapping cases
4139 because they are illegal and we never even try to generate code.
4141 We have the additional caveat that a SELECT construct could have
4142 been a computed GOTO in the source code. Fortunately we can fairly
4143 easily work around that here: The case_expr for a "real" SELECT CASE
4144 is in code->expr1, but for a computed GOTO it is in code->expr2. All
4145 we have to do is make sure that the case_expr is a scalar integer
4149 resolve_select (gfc_code *code)
4152 gfc_expr *case_expr;
4153 gfc_case *cp, *default_case, *tail, *head;
4154 int seen_unreachable;
4160 if (code->expr == NULL)
4162 /* This was actually a computed GOTO statement. */
4163 case_expr = code->expr2;
4164 if (case_expr->ts.type != BT_INTEGER|| case_expr->rank != 0)
4165 gfc_error ("Selection expression in computed GOTO statement "
4166 "at %L must be a scalar integer expression",
4169 /* Further checking is not necessary because this SELECT was built
4170 by the compiler, so it should always be OK. Just move the
4171 case_expr from expr2 to expr so that we can handle computed
4172 GOTOs as normal SELECTs from here on. */
4173 code->expr = code->expr2;
4178 case_expr = code->expr;
4180 type = case_expr->ts.type;
4181 if (type != BT_LOGICAL && type != BT_INTEGER && type != BT_CHARACTER)
4183 gfc_error ("Argument of SELECT statement at %L cannot be %s",
4184 &case_expr->where, gfc_typename (&case_expr->ts));
4186 /* Punt. Going on here just produce more garbage error messages. */
4190 if (case_expr->rank != 0)
4192 gfc_error ("Argument of SELECT statement at %L must be a scalar "
4193 "expression", &case_expr->where);
4199 /* PR 19168 has a long discussion concerning a mismatch of the kinds
4200 of the SELECT CASE expression and its CASE values. Walk the lists
4201 of case values, and if we find a mismatch, promote case_expr to
4202 the appropriate kind. */
4204 if (type == BT_LOGICAL || type == BT_INTEGER)
4206 for (body = code->block; body; body = body->block)
4208 /* Walk the case label list. */
4209 for (cp = body->ext.case_list; cp; cp = cp->next)
4211 /* Intercept the DEFAULT case. It does not have a kind. */
4212 if (cp->low == NULL && cp->high == NULL)
4215 /* Unreachable case ranges are discarded, so ignore. */
4216 if (cp->low != NULL && cp->high != NULL
4217 && cp->low != cp->high
4218 && gfc_compare_expr (cp->low, cp->high) > 0)
4221 /* FIXME: Should a warning be issued? */
4223 && case_expr->ts.kind != gfc_kind_max(case_expr, cp->low))
4224 gfc_convert_type_warn (case_expr, &cp->low->ts, 2, 0);
4226 if (cp->high != NULL
4227 && case_expr->ts.kind != gfc_kind_max(case_expr, cp->high))
4228 gfc_convert_type_warn (case_expr, &cp->high->ts, 2, 0);
4233 /* Assume there is no DEFAULT case. */
4234 default_case = NULL;
4239 for (body = code->block; body; body = body->block)
4241 /* Assume the CASE list is OK, and all CASE labels can be matched. */
4243 seen_unreachable = 0;
4245 /* Walk the case label list, making sure that all case labels
4247 for (cp = body->ext.case_list; cp; cp = cp->next)
4249 /* Count the number of cases in the whole construct. */
4252 /* Intercept the DEFAULT case. */
4253 if (cp->low == NULL && cp->high == NULL)
4255 if (default_case != NULL)
4257 gfc_error ("The DEFAULT CASE at %L cannot be followed "
4258 "by a second DEFAULT CASE at %L",
4259 &default_case->where, &cp->where);
4270 /* Deal with single value cases and case ranges. Errors are
4271 issued from the validation function. */
4272 if(validate_case_label_expr (cp->low, case_expr) != SUCCESS
4273 || validate_case_label_expr (cp->high, case_expr) != SUCCESS)
4279 if (type == BT_LOGICAL
4280 && ((cp->low == NULL || cp->high == NULL)
4281 || cp->low != cp->high))
4283 gfc_error ("Logical range in CASE statement at %L is not "
4284 "allowed", &cp->low->where);
4289 if (type == BT_LOGICAL && cp->low->expr_type == EXPR_CONSTANT)
4292 value = cp->low->value.logical == 0 ? 2 : 1;
4293 if (value & seen_logical)
4295 gfc_error ("constant logical value in CASE statement "
4296 "is repeated at %L",
4301 seen_logical |= value;
4304 if (cp->low != NULL && cp->high != NULL
4305 && cp->low != cp->high
4306 && gfc_compare_expr (cp->low, cp->high) > 0)
4308 if (gfc_option.warn_surprising)
4309 gfc_warning ("Range specification at %L can never "
4310 "be matched", &cp->where);
4312 cp->unreachable = 1;
4313 seen_unreachable = 1;
4317 /* If the case range can be matched, it can also overlap with
4318 other cases. To make sure it does not, we put it in a
4319 double linked list here. We sort that with a merge sort
4320 later on to detect any overlapping cases. */
4324 head->right = head->left = NULL;
4329 tail->right->left = tail;
4336 /* It there was a failure in the previous case label, give up
4337 for this case label list. Continue with the next block. */
4341 /* See if any case labels that are unreachable have been seen.
4342 If so, we eliminate them. This is a bit of a kludge because
4343 the case lists for a single case statement (label) is a
4344 single forward linked lists. */
4345 if (seen_unreachable)
4347 /* Advance until the first case in the list is reachable. */
4348 while (body->ext.case_list != NULL
4349 && body->ext.case_list->unreachable)
4351 gfc_case *n = body->ext.case_list;
4352 body->ext.case_list = body->ext.case_list->next;
4354 gfc_free_case_list (n);
4357 /* Strip all other unreachable cases. */
4358 if (body->ext.case_list)
4360 for (cp = body->ext.case_list; cp->next; cp = cp->next)
4362 if (cp->next->unreachable)
4364 gfc_case *n = cp->next;
4365 cp->next = cp->next->next;
4367 gfc_free_case_list (n);
4374 /* See if there were overlapping cases. If the check returns NULL,
4375 there was overlap. In that case we don't do anything. If head
4376 is non-NULL, we prepend the DEFAULT case. The sorted list can
4377 then used during code generation for SELECT CASE constructs with
4378 a case expression of a CHARACTER type. */
4381 head = check_case_overlap (head);
4383 /* Prepend the default_case if it is there. */
4384 if (head != NULL && default_case)
4386 default_case->left = NULL;
4387 default_case->right = head;
4388 head->left = default_case;
4392 /* Eliminate dead blocks that may be the result if we've seen
4393 unreachable case labels for a block. */
4394 for (body = code; body && body->block; body = body->block)
4396 if (body->block->ext.case_list == NULL)
4398 /* Cut the unreachable block from the code chain. */
4399 gfc_code *c = body->block;
4400 body->block = c->block;
4402 /* Kill the dead block, but not the blocks below it. */
4404 gfc_free_statements (c);
4408 /* More than two cases is legal but insane for logical selects.
4409 Issue a warning for it. */
4410 if (gfc_option.warn_surprising && type == BT_LOGICAL
4412 gfc_warning ("Logical SELECT CASE block at %L has more that two cases",
4417 /* Resolve a transfer statement. This is making sure that:
4418 -- a derived type being transferred has only non-pointer components
4419 -- a derived type being transferred doesn't have private components, unless
4420 it's being transferred from the module where the type was defined
4421 -- we're not trying to transfer a whole assumed size array. */
4424 resolve_transfer (gfc_code *code)
4433 if (exp->expr_type != EXPR_VARIABLE && exp->expr_type != EXPR_FUNCTION)
4436 sym = exp->symtree->n.sym;
4439 /* Go to actual component transferred. */
4440 for (ref = code->expr->ref; ref; ref = ref->next)
4441 if (ref->type == REF_COMPONENT)
4442 ts = &ref->u.c.component->ts;
4444 if (ts->type == BT_DERIVED)
4446 /* Check that transferred derived type doesn't contain POINTER
4448 if (derived_pointer (ts->derived))
4450 gfc_error ("Data transfer element at %L cannot have "
4451 "POINTER components", &code->loc);
4455 if (ts->derived->attr.alloc_comp)
4457 gfc_error ("Data transfer element at %L cannot have "
4458 "ALLOCATABLE components", &code->loc);
4462 if (derived_inaccessible (ts->derived))
4464 gfc_error ("Data transfer element at %L cannot have "
4465 "PRIVATE components",&code->loc);
4470 if (sym->as != NULL && sym->as->type == AS_ASSUMED_SIZE
4471 && exp->ref->type == REF_ARRAY && exp->ref->u.ar.type == AR_FULL)
4473 gfc_error ("Data transfer element at %L cannot be a full reference to "
4474 "an assumed-size array", &code->loc);
4480 /*********** Toplevel code resolution subroutines ***********/
4482 /* Find the set of labels that are reachable from this block. We also
4483 record the last statement in each block so that we don't have to do
4484 a linear search to find the END DO statements of the blocks. */
4487 reachable_labels (gfc_code *block)
4494 cs_base->reachable_labels = bitmap_obstack_alloc (&labels_obstack);
4496 /* Collect labels in this block. */
4497 for (c = block; c; c = c->next)
4500 bitmap_set_bit (cs_base->reachable_labels, c->here->value);
4502 if (!c->next && cs_base->prev)
4503 cs_base->prev->tail = c;
4506 /* Merge with labels from parent block. */
4509 gcc_assert (cs_base->prev->reachable_labels);
4510 bitmap_ior_into (cs_base->reachable_labels,
4511 cs_base->prev->reachable_labels);
4515 /* Given a branch to a label and a namespace, if the branch is conforming.
4516 The code node describes where the branch is located. */
4519 resolve_branch (gfc_st_label *label, gfc_code *code)
4526 /* Step one: is this a valid branching target? */
4528 if (label->defined == ST_LABEL_UNKNOWN)
4530 gfc_error ("Label %d referenced at %L is never defined", label->value,
4535 if (label->defined != ST_LABEL_TARGET)
4537 gfc_error ("Statement at %L is not a valid branch target statement "
4538 "for the branch statement at %L", &label->where, &code->loc);
4542 /* Step two: make sure this branch is not a branch to itself ;-) */
4544 if (code->here == label)
4546 gfc_warning ("Branch at %L causes an infinite loop", &code->loc);
4550 /* Step three: See if the label is in the same block as the
4551 branching statement. The hard work has been done by setting up
4552 the bitmap reachable_labels. */
4554 if (!bitmap_bit_p (cs_base->reachable_labels, label->value))
4556 /* The label is not in an enclosing block, so illegal. This was
4557 allowed in Fortran 66, so we allow it as extension. No
4558 further checks are necessary in this case. */
4559 gfc_notify_std (GFC_STD_LEGACY, "Label at %L is not in the same block "
4560 "as the GOTO statement at %L", &label->where,
4565 /* Step four: Make sure that the branching target is legal if
4566 the statement is an END {SELECT,IF}. */
4568 for (stack = cs_base; stack; stack = stack->prev)
4569 if (stack->current->next && stack->current->next->here == label)
4572 if (stack && stack->current->next->op == EXEC_NOP)
4574 gfc_notify_std (GFC_STD_F95_DEL, "Obsolete: GOTO at %L jumps to "
4575 "END of construct at %L", &code->loc,
4576 &stack->current->next->loc);
4577 return; /* We know this is not an END DO. */
4580 /* Step five: Make sure that we're not jumping to the end of a DO
4581 loop from within the loop. */
4583 for (stack = cs_base; stack; stack = stack->prev)
4584 if ((stack->current->op == EXEC_DO
4585 || stack->current->op == EXEC_DO_WHILE)
4586 && stack->tail->here == label && stack->tail->op == EXEC_NOP)
4588 gfc_notify_std (GFC_STD_F95_DEL, "Obsolete: GOTO at %L jumps "
4589 "to END of construct at %L", &code->loc,
4597 /* Check whether EXPR1 has the same shape as EXPR2. */
4600 resolve_where_shape (gfc_expr *expr1, gfc_expr *expr2)
4602 mpz_t shape[GFC_MAX_DIMENSIONS];
4603 mpz_t shape2[GFC_MAX_DIMENSIONS];
4604 try result = FAILURE;
4607 /* Compare the rank. */
4608 if (expr1->rank != expr2->rank)
4611 /* Compare the size of each dimension. */
4612 for (i=0; i<expr1->rank; i++)
4614 if (gfc_array_dimen_size (expr1, i, &shape[i]) == FAILURE)
4617 if (gfc_array_dimen_size (expr2, i, &shape2[i]) == FAILURE)
4620 if (mpz_cmp (shape[i], shape2[i]))
4624 /* When either of the two expression is an assumed size array, we
4625 ignore the comparison of dimension sizes. */
4630 for (i--; i >= 0; i--)
4632 mpz_clear (shape[i]);
4633 mpz_clear (shape2[i]);
4639 /* Check whether a WHERE assignment target or a WHERE mask expression
4640 has the same shape as the outmost WHERE mask expression. */
4643 resolve_where (gfc_code *code, gfc_expr *mask)
4649 cblock = code->block;
4651 /* Store the first WHERE mask-expr of the WHERE statement or construct.
4652 In case of nested WHERE, only the outmost one is stored. */
4653 if (mask == NULL) /* outmost WHERE */
4655 else /* inner WHERE */
4662 /* Check if the mask-expr has a consistent shape with the
4663 outmost WHERE mask-expr. */
4664 if (resolve_where_shape (cblock->expr, e) == FAILURE)
4665 gfc_error ("WHERE mask at %L has inconsistent shape",
4666 &cblock->expr->where);
4669 /* the assignment statement of a WHERE statement, or the first
4670 statement in where-body-construct of a WHERE construct */
4671 cnext = cblock->next;
4676 /* WHERE assignment statement */
4679 /* Check shape consistent for WHERE assignment target. */
4680 if (e && resolve_where_shape (cnext->expr, e) == FAILURE)
4681 gfc_error ("WHERE assignment target at %L has "
4682 "inconsistent shape", &cnext->expr->where);
4686 case EXEC_ASSIGN_CALL:
4687 resolve_call (cnext);
4690 /* WHERE or WHERE construct is part of a where-body-construct */
4692 resolve_where (cnext, e);
4696 gfc_error ("Unsupported statement inside WHERE at %L",
4699 /* the next statement within the same where-body-construct */
4700 cnext = cnext->next;
4702 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
4703 cblock = cblock->block;
4708 /* Check whether the FORALL index appears in the expression or not. */
4711 gfc_find_forall_index (gfc_expr *expr, gfc_symbol *symbol)
4715 gfc_actual_arglist *args;
4718 switch (expr->expr_type)
4721 gcc_assert (expr->symtree->n.sym);
4723 /* A scalar assignment */
4726 if (expr->symtree->n.sym == symbol)
4732 /* the expr is array ref, substring or struct component. */
4739 /* Check if the symbol appears in the array subscript. */
4741 for (i = 0; i < GFC_MAX_DIMENSIONS; i++)
4744 if (gfc_find_forall_index (ar.start[i], symbol) == SUCCESS)
4748 if (gfc_find_forall_index (ar.end[i], symbol) == SUCCESS)
4752 if (gfc_find_forall_index (ar.stride[i], symbol) == SUCCESS)
4758 if (expr->symtree->n.sym == symbol)
4761 /* Check if the symbol appears in the substring section. */
4762 if (gfc_find_forall_index (tmp->u.ss.start, symbol) == SUCCESS)
4764 if (gfc_find_forall_index (tmp->u.ss.end, symbol) == SUCCESS)
4772 gfc_error("expression reference type error at %L", &expr->where);
4778 /* If the expression is a function call, then check if the symbol
4779 appears in the actual arglist of the function. */
4781 for (args = expr->value.function.actual; args; args = args->next)
4783 if (gfc_find_forall_index(args->expr,symbol) == SUCCESS)
4788 /* It seems not to happen. */
4789 case EXPR_SUBSTRING:
4793 gcc_assert (expr->ref->type == REF_SUBSTRING);
4794 if (gfc_find_forall_index (tmp->u.ss.start, symbol) == SUCCESS)
4796 if (gfc_find_forall_index (tmp->u.ss.end, symbol) == SUCCESS)
4801 /* It seems not to happen. */
4802 case EXPR_STRUCTURE:
4804 gfc_error ("Unsupported statement while finding forall index in "
4809 /* Find the FORALL index in the first operand. */
4810 if (expr->value.op.op1)
4812 if (gfc_find_forall_index (expr->value.op.op1, symbol) == SUCCESS)
4816 /* Find the FORALL index in the second operand. */
4817 if (expr->value.op.op2)
4819 if (gfc_find_forall_index (expr->value.op.op2, symbol) == SUCCESS)
4832 /* Resolve assignment in FORALL construct.
4833 NVAR is the number of FORALL index variables, and VAR_EXPR records the
4834 FORALL index variables. */
4837 gfc_resolve_assign_in_forall (gfc_code *code, int nvar, gfc_expr **var_expr)
4841 for (n = 0; n < nvar; n++)
4843 gfc_symbol *forall_index;
4845 forall_index = var_expr[n]->symtree->n.sym;
4847 /* Check whether the assignment target is one of the FORALL index
4849 if ((code->expr->expr_type == EXPR_VARIABLE)
4850 && (code->expr->symtree->n.sym == forall_index))
4851 gfc_error ("Assignment to a FORALL index variable at %L",
4852 &code->expr->where);
4855 /* If one of the FORALL index variables doesn't appear in the
4856 assignment target, then there will be a many-to-one
4858 if (gfc_find_forall_index (code->expr, forall_index) == FAILURE)
4859 gfc_error ("The FORALL with index '%s' cause more than one "
4860 "assignment to this object at %L",
4861 var_expr[n]->symtree->name, &code->expr->where);
4867 /* Resolve WHERE statement in FORALL construct. */
4870 gfc_resolve_where_code_in_forall (gfc_code *code, int nvar,
4871 gfc_expr **var_expr)
4876 cblock = code->block;
4879 /* the assignment statement of a WHERE statement, or the first
4880 statement in where-body-construct of a WHERE construct */
4881 cnext = cblock->next;
4886 /* WHERE assignment statement */
4888 gfc_resolve_assign_in_forall (cnext, nvar, var_expr);
4891 /* WHERE operator assignment statement */
4892 case EXEC_ASSIGN_CALL:
4893 resolve_call (cnext);
4896 /* WHERE or WHERE construct is part of a where-body-construct */
4898 gfc_resolve_where_code_in_forall (cnext, nvar, var_expr);
4902 gfc_error ("Unsupported statement inside WHERE at %L",
4905 /* the next statement within the same where-body-construct */
4906 cnext = cnext->next;
4908 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
4909 cblock = cblock->block;
4914 /* Traverse the FORALL body to check whether the following errors exist:
4915 1. For assignment, check if a many-to-one assignment happens.
4916 2. For WHERE statement, check the WHERE body to see if there is any
4917 many-to-one assignment. */
4920 gfc_resolve_forall_body (gfc_code *code, int nvar, gfc_expr **var_expr)
4924 c = code->block->next;
4930 case EXEC_POINTER_ASSIGN:
4931 gfc_resolve_assign_in_forall (c, nvar, var_expr);
4934 case EXEC_ASSIGN_CALL:
4938 /* Because the gfc_resolve_blocks() will handle the nested FORALL,
4939 there is no need to handle it here. */
4943 gfc_resolve_where_code_in_forall(c, nvar, var_expr);
4948 /* The next statement in the FORALL body. */
4954 /* Given a FORALL construct, first resolve the FORALL iterator, then call
4955 gfc_resolve_forall_body to resolve the FORALL body. */
4958 gfc_resolve_forall (gfc_code *code, gfc_namespace *ns, int forall_save)
4960 static gfc_expr **var_expr;
4961 static int total_var = 0;
4962 static int nvar = 0;
4963 gfc_forall_iterator *fa;
4964 gfc_symbol *forall_index;
4968 /* Start to resolve a FORALL construct */
4969 if (forall_save == 0)
4971 /* Count the total number of FORALL index in the nested FORALL
4972 construct in order to allocate the VAR_EXPR with proper size. */
4974 while ((next != NULL) && (next->op == EXEC_FORALL))
4976 for (fa = next->ext.forall_iterator; fa; fa = fa->next)
4978 next = next->block->next;
4981 /* Allocate VAR_EXPR with NUMBER_OF_FORALL_INDEX elements. */
4982 var_expr = (gfc_expr **) gfc_getmem (total_var * sizeof (gfc_expr *));
4985 /* The information about FORALL iterator, including FORALL index start, end
4986 and stride. The FORALL index can not appear in start, end or stride. */
4987 for (fa = code->ext.forall_iterator; fa; fa = fa->next)
4989 /* Check if any outer FORALL index name is the same as the current
4991 for (i = 0; i < nvar; i++)
4993 if (fa->var->symtree->n.sym == var_expr[i]->symtree->n.sym)
4995 gfc_error ("An outer FORALL construct already has an index "
4996 "with this name %L", &fa->var->where);
5000 /* Record the current FORALL index. */
5001 var_expr[nvar] = gfc_copy_expr (fa->var);
5003 forall_index = fa->var->symtree->n.sym;
5005 /* Check if the FORALL index appears in start, end or stride. */
5006 if (gfc_find_forall_index (fa->start, forall_index) == SUCCESS)
5007 gfc_error ("A FORALL index must not appear in a limit or stride "
5008 "expression in the same FORALL at %L", &fa->start->where);
5009 if (gfc_find_forall_index (fa->end, forall_index) == SUCCESS)
5010 gfc_error ("A FORALL index must not appear in a limit or stride "
5011 "expression in the same FORALL at %L", &fa->end->where);
5012 if (gfc_find_forall_index (fa->stride, forall_index) == SUCCESS)
5013 gfc_error ("A FORALL index must not appear in a limit or stride "
5014 "expression in the same FORALL at %L", &fa->stride->where);
5018 /* Resolve the FORALL body. */
5019 gfc_resolve_forall_body (code, nvar, var_expr);
5021 /* May call gfc_resolve_forall to resolve the inner FORALL loop. */
5022 gfc_resolve_blocks (code->block, ns);
5024 /* Free VAR_EXPR after the whole FORALL construct resolved. */
5025 for (i = 0; i < total_var; i++)
5026 gfc_free_expr (var_expr[i]);
5028 /* Reset the counters. */
5034 /* Resolve lists of blocks found in IF, SELECT CASE, WHERE, FORALL ,GOTO and
5037 static void resolve_code (gfc_code *, gfc_namespace *);
5040 gfc_resolve_blocks (gfc_code *b, gfc_namespace *ns)
5044 for (; b; b = b->block)
5046 t = gfc_resolve_expr (b->expr);
5047 if (gfc_resolve_expr (b->expr2) == FAILURE)
5053 if (t == SUCCESS && b->expr != NULL
5054 && (b->expr->ts.type != BT_LOGICAL || b->expr->rank != 0))
5055 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
5062 && (b->expr->ts.type != BT_LOGICAL || b->expr->rank == 0))
5063 gfc_error ("WHERE/ELSEWHERE clause at %L requires a LOGICAL array",
5068 resolve_branch (b->label, b);
5080 case EXEC_OMP_ATOMIC:
5081 case EXEC_OMP_CRITICAL:
5083 case EXEC_OMP_MASTER:
5084 case EXEC_OMP_ORDERED:
5085 case EXEC_OMP_PARALLEL:
5086 case EXEC_OMP_PARALLEL_DO:
5087 case EXEC_OMP_PARALLEL_SECTIONS:
5088 case EXEC_OMP_PARALLEL_WORKSHARE:
5089 case EXEC_OMP_SECTIONS:
5090 case EXEC_OMP_SINGLE:
5091 case EXEC_OMP_WORKSHARE:
5095 gfc_internal_error ("resolve_block(): Bad block type");
5098 resolve_code (b->next, ns);
5103 /* Given a block of code, recursively resolve everything pointed to by this
5107 resolve_code (gfc_code *code, gfc_namespace *ns)
5109 int omp_workshare_save;
5115 frame.prev = cs_base;
5119 reachable_labels (code);
5121 for (; code; code = code->next)
5123 frame.current = code;
5124 forall_save = forall_flag;
5126 if (code->op == EXEC_FORALL)
5129 gfc_resolve_forall (code, ns, forall_save);
5132 else if (code->block)
5134 omp_workshare_save = -1;
5137 case EXEC_OMP_PARALLEL_WORKSHARE:
5138 omp_workshare_save = omp_workshare_flag;
5139 omp_workshare_flag = 1;
5140 gfc_resolve_omp_parallel_blocks (code, ns);
5142 case EXEC_OMP_PARALLEL:
5143 case EXEC_OMP_PARALLEL_DO:
5144 case EXEC_OMP_PARALLEL_SECTIONS:
5145 omp_workshare_save = omp_workshare_flag;
5146 omp_workshare_flag = 0;
5147 gfc_resolve_omp_parallel_blocks (code, ns);
5150 gfc_resolve_omp_do_blocks (code, ns);
5152 case EXEC_OMP_WORKSHARE:
5153 omp_workshare_save = omp_workshare_flag;
5154 omp_workshare_flag = 1;
5157 gfc_resolve_blocks (code->block, ns);
5161 if (omp_workshare_save != -1)
5162 omp_workshare_flag = omp_workshare_save;
5165 t = gfc_resolve_expr (code->expr);
5166 forall_flag = forall_save;
5168 if (gfc_resolve_expr (code->expr2) == FAILURE)
5183 /* Keep track of which entry we are up to. */
5184 current_entry_id = code->ext.entry->id;
5188 resolve_where (code, NULL);
5192 if (code->expr != NULL)
5194 if (code->expr->ts.type != BT_INTEGER)
5195 gfc_error ("ASSIGNED GOTO statement at %L requires an "
5196 "INTEGER variable", &code->expr->where);
5197 else if (code->expr->symtree->n.sym->attr.assign != 1)
5198 gfc_error ("Variable '%s' has not been assigned a target "
5199 "label at %L", code->expr->symtree->n.sym->name,
5200 &code->expr->where);
5203 resolve_branch (code->label, code);
5207 if (code->expr != NULL
5208 && (code->expr->ts.type != BT_INTEGER || code->expr->rank))
5209 gfc_error ("Alternate RETURN statement at %L requires a SCALAR-"
5210 "INTEGER return specifier", &code->expr->where);
5213 case EXEC_INIT_ASSIGN:
5220 if (gfc_extend_assign (code, ns) == SUCCESS)
5222 if (gfc_pure (NULL) && !gfc_pure (code->symtree->n.sym))
5224 gfc_error ("Subroutine '%s' called instead of assignment at "
5225 "%L must be PURE", code->symtree->n.sym->name,
5232 if (code->expr->ts.type == BT_CHARACTER
5233 && gfc_option.warn_character_truncation)
5235 int llen = 0, rlen = 0;
5237 if (code->expr->ts.cl != NULL
5238 && code->expr->ts.cl->length != NULL
5239 && code->expr->ts.cl->length->expr_type == EXPR_CONSTANT)
5240 llen = mpz_get_si (code->expr->ts.cl->length->value.integer);
5242 if (code->expr2->expr_type == EXPR_CONSTANT)
5243 rlen = code->expr2->value.character.length;
5245 else if (code->expr2->ts.cl != NULL
5246 && code->expr2->ts.cl->length != NULL
5247 && code->expr2->ts.cl->length->expr_type
5249 rlen = mpz_get_si (code->expr2->ts.cl->length->value.integer);
5251 if (rlen && llen && rlen > llen)
5252 gfc_warning_now ("CHARACTER expression will be truncated "
5253 "in assignment (%d/%d) at %L",
5254 llen, rlen, &code->loc);
5257 if (gfc_pure (NULL))
5259 if (gfc_impure_variable (code->expr->symtree->n.sym))
5261 gfc_error ("Cannot assign to variable '%s' in PURE "
5263 code->expr->symtree->n.sym->name,
5264 &code->expr->where);
5268 if (code->expr2->ts.type == BT_DERIVED
5269 && derived_pointer (code->expr2->ts.derived))
5271 gfc_error ("Right side of assignment at %L is a derived "
5272 "type containing a POINTER in a PURE procedure",
5273 &code->expr2->where);
5278 gfc_check_assign (code->expr, code->expr2, 1);
5281 case EXEC_LABEL_ASSIGN:
5282 if (code->label->defined == ST_LABEL_UNKNOWN)
5283 gfc_error ("Label %d referenced at %L is never defined",
5284 code->label->value, &code->label->where);
5286 && (code->expr->expr_type != EXPR_VARIABLE
5287 || code->expr->symtree->n.sym->ts.type != BT_INTEGER
5288 || code->expr->symtree->n.sym->ts.kind
5289 != gfc_default_integer_kind
5290 || code->expr->symtree->n.sym->as != NULL))
5291 gfc_error ("ASSIGN statement at %L requires a scalar "
5292 "default INTEGER variable", &code->expr->where);
5295 case EXEC_POINTER_ASSIGN:
5299 gfc_check_pointer_assign (code->expr, code->expr2);
5302 case EXEC_ARITHMETIC_IF:
5304 && code->expr->ts.type != BT_INTEGER
5305 && code->expr->ts.type != BT_REAL)
5306 gfc_error ("Arithmetic IF statement at %L requires a numeric "
5307 "expression", &code->expr->where);
5309 resolve_branch (code->label, code);
5310 resolve_branch (code->label2, code);
5311 resolve_branch (code->label3, code);
5315 if (t == SUCCESS && code->expr != NULL
5316 && (code->expr->ts.type != BT_LOGICAL
5317 || code->expr->rank != 0))
5318 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
5319 &code->expr->where);
5324 resolve_call (code);
5328 /* Select is complicated. Also, a SELECT construct could be
5329 a transformed computed GOTO. */
5330 resolve_select (code);
5334 if (code->ext.iterator != NULL)
5336 gfc_iterator *iter = code->ext.iterator;
5337 if (gfc_resolve_iterator (iter, true) != FAILURE)
5338 gfc_resolve_do_iterator (code, iter->var->symtree->n.sym);
5343 if (code->expr == NULL)
5344 gfc_internal_error ("resolve_code(): No expression on DO WHILE");
5346 && (code->expr->rank != 0
5347 || code->expr->ts.type != BT_LOGICAL))
5348 gfc_error ("Exit condition of DO WHILE loop at %L must be "
5349 "a scalar LOGICAL expression", &code->expr->where);
5353 if (t == SUCCESS && code->expr != NULL
5354 && code->expr->ts.type != BT_INTEGER)
5355 gfc_error ("STAT tag in ALLOCATE statement at %L must be "
5356 "of type INTEGER", &code->expr->where);
5358 for (a = code->ext.alloc_list; a; a = a->next)
5359 resolve_allocate_expr (a->expr, code);
5363 case EXEC_DEALLOCATE:
5364 if (t == SUCCESS && code->expr != NULL
5365 && code->expr->ts.type != BT_INTEGER)
5367 ("STAT tag in DEALLOCATE statement at %L must be of type "
5368 "INTEGER", &code->expr->where);
5370 for (a = code->ext.alloc_list; a; a = a->next)
5371 resolve_deallocate_expr (a->expr);
5376 if (gfc_resolve_open (code->ext.open) == FAILURE)
5379 resolve_branch (code->ext.open->err, code);
5383 if (gfc_resolve_close (code->ext.close) == FAILURE)
5386 resolve_branch (code->ext.close->err, code);
5389 case EXEC_BACKSPACE:
5393 if (gfc_resolve_filepos (code->ext.filepos) == FAILURE)
5396 resolve_branch (code->ext.filepos->err, code);
5400 if (gfc_resolve_inquire (code->ext.inquire) == FAILURE)
5403 resolve_branch (code->ext.inquire->err, code);
5407 gcc_assert (code->ext.inquire != NULL);
5408 if (gfc_resolve_inquire (code->ext.inquire) == FAILURE)
5411 resolve_branch (code->ext.inquire->err, code);
5416 if (gfc_resolve_dt (code->ext.dt) == FAILURE)
5419 resolve_branch (code->ext.dt->err, code);
5420 resolve_branch (code->ext.dt->end, code);
5421 resolve_branch (code->ext.dt->eor, code);
5425 resolve_transfer (code);
5429 resolve_forall_iterators (code->ext.forall_iterator);
5431 if (code->expr != NULL && code->expr->ts.type != BT_LOGICAL)
5432 gfc_error ("FORALL mask clause at %L requires a LOGICAL "
5433 "expression", &code->expr->where);
5436 case EXEC_OMP_ATOMIC:
5437 case EXEC_OMP_BARRIER:
5438 case EXEC_OMP_CRITICAL:
5439 case EXEC_OMP_FLUSH:
5441 case EXEC_OMP_MASTER:
5442 case EXEC_OMP_ORDERED:
5443 case EXEC_OMP_SECTIONS:
5444 case EXEC_OMP_SINGLE:
5445 case EXEC_OMP_WORKSHARE:
5446 gfc_resolve_omp_directive (code, ns);
5449 case EXEC_OMP_PARALLEL:
5450 case EXEC_OMP_PARALLEL_DO:
5451 case EXEC_OMP_PARALLEL_SECTIONS:
5452 case EXEC_OMP_PARALLEL_WORKSHARE:
5453 omp_workshare_save = omp_workshare_flag;
5454 omp_workshare_flag = 0;
5455 gfc_resolve_omp_directive (code, ns);
5456 omp_workshare_flag = omp_workshare_save;
5460 gfc_internal_error ("resolve_code(): Bad statement code");
5464 cs_base = frame.prev;
5468 /* Resolve initial values and make sure they are compatible with
5472 resolve_values (gfc_symbol *sym)
5474 if (sym->value == NULL)
5477 if (gfc_resolve_expr (sym->value) == FAILURE)
5480 gfc_check_assign_symbol (sym, sym->value);
5484 /* Resolve an index expression. */
5487 resolve_index_expr (gfc_expr *e)
5489 if (gfc_resolve_expr (e) == FAILURE)
5492 if (gfc_simplify_expr (e, 0) == FAILURE)
5495 if (gfc_specification_expr (e) == FAILURE)
5501 /* Resolve a charlen structure. */
5504 resolve_charlen (gfc_charlen *cl)
5513 specification_expr = 1;
5515 if (resolve_index_expr (cl->length) == FAILURE)
5517 specification_expr = 0;
5521 /* "If the character length parameter value evaluates to a negative
5522 value, the length of character entities declared is zero." */
5523 if (cl->length && !gfc_extract_int (cl->length, &i) && i <= 0)
5525 gfc_warning_now ("CHARACTER variable has zero length at %L",
5526 &cl->length->where);
5527 gfc_replace_expr (cl->length, gfc_int_expr (0));
5534 /* Test for non-constant shape arrays. */
5537 is_non_constant_shape_array (gfc_symbol *sym)
5543 not_constant = false;
5544 if (sym->as != NULL)
5546 /* Unfortunately, !gfc_is_compile_time_shape hits a legal case that
5547 has not been simplified; parameter array references. Do the
5548 simplification now. */
5549 for (i = 0; i < sym->as->rank; i++)
5551 e = sym->as->lower[i];
5552 if (e && (resolve_index_expr (e) == FAILURE
5553 || !gfc_is_constant_expr (e)))
5554 not_constant = true;
5556 e = sym->as->upper[i];
5557 if (e && (resolve_index_expr (e) == FAILURE
5558 || !gfc_is_constant_expr (e)))
5559 not_constant = true;
5562 return not_constant;
5566 /* Assign the default initializer to a derived type variable or result. */
5569 apply_default_init (gfc_symbol *sym)
5572 gfc_expr *init = NULL;
5574 gfc_namespace *ns = sym->ns;
5576 if (sym->attr.flavor != FL_VARIABLE && !sym->attr.function)
5579 if (sym->ts.type == BT_DERIVED && sym->ts.derived)
5580 init = gfc_default_initializer (&sym->ts);
5585 /* Search for the function namespace if this is a contained
5586 function without an explicit result. */
5587 if (sym->attr.function && sym == sym->result
5588 && sym->name != sym->ns->proc_name->name)
5591 for (;ns; ns = ns->sibling)
5592 if (strcmp (ns->proc_name->name, sym->name) == 0)
5598 gfc_free_expr (init);
5602 /* Build an l-value expression for the result. */
5603 lval = gfc_get_expr ();
5604 lval->expr_type = EXPR_VARIABLE;
5605 lval->where = sym->declared_at;
5607 lval->symtree = gfc_find_symtree (sym->ns->sym_root, sym->name);
5609 /* It will always be a full array. */
5610 lval->rank = sym->as ? sym->as->rank : 0;
5613 lval->ref = gfc_get_ref ();
5614 lval->ref->type = REF_ARRAY;
5615 lval->ref->u.ar.type = AR_FULL;
5616 lval->ref->u.ar.dimen = lval->rank;
5617 lval->ref->u.ar.where = sym->declared_at;
5618 lval->ref->u.ar.as = sym->as;
5621 /* Add the code at scope entry. */
5622 init_st = gfc_get_code ();
5623 init_st->next = ns->code;
5626 /* Assign the default initializer to the l-value. */
5627 init_st->loc = sym->declared_at;
5628 init_st->op = EXEC_INIT_ASSIGN;
5629 init_st->expr = lval;
5630 init_st->expr2 = init;
5634 /* Resolution of common features of flavors variable and procedure. */
5637 resolve_fl_var_and_proc (gfc_symbol *sym, int mp_flag)
5639 /* Constraints on deferred shape variable. */
5640 if (sym->as == NULL || sym->as->type != AS_DEFERRED)
5642 if (sym->attr.allocatable)
5644 if (sym->attr.dimension)
5645 gfc_error ("Allocatable array '%s' at %L must have "
5646 "a deferred shape", sym->name, &sym->declared_at);
5648 gfc_error ("Scalar object '%s' at %L may not be ALLOCATABLE",
5649 sym->name, &sym->declared_at);
5653 if (sym->attr.pointer && sym->attr.dimension)
5655 gfc_error ("Array pointer '%s' at %L must have a deferred shape",
5656 sym->name, &sym->declared_at);
5663 if (!mp_flag && !sym->attr.allocatable
5664 && !sym->attr.pointer && !sym->attr.dummy)
5666 gfc_error ("Array '%s' at %L cannot have a deferred shape",
5667 sym->name, &sym->declared_at);
5675 static gfc_component *
5676 has_default_initializer (gfc_symbol *der)
5679 for (c = der->components; c; c = c->next)
5680 if ((c->ts.type != BT_DERIVED && c->initializer)
5681 || (c->ts.type == BT_DERIVED
5683 && has_default_initializer (c->ts.derived)))
5690 /* Resolve symbols with flavor variable. */
5693 resolve_fl_variable (gfc_symbol *sym, int mp_flag)
5699 const char *auto_save_msg;
5701 auto_save_msg = "automatic object '%s' at %L cannot have the "
5704 if (resolve_fl_var_and_proc (sym, mp_flag) == FAILURE)
5707 /* Set this flag to check that variables are parameters of all entries.
5708 This check is effected by the call to gfc_resolve_expr through
5709 is_non_constant_shape_array. */
5710 specification_expr = 1;
5712 if (!sym->attr.use_assoc
5713 && !sym->attr.allocatable
5714 && !sym->attr.pointer
5715 && is_non_constant_shape_array (sym))
5717 /* The shape of a main program or module array needs to be
5719 if (sym->ns->proc_name
5720 && (sym->ns->proc_name->attr.flavor == FL_MODULE
5721 || sym->ns->proc_name->attr.is_main_program))
5723 gfc_error ("The module or main program array '%s' at %L must "
5724 "have constant shape", sym->name, &sym->declared_at);
5725 specification_expr = 0;
5730 if (sym->ts.type == BT_CHARACTER)
5732 /* Make sure that character string variables with assumed length are
5734 e = sym->ts.cl->length;
5735 if (e == NULL && !sym->attr.dummy && !sym->attr.result)
5737 gfc_error ("Entity with assumed character length at %L must be a "
5738 "dummy argument or a PARAMETER", &sym->declared_at);
5742 if (e && sym->attr.save && !gfc_is_constant_expr (e))
5744 gfc_error (auto_save_msg, sym->name, &sym->declared_at);
5748 if (!gfc_is_constant_expr (e)
5749 && !(e->expr_type == EXPR_VARIABLE
5750 && e->symtree->n.sym->attr.flavor == FL_PARAMETER)
5751 && sym->ns->proc_name
5752 && (sym->ns->proc_name->attr.flavor == FL_MODULE
5753 || sym->ns->proc_name->attr.is_main_program)
5754 && !sym->attr.use_assoc)
5756 gfc_error ("'%s' at %L must have constant character length "
5757 "in this context", sym->name, &sym->declared_at);
5762 /* Can the symbol have an initializer? */
5764 if (sym->attr.allocatable || sym->attr.external || sym->attr.dummy
5765 || sym->attr.intrinsic || sym->attr.result)
5767 else if (sym->attr.dimension && !sym->attr.pointer)
5769 /* Don't allow initialization of automatic arrays. */
5770 for (i = 0; i < sym->as->rank; i++)
5772 if (sym->as->lower[i] == NULL
5773 || sym->as->lower[i]->expr_type != EXPR_CONSTANT
5774 || sym->as->upper[i] == NULL
5775 || sym->as->upper[i]->expr_type != EXPR_CONSTANT)
5782 /* Also, they must not have the SAVE attribute. */
5783 if (flag && sym->attr.save)
5785 gfc_error (auto_save_msg, sym->name, &sym->declared_at);
5790 /* Reject illegal initializers. */
5791 if (sym->value && flag)
5793 if (sym->attr.allocatable)
5794 gfc_error ("Allocatable '%s' at %L cannot have an initializer",
5795 sym->name, &sym->declared_at);
5796 else if (sym->attr.external)
5797 gfc_error ("External '%s' at %L cannot have an initializer",
5798 sym->name, &sym->declared_at);
5799 else if (sym->attr.dummy
5800 && !(sym->ts.type == BT_DERIVED && sym->attr.intent == INTENT_OUT))
5801 gfc_error ("Dummy '%s' at %L cannot have an initializer",
5802 sym->name, &sym->declared_at);
5803 else if (sym->attr.intrinsic)
5804 gfc_error ("Intrinsic '%s' at %L cannot have an initializer",
5805 sym->name, &sym->declared_at);
5806 else if (sym->attr.result)
5807 gfc_error ("Function result '%s' at %L cannot have an initializer",
5808 sym->name, &sym->declared_at);
5810 gfc_error ("Automatic array '%s' at %L cannot have an initializer",
5811 sym->name, &sym->declared_at);
5818 /* Check to see if a derived type is blocked from being host associated
5819 by the presence of another class I symbol in the same namespace.
5820 14.6.1.3 of the standard and the discussion on comp.lang.fortran. */
5821 if (sym->ts.type == BT_DERIVED && sym->ns != sym->ts.derived->ns
5822 && sym->ns->proc_name->attr.if_source != IFSRC_IFBODY)
5825 gfc_find_symbol (sym->ts.derived->name, sym->ns, 0, &s);
5826 if (s && (s->attr.flavor != FL_DERIVED
5827 || !gfc_compare_derived_types (s, sym->ts.derived)))
5829 gfc_error ("The type %s cannot be host associated at %L because "
5830 "it is blocked by an incompatible object of the same "
5831 "name at %L", sym->ts.derived->name, &sym->declared_at,
5837 /* Do not use gfc_default_initializer to test for a default initializer
5838 in the fortran because it generates a hidden default for allocatable
5841 if (sym->ts.type == BT_DERIVED && !(sym->value || flag))
5842 c = has_default_initializer (sym->ts.derived);
5844 /* 4th constraint in section 11.3: "If an object of a type for which
5845 component-initialization is specified (R429) appears in the
5846 specification-part of a module and does not have the ALLOCATABLE
5847 or POINTER attribute, the object shall have the SAVE attribute." */
5848 if (c && sym->ns->proc_name
5849 && sym->ns->proc_name->attr.flavor == FL_MODULE
5850 && !sym->ns->save_all && !sym->attr.save
5851 && !sym->attr.pointer && !sym->attr.allocatable)
5853 gfc_error("Object '%s' at %L must have the SAVE attribute %s",
5854 sym->name, &sym->declared_at,
5855 "for default initialization of a component");
5859 /* Assign default initializer. */
5860 if (sym->ts.type == BT_DERIVED
5862 && !sym->attr.pointer
5863 && !sym->attr.allocatable
5864 && (!flag || sym->attr.intent == INTENT_OUT))
5865 sym->value = gfc_default_initializer (&sym->ts);
5871 /* Resolve a procedure. */
5874 resolve_fl_procedure (gfc_symbol *sym, int mp_flag)
5876 gfc_formal_arglist *arg;
5878 if (sym->attr.ambiguous_interfaces && !sym->attr.referenced)
5879 gfc_warning ("Although not referenced, '%s' at %L has ambiguous "
5880 "interfaces", sym->name, &sym->declared_at);
5882 if (sym->attr.function
5883 && resolve_fl_var_and_proc (sym, mp_flag) == FAILURE)
5886 if (sym->ts.type == BT_CHARACTER)
5888 gfc_charlen *cl = sym->ts.cl;
5890 if (cl && cl->length && gfc_is_constant_expr (cl->length)
5891 && resolve_charlen (cl) == FAILURE)
5894 if (!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT)
5896 if (sym->attr.proc == PROC_ST_FUNCTION)
5898 gfc_error ("Character-valued statement function '%s' at %L must "
5899 "have constant length", sym->name, &sym->declared_at);
5903 if (sym->attr.external && sym->formal == NULL
5904 && cl && cl->length && cl->length->expr_type != EXPR_CONSTANT)
5906 gfc_error ("Automatic character length function '%s' at %L must "
5907 "have an explicit interface", sym->name,
5914 /* Ensure that derived type for are not of a private type. Internal
5915 module procedures are excluded by 2.2.3.3 - ie. they are not
5916 externally accessible and can access all the objects accessible in
5918 if (!(sym->ns->parent
5919 && sym->ns->parent->proc_name->attr.flavor == FL_MODULE)
5920 && gfc_check_access(sym->attr.access, sym->ns->default_access))
5922 for (arg = sym->formal; arg; arg = arg->next)
5925 && arg->sym->ts.type == BT_DERIVED
5926 && !arg->sym->ts.derived->attr.use_assoc
5927 && !gfc_check_access (arg->sym->ts.derived->attr.access,
5928 arg->sym->ts.derived->ns->default_access))
5930 gfc_error_now ("'%s' is of a PRIVATE type and cannot be "
5931 "a dummy argument of '%s', which is "
5932 "PUBLIC at %L", arg->sym->name, sym->name,
5934 /* Stop this message from recurring. */
5935 arg->sym->ts.derived->attr.access = ACCESS_PUBLIC;
5941 /* An external symbol may not have an initializer because it is taken to be
5943 if (sym->attr.external && sym->value)
5945 gfc_error ("External object '%s' at %L may not have an initializer",
5946 sym->name, &sym->declared_at);
5950 /* An elemental function is required to return a scalar 12.7.1 */
5951 if (sym->attr.elemental && sym->attr.function && sym->as)
5953 gfc_error ("ELEMENTAL function '%s' at %L must have a scalar "
5954 "result", sym->name, &sym->declared_at);
5955 /* Reset so that the error only occurs once. */
5956 sym->attr.elemental = 0;
5960 /* 5.1.1.5 of the Standard: A function name declared with an asterisk
5961 char-len-param shall not be array-valued, pointer-valued, recursive
5962 or pure. ....snip... A character value of * may only be used in the
5963 following ways: (i) Dummy arg of procedure - dummy associates with
5964 actual length; (ii) To declare a named constant; or (iii) External
5965 function - but length must be declared in calling scoping unit. */
5966 if (sym->attr.function
5967 && sym->ts.type == BT_CHARACTER
5968 && sym->ts.cl && sym->ts.cl->length == NULL)
5970 if ((sym->as && sym->as->rank) || (sym->attr.pointer)
5971 || (sym->attr.recursive) || (sym->attr.pure))
5973 if (sym->as && sym->as->rank)
5974 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
5975 "array-valued", sym->name, &sym->declared_at);
5977 if (sym->attr.pointer)
5978 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
5979 "pointer-valued", sym->name, &sym->declared_at);
5982 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
5983 "pure", sym->name, &sym->declared_at);
5985 if (sym->attr.recursive)
5986 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
5987 "recursive", sym->name, &sym->declared_at);
5992 /* Appendix B.2 of the standard. Contained functions give an
5993 error anyway. Fixed-form is likely to be F77/legacy. */
5994 if (!sym->attr.contained && gfc_current_form != FORM_FIXED)
5995 gfc_notify_std (GFC_STD_F95_OBS, "CHARACTER(*) function "
5996 "'%s' at %L is obsolescent in fortran 95",
5997 sym->name, &sym->declared_at);
6003 /* Resolve the components of a derived type. */
6006 resolve_fl_derived (gfc_symbol *sym)
6009 gfc_dt_list * dt_list;
6012 for (c = sym->components; c != NULL; c = c->next)
6014 if (c->ts.type == BT_CHARACTER)
6016 if (c->ts.cl->length == NULL
6017 || (resolve_charlen (c->ts.cl) == FAILURE)
6018 || !gfc_is_constant_expr (c->ts.cl->length))
6020 gfc_error ("Character length of component '%s' needs to "
6021 "be a constant specification expression at %L",
6023 c->ts.cl->length ? &c->ts.cl->length->where : &c->loc);
6028 if (c->ts.type == BT_DERIVED
6029 && sym->component_access != ACCESS_PRIVATE
6030 && gfc_check_access (sym->attr.access, sym->ns->default_access)
6031 && !c->ts.derived->attr.use_assoc
6032 && !gfc_check_access (c->ts.derived->attr.access,
6033 c->ts.derived->ns->default_access))
6035 gfc_error ("The component '%s' is a PRIVATE type and cannot be "
6036 "a component of '%s', which is PUBLIC at %L",
6037 c->name, sym->name, &sym->declared_at);
6041 if (sym->attr.sequence)
6043 if (c->ts.type == BT_DERIVED && c->ts.derived->attr.sequence == 0)
6045 gfc_error ("Component %s of SEQUENCE type declared at %L does "
6046 "not have the SEQUENCE attribute",
6047 c->ts.derived->name, &sym->declared_at);
6052 if (c->ts.type == BT_DERIVED && c->pointer
6053 && c->ts.derived->components == NULL)
6055 gfc_error ("The pointer component '%s' of '%s' at %L is a type "
6056 "that has not been declared", c->name, sym->name,
6061 if (c->pointer || c->allocatable || c->as == NULL)
6064 for (i = 0; i < c->as->rank; i++)
6066 if (c->as->lower[i] == NULL
6067 || !gfc_is_constant_expr (c->as->lower[i])
6068 || (resolve_index_expr (c->as->lower[i]) == FAILURE)
6069 || c->as->upper[i] == NULL
6070 || (resolve_index_expr (c->as->upper[i]) == FAILURE)
6071 || !gfc_is_constant_expr (c->as->upper[i]))
6073 gfc_error ("Component '%s' of '%s' at %L must have "
6074 "constant array bounds",
6075 c->name, sym->name, &c->loc);
6081 /* Add derived type to the derived type list. */
6082 for (dt_list = gfc_derived_types; dt_list; dt_list = dt_list->next)
6083 if (sym == dt_list->derived)
6086 if (dt_list == NULL)
6088 dt_list = gfc_get_dt_list ();
6089 dt_list->next = gfc_derived_types;
6090 dt_list->derived = sym;
6091 gfc_derived_types = dt_list;
6099 resolve_fl_namelist (gfc_symbol *sym)
6104 /* Reject PRIVATE objects in a PUBLIC namelist. */
6105 if (gfc_check_access(sym->attr.access, sym->ns->default_access))
6107 for (nl = sym->namelist; nl; nl = nl->next)
6109 if (!nl->sym->attr.use_assoc
6110 && !(sym->ns->parent == nl->sym->ns)
6111 && !gfc_check_access(nl->sym->attr.access,
6112 nl->sym->ns->default_access))
6114 gfc_error ("PRIVATE symbol '%s' cannot be member of "
6115 "PUBLIC namelist at %L", nl->sym->name,
6122 /* Reject namelist arrays that are not constant shape. */
6123 for (nl = sym->namelist; nl; nl = nl->next)
6125 if (is_non_constant_shape_array (nl->sym))
6127 gfc_error ("The array '%s' must have constant shape to be "
6128 "a NAMELIST object at %L", nl->sym->name,
6134 /* Namelist objects cannot have allocatable components. */
6135 for (nl = sym->namelist; nl; nl = nl->next)
6137 if (nl->sym->ts.type == BT_DERIVED
6138 && nl->sym->ts.derived->attr.alloc_comp)
6140 gfc_error ("NAMELIST object '%s' at %L cannot have ALLOCATABLE "
6141 "components", nl->sym->name, &sym->declared_at);
6146 /* 14.1.2 A module or internal procedure represent local entities
6147 of the same type as a namelist member and so are not allowed. */
6148 for (nl = sym->namelist; nl; nl = nl->next)
6150 if (nl->sym->ts.kind != 0 && nl->sym->attr.flavor == FL_VARIABLE)
6153 if (nl->sym->attr.function && nl->sym == nl->sym->result)
6154 if ((nl->sym == sym->ns->proc_name)
6156 (sym->ns->parent && nl->sym == sym->ns->parent->proc_name))
6160 if (nl->sym && nl->sym->name)
6161 gfc_find_symbol (nl->sym->name, sym->ns, 1, &nlsym);
6162 if (nlsym && nlsym->attr.flavor == FL_PROCEDURE)
6164 gfc_error ("PROCEDURE attribute conflicts with NAMELIST "
6165 "attribute in '%s' at %L", nlsym->name,
6176 resolve_fl_parameter (gfc_symbol *sym)
6178 /* A parameter array's shape needs to be constant. */
6179 if (sym->as != NULL && !gfc_is_compile_time_shape (sym->as))
6181 gfc_error ("Parameter array '%s' at %L cannot be automatic "
6182 "or assumed shape", sym->name, &sym->declared_at);
6186 /* Make sure a parameter that has been implicitly typed still
6187 matches the implicit type, since PARAMETER statements can precede
6188 IMPLICIT statements. */
6189 if (sym->attr.implicit_type
6190 && !gfc_compare_types (&sym->ts, gfc_get_default_type (sym, sym->ns)))
6192 gfc_error ("Implicitly typed PARAMETER '%s' at %L doesn't match a "
6193 "later IMPLICIT type", sym->name, &sym->declared_at);
6197 /* Make sure the types of derived parameters are consistent. This
6198 type checking is deferred until resolution because the type may
6199 refer to a derived type from the host. */
6200 if (sym->ts.type == BT_DERIVED
6201 && !gfc_compare_types (&sym->ts, &sym->value->ts))
6203 gfc_error ("Incompatible derived type in PARAMETER at %L",
6204 &sym->value->where);
6211 /* Do anything necessary to resolve a symbol. Right now, we just
6212 assume that an otherwise unknown symbol is a variable. This sort
6213 of thing commonly happens for symbols in module. */
6216 resolve_symbol (gfc_symbol *sym)
6218 int check_constant, mp_flag;
6219 gfc_symtree *symtree;
6220 gfc_symtree *this_symtree;
6224 if (sym->attr.flavor == FL_UNKNOWN)
6227 /* If we find that a flavorless symbol is an interface in one of the
6228 parent namespaces, find its symtree in this namespace, free the
6229 symbol and set the symtree to point to the interface symbol. */
6230 for (ns = gfc_current_ns->parent; ns; ns = ns->parent)
6232 symtree = gfc_find_symtree (ns->sym_root, sym->name);
6233 if (symtree && symtree->n.sym->generic)
6235 this_symtree = gfc_find_symtree (gfc_current_ns->sym_root,
6239 gfc_free_symbol (sym);
6240 symtree->n.sym->refs++;
6241 this_symtree->n.sym = symtree->n.sym;
6246 /* Otherwise give it a flavor according to such attributes as
6248 if (sym->attr.external == 0 && sym->attr.intrinsic == 0)
6249 sym->attr.flavor = FL_VARIABLE;
6252 sym->attr.flavor = FL_PROCEDURE;
6253 if (sym->attr.dimension)
6254 sym->attr.function = 1;
6258 if (sym->attr.flavor == FL_DERIVED && resolve_fl_derived (sym) == FAILURE)
6261 /* Symbols that are module procedures with results (functions) have
6262 the types and array specification copied for type checking in
6263 procedures that call them, as well as for saving to a module
6264 file. These symbols can't stand the scrutiny that their results
6266 mp_flag = (sym->result != NULL && sym->result != sym);
6268 /* Assign default type to symbols that need one and don't have one. */
6269 if (sym->ts.type == BT_UNKNOWN)
6271 if (sym->attr.flavor == FL_VARIABLE || sym->attr.flavor == FL_PARAMETER)
6272 gfc_set_default_type (sym, 1, NULL);
6274 if (sym->attr.flavor == FL_PROCEDURE && sym->attr.function)
6276 /* The specific case of an external procedure should emit an error
6277 in the case that there is no implicit type. */
6279 gfc_set_default_type (sym, sym->attr.external, NULL);
6282 /* Result may be in another namespace. */
6283 resolve_symbol (sym->result);
6285 sym->ts = sym->result->ts;
6286 sym->as = gfc_copy_array_spec (sym->result->as);
6287 sym->attr.dimension = sym->result->attr.dimension;
6288 sym->attr.pointer = sym->result->attr.pointer;
6289 sym->attr.allocatable = sym->result->attr.allocatable;
6294 /* Assumed size arrays and assumed shape arrays must be dummy
6298 && (sym->as->type == AS_ASSUMED_SIZE
6299 || sym->as->type == AS_ASSUMED_SHAPE)
6300 && sym->attr.dummy == 0)
6302 if (sym->as->type == AS_ASSUMED_SIZE)
6303 gfc_error ("Assumed size array at %L must be a dummy argument",
6306 gfc_error ("Assumed shape array at %L must be a dummy argument",
6311 /* Make sure symbols with known intent or optional are really dummy
6312 variable. Because of ENTRY statement, this has to be deferred
6313 until resolution time. */
6315 if (!sym->attr.dummy
6316 && (sym->attr.optional || sym->attr.intent != INTENT_UNKNOWN))
6318 gfc_error ("Symbol at %L is not a DUMMY variable", &sym->declared_at);
6322 if (sym->attr.value && !sym->attr.dummy)
6324 gfc_error ("'%s' at %L cannot have the VALUE attribute because "
6325 "it is not a dummy argument", sym->name, &sym->declared_at);
6329 if (sym->attr.value && sym->ts.type == BT_CHARACTER)
6331 gfc_charlen *cl = sym->ts.cl;
6332 if (!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT)
6334 gfc_error ("Character dummy variable '%s' at %L with VALUE "
6335 "attribute must have constant length",
6336 sym->name, &sym->declared_at);
6341 /* If a derived type symbol has reached this point, without its
6342 type being declared, we have an error. Notice that most
6343 conditions that produce undefined derived types have already
6344 been dealt with. However, the likes of:
6345 implicit type(t) (t) ..... call foo (t) will get us here if
6346 the type is not declared in the scope of the implicit
6347 statement. Change the type to BT_UNKNOWN, both because it is so
6348 and to prevent an ICE. */
6349 if (sym->ts.type == BT_DERIVED && sym->ts.derived->components == NULL)
6351 gfc_error ("The derived type '%s' at %L is of type '%s', "
6352 "which has not been defined", sym->name,
6353 &sym->declared_at, sym->ts.derived->name);
6354 sym->ts.type = BT_UNKNOWN;
6358 /* An assumed-size array with INTENT(OUT) shall not be of a type for which
6359 default initialization is defined (5.1.2.4.4). */
6360 if (sym->ts.type == BT_DERIVED
6362 && sym->attr.intent == INTENT_OUT
6364 && sym->as->type == AS_ASSUMED_SIZE)
6366 for (c = sym->ts.derived->components; c; c = c->next)
6370 gfc_error ("The INTENT(OUT) dummy argument '%s' at %L is "
6371 "ASSUMED SIZE and so cannot have a default initializer",
6372 sym->name, &sym->declared_at);
6378 switch (sym->attr.flavor)
6381 if (resolve_fl_variable (sym, mp_flag) == FAILURE)
6386 if (resolve_fl_procedure (sym, mp_flag) == FAILURE)
6391 if (resolve_fl_namelist (sym) == FAILURE)
6396 if (resolve_fl_parameter (sym) == FAILURE)
6404 /* Make sure that intrinsic exist */
6405 if (sym->attr.flavor != FL_MODULE && sym->attr.intrinsic
6406 && !gfc_intrinsic_name(sym->name, 0)
6407 && !gfc_intrinsic_name(sym->name, 1))
6408 gfc_error("Intrinsic at %L does not exist", &sym->declared_at);
6410 /* Resolve array specifier. Check as well some constraints
6411 on COMMON blocks. */
6413 check_constant = sym->attr.in_common && !sym->attr.pointer;
6415 /* Set the formal_arg_flag so that check_conflict will not throw
6416 an error for host associated variables in the specification
6417 expression for an array_valued function. */
6418 if (sym->attr.function && sym->as)
6419 formal_arg_flag = 1;
6421 gfc_resolve_array_spec (sym->as, check_constant);
6423 formal_arg_flag = 0;
6425 /* Resolve formal namespaces. */
6426 if (sym->formal_ns && sym->formal_ns != gfc_current_ns)
6427 gfc_resolve (sym->formal_ns);
6429 /* Check threadprivate restrictions. */
6430 if (sym->attr.threadprivate && !sym->attr.save
6431 && (!sym->attr.in_common
6432 && sym->module == NULL
6433 && (sym->ns->proc_name == NULL
6434 || sym->ns->proc_name->attr.flavor != FL_MODULE)))
6435 gfc_error ("Threadprivate at %L isn't SAVEd", &sym->declared_at);
6437 /* If we have come this far we can apply default-initializers, as
6438 described in 14.7.5, to those variables that have not already
6439 been assigned one. */
6440 if (sym->ts.type == BT_DERIVED
6441 && sym->attr.referenced
6442 && sym->ns == gfc_current_ns
6444 && !sym->attr.allocatable
6445 && !sym->attr.alloc_comp)
6447 symbol_attribute *a = &sym->attr;
6449 if ((!a->save && !a->dummy && !a->pointer
6450 && !a->in_common && !a->use_assoc
6451 && !(a->function && sym != sym->result))
6452 || (a->dummy && a->intent == INTENT_OUT))
6453 apply_default_init (sym);
6458 /************* Resolve DATA statements *************/
6462 gfc_data_value *vnode;
6468 /* Advance the values structure to point to the next value in the data list. */
6471 next_data_value (void)
6473 while (values.left == 0)
6475 if (values.vnode->next == NULL)
6478 values.vnode = values.vnode->next;
6479 values.left = values.vnode->repeat;
6487 check_data_variable (gfc_data_variable *var, locus *where)
6493 ar_type mark = AR_UNKNOWN;
6495 mpz_t section_index[GFC_MAX_DIMENSIONS];
6499 if (gfc_resolve_expr (var->expr) == FAILURE)
6503 mpz_init_set_si (offset, 0);
6506 if (e->expr_type != EXPR_VARIABLE)
6507 gfc_internal_error ("check_data_variable(): Bad expression");
6509 if (e->symtree->n.sym->ns->is_block_data
6510 && !e->symtree->n.sym->attr.in_common)
6512 gfc_error ("BLOCK DATA element '%s' at %L must be in COMMON",
6513 e->symtree->n.sym->name, &e->symtree->n.sym->declared_at);
6518 mpz_init_set_ui (size, 1);
6525 /* Find the array section reference. */
6526 for (ref = e->ref; ref; ref = ref->next)
6528 if (ref->type != REF_ARRAY)
6530 if (ref->u.ar.type == AR_ELEMENT)
6536 /* Set marks according to the reference pattern. */
6537 switch (ref->u.ar.type)
6545 /* Get the start position of array section. */
6546 gfc_get_section_index (ar, section_index, &offset);
6554 if (gfc_array_size (e, &size) == FAILURE)
6556 gfc_error ("Nonconstant array section at %L in DATA statement",
6565 while (mpz_cmp_ui (size, 0) > 0)
6567 if (next_data_value () == FAILURE)
6569 gfc_error ("DATA statement at %L has more variables than values",
6575 t = gfc_check_assign (var->expr, values.vnode->expr, 0);
6579 /* If we have more than one element left in the repeat count,
6580 and we have more than one element left in the target variable,
6581 then create a range assignment. */
6582 /* ??? Only done for full arrays for now, since array sections
6584 if (mark == AR_FULL && ref && ref->next == NULL
6585 && values.left > 1 && mpz_cmp_ui (size, 1) > 0)
6589 if (mpz_cmp_ui (size, values.left) >= 0)
6591 mpz_init_set_ui (range, values.left);
6592 mpz_sub_ui (size, size, values.left);
6597 mpz_init_set (range, size);
6598 values.left -= mpz_get_ui (size);
6599 mpz_set_ui (size, 0);
6602 gfc_assign_data_value_range (var->expr, values.vnode->expr,
6605 mpz_add (offset, offset, range);
6609 /* Assign initial value to symbol. */
6613 mpz_sub_ui (size, size, 1);
6615 gfc_assign_data_value (var->expr, values.vnode->expr, offset);
6617 if (mark == AR_FULL)
6618 mpz_add_ui (offset, offset, 1);
6620 /* Modify the array section indexes and recalculate the offset
6621 for next element. */
6622 else if (mark == AR_SECTION)
6623 gfc_advance_section (section_index, ar, &offset);
6627 if (mark == AR_SECTION)
6629 for (i = 0; i < ar->dimen; i++)
6630 mpz_clear (section_index[i]);
6640 static try traverse_data_var (gfc_data_variable *, locus *);
6642 /* Iterate over a list of elements in a DATA statement. */
6645 traverse_data_list (gfc_data_variable *var, locus *where)
6648 iterator_stack frame;
6649 gfc_expr *e, *start, *end, *step;
6650 try retval = SUCCESS;
6652 mpz_init (frame.value);
6654 start = gfc_copy_expr (var->iter.start);
6655 end = gfc_copy_expr (var->iter.end);
6656 step = gfc_copy_expr (var->iter.step);
6658 if (gfc_simplify_expr (start, 1) == FAILURE
6659 || start->expr_type != EXPR_CONSTANT)
6661 gfc_error ("iterator start at %L does not simplify", &start->where);
6665 if (gfc_simplify_expr (end, 1) == FAILURE
6666 || end->expr_type != EXPR_CONSTANT)
6668 gfc_error ("iterator end at %L does not simplify", &end->where);
6672 if (gfc_simplify_expr (step, 1) == FAILURE
6673 || step->expr_type != EXPR_CONSTANT)
6675 gfc_error ("iterator step at %L does not simplify", &step->where);
6680 mpz_init_set (trip, end->value.integer);
6681 mpz_sub (trip, trip, start->value.integer);
6682 mpz_add (trip, trip, step->value.integer);
6684 mpz_div (trip, trip, step->value.integer);
6686 mpz_set (frame.value, start->value.integer);
6688 frame.prev = iter_stack;
6689 frame.variable = var->iter.var->symtree;
6690 iter_stack = &frame;
6692 while (mpz_cmp_ui (trip, 0) > 0)
6694 if (traverse_data_var (var->list, where) == FAILURE)
6701 e = gfc_copy_expr (var->expr);
6702 if (gfc_simplify_expr (e, 1) == FAILURE)
6710 mpz_add (frame.value, frame.value, step->value.integer);
6712 mpz_sub_ui (trip, trip, 1);
6717 mpz_clear (frame.value);
6719 gfc_free_expr (start);
6720 gfc_free_expr (end);
6721 gfc_free_expr (step);
6723 iter_stack = frame.prev;
6728 /* Type resolve variables in the variable list of a DATA statement. */
6731 traverse_data_var (gfc_data_variable *var, locus *where)
6735 for (; var; var = var->next)
6737 if (var->expr == NULL)
6738 t = traverse_data_list (var, where);
6740 t = check_data_variable (var, where);
6750 /* Resolve the expressions and iterators associated with a data statement.
6751 This is separate from the assignment checking because data lists should
6752 only be resolved once. */
6755 resolve_data_variables (gfc_data_variable *d)
6757 for (; d; d = d->next)
6759 if (d->list == NULL)
6761 if (gfc_resolve_expr (d->expr) == FAILURE)
6766 if (gfc_resolve_iterator (&d->iter, false) == FAILURE)
6769 if (resolve_data_variables (d->list) == FAILURE)
6778 /* Resolve a single DATA statement. We implement this by storing a pointer to
6779 the value list into static variables, and then recursively traversing the
6780 variables list, expanding iterators and such. */
6783 resolve_data (gfc_data * d)
6785 if (resolve_data_variables (d->var) == FAILURE)
6788 values.vnode = d->value;
6789 values.left = (d->value == NULL) ? 0 : d->value->repeat;
6791 if (traverse_data_var (d->var, &d->where) == FAILURE)
6794 /* At this point, we better not have any values left. */
6796 if (next_data_value () == SUCCESS)
6797 gfc_error ("DATA statement at %L has more values than variables",
6802 /* Determines if a variable is not 'pure', ie not assignable within a pure
6803 procedure. Returns zero if assignment is OK, nonzero if there is a
6807 gfc_impure_variable (gfc_symbol *sym)
6809 if (sym->attr.use_assoc || sym->attr.in_common)
6812 if (sym->ns != gfc_current_ns)
6813 return !sym->attr.function;
6815 /* TODO: Check storage association through EQUIVALENCE statements */
6821 /* Test whether a symbol is pure or not. For a NULL pointer, checks the
6822 symbol of the current procedure. */
6825 gfc_pure (gfc_symbol *sym)
6827 symbol_attribute attr;
6830 sym = gfc_current_ns->proc_name;
6836 return attr.flavor == FL_PROCEDURE && (attr.pure || attr.elemental);
6840 /* Test whether the current procedure is elemental or not. */
6843 gfc_elemental (gfc_symbol *sym)
6845 symbol_attribute attr;
6848 sym = gfc_current_ns->proc_name;
6853 return attr.flavor == FL_PROCEDURE && attr.elemental;
6857 /* Warn about unused labels. */
6860 warn_unused_fortran_label (gfc_st_label *label)
6865 warn_unused_fortran_label (label->left);
6867 if (label->defined == ST_LABEL_UNKNOWN)
6870 switch (label->referenced)
6872 case ST_LABEL_UNKNOWN:
6873 gfc_warning ("Label %d at %L defined but not used", label->value,
6877 case ST_LABEL_BAD_TARGET:
6878 gfc_warning ("Label %d at %L defined but cannot be used",
6879 label->value, &label->where);
6886 warn_unused_fortran_label (label->right);
6890 /* Returns the sequence type of a symbol or sequence. */
6893 sequence_type (gfc_typespec ts)
6902 if (ts.derived->components == NULL)
6903 return SEQ_NONDEFAULT;
6905 result = sequence_type (ts.derived->components->ts);
6906 for (c = ts.derived->components->next; c; c = c->next)
6907 if (sequence_type (c->ts) != result)
6913 if (ts.kind != gfc_default_character_kind)
6914 return SEQ_NONDEFAULT;
6916 return SEQ_CHARACTER;
6919 if (ts.kind != gfc_default_integer_kind)
6920 return SEQ_NONDEFAULT;
6925 if (!(ts.kind == gfc_default_real_kind
6926 || ts.kind == gfc_default_double_kind))
6927 return SEQ_NONDEFAULT;
6932 if (ts.kind != gfc_default_complex_kind)
6933 return SEQ_NONDEFAULT;
6938 if (ts.kind != gfc_default_logical_kind)
6939 return SEQ_NONDEFAULT;
6944 return SEQ_NONDEFAULT;
6949 /* Resolve derived type EQUIVALENCE object. */
6952 resolve_equivalence_derived (gfc_symbol *derived, gfc_symbol *sym, gfc_expr *e)
6955 gfc_component *c = derived->components;
6960 /* Shall not be an object of nonsequence derived type. */
6961 if (!derived->attr.sequence)
6963 gfc_error ("Derived type variable '%s' at %L must have SEQUENCE "
6964 "attribute to be an EQUIVALENCE object", sym->name,
6969 /* Shall not have allocatable components. */
6970 if (derived->attr.alloc_comp)
6972 gfc_error ("Derived type variable '%s' at %L cannot have ALLOCATABLE "
6973 "components to be an EQUIVALENCE object",sym->name,
6978 for (; c ; c = c->next)
6982 && (resolve_equivalence_derived (c->ts.derived, sym, e) == FAILURE))
6985 /* Shall not be an object of sequence derived type containing a pointer
6986 in the structure. */
6989 gfc_error ("Derived type variable '%s' at %L with pointer "
6990 "component(s) cannot be an EQUIVALENCE object",
6991 sym->name, &e->where);
6997 gfc_error ("Derived type variable '%s' at %L with default "
6998 "initializer cannot be an EQUIVALENCE object",
6999 sym->name, &e->where);
7007 /* Resolve equivalence object.
7008 An EQUIVALENCE object shall not be a dummy argument, a pointer, a target,
7009 an allocatable array, an object of nonsequence derived type, an object of
7010 sequence derived type containing a pointer at any level of component
7011 selection, an automatic object, a function name, an entry name, a result
7012 name, a named constant, a structure component, or a subobject of any of
7013 the preceding objects. A substring shall not have length zero. A
7014 derived type shall not have components with default initialization nor
7015 shall two objects of an equivalence group be initialized.
7016 Either all or none of the objects shall have an protected attribute.
7017 The simple constraints are done in symbol.c(check_conflict) and the rest
7018 are implemented here. */
7021 resolve_equivalence (gfc_equiv *eq)
7024 gfc_symbol *derived;
7025 gfc_symbol *first_sym;
7028 locus *last_where = NULL;
7029 seq_type eq_type, last_eq_type;
7030 gfc_typespec *last_ts;
7031 int object, cnt_protected;
7032 const char *value_name;
7036 last_ts = &eq->expr->symtree->n.sym->ts;
7038 first_sym = eq->expr->symtree->n.sym;
7042 for (object = 1; eq; eq = eq->eq, object++)
7046 e->ts = e->symtree->n.sym->ts;
7047 /* match_varspec might not know yet if it is seeing
7048 array reference or substring reference, as it doesn't
7050 if (e->ref && e->ref->type == REF_ARRAY)
7052 gfc_ref *ref = e->ref;
7053 sym = e->symtree->n.sym;
7055 if (sym->attr.dimension)
7057 ref->u.ar.as = sym->as;
7061 /* For substrings, convert REF_ARRAY into REF_SUBSTRING. */
7062 if (e->ts.type == BT_CHARACTER
7064 && ref->type == REF_ARRAY
7065 && ref->u.ar.dimen == 1
7066 && ref->u.ar.dimen_type[0] == DIMEN_RANGE
7067 && ref->u.ar.stride[0] == NULL)
7069 gfc_expr *start = ref->u.ar.start[0];
7070 gfc_expr *end = ref->u.ar.end[0];
7073 /* Optimize away the (:) reference. */
7074 if (start == NULL && end == NULL)
7079 e->ref->next = ref->next;
7084 ref->type = REF_SUBSTRING;
7086 start = gfc_int_expr (1);
7087 ref->u.ss.start = start;
7088 if (end == NULL && e->ts.cl)
7089 end = gfc_copy_expr (e->ts.cl->length);
7090 ref->u.ss.end = end;
7091 ref->u.ss.length = e->ts.cl;
7098 /* Any further ref is an error. */
7101 gcc_assert (ref->type == REF_ARRAY);
7102 gfc_error ("Syntax error in EQUIVALENCE statement at %L",
7108 if (gfc_resolve_expr (e) == FAILURE)
7111 sym = e->symtree->n.sym;
7113 if (sym->attr.protected)
7115 if (cnt_protected > 0 && cnt_protected != object)
7117 gfc_error ("Either all or none of the objects in the "
7118 "EQUIVALENCE set at %L shall have the "
7119 "PROTECTED attribute",
7124 /* An equivalence statement cannot have more than one initialized
7128 if (value_name != NULL)
7130 gfc_error ("Initialized objects '%s' and '%s' cannot both "
7131 "be in the EQUIVALENCE statement at %L",
7132 value_name, sym->name, &e->where);
7136 value_name = sym->name;
7139 /* Shall not equivalence common block variables in a PURE procedure. */
7140 if (sym->ns->proc_name
7141 && sym->ns->proc_name->attr.pure
7142 && sym->attr.in_common)
7144 gfc_error ("Common block member '%s' at %L cannot be an EQUIVALENCE "
7145 "object in the pure procedure '%s'",
7146 sym->name, &e->where, sym->ns->proc_name->name);
7150 /* Shall not be a named constant. */
7151 if (e->expr_type == EXPR_CONSTANT)
7153 gfc_error ("Named constant '%s' at %L cannot be an EQUIVALENCE "
7154 "object", sym->name, &e->where);
7158 derived = e->ts.derived;
7159 if (derived && resolve_equivalence_derived (derived, sym, e) == FAILURE)
7162 /* Check that the types correspond correctly:
7164 A numeric sequence structure may be equivalenced to another sequence
7165 structure, an object of default integer type, default real type, double
7166 precision real type, default logical type such that components of the
7167 structure ultimately only become associated to objects of the same
7168 kind. A character sequence structure may be equivalenced to an object
7169 of default character kind or another character sequence structure.
7170 Other objects may be equivalenced only to objects of the same type and
7173 /* Identical types are unconditionally OK. */
7174 if (object == 1 || gfc_compare_types (last_ts, &sym->ts))
7175 goto identical_types;
7177 last_eq_type = sequence_type (*last_ts);
7178 eq_type = sequence_type (sym->ts);
7180 /* Since the pair of objects is not of the same type, mixed or
7181 non-default sequences can be rejected. */
7183 msg = "Sequence %s with mixed components in EQUIVALENCE "
7184 "statement at %L with different type objects";
7186 && last_eq_type == SEQ_MIXED
7187 && gfc_notify_std (GFC_STD_GNU, msg, first_sym->name, last_where)
7189 || (eq_type == SEQ_MIXED
7190 && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
7191 &e->where) == FAILURE))
7194 msg = "Non-default type object or sequence %s in EQUIVALENCE "
7195 "statement at %L with objects of different type";
7197 && last_eq_type == SEQ_NONDEFAULT
7198 && gfc_notify_std (GFC_STD_GNU, msg, first_sym->name,
7199 last_where) == FAILURE)
7200 || (eq_type == SEQ_NONDEFAULT
7201 && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
7202 &e->where) == FAILURE))
7205 msg ="Non-CHARACTER object '%s' in default CHARACTER "
7206 "EQUIVALENCE statement at %L";
7207 if (last_eq_type == SEQ_CHARACTER
7208 && eq_type != SEQ_CHARACTER
7209 && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
7210 &e->where) == FAILURE)
7213 msg ="Non-NUMERIC object '%s' in default NUMERIC "
7214 "EQUIVALENCE statement at %L";
7215 if (last_eq_type == SEQ_NUMERIC
7216 && eq_type != SEQ_NUMERIC
7217 && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
7218 &e->where) == FAILURE)
7223 last_where = &e->where;
7228 /* Shall not be an automatic array. */
7229 if (e->ref->type == REF_ARRAY
7230 && gfc_resolve_array_spec (e->ref->u.ar.as, 1) == FAILURE)
7232 gfc_error ("Array '%s' at %L with non-constant bounds cannot be "
7233 "an EQUIVALENCE object", sym->name, &e->where);
7240 /* Shall not be a structure component. */
7241 if (r->type == REF_COMPONENT)
7243 gfc_error ("Structure component '%s' at %L cannot be an "
7244 "EQUIVALENCE object",
7245 r->u.c.component->name, &e->where);
7249 /* A substring shall not have length zero. */
7250 if (r->type == REF_SUBSTRING)
7252 if (compare_bound (r->u.ss.start, r->u.ss.end) == CMP_GT)
7254 gfc_error ("Substring at %L has length zero",
7255 &r->u.ss.start->where);
7265 /* Resolve function and ENTRY types, issue diagnostics if needed. */
7268 resolve_fntype (gfc_namespace *ns)
7273 if (ns->proc_name == NULL || !ns->proc_name->attr.function)
7276 /* If there are any entries, ns->proc_name is the entry master
7277 synthetic symbol and ns->entries->sym actual FUNCTION symbol. */
7279 sym = ns->entries->sym;
7281 sym = ns->proc_name;
7282 if (sym->result == sym
7283 && sym->ts.type == BT_UNKNOWN
7284 && gfc_set_default_type (sym, 0, NULL) == FAILURE
7285 && !sym->attr.untyped)
7287 gfc_error ("Function '%s' at %L has no IMPLICIT type",
7288 sym->name, &sym->declared_at);
7289 sym->attr.untyped = 1;
7292 if (sym->ts.type == BT_DERIVED && !sym->ts.derived->attr.use_assoc
7293 && !gfc_check_access (sym->ts.derived->attr.access,
7294 sym->ts.derived->ns->default_access)
7295 && gfc_check_access (sym->attr.access, sym->ns->default_access))
7297 gfc_error ("PUBLIC function '%s' at %L cannot be of PRIVATE type '%s'",
7298 sym->name, &sym->declared_at, sym->ts.derived->name);
7302 for (el = ns->entries->next; el; el = el->next)
7304 if (el->sym->result == el->sym
7305 && el->sym->ts.type == BT_UNKNOWN
7306 && gfc_set_default_type (el->sym, 0, NULL) == FAILURE
7307 && !el->sym->attr.untyped)
7309 gfc_error ("ENTRY '%s' at %L has no IMPLICIT type",
7310 el->sym->name, &el->sym->declared_at);
7311 el->sym->attr.untyped = 1;
7316 /* 12.3.2.1.1 Defined operators. */
7319 gfc_resolve_uops (gfc_symtree *symtree)
7323 gfc_formal_arglist *formal;
7325 if (symtree == NULL)
7328 gfc_resolve_uops (symtree->left);
7329 gfc_resolve_uops (symtree->right);
7331 for (itr = symtree->n.uop->operator; itr; itr = itr->next)
7334 if (!sym->attr.function)
7335 gfc_error ("User operator procedure '%s' at %L must be a FUNCTION",
7336 sym->name, &sym->declared_at);
7338 if (sym->ts.type == BT_CHARACTER
7339 && !(sym->ts.cl && sym->ts.cl->length)
7340 && !(sym->result && sym->result->ts.cl
7341 && sym->result->ts.cl->length))
7342 gfc_error ("User operator procedure '%s' at %L cannot be assumed "
7343 "character length", sym->name, &sym->declared_at);
7345 formal = sym->formal;
7346 if (!formal || !formal->sym)
7348 gfc_error ("User operator procedure '%s' at %L must have at least "
7349 "one argument", sym->name, &sym->declared_at);
7353 if (formal->sym->attr.intent != INTENT_IN)
7354 gfc_error ("First argument of operator interface at %L must be "
7355 "INTENT(IN)", &sym->declared_at);
7357 if (formal->sym->attr.optional)
7358 gfc_error ("First argument of operator interface at %L cannot be "
7359 "optional", &sym->declared_at);
7361 formal = formal->next;
7362 if (!formal || !formal->sym)
7365 if (formal->sym->attr.intent != INTENT_IN)
7366 gfc_error ("Second argument of operator interface at %L must be "
7367 "INTENT(IN)", &sym->declared_at);
7369 if (formal->sym->attr.optional)
7370 gfc_error ("Second argument of operator interface at %L cannot be "
7371 "optional", &sym->declared_at);
7374 gfc_error ("Operator interface at %L must have, at most, two "
7375 "arguments", &sym->declared_at);
7380 /* Examine all of the expressions associated with a program unit,
7381 assign types to all intermediate expressions, make sure that all
7382 assignments are to compatible types and figure out which names
7383 refer to which functions or subroutines. It doesn't check code
7384 block, which is handled by resolve_code. */
7387 resolve_types (gfc_namespace *ns)
7394 gfc_current_ns = ns;
7396 resolve_entries (ns);
7398 resolve_contained_functions (ns);
7400 for (cl = ns->cl_list; cl; cl = cl->next)
7401 resolve_charlen (cl);
7403 gfc_traverse_ns (ns, resolve_symbol);
7405 resolve_fntype (ns);
7407 for (n = ns->contained; n; n = n->sibling)
7409 if (gfc_pure (ns->proc_name) && !gfc_pure (n->proc_name))
7410 gfc_error ("Contained procedure '%s' at %L of a PURE procedure must "
7411 "also be PURE", n->proc_name->name,
7412 &n->proc_name->declared_at);
7418 gfc_check_interfaces (ns);
7420 gfc_traverse_ns (ns, resolve_values);
7426 for (d = ns->data; d; d = d->next)
7430 gfc_traverse_ns (ns, gfc_formalize_init_value);
7432 for (eq = ns->equiv; eq; eq = eq->next)
7433 resolve_equivalence (eq);
7435 /* Warn about unused labels. */
7436 if (warn_unused_label)
7437 warn_unused_fortran_label (ns->st_labels);
7439 gfc_resolve_uops (ns->uop_root);
7443 /* Call resolve_code recursively. */
7446 resolve_codes (gfc_namespace *ns)
7450 for (n = ns->contained; n; n = n->sibling)
7453 gfc_current_ns = ns;
7455 /* Set to an out of range value. */
7456 current_entry_id = -1;
7458 bitmap_obstack_initialize (&labels_obstack);
7459 resolve_code (ns->code, ns);
7460 bitmap_obstack_release (&labels_obstack);
7464 /* This function is called after a complete program unit has been compiled.
7465 Its purpose is to examine all of the expressions associated with a program
7466 unit, assign types to all intermediate expressions, make sure that all
7467 assignments are to compatible types and figure out which names refer to
7468 which functions or subroutines. */
7471 gfc_resolve (gfc_namespace *ns)
7473 gfc_namespace *old_ns;
7475 old_ns = gfc_current_ns;
7480 gfc_current_ns = old_ns;