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->ts.type == BT_UNKNOWN)
294 t = gfc_set_default_type (sym->result, 0, ns);
296 if (t == FAILURE && !sym->result->attr.untyped)
298 if (sym->result == sym)
299 gfc_error ("Contained function '%s' at %L has no IMPLICIT type",
300 sym->name, &sym->declared_at);
302 gfc_error ("Result '%s' of contained function '%s' at %L has "
303 "no IMPLICIT type", sym->result->name, sym->name,
304 &sym->result->declared_at);
305 sym->result->attr.untyped = 1;
309 /* Fortran 95 Draft Standard, page 51, Section 5.1.1.5, on the Character
310 type, lists the only ways a character length value of * can be used:
311 dummy arguments of procedures, named constants, and function results
312 in external functions. Internal function results are not on that list;
313 ergo, not permitted. */
315 if (sym->result->ts.type == BT_CHARACTER)
317 gfc_charlen *cl = sym->result->ts.cl;
318 if (!cl || !cl->length)
319 gfc_error ("Character-valued internal function '%s' at %L must "
320 "not be assumed length", sym->name, &sym->declared_at);
325 /* Add NEW_ARGS to the formal argument list of PROC, taking care not to
326 introduce duplicates. */
329 merge_argument_lists (gfc_symbol *proc, gfc_formal_arglist *new_args)
331 gfc_formal_arglist *f, *new_arglist;
334 for (; new_args != NULL; new_args = new_args->next)
336 new_sym = new_args->sym;
337 /* See if this arg is already in the formal argument list. */
338 for (f = proc->formal; f; f = f->next)
340 if (new_sym == f->sym)
347 /* Add a new argument. Argument order is not important. */
348 new_arglist = gfc_get_formal_arglist ();
349 new_arglist->sym = new_sym;
350 new_arglist->next = proc->formal;
351 proc->formal = new_arglist;
356 /* Flag the arguments that are not present in all entries. */
359 check_argument_lists (gfc_symbol *proc, gfc_formal_arglist *new_args)
361 gfc_formal_arglist *f, *head;
364 for (f = proc->formal; f; f = f->next)
369 for (new_args = head; new_args; new_args = new_args->next)
371 if (new_args->sym == f->sym)
378 f->sym->attr.not_always_present = 1;
383 /* Resolve alternate entry points. If a symbol has multiple entry points we
384 create a new master symbol for the main routine, and turn the existing
385 symbol into an entry point. */
388 resolve_entries (gfc_namespace *ns)
390 gfc_namespace *old_ns;
394 char name[GFC_MAX_SYMBOL_LEN + 1];
395 static int master_count = 0;
397 if (ns->proc_name == NULL)
400 /* No need to do anything if this procedure doesn't have alternate entry
405 /* We may already have resolved alternate entry points. */
406 if (ns->proc_name->attr.entry_master)
409 /* If this isn't a procedure something has gone horribly wrong. */
410 gcc_assert (ns->proc_name->attr.flavor == FL_PROCEDURE);
412 /* Remember the current namespace. */
413 old_ns = gfc_current_ns;
417 /* Add the main entry point to the list of entry points. */
418 el = gfc_get_entry_list ();
419 el->sym = ns->proc_name;
421 el->next = ns->entries;
423 ns->proc_name->attr.entry = 1;
425 /* If it is a module function, it needs to be in the right namespace
426 so that gfc_get_fake_result_decl can gather up the results. The
427 need for this arose in get_proc_name, where these beasts were
428 left in their own namespace, to keep prior references linked to
429 the entry declaration.*/
430 if (ns->proc_name->attr.function
431 && ns->parent && ns->parent->proc_name->attr.flavor == FL_MODULE)
434 /* Add an entry statement for it. */
441 /* Create a new symbol for the master function. */
442 /* Give the internal function a unique name (within this file).
443 Also include the function name so the user has some hope of figuring
444 out what is going on. */
445 snprintf (name, GFC_MAX_SYMBOL_LEN, "master.%d.%s",
446 master_count++, ns->proc_name->name);
447 gfc_get_ha_symbol (name, &proc);
448 gcc_assert (proc != NULL);
450 gfc_add_procedure (&proc->attr, PROC_INTERNAL, proc->name, NULL);
451 if (ns->proc_name->attr.subroutine)
452 gfc_add_subroutine (&proc->attr, proc->name, NULL);
456 gfc_typespec *ts, *fts;
457 gfc_array_spec *as, *fas;
458 gfc_add_function (&proc->attr, proc->name, NULL);
460 fas = ns->entries->sym->as;
461 fas = fas ? fas : ns->entries->sym->result->as;
462 fts = &ns->entries->sym->result->ts;
463 if (fts->type == BT_UNKNOWN)
464 fts = gfc_get_default_type (ns->entries->sym->result, NULL);
465 for (el = ns->entries->next; el; el = el->next)
467 ts = &el->sym->result->ts;
469 as = as ? as : el->sym->result->as;
470 if (ts->type == BT_UNKNOWN)
471 ts = gfc_get_default_type (el->sym->result, NULL);
473 if (! gfc_compare_types (ts, fts)
474 || (el->sym->result->attr.dimension
475 != ns->entries->sym->result->attr.dimension)
476 || (el->sym->result->attr.pointer
477 != ns->entries->sym->result->attr.pointer))
480 else if (as && fas && gfc_compare_array_spec (as, fas) == 0)
481 gfc_error ("Procedure %s at %L has entries with mismatched "
482 "array specifications", ns->entries->sym->name,
483 &ns->entries->sym->declared_at);
488 sym = ns->entries->sym->result;
489 /* All result types the same. */
491 if (sym->attr.dimension)
492 gfc_set_array_spec (proc, gfc_copy_array_spec (sym->as), NULL);
493 if (sym->attr.pointer)
494 gfc_add_pointer (&proc->attr, NULL);
498 /* Otherwise the result will be passed through a union by
500 proc->attr.mixed_entry_master = 1;
501 for (el = ns->entries; el; el = el->next)
503 sym = el->sym->result;
504 if (sym->attr.dimension)
506 if (el == ns->entries)
507 gfc_error ("FUNCTION result %s can't be an array in "
508 "FUNCTION %s at %L", sym->name,
509 ns->entries->sym->name, &sym->declared_at);
511 gfc_error ("ENTRY result %s can't be an array in "
512 "FUNCTION %s at %L", sym->name,
513 ns->entries->sym->name, &sym->declared_at);
515 else if (sym->attr.pointer)
517 if (el == ns->entries)
518 gfc_error ("FUNCTION result %s can't be a POINTER in "
519 "FUNCTION %s at %L", sym->name,
520 ns->entries->sym->name, &sym->declared_at);
522 gfc_error ("ENTRY result %s can't be a POINTER in "
523 "FUNCTION %s at %L", sym->name,
524 ns->entries->sym->name, &sym->declared_at);
529 if (ts->type == BT_UNKNOWN)
530 ts = gfc_get_default_type (sym, NULL);
534 if (ts->kind == gfc_default_integer_kind)
538 if (ts->kind == gfc_default_real_kind
539 || ts->kind == gfc_default_double_kind)
543 if (ts->kind == gfc_default_complex_kind)
547 if (ts->kind == gfc_default_logical_kind)
551 /* We will issue error elsewhere. */
559 if (el == ns->entries)
560 gfc_error ("FUNCTION result %s can't be of type %s "
561 "in FUNCTION %s at %L", sym->name,
562 gfc_typename (ts), ns->entries->sym->name,
565 gfc_error ("ENTRY result %s can't be of type %s "
566 "in FUNCTION %s at %L", sym->name,
567 gfc_typename (ts), ns->entries->sym->name,
574 proc->attr.access = ACCESS_PRIVATE;
575 proc->attr.entry_master = 1;
577 /* Merge all the entry point arguments. */
578 for (el = ns->entries; el; el = el->next)
579 merge_argument_lists (proc, el->sym->formal);
581 /* Check the master formal arguments for any that are not
582 present in all entry points. */
583 for (el = ns->entries; el; el = el->next)
584 check_argument_lists (proc, el->sym->formal);
586 /* Use the master function for the function body. */
587 ns->proc_name = proc;
589 /* Finalize the new symbols. */
590 gfc_commit_symbols ();
592 /* Restore the original namespace. */
593 gfc_current_ns = old_ns;
597 /* Resolve common blocks. */
599 resolve_common_blocks (gfc_symtree *common_root)
601 gfc_symtree *symtree;
604 if (common_root == NULL)
607 for (symtree = common_root; symtree->left; symtree = symtree->left);
609 for (; symtree; symtree = symtree->right)
611 gfc_find_symbol (symtree->name, gfc_current_ns, 0, &sym);
615 if (sym->attr.flavor == FL_PARAMETER)
617 gfc_error ("COMMON block '%s' at %L is used as PARAMETER at %L",
618 sym->name, &symtree->n.common->where,
622 if (sym->attr.intrinsic)
624 gfc_error ("COMMON block '%s' at %L is also an intrinsic "
625 "procedure", sym->name,
626 &symtree->n.common->where);
628 else if (sym->attr.result
629 ||(sym->attr.function && gfc_current_ns->proc_name == sym))
631 gfc_notify_std (GFC_STD_F2003, "Fortran 2003: COMMON block '%s' "
632 "at %L that is also a function result", sym->name,
633 &symtree->n.common->where);
635 else if (sym->attr.flavor == FL_PROCEDURE
636 && sym->attr.proc != PROC_INTERNAL
637 && sym->attr.proc != PROC_ST_FUNCTION)
639 gfc_notify_std (GFC_STD_F2003, "Fortran 2003: COMMON block '%s' "
640 "at %L that is also a global procedure", sym->name,
641 &symtree->n.common->where);
647 /* Resolve contained function types. Because contained functions can call one
648 another, they have to be worked out before any of the contained procedures
651 The good news is that if a function doesn't already have a type, the only
652 way it can get one is through an IMPLICIT type or a RESULT variable, because
653 by definition contained functions are contained namespace they're contained
654 in, not in a sibling or parent namespace. */
657 resolve_contained_functions (gfc_namespace *ns)
659 gfc_namespace *child;
662 resolve_formal_arglists (ns);
664 for (child = ns->contained; child; child = child->sibling)
666 /* Resolve alternate entry points first. */
667 resolve_entries (child);
669 /* Then check function return types. */
670 resolve_contained_fntype (child->proc_name, child);
671 for (el = child->entries; el; el = el->next)
672 resolve_contained_fntype (el->sym, child);
677 /* Resolve all of the elements of a structure constructor and make sure that
678 the types are correct. */
681 resolve_structure_cons (gfc_expr *expr)
683 gfc_constructor *cons;
689 cons = expr->value.constructor;
690 /* A constructor may have references if it is the result of substituting a
691 parameter variable. In this case we just pull out the component we
694 comp = expr->ref->u.c.sym->components;
696 comp = expr->ts.derived->components;
698 for (; comp; comp = comp->next, cons = cons->next)
703 if (gfc_resolve_expr (cons->expr) == FAILURE)
709 if (cons->expr->expr_type != EXPR_NULL
710 && comp->as && comp->as->rank != cons->expr->rank
711 && (comp->allocatable || cons->expr->rank))
713 gfc_error ("The rank of the element in the derived type "
714 "constructor at %L does not match that of the "
715 "component (%d/%d)", &cons->expr->where,
716 cons->expr->rank, comp->as ? comp->as->rank : 0);
720 /* If we don't have the right type, try to convert it. */
722 if (!gfc_compare_types (&cons->expr->ts, &comp->ts))
725 if (comp->pointer && cons->expr->ts.type != BT_UNKNOWN)
726 gfc_error ("The element in the derived type constructor at %L, "
727 "for pointer component '%s', is %s but should be %s",
728 &cons->expr->where, comp->name,
729 gfc_basic_typename (cons->expr->ts.type),
730 gfc_basic_typename (comp->ts.type));
732 t = gfc_convert_type (cons->expr, &comp->ts, 1);
735 if (!comp->pointer || cons->expr->expr_type == EXPR_NULL)
738 a = gfc_expr_attr (cons->expr);
740 if (!a.pointer && !a.target)
743 gfc_error ("The element in the derived type constructor at %L, "
744 "for pointer component '%s' should be a POINTER or "
745 "a TARGET", &cons->expr->where, comp->name);
753 /****************** Expression name resolution ******************/
755 /* Returns 0 if a symbol was not declared with a type or
756 attribute declaration statement, nonzero otherwise. */
759 was_declared (gfc_symbol *sym)
765 if (!a.implicit_type && sym->ts.type != BT_UNKNOWN)
768 if (a.allocatable || a.dimension || a.dummy || a.external || a.intrinsic
769 || a.optional || a.pointer || a.save || a.target || a.volatile_
770 || a.value || a.access != ACCESS_UNKNOWN || a.intent != INTENT_UNKNOWN)
777 /* Determine if a symbol is generic or not. */
780 generic_sym (gfc_symbol *sym)
784 if (sym->attr.generic ||
785 (sym->attr.intrinsic && gfc_generic_intrinsic (sym->name)))
788 if (was_declared (sym) || sym->ns->parent == NULL)
791 gfc_find_symbol (sym->name, sym->ns->parent, 1, &s);
793 return (s == NULL) ? 0 : generic_sym (s);
797 /* Determine if a symbol is specific or not. */
800 specific_sym (gfc_symbol *sym)
804 if (sym->attr.if_source == IFSRC_IFBODY
805 || sym->attr.proc == PROC_MODULE
806 || sym->attr.proc == PROC_INTERNAL
807 || sym->attr.proc == PROC_ST_FUNCTION
808 || (sym->attr.intrinsic && gfc_specific_intrinsic (sym->name))
809 || sym->attr.external)
812 if (was_declared (sym) || sym->ns->parent == NULL)
815 gfc_find_symbol (sym->name, sym->ns->parent, 1, &s);
817 return (s == NULL) ? 0 : specific_sym (s);
821 /* Figure out if the procedure is specific, generic or unknown. */
824 { PTYPE_GENERIC = 1, PTYPE_SPECIFIC, PTYPE_UNKNOWN }
828 procedure_kind (gfc_symbol *sym)
830 if (generic_sym (sym))
831 return PTYPE_GENERIC;
833 if (specific_sym (sym))
834 return PTYPE_SPECIFIC;
836 return PTYPE_UNKNOWN;
839 /* Check references to assumed size arrays. The flag need_full_assumed_size
840 is nonzero when matching actual arguments. */
842 static int need_full_assumed_size = 0;
845 check_assumed_size_reference (gfc_symbol *sym, gfc_expr *e)
851 if (need_full_assumed_size || !(sym->as && sym->as->type == AS_ASSUMED_SIZE))
854 for (ref = e->ref; ref; ref = ref->next)
855 if (ref->type == REF_ARRAY)
856 for (dim = 0; dim < ref->u.ar.as->rank; dim++)
857 last = (ref->u.ar.end[dim] == NULL)
858 && (ref->u.ar.type == DIMEN_ELEMENT);
862 gfc_error ("The upper bound in the last dimension must "
863 "appear in the reference to the assumed size "
864 "array '%s' at %L", sym->name, &e->where);
871 /* Look for bad assumed size array references in argument expressions
872 of elemental and array valued intrinsic procedures. Since this is
873 called from procedure resolution functions, it only recurses at
877 resolve_assumed_size_actual (gfc_expr *e)
882 switch (e->expr_type)
885 if (e->symtree && check_assumed_size_reference (e->symtree->n.sym, e))
890 if (resolve_assumed_size_actual (e->value.op.op1)
891 || resolve_assumed_size_actual (e->value.op.op2))
902 /* Resolve an actual argument list. Most of the time, this is just
903 resolving the expressions in the list.
904 The exception is that we sometimes have to decide whether arguments
905 that look like procedure arguments are really simple variable
909 resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype)
912 gfc_symtree *parent_st;
915 for (; arg; arg = arg->next)
920 /* Check the label is a valid branching target. */
923 if (arg->label->defined == ST_LABEL_UNKNOWN)
925 gfc_error ("Label %d referenced at %L is never defined",
926 arg->label->value, &arg->label->where);
933 if (e->ts.type != BT_PROCEDURE)
935 if (gfc_resolve_expr (e) != SUCCESS)
940 /* See if the expression node should really be a variable reference. */
942 sym = e->symtree->n.sym;
944 if (sym->attr.flavor == FL_PROCEDURE
945 || sym->attr.intrinsic
946 || sym->attr.external)
950 /* If a procedure is not already determined to be something else
951 check if it is intrinsic. */
952 if (!sym->attr.intrinsic
953 && !(sym->attr.external || sym->attr.use_assoc
954 || sym->attr.if_source == IFSRC_IFBODY)
955 && gfc_intrinsic_name (sym->name, sym->attr.subroutine))
956 sym->attr.intrinsic = 1;
958 if (sym->attr.proc == PROC_ST_FUNCTION)
960 gfc_error ("Statement function '%s' at %L is not allowed as an "
961 "actual argument", sym->name, &e->where);
964 actual_ok = gfc_intrinsic_actual_ok (sym->name,
965 sym->attr.subroutine);
966 if (sym->attr.intrinsic && actual_ok == 0)
968 gfc_error ("Intrinsic '%s' at %L is not allowed as an "
969 "actual argument", sym->name, &e->where);
972 if (sym->attr.contained && !sym->attr.use_assoc
973 && sym->ns->proc_name->attr.flavor != FL_MODULE)
975 gfc_error ("Internal procedure '%s' is not allowed as an "
976 "actual argument at %L", sym->name, &e->where);
979 if (sym->attr.elemental && !sym->attr.intrinsic)
981 gfc_error ("ELEMENTAL non-INTRINSIC procedure '%s' is not "
982 "allowed as an actual argument at %L", sym->name,
986 /* Check if a generic interface has a specific procedure
987 with the same name before emitting an error. */
988 if (sym->attr.generic)
991 for (p = sym->generic; p; p = p->next)
992 if (strcmp (sym->name, p->sym->name) == 0)
994 e->symtree = gfc_find_symtree
995 (p->sym->ns->sym_root, sym->name);
1000 if (p == NULL || e->symtree == NULL)
1001 gfc_error ("GENERIC non-INTRINSIC procedure '%s' is not "
1002 "allowed as an actual argument at %L", sym->name,
1006 /* If the symbol is the function that names the current (or
1007 parent) scope, then we really have a variable reference. */
1009 if (sym->attr.function && sym->result == sym
1010 && (sym->ns->proc_name == sym
1011 || (sym->ns->parent != NULL
1012 && sym->ns->parent->proc_name == sym)))
1015 /* If all else fails, see if we have a specific intrinsic. */
1016 if (sym->attr.function
1017 && sym->ts.type == BT_UNKNOWN && sym->attr.intrinsic)
1019 gfc_intrinsic_sym *isym;
1020 isym = gfc_find_function (sym->name);
1021 if (isym == NULL || !isym->specific)
1023 gfc_error ("Unable to find a specific INTRINSIC procedure "
1024 "for the reference '%s' at %L", sym->name,
1032 /* See if the name is a module procedure in a parent unit. */
1034 if (was_declared (sym) || sym->ns->parent == NULL)
1037 if (gfc_find_sym_tree (sym->name, sym->ns->parent, 1, &parent_st))
1039 gfc_error ("Symbol '%s' at %L is ambiguous", sym->name, &e->where);
1043 if (parent_st == NULL)
1046 sym = parent_st->n.sym;
1047 e->symtree = parent_st; /* Point to the right thing. */
1049 if (sym->attr.flavor == FL_PROCEDURE
1050 || sym->attr.intrinsic
1051 || sym->attr.external)
1057 e->expr_type = EXPR_VARIABLE;
1059 if (sym->as != NULL)
1061 e->rank = sym->as->rank;
1062 e->ref = gfc_get_ref ();
1063 e->ref->type = REF_ARRAY;
1064 e->ref->u.ar.type = AR_FULL;
1065 e->ref->u.ar.as = sym->as;
1068 /* Expressions are assigned a default ts.type of BT_PROCEDURE in
1069 primary.c (match_actual_arg). If above code determines that it
1070 is a variable instead, it needs to be resolved as it was not
1071 done at the beginning of this function. */
1072 if (gfc_resolve_expr (e) != SUCCESS)
1076 /* Check argument list functions %VAL, %LOC and %REF. There is
1077 nothing to do for %REF. */
1078 if (arg->name && arg->name[0] == '%')
1080 if (strncmp ("%VAL", arg->name, 4) == 0)
1082 if (e->ts.type == BT_CHARACTER || e->ts.type == BT_DERIVED)
1084 gfc_error ("By-value argument at %L is not of numeric "
1091 gfc_error ("By-value argument at %L cannot be an array or "
1092 "an array section", &e->where);
1096 /* Intrinsics are still PROC_UNKNOWN here. However,
1097 since same file external procedures are not resolvable
1098 in gfortran, it is a good deal easier to leave them to
1100 if (ptype != PROC_UNKNOWN
1101 && ptype != PROC_DUMMY
1102 && ptype != PROC_EXTERNAL
1103 && ptype != PROC_MODULE)
1105 gfc_error ("By-value argument at %L is not allowed "
1106 "in this context", &e->where);
1111 /* Statement functions have already been excluded above. */
1112 else if (strncmp ("%LOC", arg->name, 4) == 0
1113 && e->ts.type == BT_PROCEDURE)
1115 if (e->symtree->n.sym->attr.proc == PROC_INTERNAL)
1117 gfc_error ("Passing internal procedure at %L by location "
1118 "not allowed", &e->where);
1129 /* Do the checks of the actual argument list that are specific to elemental
1130 procedures. If called with c == NULL, we have a function, otherwise if
1131 expr == NULL, we have a subroutine. */
1134 resolve_elemental_actual (gfc_expr *expr, gfc_code *c)
1136 gfc_actual_arglist *arg0;
1137 gfc_actual_arglist *arg;
1138 gfc_symbol *esym = NULL;
1139 gfc_intrinsic_sym *isym = NULL;
1141 gfc_intrinsic_arg *iformal = NULL;
1142 gfc_formal_arglist *eformal = NULL;
1143 bool formal_optional = false;
1144 bool set_by_optional = false;
1148 /* Is this an elemental procedure? */
1149 if (expr && expr->value.function.actual != NULL)
1151 if (expr->value.function.esym != NULL
1152 && expr->value.function.esym->attr.elemental)
1154 arg0 = expr->value.function.actual;
1155 esym = expr->value.function.esym;
1157 else if (expr->value.function.isym != NULL
1158 && expr->value.function.isym->elemental)
1160 arg0 = expr->value.function.actual;
1161 isym = expr->value.function.isym;
1166 else if (c && c->ext.actual != NULL && c->symtree->n.sym->attr.elemental)
1168 arg0 = c->ext.actual;
1169 esym = c->symtree->n.sym;
1174 /* The rank of an elemental is the rank of its array argument(s). */
1175 for (arg = arg0; arg; arg = arg->next)
1177 if (arg->expr != NULL && arg->expr->rank > 0)
1179 rank = arg->expr->rank;
1180 if (arg->expr->expr_type == EXPR_VARIABLE
1181 && arg->expr->symtree->n.sym->attr.optional)
1182 set_by_optional = true;
1184 /* Function specific; set the result rank and shape. */
1188 if (!expr->shape && arg->expr->shape)
1190 expr->shape = gfc_get_shape (rank);
1191 for (i = 0; i < rank; i++)
1192 mpz_init_set (expr->shape[i], arg->expr->shape[i]);
1199 /* If it is an array, it shall not be supplied as an actual argument
1200 to an elemental procedure unless an array of the same rank is supplied
1201 as an actual argument corresponding to a nonoptional dummy argument of
1202 that elemental procedure(12.4.1.5). */
1203 formal_optional = false;
1205 iformal = isym->formal;
1207 eformal = esym->formal;
1209 for (arg = arg0; arg; arg = arg->next)
1213 if (eformal->sym && eformal->sym->attr.optional)
1214 formal_optional = true;
1215 eformal = eformal->next;
1217 else if (isym && iformal)
1219 if (iformal->optional)
1220 formal_optional = true;
1221 iformal = iformal->next;
1224 formal_optional = true;
1226 if (pedantic && arg->expr != NULL
1227 && arg->expr->expr_type == EXPR_VARIABLE
1228 && arg->expr->symtree->n.sym->attr.optional
1231 && (set_by_optional || arg->expr->rank != rank)
1232 && !(isym && isym->id == GFC_ISYM_CONVERSION))
1234 gfc_warning ("'%s' at %L is an array and OPTIONAL; IF IT IS "
1235 "MISSING, it cannot be the actual argument of an "
1236 "ELEMENTAL procedure unless there is a non-optional "
1237 "argument with the same rank (12.4.1.5)",
1238 arg->expr->symtree->n.sym->name, &arg->expr->where);
1243 for (arg = arg0; arg; arg = arg->next)
1245 if (arg->expr == NULL || arg->expr->rank == 0)
1248 /* Being elemental, the last upper bound of an assumed size array
1249 argument must be present. */
1250 if (resolve_assumed_size_actual (arg->expr))
1256 /* Elemental subroutine array actual arguments must conform. */
1259 if (gfc_check_conformance ("elemental subroutine", arg->expr, e)
1271 /* Go through each actual argument in ACTUAL and see if it can be
1272 implemented as an inlined, non-copying intrinsic. FNSYM is the
1273 function being called, or NULL if not known. */
1276 find_noncopying_intrinsics (gfc_symbol *fnsym, gfc_actual_arglist *actual)
1278 gfc_actual_arglist *ap;
1281 for (ap = actual; ap; ap = ap->next)
1283 && (expr = gfc_get_noncopying_intrinsic_argument (ap->expr))
1284 && !gfc_check_fncall_dependency (expr, INTENT_IN, fnsym, actual))
1285 ap->expr->inline_noncopying_intrinsic = 1;
1289 /* This function does the checking of references to global procedures
1290 as defined in sections 18.1 and 14.1, respectively, of the Fortran
1291 77 and 95 standards. It checks for a gsymbol for the name, making
1292 one if it does not already exist. If it already exists, then the
1293 reference being resolved must correspond to the type of gsymbol.
1294 Otherwise, the new symbol is equipped with the attributes of the
1295 reference. The corresponding code that is called in creating
1296 global entities is parse.c. */
1299 resolve_global_procedure (gfc_symbol *sym, locus *where, int sub)
1304 type = sub ? GSYM_SUBROUTINE : GSYM_FUNCTION;
1306 gsym = gfc_get_gsymbol (sym->name);
1308 if ((gsym->type != GSYM_UNKNOWN && gsym->type != type))
1309 global_used (gsym, where);
1311 if (gsym->type == GSYM_UNKNOWN)
1314 gsym->where = *where;
1321 /************* Function resolution *************/
1323 /* Resolve a function call known to be generic.
1324 Section 14.1.2.4.1. */
1327 resolve_generic_f0 (gfc_expr *expr, gfc_symbol *sym)
1331 if (sym->attr.generic)
1333 s = gfc_search_interface (sym->generic, 0, &expr->value.function.actual);
1336 expr->value.function.name = s->name;
1337 expr->value.function.esym = s;
1339 if (s->ts.type != BT_UNKNOWN)
1341 else if (s->result != NULL && s->result->ts.type != BT_UNKNOWN)
1342 expr->ts = s->result->ts;
1345 expr->rank = s->as->rank;
1346 else if (s->result != NULL && s->result->as != NULL)
1347 expr->rank = s->result->as->rank;
1352 /* TODO: Need to search for elemental references in generic
1356 if (sym->attr.intrinsic)
1357 return gfc_intrinsic_func_interface (expr, 0);
1364 resolve_generic_f (gfc_expr *expr)
1369 sym = expr->symtree->n.sym;
1373 m = resolve_generic_f0 (expr, sym);
1376 else if (m == MATCH_ERROR)
1380 if (sym->ns->parent == NULL)
1382 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
1386 if (!generic_sym (sym))
1390 /* Last ditch attempt. See if the reference is to an intrinsic
1391 that possesses a matching interface. 14.1.2.4 */
1392 if (sym && !gfc_intrinsic_name (sym->name, 0))
1394 gfc_error ("There is no specific function for the generic '%s' at %L",
1395 expr->symtree->n.sym->name, &expr->where);
1399 m = gfc_intrinsic_func_interface (expr, 0);
1403 gfc_error ("Generic function '%s' at %L is not consistent with a "
1404 "specific intrinsic interface", expr->symtree->n.sym->name,
1411 /* Resolve a function call known to be specific. */
1414 resolve_specific_f0 (gfc_symbol *sym, gfc_expr *expr)
1418 if (sym->attr.external || sym->attr.if_source == IFSRC_IFBODY)
1420 if (sym->attr.dummy)
1422 sym->attr.proc = PROC_DUMMY;
1426 sym->attr.proc = PROC_EXTERNAL;
1430 if (sym->attr.proc == PROC_MODULE
1431 || sym->attr.proc == PROC_ST_FUNCTION
1432 || sym->attr.proc == PROC_INTERNAL)
1435 if (sym->attr.intrinsic)
1437 m = gfc_intrinsic_func_interface (expr, 1);
1441 gfc_error ("Function '%s' at %L is INTRINSIC but is not compatible "
1442 "with an intrinsic", sym->name, &expr->where);
1450 gfc_procedure_use (sym, &expr->value.function.actual, &expr->where);
1453 expr->value.function.name = sym->name;
1454 expr->value.function.esym = sym;
1455 if (sym->as != NULL)
1456 expr->rank = sym->as->rank;
1463 resolve_specific_f (gfc_expr *expr)
1468 sym = expr->symtree->n.sym;
1472 m = resolve_specific_f0 (sym, expr);
1475 if (m == MATCH_ERROR)
1478 if (sym->ns->parent == NULL)
1481 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
1487 gfc_error ("Unable to resolve the specific function '%s' at %L",
1488 expr->symtree->n.sym->name, &expr->where);
1494 /* Resolve a procedure call not known to be generic nor specific. */
1497 resolve_unknown_f (gfc_expr *expr)
1502 sym = expr->symtree->n.sym;
1504 if (sym->attr.dummy)
1506 sym->attr.proc = PROC_DUMMY;
1507 expr->value.function.name = sym->name;
1511 /* See if we have an intrinsic function reference. */
1513 if (gfc_intrinsic_name (sym->name, 0))
1515 if (gfc_intrinsic_func_interface (expr, 1) == MATCH_YES)
1520 /* The reference is to an external name. */
1522 sym->attr.proc = PROC_EXTERNAL;
1523 expr->value.function.name = sym->name;
1524 expr->value.function.esym = expr->symtree->n.sym;
1526 if (sym->as != NULL)
1527 expr->rank = sym->as->rank;
1529 /* Type of the expression is either the type of the symbol or the
1530 default type of the symbol. */
1533 gfc_procedure_use (sym, &expr->value.function.actual, &expr->where);
1535 if (sym->ts.type != BT_UNKNOWN)
1539 ts = gfc_get_default_type (sym, sym->ns);
1541 if (ts->type == BT_UNKNOWN)
1543 gfc_error ("Function '%s' at %L has no IMPLICIT type",
1544 sym->name, &expr->where);
1555 /* Return true, if the symbol is an external procedure. */
1557 is_external_proc (gfc_symbol *sym)
1559 if (!sym->attr.dummy && !sym->attr.contained
1560 && !(sym->attr.intrinsic
1561 || gfc_intrinsic_name (sym->name, sym->attr.subroutine))
1562 && sym->attr.proc != PROC_ST_FUNCTION
1563 && !sym->attr.use_assoc
1571 /* Figure out if a function reference is pure or not. Also set the name
1572 of the function for a potential error message. Return nonzero if the
1573 function is PURE, zero if not. */
1576 pure_function (gfc_expr *e, const char **name)
1582 if (e->symtree != NULL
1583 && e->symtree->n.sym != NULL
1584 && e->symtree->n.sym->attr.proc == PROC_ST_FUNCTION)
1587 if (e->value.function.esym)
1589 pure = gfc_pure (e->value.function.esym);
1590 *name = e->value.function.esym->name;
1592 else if (e->value.function.isym)
1594 pure = e->value.function.isym->pure
1595 || e->value.function.isym->elemental;
1596 *name = e->value.function.isym->name;
1600 /* Implicit functions are not pure. */
1602 *name = e->value.function.name;
1610 is_scalar_expr_ptr (gfc_expr *expr)
1612 try retval = SUCCESS;
1617 /* See if we have a gfc_ref, which means we have a substring, array
1618 reference, or a component. */
1619 if (expr->ref != NULL)
1622 while (ref->next != NULL)
1628 if (ref->u.ss.length != NULL
1629 && ref->u.ss.length->length != NULL
1631 && ref->u.ss.start->expr_type == EXPR_CONSTANT
1633 && ref->u.ss.end->expr_type == EXPR_CONSTANT)
1635 start = (int) mpz_get_si (ref->u.ss.start->value.integer);
1636 end = (int) mpz_get_si (ref->u.ss.end->value.integer);
1637 if (end - start + 1 != 1)
1644 if (ref->u.ar.type == AR_ELEMENT)
1646 else if (ref->u.ar.type == AR_FULL)
1648 /* The user can give a full array if the array is of size 1. */
1649 if (ref->u.ar.as != NULL
1650 && ref->u.ar.as->rank == 1
1651 && ref->u.ar.as->type == AS_EXPLICIT
1652 && ref->u.ar.as->lower[0] != NULL
1653 && ref->u.ar.as->lower[0]->expr_type == EXPR_CONSTANT
1654 && ref->u.ar.as->upper[0] != NULL
1655 && ref->u.ar.as->upper[0]->expr_type == EXPR_CONSTANT)
1657 /* If we have a character string, we need to check if
1658 its length is one. */
1659 if (expr->ts.type == BT_CHARACTER)
1661 if (expr->ts.cl == NULL
1662 || expr->ts.cl->length == NULL
1663 || mpz_cmp_si (expr->ts.cl->length->value.integer, 1)
1669 /* We have constant lower and upper bounds. If the
1670 difference between is 1, it can be considered a
1672 start = (int) mpz_get_si
1673 (ref->u.ar.as->lower[0]->value.integer);
1674 end = (int) mpz_get_si
1675 (ref->u.ar.as->upper[0]->value.integer);
1676 if (end - start + 1 != 1)
1691 else if (expr->ts.type == BT_CHARACTER && expr->rank == 0)
1693 /* Character string. Make sure it's of length 1. */
1694 if (expr->ts.cl == NULL
1695 || expr->ts.cl->length == NULL
1696 || mpz_cmp_si (expr->ts.cl->length->value.integer, 1) != 0)
1699 else if (expr->rank != 0)
1706 /* Match one of the iso_c_binding functions (c_associated or c_loc)
1707 and, in the case of c_associated, set the binding label based on
1711 gfc_iso_c_func_interface (gfc_symbol *sym, gfc_actual_arglist *args,
1712 gfc_symbol **new_sym)
1714 char name[GFC_MAX_SYMBOL_LEN + 1];
1715 char binding_label[GFC_MAX_BINDING_LABEL_LEN + 1];
1716 int optional_arg = 0;
1717 try retval = SUCCESS;
1718 gfc_symbol *args_sym;
1720 args_sym = args->expr->symtree->n.sym;
1722 if (sym->intmod_sym_id == ISOCBINDING_ASSOCIATED)
1724 /* If the user gave two args then they are providing something for
1725 the optional arg (the second cptr). Therefore, set the name and
1726 binding label to the c_associated for two cptrs. Otherwise,
1727 set c_associated to expect one cptr. */
1731 sprintf (name, "%s_2", sym->name);
1732 sprintf (binding_label, "%s_2", sym->binding_label);
1738 sprintf (name, "%s_1", sym->name);
1739 sprintf (binding_label, "%s_1", sym->binding_label);
1743 /* Get a new symbol for the version of c_associated that
1745 *new_sym = get_iso_c_sym (sym, name, binding_label, optional_arg);
1747 else if (sym->intmod_sym_id == ISOCBINDING_LOC
1748 || sym->intmod_sym_id == ISOCBINDING_FUNLOC)
1750 sprintf (name, "%s", sym->name);
1751 sprintf (binding_label, "%s", sym->binding_label);
1753 /* Error check the call. */
1754 if (args->next != NULL)
1756 gfc_error_now ("More actual than formal arguments in '%s' "
1757 "call at %L", name, &(args->expr->where));
1760 else if (sym->intmod_sym_id == ISOCBINDING_LOC)
1762 /* Make sure we have either the target or pointer attribute. */
1763 if (!(args->expr->symtree->n.sym->attr.target)
1764 && !(args->expr->symtree->n.sym->attr.pointer))
1766 gfc_error_now ("Parameter '%s' to '%s' at %L must be either "
1767 "a TARGET or an associated pointer",
1768 args->expr->symtree->n.sym->name,
1769 sym->name, &(args->expr->where));
1773 /* See if we have interoperable type and type param. */
1774 if (verify_c_interop (&(args->expr->symtree->n.sym->ts),
1775 args->expr->symtree->n.sym->name,
1776 &(args->expr->where)) == SUCCESS
1777 || gfc_check_any_c_kind (&(args_sym->ts)) == SUCCESS)
1779 if (args_sym->attr.target == 1)
1781 /* Case 1a, section 15.1.2.5, J3/04-007: variable that
1782 has the target attribute and is interoperable. */
1783 /* Case 1b, section 15.1.2.5, J3/04-007: allocated
1784 allocatable variable that has the TARGET attribute and
1785 is not an array of zero size. */
1786 if (args_sym->attr.allocatable == 1)
1788 if (args_sym->attr.dimension != 0
1789 && (args_sym->as && args_sym->as->rank == 0))
1791 gfc_error_now ("Allocatable variable '%s' used as a "
1792 "parameter to '%s' at %L must not be "
1793 "an array of zero size",
1794 args_sym->name, sym->name,
1795 &(args->expr->where));
1801 /* Make sure it's not a character string. Arrays of
1802 any type should be ok if the variable is of a C
1803 interoperable type. */
1804 if (args_sym->ts.type == BT_CHARACTER
1805 && is_scalar_expr_ptr (args->expr) != SUCCESS)
1807 gfc_error_now ("CHARACTER argument '%s' to '%s' at "
1808 "%L must have a length of 1",
1809 args_sym->name, sym->name,
1810 &(args->expr->where));
1815 else if (args_sym->attr.pointer == 1
1816 && is_scalar_expr_ptr (args->expr) != SUCCESS)
1818 /* Case 1c, section 15.1.2.5, J3/04-007: an associated
1820 gfc_error_now ("Argument '%s' to '%s' at %L must be an "
1821 "associated scalar POINTER", args_sym->name,
1822 sym->name, &(args->expr->where));
1828 /* The parameter is not required to be C interoperable. If it
1829 is not C interoperable, it must be a nonpolymorphic scalar
1830 with no length type parameters. It still must have either
1831 the pointer or target attribute, and it can be
1832 allocatable (but must be allocated when c_loc is called). */
1833 if (args_sym->attr.dimension != 0
1834 && is_scalar_expr_ptr (args->expr) != SUCCESS)
1836 gfc_error_now ("Parameter '%s' to '%s' at %L must be a "
1837 "scalar", args_sym->name, sym->name,
1838 &(args->expr->where));
1841 else if (args_sym->ts.type == BT_CHARACTER
1842 && args_sym->ts.cl != NULL)
1844 gfc_error_now ("CHARACTER parameter '%s' to '%s' at %L "
1845 "cannot have a length type parameter",
1846 args_sym->name, sym->name,
1847 &(args->expr->where));
1852 else if (sym->intmod_sym_id == ISOCBINDING_FUNLOC)
1854 if (args->expr->symtree->n.sym->attr.flavor != FL_PROCEDURE)
1856 /* TODO: Update this error message to allow for procedure
1857 pointers once they are implemented. */
1858 gfc_error_now ("Parameter '%s' to '%s' at %L must be a "
1860 args->expr->symtree->n.sym->name, sym->name,
1861 &(args->expr->where));
1864 else if (args->expr->symtree->n.sym->attr.is_c_interop != 1)
1866 gfc_error_now ("Parameter '%s' to '%s' at %L must be C "
1868 args->expr->symtree->n.sym->name, sym->name,
1869 &(args->expr->where));
1874 /* for c_loc/c_funloc, the new symbol is the same as the old one */
1879 gfc_internal_error ("gfc_iso_c_func_interface(): Unhandled "
1880 "iso_c_binding function: '%s'!\n", sym->name);
1887 /* Resolve a function call, which means resolving the arguments, then figuring
1888 out which entity the name refers to. */
1889 /* TODO: Check procedure arguments so that an INTENT(IN) isn't passed
1890 to INTENT(OUT) or INTENT(INOUT). */
1893 resolve_function (gfc_expr *expr)
1895 gfc_actual_arglist *arg;
1900 procedure_type p = PROC_INTRINSIC;
1904 sym = expr->symtree->n.sym;
1906 if (sym && sym->attr.flavor == FL_VARIABLE)
1908 gfc_error ("'%s' at %L is not a function", sym->name, &expr->where);
1912 /* If the procedure is external, check for usage. */
1913 if (sym && is_external_proc (sym))
1914 resolve_global_procedure (sym, &expr->where, 0);
1916 /* Switch off assumed size checking and do this again for certain kinds
1917 of procedure, once the procedure itself is resolved. */
1918 need_full_assumed_size++;
1920 if (expr->symtree && expr->symtree->n.sym)
1921 p = expr->symtree->n.sym->attr.proc;
1923 if (resolve_actual_arglist (expr->value.function.actual, p) == FAILURE)
1926 /* Need to setup the call to the correct c_associated, depending on
1927 the number of cptrs to user gives to compare. */
1928 if (sym && sym->attr.is_iso_c == 1)
1930 if (gfc_iso_c_func_interface (sym, expr->value.function.actual, &sym)
1934 /* Get the symtree for the new symbol (resolved func).
1935 the old one will be freed later, when it's no longer used. */
1936 gfc_find_sym_tree (sym->name, sym->ns, 1, &(expr->symtree));
1939 /* Resume assumed_size checking. */
1940 need_full_assumed_size--;
1942 if (sym && sym->ts.type == BT_CHARACTER
1944 && sym->ts.cl->length == NULL
1946 && expr->value.function.esym == NULL
1947 && !sym->attr.contained)
1949 /* Internal procedures are taken care of in resolve_contained_fntype. */
1950 gfc_error ("Function '%s' is declared CHARACTER(*) and cannot "
1951 "be used at %L since it is not a dummy argument",
1952 sym->name, &expr->where);
1956 /* See if function is already resolved. */
1958 if (expr->value.function.name != NULL)
1960 if (expr->ts.type == BT_UNKNOWN)
1966 /* Apply the rules of section 14.1.2. */
1968 switch (procedure_kind (sym))
1971 t = resolve_generic_f (expr);
1974 case PTYPE_SPECIFIC:
1975 t = resolve_specific_f (expr);
1979 t = resolve_unknown_f (expr);
1983 gfc_internal_error ("resolve_function(): bad function type");
1987 /* If the expression is still a function (it might have simplified),
1988 then we check to see if we are calling an elemental function. */
1990 if (expr->expr_type != EXPR_FUNCTION)
1993 temp = need_full_assumed_size;
1994 need_full_assumed_size = 0;
1996 if (resolve_elemental_actual (expr, NULL) == FAILURE)
1999 if (omp_workshare_flag
2000 && expr->value.function.esym
2001 && ! gfc_elemental (expr->value.function.esym))
2003 gfc_error ("User defined non-ELEMENTAL function '%s' at %L not allowed "
2004 "in WORKSHARE construct", expr->value.function.esym->name,
2009 #define GENERIC_ID expr->value.function.isym->id
2010 else if (expr->value.function.actual != NULL
2011 && expr->value.function.isym != NULL
2012 && GENERIC_ID != GFC_ISYM_LBOUND
2013 && GENERIC_ID != GFC_ISYM_LEN
2014 && GENERIC_ID != GFC_ISYM_LOC
2015 && GENERIC_ID != GFC_ISYM_PRESENT)
2017 /* Array intrinsics must also have the last upper bound of an
2018 assumed size array argument. UBOUND and SIZE have to be
2019 excluded from the check if the second argument is anything
2022 inquiry = GENERIC_ID == GFC_ISYM_UBOUND
2023 || GENERIC_ID == GFC_ISYM_SIZE;
2025 for (arg = expr->value.function.actual; arg; arg = arg->next)
2027 if (inquiry && arg->next != NULL && arg->next->expr)
2029 if (arg->next->expr->expr_type != EXPR_CONSTANT)
2032 if ((int)mpz_get_si (arg->next->expr->value.integer)
2037 if (arg->expr != NULL
2038 && arg->expr->rank > 0
2039 && resolve_assumed_size_actual (arg->expr))
2045 need_full_assumed_size = temp;
2048 if (!pure_function (expr, &name) && name)
2052 gfc_error ("reference to non-PURE function '%s' at %L inside a "
2053 "FORALL %s", name, &expr->where,
2054 forall_flag == 2 ? "mask" : "block");
2057 else if (gfc_pure (NULL))
2059 gfc_error ("Function reference to '%s' at %L is to a non-PURE "
2060 "procedure within a PURE procedure", name, &expr->where);
2065 /* Functions without the RECURSIVE attribution are not allowed to
2066 * call themselves. */
2067 if (expr->value.function.esym && !expr->value.function.esym->attr.recursive)
2069 gfc_symbol *esym, *proc;
2070 esym = expr->value.function.esym;
2071 proc = gfc_current_ns->proc_name;
2074 gfc_error ("Function '%s' at %L cannot call itself, as it is not "
2075 "RECURSIVE", name, &expr->where);
2079 if (esym->attr.entry && esym->ns->entries && proc->ns->entries
2080 && esym->ns->entries->sym == proc->ns->entries->sym)
2082 gfc_error ("Call to ENTRY '%s' at %L is recursive, but function "
2083 "'%s' is not declared as RECURSIVE",
2084 esym->name, &expr->where, esym->ns->entries->sym->name);
2089 /* Character lengths of use associated functions may contains references to
2090 symbols not referenced from the current program unit otherwise. Make sure
2091 those symbols are marked as referenced. */
2093 if (expr->ts.type == BT_CHARACTER && expr->value.function.esym
2094 && expr->value.function.esym->attr.use_assoc)
2096 gfc_expr_set_symbols_referenced (expr->ts.cl->length);
2100 find_noncopying_intrinsics (expr->value.function.esym,
2101 expr->value.function.actual);
2103 /* Make sure that the expression has a typespec that works. */
2104 if (expr->ts.type == BT_UNKNOWN)
2106 if (expr->symtree->n.sym->result
2107 && expr->symtree->n.sym->result->ts.type != BT_UNKNOWN)
2108 expr->ts = expr->symtree->n.sym->result->ts;
2115 /************* Subroutine resolution *************/
2118 pure_subroutine (gfc_code *c, gfc_symbol *sym)
2124 gfc_error ("Subroutine call to '%s' in FORALL block at %L is not PURE",
2125 sym->name, &c->loc);
2126 else if (gfc_pure (NULL))
2127 gfc_error ("Subroutine call to '%s' at %L is not PURE", sym->name,
2133 resolve_generic_s0 (gfc_code *c, gfc_symbol *sym)
2137 if (sym->attr.generic)
2139 s = gfc_search_interface (sym->generic, 1, &c->ext.actual);
2142 c->resolved_sym = s;
2143 pure_subroutine (c, s);
2147 /* TODO: Need to search for elemental references in generic interface. */
2150 if (sym->attr.intrinsic)
2151 return gfc_intrinsic_sub_interface (c, 0);
2158 resolve_generic_s (gfc_code *c)
2163 sym = c->symtree->n.sym;
2167 m = resolve_generic_s0 (c, sym);
2170 else if (m == MATCH_ERROR)
2174 if (sym->ns->parent == NULL)
2176 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
2180 if (!generic_sym (sym))
2184 /* Last ditch attempt. See if the reference is to an intrinsic
2185 that possesses a matching interface. 14.1.2.4 */
2186 sym = c->symtree->n.sym;
2188 if (!gfc_intrinsic_name (sym->name, 1))
2190 gfc_error ("There is no specific subroutine for the generic '%s' at %L",
2191 sym->name, &c->loc);
2195 m = gfc_intrinsic_sub_interface (c, 0);
2199 gfc_error ("Generic subroutine '%s' at %L is not consistent with an "
2200 "intrinsic subroutine interface", sym->name, &c->loc);
2206 /* Set the name and binding label of the subroutine symbol in the call
2207 expression represented by 'c' to include the type and kind of the
2208 second parameter. This function is for resolving the appropriate
2209 version of c_f_pointer() and c_f_procpointer(). For example, a
2210 call to c_f_pointer() for a default integer pointer could have a
2211 name of c_f_pointer_i4. If no second arg exists, which is an error
2212 for these two functions, it defaults to the generic symbol's name
2213 and binding label. */
2216 set_name_and_label (gfc_code *c, gfc_symbol *sym,
2217 char *name, char *binding_label)
2219 gfc_expr *arg = NULL;
2223 /* The second arg of c_f_pointer and c_f_procpointer determines
2224 the type and kind for the procedure name. */
2225 arg = c->ext.actual->next->expr;
2229 /* Set up the name to have the given symbol's name,
2230 plus the type and kind. */
2231 /* a derived type is marked with the type letter 'u' */
2232 if (arg->ts.type == BT_DERIVED)
2235 kind = 0; /* set the kind as 0 for now */
2239 type = gfc_type_letter (arg->ts.type);
2240 kind = arg->ts.kind;
2242 sprintf (name, "%s_%c%d", sym->name, type, kind);
2243 /* Set up the binding label as the given symbol's label plus
2244 the type and kind. */
2245 sprintf (binding_label, "%s_%c%d", sym->binding_label, type, kind);
2249 /* If the second arg is missing, set the name and label as
2250 was, cause it should at least be found, and the missing
2251 arg error will be caught by compare_parameters(). */
2252 sprintf (name, "%s", sym->name);
2253 sprintf (binding_label, "%s", sym->binding_label);
2260 /* Resolve a generic version of the iso_c_binding procedure given
2261 (sym) to the specific one based on the type and kind of the
2262 argument(s). Currently, this function resolves c_f_pointer() and
2263 c_f_procpointer based on the type and kind of the second argument
2264 (FPTR). Other iso_c_binding procedures aren't specially handled.
2265 Upon successfully exiting, c->resolved_sym will hold the resolved
2266 symbol. Returns MATCH_ERROR if an error occurred; MATCH_YES
2270 gfc_iso_c_sub_interface (gfc_code *c, gfc_symbol *sym)
2272 gfc_symbol *new_sym;
2273 /* this is fine, since we know the names won't use the max */
2274 char name[GFC_MAX_SYMBOL_LEN + 1];
2275 char binding_label[GFC_MAX_BINDING_LABEL_LEN + 1];
2276 /* default to success; will override if find error */
2277 match m = MATCH_YES;
2278 gfc_symbol *tmp_sym;
2280 if ((sym->intmod_sym_id == ISOCBINDING_F_POINTER) ||
2281 (sym->intmod_sym_id == ISOCBINDING_F_PROCPOINTER))
2283 set_name_and_label (c, sym, name, binding_label);
2285 if (sym->intmod_sym_id == ISOCBINDING_F_POINTER)
2287 if (c->ext.actual != NULL && c->ext.actual->next != NULL)
2289 /* Make sure we got a third arg. The type/rank of it will
2290 be checked later if it's there (gfc_procedure_use()). */
2291 if (c->ext.actual->next->expr->rank != 0 &&
2292 c->ext.actual->next->next == NULL)
2295 gfc_error ("Missing SHAPE parameter for call to %s "
2296 "at %L", sym->name, &(c->loc));
2298 /* Make sure the param is a POINTER. No need to make sure
2299 it does not have INTENT(IN) since it is a POINTER. */
2300 tmp_sym = c->ext.actual->next->expr->symtree->n.sym;
2301 if (tmp_sym != NULL && tmp_sym->attr.pointer != 1)
2303 gfc_error ("Argument '%s' to '%s' at %L "
2304 "must have the POINTER attribute",
2305 tmp_sym->name, sym->name, &(c->loc));
2311 if (m != MATCH_ERROR)
2313 /* the 1 means to add the optional arg to formal list */
2314 new_sym = get_iso_c_sym (sym, name, binding_label, 1);
2316 /* for error reporting, say it's declared where the original was */
2317 new_sym->declared_at = sym->declared_at;
2320 else if (sym->intmod_sym_id == ISOCBINDING_ASSOCIATED)
2322 /* TODO: Figure out if this is even reacable; this part of the
2323 conditional may not be necessary. */
2325 if (c->ext.actual->next == NULL)
2327 /* The user did not give two args, so resolve to the version
2328 of c_associated expecting one arg. */
2330 /* get rid of the second arg */
2331 /* TODO!! Should free up the memory here! */
2332 sym->formal->next = NULL;
2340 sprintf (name, "%s_%d", sym->name, num_args);
2341 sprintf (binding_label, "%s_%d", sym->binding_label, num_args);
2342 sym->name = gfc_get_string (name);
2343 strcpy (sym->binding_label, binding_label);
2347 /* no differences for c_loc or c_funloc */
2351 /* set the resolved symbol */
2352 if (m != MATCH_ERROR)
2354 gfc_procedure_use (new_sym, &c->ext.actual, &c->loc);
2355 c->resolved_sym = new_sym;
2358 c->resolved_sym = sym;
2364 /* Resolve a subroutine call known to be specific. */
2367 resolve_specific_s0 (gfc_code *c, gfc_symbol *sym)
2371 if(sym->attr.is_iso_c)
2373 m = gfc_iso_c_sub_interface (c,sym);
2377 if (sym->attr.external || sym->attr.if_source == IFSRC_IFBODY)
2379 if (sym->attr.dummy)
2381 sym->attr.proc = PROC_DUMMY;
2385 sym->attr.proc = PROC_EXTERNAL;
2389 if (sym->attr.proc == PROC_MODULE || sym->attr.proc == PROC_INTERNAL)
2392 if (sym->attr.intrinsic)
2394 m = gfc_intrinsic_sub_interface (c, 1);
2398 gfc_error ("Subroutine '%s' at %L is INTRINSIC but is not compatible "
2399 "with an intrinsic", sym->name, &c->loc);
2407 gfc_procedure_use (sym, &c->ext.actual, &c->loc);
2409 c->resolved_sym = sym;
2410 pure_subroutine (c, sym);
2417 resolve_specific_s (gfc_code *c)
2422 sym = c->symtree->n.sym;
2426 m = resolve_specific_s0 (c, sym);
2429 if (m == MATCH_ERROR)
2432 if (sym->ns->parent == NULL)
2435 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
2441 sym = c->symtree->n.sym;
2442 gfc_error ("Unable to resolve the specific subroutine '%s' at %L",
2443 sym->name, &c->loc);
2449 /* Resolve a subroutine call not known to be generic nor specific. */
2452 resolve_unknown_s (gfc_code *c)
2456 sym = c->symtree->n.sym;
2458 if (sym->attr.dummy)
2460 sym->attr.proc = PROC_DUMMY;
2464 /* See if we have an intrinsic function reference. */
2466 if (gfc_intrinsic_name (sym->name, 1))
2468 if (gfc_intrinsic_sub_interface (c, 1) == MATCH_YES)
2473 /* The reference is to an external name. */
2476 gfc_procedure_use (sym, &c->ext.actual, &c->loc);
2478 c->resolved_sym = sym;
2480 pure_subroutine (c, sym);
2486 /* Resolve a subroutine call. Although it was tempting to use the same code
2487 for functions, subroutines and functions are stored differently and this
2488 makes things awkward. */
2491 resolve_call (gfc_code *c)
2494 procedure_type ptype = PROC_INTRINSIC;
2496 if (c->symtree && c->symtree->n.sym
2497 && c->symtree->n.sym->ts.type != BT_UNKNOWN)
2499 gfc_error ("'%s' at %L has a type, which is not consistent with "
2500 "the CALL at %L", c->symtree->n.sym->name,
2501 &c->symtree->n.sym->declared_at, &c->loc);
2505 /* If external, check for usage. */
2506 if (c->symtree && is_external_proc (c->symtree->n.sym))
2507 resolve_global_procedure (c->symtree->n.sym, &c->loc, 1);
2509 /* Subroutines without the RECURSIVE attribution are not allowed to
2510 * call themselves. */
2511 if (c->symtree && c->symtree->n.sym && !c->symtree->n.sym->attr.recursive)
2513 gfc_symbol *csym, *proc;
2514 csym = c->symtree->n.sym;
2515 proc = gfc_current_ns->proc_name;
2518 gfc_error ("SUBROUTINE '%s' at %L cannot call itself, as it is not "
2519 "RECURSIVE", csym->name, &c->loc);
2523 if (csym->attr.entry && csym->ns->entries && proc->ns->entries
2524 && csym->ns->entries->sym == proc->ns->entries->sym)
2526 gfc_error ("Call to ENTRY '%s' at %L is recursive, but subroutine "
2527 "'%s' is not declared as RECURSIVE",
2528 csym->name, &c->loc, csym->ns->entries->sym->name);
2533 /* Switch off assumed size checking and do this again for certain kinds
2534 of procedure, once the procedure itself is resolved. */
2535 need_full_assumed_size++;
2537 if (c->symtree && c->symtree->n.sym)
2538 ptype = c->symtree->n.sym->attr.proc;
2540 if (resolve_actual_arglist (c->ext.actual, ptype) == FAILURE)
2543 /* Resume assumed_size checking. */
2544 need_full_assumed_size--;
2547 if (c->resolved_sym == NULL)
2548 switch (procedure_kind (c->symtree->n.sym))
2551 t = resolve_generic_s (c);
2554 case PTYPE_SPECIFIC:
2555 t = resolve_specific_s (c);
2559 t = resolve_unknown_s (c);
2563 gfc_internal_error ("resolve_subroutine(): bad function type");
2566 /* Some checks of elemental subroutine actual arguments. */
2567 if (resolve_elemental_actual (NULL, c) == FAILURE)
2571 find_noncopying_intrinsics (c->resolved_sym, c->ext.actual);
2576 /* Compare the shapes of two arrays that have non-NULL shapes. If both
2577 op1->shape and op2->shape are non-NULL return SUCCESS if their shapes
2578 match. If both op1->shape and op2->shape are non-NULL return FAILURE
2579 if their shapes do not match. If either op1->shape or op2->shape is
2580 NULL, return SUCCESS. */
2583 compare_shapes (gfc_expr *op1, gfc_expr *op2)
2590 if (op1->shape != NULL && op2->shape != NULL)
2592 for (i = 0; i < op1->rank; i++)
2594 if (mpz_cmp (op1->shape[i], op2->shape[i]) != 0)
2596 gfc_error ("Shapes for operands at %L and %L are not conformable",
2597 &op1->where, &op2->where);
2608 /* Resolve an operator expression node. This can involve replacing the
2609 operation with a user defined function call. */
2612 resolve_operator (gfc_expr *e)
2614 gfc_expr *op1, *op2;
2616 bool dual_locus_error;
2619 /* Resolve all subnodes-- give them types. */
2621 switch (e->value.op.operator)
2624 if (gfc_resolve_expr (e->value.op.op2) == FAILURE)
2627 /* Fall through... */
2630 case INTRINSIC_UPLUS:
2631 case INTRINSIC_UMINUS:
2632 case INTRINSIC_PARENTHESES:
2633 if (gfc_resolve_expr (e->value.op.op1) == FAILURE)
2638 /* Typecheck the new node. */
2640 op1 = e->value.op.op1;
2641 op2 = e->value.op.op2;
2642 dual_locus_error = false;
2644 if ((op1 && op1->expr_type == EXPR_NULL)
2645 || (op2 && op2->expr_type == EXPR_NULL))
2647 sprintf (msg, _("Invalid context for NULL() pointer at %%L"));
2651 switch (e->value.op.operator)
2653 case INTRINSIC_UPLUS:
2654 case INTRINSIC_UMINUS:
2655 if (op1->ts.type == BT_INTEGER
2656 || op1->ts.type == BT_REAL
2657 || op1->ts.type == BT_COMPLEX)
2663 sprintf (msg, _("Operand of unary numeric operator '%s' at %%L is %s"),
2664 gfc_op2string (e->value.op.operator), gfc_typename (&e->ts));
2667 case INTRINSIC_PLUS:
2668 case INTRINSIC_MINUS:
2669 case INTRINSIC_TIMES:
2670 case INTRINSIC_DIVIDE:
2671 case INTRINSIC_POWER:
2672 if (gfc_numeric_ts (&op1->ts) && gfc_numeric_ts (&op2->ts))
2674 gfc_type_convert_binary (e);
2679 _("Operands of binary numeric operator '%s' at %%L are %s/%s"),
2680 gfc_op2string (e->value.op.operator), gfc_typename (&op1->ts),
2681 gfc_typename (&op2->ts));
2684 case INTRINSIC_CONCAT:
2685 if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER)
2687 e->ts.type = BT_CHARACTER;
2688 e->ts.kind = op1->ts.kind;
2693 _("Operands of string concatenation operator at %%L are %s/%s"),
2694 gfc_typename (&op1->ts), gfc_typename (&op2->ts));
2700 case INTRINSIC_NEQV:
2701 if (op1->ts.type == BT_LOGICAL && op2->ts.type == BT_LOGICAL)
2703 e->ts.type = BT_LOGICAL;
2704 e->ts.kind = gfc_kind_max (op1, op2);
2705 if (op1->ts.kind < e->ts.kind)
2706 gfc_convert_type (op1, &e->ts, 2);
2707 else if (op2->ts.kind < e->ts.kind)
2708 gfc_convert_type (op2, &e->ts, 2);
2712 sprintf (msg, _("Operands of logical operator '%s' at %%L are %s/%s"),
2713 gfc_op2string (e->value.op.operator), gfc_typename (&op1->ts),
2714 gfc_typename (&op2->ts));
2719 if (op1->ts.type == BT_LOGICAL)
2721 e->ts.type = BT_LOGICAL;
2722 e->ts.kind = op1->ts.kind;
2726 sprintf (msg, _("Operand of .not. operator at %%L is %s"),
2727 gfc_typename (&op1->ts));
2731 case INTRINSIC_GT_OS:
2733 case INTRINSIC_GE_OS:
2735 case INTRINSIC_LT_OS:
2737 case INTRINSIC_LE_OS:
2738 if (op1->ts.type == BT_COMPLEX || op2->ts.type == BT_COMPLEX)
2740 strcpy (msg, _("COMPLEX quantities cannot be compared at %L"));
2744 /* Fall through... */
2747 case INTRINSIC_EQ_OS:
2749 case INTRINSIC_NE_OS:
2750 if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER)
2752 e->ts.type = BT_LOGICAL;
2753 e->ts.kind = gfc_default_logical_kind;
2757 if (gfc_numeric_ts (&op1->ts) && gfc_numeric_ts (&op2->ts))
2759 gfc_type_convert_binary (e);
2761 e->ts.type = BT_LOGICAL;
2762 e->ts.kind = gfc_default_logical_kind;
2766 if (op1->ts.type == BT_LOGICAL && op2->ts.type == BT_LOGICAL)
2768 _("Logicals at %%L must be compared with %s instead of %s"),
2769 e->value.op.operator == INTRINSIC_EQ ? ".eqv." : ".neqv.",
2770 gfc_op2string (e->value.op.operator));
2773 _("Operands of comparison operator '%s' at %%L are %s/%s"),
2774 gfc_op2string (e->value.op.operator), gfc_typename (&op1->ts),
2775 gfc_typename (&op2->ts));
2779 case INTRINSIC_USER:
2780 if (e->value.op.uop->operator == NULL)
2781 sprintf (msg, _("Unknown operator '%s' at %%L"), e->value.op.uop->name);
2782 else if (op2 == NULL)
2783 sprintf (msg, _("Operand of user operator '%s' at %%L is %s"),
2784 e->value.op.uop->name, gfc_typename (&op1->ts));
2786 sprintf (msg, _("Operands of user operator '%s' at %%L are %s/%s"),
2787 e->value.op.uop->name, gfc_typename (&op1->ts),
2788 gfc_typename (&op2->ts));
2792 case INTRINSIC_PARENTHESES:
2796 gfc_internal_error ("resolve_operator(): Bad intrinsic");
2799 /* Deal with arrayness of an operand through an operator. */
2803 switch (e->value.op.operator)
2805 case INTRINSIC_PLUS:
2806 case INTRINSIC_MINUS:
2807 case INTRINSIC_TIMES:
2808 case INTRINSIC_DIVIDE:
2809 case INTRINSIC_POWER:
2810 case INTRINSIC_CONCAT:
2814 case INTRINSIC_NEQV:
2816 case INTRINSIC_EQ_OS:
2818 case INTRINSIC_NE_OS:
2820 case INTRINSIC_GT_OS:
2822 case INTRINSIC_GE_OS:
2824 case INTRINSIC_LT_OS:
2826 case INTRINSIC_LE_OS:
2828 if (op1->rank == 0 && op2->rank == 0)
2831 if (op1->rank == 0 && op2->rank != 0)
2833 e->rank = op2->rank;
2835 if (e->shape == NULL)
2836 e->shape = gfc_copy_shape (op2->shape, op2->rank);
2839 if (op1->rank != 0 && op2->rank == 0)
2841 e->rank = op1->rank;
2843 if (e->shape == NULL)
2844 e->shape = gfc_copy_shape (op1->shape, op1->rank);
2847 if (op1->rank != 0 && op2->rank != 0)
2849 if (op1->rank == op2->rank)
2851 e->rank = op1->rank;
2852 if (e->shape == NULL)
2854 t = compare_shapes(op1, op2);
2858 e->shape = gfc_copy_shape (op1->shape, op1->rank);
2863 /* Allow higher level expressions to work. */
2866 /* Try user-defined operators, and otherwise throw an error. */
2867 dual_locus_error = true;
2869 _("Inconsistent ranks for operator at %%L and %%L"));
2877 case INTRINSIC_UPLUS:
2878 case INTRINSIC_UMINUS:
2879 case INTRINSIC_PARENTHESES:
2880 e->rank = op1->rank;
2882 if (e->shape == NULL)
2883 e->shape = gfc_copy_shape (op1->shape, op1->rank);
2885 /* Simply copy arrayness attribute */
2892 /* Attempt to simplify the expression. */
2895 t = gfc_simplify_expr (e, 0);
2896 /* Some calls do not succeed in simplification and return FAILURE
2897 even though there is no error; eg. variable references to
2898 PARAMETER arrays. */
2899 if (!gfc_is_constant_expr (e))
2906 if (gfc_extend_expr (e) == SUCCESS)
2909 if (dual_locus_error)
2910 gfc_error (msg, &op1->where, &op2->where);
2912 gfc_error (msg, &e->where);
2918 /************** Array resolution subroutines **************/
2921 { CMP_LT, CMP_EQ, CMP_GT, CMP_UNKNOWN }
2924 /* Compare two integer expressions. */
2927 compare_bound (gfc_expr *a, gfc_expr *b)
2931 if (a == NULL || a->expr_type != EXPR_CONSTANT
2932 || b == NULL || b->expr_type != EXPR_CONSTANT)
2935 if (a->ts.type != BT_INTEGER || b->ts.type != BT_INTEGER)
2936 gfc_internal_error ("compare_bound(): Bad expression");
2938 i = mpz_cmp (a->value.integer, b->value.integer);
2948 /* Compare an integer expression with an integer. */
2951 compare_bound_int (gfc_expr *a, int b)
2955 if (a == NULL || a->expr_type != EXPR_CONSTANT)
2958 if (a->ts.type != BT_INTEGER)
2959 gfc_internal_error ("compare_bound_int(): Bad expression");
2961 i = mpz_cmp_si (a->value.integer, b);
2971 /* Compare an integer expression with a mpz_t. */
2974 compare_bound_mpz_t (gfc_expr *a, mpz_t b)
2978 if (a == NULL || a->expr_type != EXPR_CONSTANT)
2981 if (a->ts.type != BT_INTEGER)
2982 gfc_internal_error ("compare_bound_int(): Bad expression");
2984 i = mpz_cmp (a->value.integer, b);
2994 /* Compute the last value of a sequence given by a triplet.
2995 Return 0 if it wasn't able to compute the last value, or if the
2996 sequence if empty, and 1 otherwise. */
2999 compute_last_value_for_triplet (gfc_expr *start, gfc_expr *end,
3000 gfc_expr *stride, mpz_t last)
3004 if (start == NULL || start->expr_type != EXPR_CONSTANT
3005 || end == NULL || end->expr_type != EXPR_CONSTANT
3006 || (stride != NULL && stride->expr_type != EXPR_CONSTANT))
3009 if (start->ts.type != BT_INTEGER || end->ts.type != BT_INTEGER
3010 || (stride != NULL && stride->ts.type != BT_INTEGER))
3013 if (stride == NULL || compare_bound_int(stride, 1) == CMP_EQ)
3015 if (compare_bound (start, end) == CMP_GT)
3017 mpz_set (last, end->value.integer);
3021 if (compare_bound_int (stride, 0) == CMP_GT)
3023 /* Stride is positive */
3024 if (mpz_cmp (start->value.integer, end->value.integer) > 0)
3029 /* Stride is negative */
3030 if (mpz_cmp (start->value.integer, end->value.integer) < 0)
3035 mpz_sub (rem, end->value.integer, start->value.integer);
3036 mpz_tdiv_r (rem, rem, stride->value.integer);
3037 mpz_sub (last, end->value.integer, rem);
3044 /* Compare a single dimension of an array reference to the array
3048 check_dimension (int i, gfc_array_ref *ar, gfc_array_spec *as)
3052 /* Given start, end and stride values, calculate the minimum and
3053 maximum referenced indexes. */
3061 if (compare_bound (ar->start[i], as->lower[i]) == CMP_LT)
3063 if (compare_bound (ar->start[i], as->upper[i]) == CMP_GT)
3070 #define AR_START (ar->start[i] ? ar->start[i] : as->lower[i])
3071 #define AR_END (ar->end[i] ? ar->end[i] : as->upper[i])
3073 comparison comp_start_end = compare_bound (AR_START, AR_END);
3075 /* Check for zero stride, which is not allowed. */
3076 if (compare_bound_int (ar->stride[i], 0) == CMP_EQ)
3078 gfc_error ("Illegal stride of zero at %L", &ar->c_where[i]);
3082 /* if start == len || (stride > 0 && start < len)
3083 || (stride < 0 && start > len),
3084 then the array section contains at least one element. In this
3085 case, there is an out-of-bounds access if
3086 (start < lower || start > upper). */
3087 if (compare_bound (AR_START, AR_END) == CMP_EQ
3088 || ((compare_bound_int (ar->stride[i], 0) == CMP_GT
3089 || ar->stride[i] == NULL) && comp_start_end == CMP_LT)
3090 || (compare_bound_int (ar->stride[i], 0) == CMP_LT
3091 && comp_start_end == CMP_GT))
3093 if (compare_bound (AR_START, as->lower[i]) == CMP_LT
3094 || compare_bound (AR_START, as->upper[i]) == CMP_GT)
3098 /* If we can compute the highest index of the array section,
3099 then it also has to be between lower and upper. */
3100 mpz_init (last_value);
3101 if (compute_last_value_for_triplet (AR_START, AR_END, ar->stride[i],
3104 if (compare_bound_mpz_t (as->lower[i], last_value) == CMP_GT
3105 || compare_bound_mpz_t (as->upper[i], last_value) == CMP_LT)
3107 mpz_clear (last_value);
3111 mpz_clear (last_value);
3119 gfc_internal_error ("check_dimension(): Bad array reference");
3125 gfc_warning ("Array reference at %L is out of bounds", &ar->c_where[i]);
3130 /* Compare an array reference with an array specification. */
3133 compare_spec_to_ref (gfc_array_ref *ar)
3140 /* TODO: Full array sections are only allowed as actual parameters. */
3141 if (as->type == AS_ASSUMED_SIZE
3142 && (/*ar->type == AR_FULL
3143 ||*/ (ar->type == AR_SECTION
3144 && ar->dimen_type[i] == DIMEN_RANGE && ar->end[i] == NULL)))
3146 gfc_error ("Rightmost upper bound of assumed size array section "
3147 "not specified at %L", &ar->where);
3151 if (ar->type == AR_FULL)
3154 if (as->rank != ar->dimen)
3156 gfc_error ("Rank mismatch in array reference at %L (%d/%d)",
3157 &ar->where, ar->dimen, as->rank);
3161 for (i = 0; i < as->rank; i++)
3162 if (check_dimension (i, ar, as) == FAILURE)
3169 /* Resolve one part of an array index. */
3172 gfc_resolve_index (gfc_expr *index, int check_scalar)
3179 if (gfc_resolve_expr (index) == FAILURE)
3182 if (check_scalar && index->rank != 0)
3184 gfc_error ("Array index at %L must be scalar", &index->where);
3188 if (index->ts.type != BT_INTEGER && index->ts.type != BT_REAL)
3190 gfc_error ("Array index at %L must be of INTEGER type",
3195 if (index->ts.type == BT_REAL)
3196 if (gfc_notify_std (GFC_STD_LEGACY, "Extension: REAL array index at %L",
3197 &index->where) == FAILURE)
3200 if (index->ts.kind != gfc_index_integer_kind
3201 || index->ts.type != BT_INTEGER)
3204 ts.type = BT_INTEGER;
3205 ts.kind = gfc_index_integer_kind;
3207 gfc_convert_type_warn (index, &ts, 2, 0);
3213 /* Resolve a dim argument to an intrinsic function. */
3216 gfc_resolve_dim_arg (gfc_expr *dim)
3221 if (gfc_resolve_expr (dim) == FAILURE)
3226 gfc_error ("Argument dim at %L must be scalar", &dim->where);
3230 if (dim->ts.type != BT_INTEGER)
3232 gfc_error ("Argument dim at %L must be of INTEGER type", &dim->where);
3235 if (dim->ts.kind != gfc_index_integer_kind)
3239 ts.type = BT_INTEGER;
3240 ts.kind = gfc_index_integer_kind;
3242 gfc_convert_type_warn (dim, &ts, 2, 0);
3248 /* Given an expression that contains array references, update those array
3249 references to point to the right array specifications. While this is
3250 filled in during matching, this information is difficult to save and load
3251 in a module, so we take care of it here.
3253 The idea here is that the original array reference comes from the
3254 base symbol. We traverse the list of reference structures, setting
3255 the stored reference to references. Component references can
3256 provide an additional array specification. */
3259 find_array_spec (gfc_expr *e)
3263 gfc_symbol *derived;
3266 as = e->symtree->n.sym->as;
3269 for (ref = e->ref; ref; ref = ref->next)
3274 gfc_internal_error ("find_array_spec(): Missing spec");
3281 if (derived == NULL)
3282 derived = e->symtree->n.sym->ts.derived;
3284 c = derived->components;
3286 for (; c; c = c->next)
3287 if (c == ref->u.c.component)
3289 /* Track the sequence of component references. */
3290 if (c->ts.type == BT_DERIVED)
3291 derived = c->ts.derived;
3296 gfc_internal_error ("find_array_spec(): Component not found");
3301 gfc_internal_error ("find_array_spec(): unused as(1)");
3312 gfc_internal_error ("find_array_spec(): unused as(2)");
3316 /* Resolve an array reference. */
3319 resolve_array_ref (gfc_array_ref *ar)
3321 int i, check_scalar;
3324 for (i = 0; i < ar->dimen; i++)
3326 check_scalar = ar->dimen_type[i] == DIMEN_RANGE;
3328 if (gfc_resolve_index (ar->start[i], check_scalar) == FAILURE)
3330 if (gfc_resolve_index (ar->end[i], check_scalar) == FAILURE)
3332 if (gfc_resolve_index (ar->stride[i], check_scalar) == FAILURE)
3337 if (ar->dimen_type[i] == DIMEN_UNKNOWN)
3341 ar->dimen_type[i] = DIMEN_ELEMENT;
3345 ar->dimen_type[i] = DIMEN_VECTOR;
3346 if (e->expr_type == EXPR_VARIABLE
3347 && e->symtree->n.sym->ts.type == BT_DERIVED)
3348 ar->start[i] = gfc_get_parentheses (e);
3352 gfc_error ("Array index at %L is an array of rank %d",
3353 &ar->c_where[i], e->rank);
3358 /* If the reference type is unknown, figure out what kind it is. */
3360 if (ar->type == AR_UNKNOWN)
3362 ar->type = AR_ELEMENT;
3363 for (i = 0; i < ar->dimen; i++)
3364 if (ar->dimen_type[i] == DIMEN_RANGE
3365 || ar->dimen_type[i] == DIMEN_VECTOR)
3367 ar->type = AR_SECTION;
3372 if (!ar->as->cray_pointee && compare_spec_to_ref (ar) == FAILURE)
3380 resolve_substring (gfc_ref *ref)
3382 if (ref->u.ss.start != NULL)
3384 if (gfc_resolve_expr (ref->u.ss.start) == FAILURE)
3387 if (ref->u.ss.start->ts.type != BT_INTEGER)
3389 gfc_error ("Substring start index at %L must be of type INTEGER",
3390 &ref->u.ss.start->where);
3394 if (ref->u.ss.start->rank != 0)
3396 gfc_error ("Substring start index at %L must be scalar",
3397 &ref->u.ss.start->where);
3401 if (compare_bound_int (ref->u.ss.start, 1) == CMP_LT
3402 && (compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_EQ
3403 || compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_GT))
3405 gfc_error ("Substring start index at %L is less than one",
3406 &ref->u.ss.start->where);
3411 if (ref->u.ss.end != NULL)
3413 if (gfc_resolve_expr (ref->u.ss.end) == FAILURE)
3416 if (ref->u.ss.end->ts.type != BT_INTEGER)
3418 gfc_error ("Substring end index at %L must be of type INTEGER",
3419 &ref->u.ss.end->where);
3423 if (ref->u.ss.end->rank != 0)
3425 gfc_error ("Substring end index at %L must be scalar",
3426 &ref->u.ss.end->where);
3430 if (ref->u.ss.length != NULL
3431 && compare_bound (ref->u.ss.end, ref->u.ss.length->length) == CMP_GT
3432 && (compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_EQ
3433 || compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_GT))
3435 gfc_error ("Substring end index at %L exceeds the string length",
3436 &ref->u.ss.start->where);
3445 /* Resolve subtype references. */
3448 resolve_ref (gfc_expr *expr)
3450 int current_part_dimension, n_components, seen_part_dimension;
3453 for (ref = expr->ref; ref; ref = ref->next)
3454 if (ref->type == REF_ARRAY && ref->u.ar.as == NULL)
3456 find_array_spec (expr);
3460 for (ref = expr->ref; ref; ref = ref->next)
3464 if (resolve_array_ref (&ref->u.ar) == FAILURE)
3472 resolve_substring (ref);
3476 /* Check constraints on part references. */
3478 current_part_dimension = 0;
3479 seen_part_dimension = 0;
3482 for (ref = expr->ref; ref; ref = ref->next)
3487 switch (ref->u.ar.type)
3491 current_part_dimension = 1;
3495 current_part_dimension = 0;
3499 gfc_internal_error ("resolve_ref(): Bad array reference");
3505 if (current_part_dimension || seen_part_dimension)
3507 if (ref->u.c.component->pointer)
3509 gfc_error ("Component to the right of a part reference "
3510 "with nonzero rank must not have the POINTER "
3511 "attribute at %L", &expr->where);
3514 else if (ref->u.c.component->allocatable)
3516 gfc_error ("Component to the right of a part reference "
3517 "with nonzero rank must not have the ALLOCATABLE "
3518 "attribute at %L", &expr->where);
3530 if (((ref->type == REF_COMPONENT && n_components > 1)
3531 || ref->next == NULL)
3532 && current_part_dimension
3533 && seen_part_dimension)
3535 gfc_error ("Two or more part references with nonzero rank must "
3536 "not be specified at %L", &expr->where);
3540 if (ref->type == REF_COMPONENT)
3542 if (current_part_dimension)
3543 seen_part_dimension = 1;
3545 /* reset to make sure */
3546 current_part_dimension = 0;
3554 /* Given an expression, determine its shape. This is easier than it sounds.
3555 Leaves the shape array NULL if it is not possible to determine the shape. */
3558 expression_shape (gfc_expr *e)
3560 mpz_t array[GFC_MAX_DIMENSIONS];
3563 if (e->rank == 0 || e->shape != NULL)
3566 for (i = 0; i < e->rank; i++)
3567 if (gfc_array_dimen_size (e, i, &array[i]) == FAILURE)
3570 e->shape = gfc_get_shape (e->rank);
3572 memcpy (e->shape, array, e->rank * sizeof (mpz_t));
3577 for (i--; i >= 0; i--)
3578 mpz_clear (array[i]);
3582 /* Given a variable expression node, compute the rank of the expression by
3583 examining the base symbol and any reference structures it may have. */
3586 expression_rank (gfc_expr *e)
3593 if (e->expr_type == EXPR_ARRAY)
3595 /* Constructors can have a rank different from one via RESHAPE(). */
3597 if (e->symtree == NULL)
3603 e->rank = (e->symtree->n.sym->as == NULL)
3604 ? 0 : e->symtree->n.sym->as->rank;
3610 for (ref = e->ref; ref; ref = ref->next)
3612 if (ref->type != REF_ARRAY)
3615 if (ref->u.ar.type == AR_FULL)
3617 rank = ref->u.ar.as->rank;
3621 if (ref->u.ar.type == AR_SECTION)
3623 /* Figure out the rank of the section. */
3625 gfc_internal_error ("expression_rank(): Two array specs");
3627 for (i = 0; i < ref->u.ar.dimen; i++)
3628 if (ref->u.ar.dimen_type[i] == DIMEN_RANGE
3629 || ref->u.ar.dimen_type[i] == DIMEN_VECTOR)
3639 expression_shape (e);
3643 /* Resolve a variable expression. */
3646 resolve_variable (gfc_expr *e)
3653 if (e->symtree == NULL)
3656 if (e->ref && resolve_ref (e) == FAILURE)
3659 sym = e->symtree->n.sym;
3660 if (sym->attr.flavor == FL_PROCEDURE && !sym->attr.function)
3662 e->ts.type = BT_PROCEDURE;
3666 if (sym->ts.type != BT_UNKNOWN)
3667 gfc_variable_attr (e, &e->ts);
3670 /* Must be a simple variable reference. */
3671 if (gfc_set_default_type (sym, 1, sym->ns) == FAILURE)
3676 if (check_assumed_size_reference (sym, e))
3679 /* Deal with forward references to entries during resolve_code, to
3680 satisfy, at least partially, 12.5.2.5. */
3681 if (gfc_current_ns->entries
3682 && current_entry_id == sym->entry_id
3685 && cs_base->current->op != EXEC_ENTRY)
3687 gfc_entry_list *entry;
3688 gfc_formal_arglist *formal;
3692 /* If the symbol is a dummy... */
3693 if (sym->attr.dummy)
3695 entry = gfc_current_ns->entries;
3698 /* ...test if the symbol is a parameter of previous entries. */
3699 for (; entry && entry->id <= current_entry_id; entry = entry->next)
3700 for (formal = entry->sym->formal; formal; formal = formal->next)
3702 if (formal->sym && sym->name == formal->sym->name)
3706 /* If it has not been seen as a dummy, this is an error. */
3709 if (specification_expr)
3710 gfc_error ("Variable '%s',used in a specification expression, "
3711 "is referenced at %L before the ENTRY statement "
3712 "in which it is a parameter",
3713 sym->name, &cs_base->current->loc);
3715 gfc_error ("Variable '%s' is used at %L before the ENTRY "
3716 "statement in which it is a parameter",
3717 sym->name, &cs_base->current->loc);
3722 /* Now do the same check on the specification expressions. */
3723 specification_expr = 1;
3724 if (sym->ts.type == BT_CHARACTER
3725 && gfc_resolve_expr (sym->ts.cl->length) == FAILURE)
3729 for (n = 0; n < sym->as->rank; n++)
3731 specification_expr = 1;
3732 if (gfc_resolve_expr (sym->as->lower[n]) == FAILURE)
3734 specification_expr = 1;
3735 if (gfc_resolve_expr (sym->as->upper[n]) == FAILURE)
3738 specification_expr = 0;
3741 /* Update the symbol's entry level. */
3742 sym->entry_id = current_entry_id + 1;
3749 /* Checks to see that the correct symbol has been host associated.
3750 The only situation where this arises is that in which a twice
3751 contained function is parsed after the host association is made.
3752 Therefore, on detecting this, the line is rematched, having got
3753 rid of the existing references and actual_arg_list. */
3755 check_host_association (gfc_expr *e)
3757 gfc_symbol *sym, *old_sym;
3761 bool retval = e->expr_type == EXPR_FUNCTION;
3763 if (e->symtree == NULL || e->symtree->n.sym == NULL)
3766 old_sym = e->symtree->n.sym;
3768 if (old_sym->attr.use_assoc)
3771 if (gfc_current_ns->parent
3772 && gfc_current_ns->parent->parent
3773 && old_sym->ns != gfc_current_ns)
3775 gfc_find_symbol (old_sym->name, gfc_current_ns->parent, 1, &sym);
3776 if (sym && old_sym != sym && sym->attr.flavor == FL_PROCEDURE)
3778 temp_locus = gfc_current_locus;
3779 gfc_current_locus = e->where;
3781 gfc_buffer_error (1);
3783 gfc_free_ref_list (e->ref);
3788 gfc_free_actual_arglist (e->value.function.actual);
3789 e->value.function.actual = NULL;
3792 if (e->shape != NULL)
3794 for (n = 0; n < e->rank; n++)
3795 mpz_clear (e->shape[n]);
3797 gfc_free (e->shape);
3800 gfc_match_rvalue (&expr);
3802 gfc_buffer_error (0);
3804 gcc_assert (expr && sym == expr->symtree->n.sym);
3810 gfc_current_locus = temp_locus;
3813 /* This might have changed! */
3814 return e->expr_type == EXPR_FUNCTION;
3818 /* Resolve an expression. That is, make sure that types of operands agree
3819 with their operators, intrinsic operators are converted to function calls
3820 for overloaded types and unresolved function references are resolved. */
3823 gfc_resolve_expr (gfc_expr *e)
3830 switch (e->expr_type)
3833 t = resolve_operator (e);
3839 if (check_host_association (e))
3840 t = resolve_function (e);
3843 t = resolve_variable (e);
3845 expression_rank (e);
3849 case EXPR_SUBSTRING:
3850 t = resolve_ref (e);
3860 if (resolve_ref (e) == FAILURE)
3863 t = gfc_resolve_array_constructor (e);
3864 /* Also try to expand a constructor. */
3867 expression_rank (e);
3868 gfc_expand_constructor (e);
3871 /* This provides the opportunity for the length of constructors with
3872 character valued function elements to propagate the string length
3873 to the expression. */
3874 if (e->ts.type == BT_CHARACTER)
3875 gfc_resolve_character_array_constructor (e);
3879 case EXPR_STRUCTURE:
3880 t = resolve_ref (e);
3884 t = resolve_structure_cons (e);
3888 t = gfc_simplify_expr (e, 0);
3892 gfc_internal_error ("gfc_resolve_expr(): Bad expression type");
3899 /* Resolve an expression from an iterator. They must be scalar and have
3900 INTEGER or (optionally) REAL type. */
3903 gfc_resolve_iterator_expr (gfc_expr *expr, bool real_ok,
3904 const char *name_msgid)
3906 if (gfc_resolve_expr (expr) == FAILURE)
3909 if (expr->rank != 0)
3911 gfc_error ("%s at %L must be a scalar", _(name_msgid), &expr->where);
3915 if (expr->ts.type != BT_INTEGER)
3917 if (expr->ts.type == BT_REAL)
3920 return gfc_notify_std (GFC_STD_F95_DEL,
3921 "Deleted feature: %s at %L must be integer",
3922 _(name_msgid), &expr->where);
3925 gfc_error ("%s at %L must be INTEGER", _(name_msgid),
3932 gfc_error ("%s at %L must be INTEGER", _(name_msgid), &expr->where);
3940 /* Resolve the expressions in an iterator structure. If REAL_OK is
3941 false allow only INTEGER type iterators, otherwise allow REAL types. */
3944 gfc_resolve_iterator (gfc_iterator *iter, bool real_ok)
3946 if (gfc_resolve_iterator_expr (iter->var, real_ok, "Loop variable")
3950 if (gfc_pure (NULL) && gfc_impure_variable (iter->var->symtree->n.sym))
3952 gfc_error ("Cannot assign to loop variable in PURE procedure at %L",
3957 if (gfc_resolve_iterator_expr (iter->start, real_ok,
3958 "Start expression in DO loop") == FAILURE)
3961 if (gfc_resolve_iterator_expr (iter->end, real_ok,
3962 "End expression in DO loop") == FAILURE)
3965 if (gfc_resolve_iterator_expr (iter->step, real_ok,
3966 "Step expression in DO loop") == FAILURE)
3969 if (iter->step->expr_type == EXPR_CONSTANT)
3971 if ((iter->step->ts.type == BT_INTEGER
3972 && mpz_cmp_ui (iter->step->value.integer, 0) == 0)
3973 || (iter->step->ts.type == BT_REAL
3974 && mpfr_sgn (iter->step->value.real) == 0))
3976 gfc_error ("Step expression in DO loop at %L cannot be zero",
3977 &iter->step->where);
3982 /* Convert start, end, and step to the same type as var. */
3983 if (iter->start->ts.kind != iter->var->ts.kind
3984 || iter->start->ts.type != iter->var->ts.type)
3985 gfc_convert_type (iter->start, &iter->var->ts, 2);
3987 if (iter->end->ts.kind != iter->var->ts.kind
3988 || iter->end->ts.type != iter->var->ts.type)
3989 gfc_convert_type (iter->end, &iter->var->ts, 2);
3991 if (iter->step->ts.kind != iter->var->ts.kind
3992 || iter->step->ts.type != iter->var->ts.type)
3993 gfc_convert_type (iter->step, &iter->var->ts, 2);
3999 /* Resolve a list of FORALL iterators. The FORALL index-name is constrained
4000 to be a scalar INTEGER variable. The subscripts and stride are scalar
4001 INTEGERs, and if stride is a constant it must be nonzero. */
4004 resolve_forall_iterators (gfc_forall_iterator *iter)
4008 if (gfc_resolve_expr (iter->var) == SUCCESS
4009 && (iter->var->ts.type != BT_INTEGER || iter->var->rank != 0))
4010 gfc_error ("FORALL index-name at %L must be a scalar INTEGER",
4013 if (gfc_resolve_expr (iter->start) == SUCCESS
4014 && (iter->start->ts.type != BT_INTEGER || iter->start->rank != 0))
4015 gfc_error ("FORALL start expression at %L must be a scalar INTEGER",
4016 &iter->start->where);
4017 if (iter->var->ts.kind != iter->start->ts.kind)
4018 gfc_convert_type (iter->start, &iter->var->ts, 2);
4020 if (gfc_resolve_expr (iter->end) == SUCCESS
4021 && (iter->end->ts.type != BT_INTEGER || iter->end->rank != 0))
4022 gfc_error ("FORALL end expression at %L must be a scalar INTEGER",
4024 if (iter->var->ts.kind != iter->end->ts.kind)
4025 gfc_convert_type (iter->end, &iter->var->ts, 2);
4027 if (gfc_resolve_expr (iter->stride) == SUCCESS)
4029 if (iter->stride->ts.type != BT_INTEGER || iter->stride->rank != 0)
4030 gfc_error ("FORALL stride expression at %L must be a scalar %s",
4031 &iter->stride->where, "INTEGER");
4033 if (iter->stride->expr_type == EXPR_CONSTANT
4034 && mpz_cmp_ui(iter->stride->value.integer, 0) == 0)
4035 gfc_error ("FORALL stride expression at %L cannot be zero",
4036 &iter->stride->where);
4038 if (iter->var->ts.kind != iter->stride->ts.kind)
4039 gfc_convert_type (iter->stride, &iter->var->ts, 2);
4046 /* Given a pointer to a symbol that is a derived type, see if any components
4047 have the POINTER attribute. The search is recursive if necessary.
4048 Returns zero if no pointer components are found, nonzero otherwise. */
4051 derived_pointer (gfc_symbol *sym)
4055 for (c = sym->components; c; c = c->next)
4060 if (c->ts.type == BT_DERIVED && derived_pointer (c->ts.derived))
4068 /* Given a pointer to a symbol that is a derived type, see if it's
4069 inaccessible, i.e. if it's defined in another module and the components are
4070 PRIVATE. The search is recursive if necessary. Returns zero if no
4071 inaccessible components are found, nonzero otherwise. */
4074 derived_inaccessible (gfc_symbol *sym)
4078 if (sym->attr.use_assoc && sym->component_access == ACCESS_PRIVATE)
4081 for (c = sym->components; c; c = c->next)
4083 if (c->ts.type == BT_DERIVED && derived_inaccessible (c->ts.derived))
4091 /* Resolve the argument of a deallocate expression. The expression must be
4092 a pointer or a full array. */
4095 resolve_deallocate_expr (gfc_expr *e)
4097 symbol_attribute attr;
4098 int allocatable, pointer, check_intent_in;
4101 /* Check INTENT(IN), unless the object is a sub-component of a pointer. */
4102 check_intent_in = 1;
4104 if (gfc_resolve_expr (e) == FAILURE)
4107 if (e->expr_type != EXPR_VARIABLE)
4110 allocatable = e->symtree->n.sym->attr.allocatable;
4111 pointer = e->symtree->n.sym->attr.pointer;
4112 for (ref = e->ref; ref; ref = ref->next)
4115 check_intent_in = 0;
4120 if (ref->u.ar.type != AR_FULL)
4125 allocatable = (ref->u.c.component->as != NULL
4126 && ref->u.c.component->as->type == AS_DEFERRED);
4127 pointer = ref->u.c.component->pointer;
4136 attr = gfc_expr_attr (e);
4138 if (allocatable == 0 && attr.pointer == 0)
4141 gfc_error ("Expression in DEALLOCATE statement at %L must be "
4142 "ALLOCATABLE or a POINTER", &e->where);
4146 && e->symtree->n.sym->attr.intent == INTENT_IN)
4148 gfc_error ("Cannot deallocate INTENT(IN) variable '%s' at %L",
4149 e->symtree->n.sym->name, &e->where);
4157 /* Returns true if the expression e contains a reference the symbol sym. */
4159 find_sym_in_expr (gfc_symbol *sym, gfc_expr *e)
4161 gfc_actual_arglist *arg;
4169 switch (e->expr_type)
4172 for (arg = e->value.function.actual; arg; arg = arg->next)
4173 rv = rv || find_sym_in_expr (sym, arg->expr);
4176 /* If the variable is not the same as the dependent, 'sym', and
4177 it is not marked as being declared and it is in the same
4178 namespace as 'sym', add it to the local declarations. */
4180 if (sym == e->symtree->n.sym)
4185 rv = rv || find_sym_in_expr (sym, e->value.op.op1);
4186 rv = rv || find_sym_in_expr (sym, e->value.op.op2);
4195 for (ref = e->ref; ref; ref = ref->next)
4200 for (i = 0; i < ref->u.ar.dimen; i++)
4202 rv = rv || find_sym_in_expr (sym, ref->u.ar.start[i]);
4203 rv = rv || find_sym_in_expr (sym, ref->u.ar.end[i]);
4204 rv = rv || find_sym_in_expr (sym, ref->u.ar.stride[i]);
4209 rv = rv || find_sym_in_expr (sym, ref->u.ss.start);
4210 rv = rv || find_sym_in_expr (sym, ref->u.ss.end);
4214 if (ref->u.c.component->ts.type == BT_CHARACTER
4215 && ref->u.c.component->ts.cl->length->expr_type
4218 || find_sym_in_expr (sym,
4219 ref->u.c.component->ts.cl->length);
4221 if (ref->u.c.component->as)
4222 for (i = 0; i < ref->u.c.component->as->rank; i++)
4225 || find_sym_in_expr (sym,
4226 ref->u.c.component->as->lower[i]);
4228 || find_sym_in_expr (sym,
4229 ref->u.c.component->as->upper[i]);
4239 /* Given the expression node e for an allocatable/pointer of derived type to be
4240 allocated, get the expression node to be initialized afterwards (needed for
4241 derived types with default initializers, and derived types with allocatable
4242 components that need nullification.) */
4245 expr_to_initialize (gfc_expr *e)
4251 result = gfc_copy_expr (e);
4253 /* Change the last array reference from AR_ELEMENT to AR_FULL. */
4254 for (ref = result->ref; ref; ref = ref->next)
4255 if (ref->type == REF_ARRAY && ref->next == NULL)
4257 ref->u.ar.type = AR_FULL;
4259 for (i = 0; i < ref->u.ar.dimen; i++)
4260 ref->u.ar.start[i] = ref->u.ar.end[i] = ref->u.ar.stride[i] = NULL;
4262 result->rank = ref->u.ar.dimen;
4270 /* Resolve the expression in an ALLOCATE statement, doing the additional
4271 checks to see whether the expression is OK or not. The expression must
4272 have a trailing array reference that gives the size of the array. */
4275 resolve_allocate_expr (gfc_expr *e, gfc_code *code)
4277 int i, pointer, allocatable, dimension, check_intent_in;
4278 symbol_attribute attr;
4279 gfc_ref *ref, *ref2;
4286 /* Check INTENT(IN), unless the object is a sub-component of a pointer. */
4287 check_intent_in = 1;
4289 if (gfc_resolve_expr (e) == FAILURE)
4292 if (code->expr && code->expr->expr_type == EXPR_VARIABLE)
4293 sym = code->expr->symtree->n.sym;
4297 /* Make sure the expression is allocatable or a pointer. If it is
4298 pointer, the next-to-last reference must be a pointer. */
4302 if (e->expr_type != EXPR_VARIABLE)
4305 attr = gfc_expr_attr (e);
4306 pointer = attr.pointer;
4307 dimension = attr.dimension;
4311 allocatable = e->symtree->n.sym->attr.allocatable;
4312 pointer = e->symtree->n.sym->attr.pointer;
4313 dimension = e->symtree->n.sym->attr.dimension;
4315 if (sym == e->symtree->n.sym && sym->ts.type != BT_DERIVED)
4317 gfc_error ("The STAT variable '%s' in an ALLOCATE statement must "
4318 "not be allocated in the same statement at %L",
4319 sym->name, &e->where);
4323 for (ref = e->ref; ref; ref2 = ref, ref = ref->next)
4326 check_intent_in = 0;
4331 if (ref->next != NULL)
4336 allocatable = (ref->u.c.component->as != NULL
4337 && ref->u.c.component->as->type == AS_DEFERRED);
4339 pointer = ref->u.c.component->pointer;
4340 dimension = ref->u.c.component->dimension;
4351 if (allocatable == 0 && pointer == 0)
4353 gfc_error ("Expression in ALLOCATE statement at %L must be "
4354 "ALLOCATABLE or a POINTER", &e->where);
4359 && e->symtree->n.sym->attr.intent == INTENT_IN)
4361 gfc_error ("Cannot allocate INTENT(IN) variable '%s' at %L",
4362 e->symtree->n.sym->name, &e->where);
4366 /* Add default initializer for those derived types that need them. */
4367 if (e->ts.type == BT_DERIVED && (init_e = gfc_default_initializer (&e->ts)))
4369 init_st = gfc_get_code ();
4370 init_st->loc = code->loc;
4371 init_st->op = EXEC_INIT_ASSIGN;
4372 init_st->expr = expr_to_initialize (e);
4373 init_st->expr2 = init_e;
4374 init_st->next = code->next;
4375 code->next = init_st;
4378 if (pointer && dimension == 0)
4381 /* Make sure the next-to-last reference node is an array specification. */
4383 if (ref2 == NULL || ref2->type != REF_ARRAY || ref2->u.ar.type == AR_FULL)
4385 gfc_error ("Array specification required in ALLOCATE statement "
4386 "at %L", &e->where);
4390 /* Make sure that the array section reference makes sense in the
4391 context of an ALLOCATE specification. */
4395 for (i = 0; i < ar->dimen; i++)
4397 if (ref2->u.ar.type == AR_ELEMENT)
4400 switch (ar->dimen_type[i])
4406 if (ar->start[i] != NULL
4407 && ar->end[i] != NULL
4408 && ar->stride[i] == NULL)
4411 /* Fall Through... */
4415 gfc_error ("Bad array specification in ALLOCATE statement at %L",
4422 for (a = code->ext.alloc_list; a; a = a->next)
4424 sym = a->expr->symtree->n.sym;
4426 /* TODO - check derived type components. */
4427 if (sym->ts.type == BT_DERIVED)
4430 if ((ar->start[i] != NULL && find_sym_in_expr (sym, ar->start[i]))
4431 || (ar->end[i] != NULL && find_sym_in_expr (sym, ar->end[i])))
4433 gfc_error ("'%s' must not appear an the array specification at "
4434 "%L in the same ALLOCATE statement where it is "
4435 "itself allocated", sym->name, &ar->where);
4445 /************ SELECT CASE resolution subroutines ************/
4447 /* Callback function for our mergesort variant. Determines interval
4448 overlaps for CASEs. Return <0 if op1 < op2, 0 for overlap, >0 for
4449 op1 > op2. Assumes we're not dealing with the default case.
4450 We have op1 = (:L), (K:L) or (K:) and op2 = (:N), (M:N) or (M:).
4451 There are nine situations to check. */
4454 compare_cases (const gfc_case *op1, const gfc_case *op2)
4458 if (op1->low == NULL) /* op1 = (:L) */
4460 /* op2 = (:N), so overlap. */
4462 /* op2 = (M:) or (M:N), L < M */
4463 if (op2->low != NULL
4464 && gfc_compare_expr (op1->high, op2->low) < 0)
4467 else if (op1->high == NULL) /* op1 = (K:) */
4469 /* op2 = (M:), so overlap. */
4471 /* op2 = (:N) or (M:N), K > N */
4472 if (op2->high != NULL
4473 && gfc_compare_expr (op1->low, op2->high) > 0)
4476 else /* op1 = (K:L) */
4478 if (op2->low == NULL) /* op2 = (:N), K > N */
4479 retval = (gfc_compare_expr (op1->low, op2->high) > 0) ? 1 : 0;
4480 else if (op2->high == NULL) /* op2 = (M:), L < M */
4481 retval = (gfc_compare_expr (op1->high, op2->low) < 0) ? -1 : 0;
4482 else /* op2 = (M:N) */
4486 if (gfc_compare_expr (op1->high, op2->low) < 0)
4489 else if (gfc_compare_expr (op1->low, op2->high) > 0)
4498 /* Merge-sort a double linked case list, detecting overlap in the
4499 process. LIST is the head of the double linked case list before it
4500 is sorted. Returns the head of the sorted list if we don't see any
4501 overlap, or NULL otherwise. */
4504 check_case_overlap (gfc_case *list)
4506 gfc_case *p, *q, *e, *tail;
4507 int insize, nmerges, psize, qsize, cmp, overlap_seen;
4509 /* If the passed list was empty, return immediately. */
4516 /* Loop unconditionally. The only exit from this loop is a return
4517 statement, when we've finished sorting the case list. */
4524 /* Count the number of merges we do in this pass. */
4527 /* Loop while there exists a merge to be done. */
4532 /* Count this merge. */
4535 /* Cut the list in two pieces by stepping INSIZE places
4536 forward in the list, starting from P. */
4539 for (i = 0; i < insize; i++)
4548 /* Now we have two lists. Merge them! */
4549 while (psize > 0 || (qsize > 0 && q != NULL))
4551 /* See from which the next case to merge comes from. */
4554 /* P is empty so the next case must come from Q. */
4559 else if (qsize == 0 || q == NULL)
4568 cmp = compare_cases (p, q);
4571 /* The whole case range for P is less than the
4579 /* The whole case range for Q is greater than
4580 the case range for P. */
4587 /* The cases overlap, or they are the same
4588 element in the list. Either way, we must
4589 issue an error and get the next case from P. */
4590 /* FIXME: Sort P and Q by line number. */
4591 gfc_error ("CASE label at %L overlaps with CASE "
4592 "label at %L", &p->where, &q->where);
4600 /* Add the next element to the merged list. */
4609 /* P has now stepped INSIZE places along, and so has Q. So
4610 they're the same. */
4615 /* If we have done only one merge or none at all, we've
4616 finished sorting the cases. */
4625 /* Otherwise repeat, merging lists twice the size. */
4631 /* Check to see if an expression is suitable for use in a CASE statement.
4632 Makes sure that all case expressions are scalar constants of the same
4633 type. Return FAILURE if anything is wrong. */
4636 validate_case_label_expr (gfc_expr *e, gfc_expr *case_expr)
4638 if (e == NULL) return SUCCESS;
4640 if (e->ts.type != case_expr->ts.type)
4642 gfc_error ("Expression in CASE statement at %L must be of type %s",
4643 &e->where, gfc_basic_typename (case_expr->ts.type));
4647 /* C805 (R808) For a given case-construct, each case-value shall be of
4648 the same type as case-expr. For character type, length differences
4649 are allowed, but the kind type parameters shall be the same. */
4651 if (case_expr->ts.type == BT_CHARACTER && e->ts.kind != case_expr->ts.kind)
4653 gfc_error("Expression in CASE statement at %L must be kind %d",
4654 &e->where, case_expr->ts.kind);
4658 /* Convert the case value kind to that of case expression kind, if needed.
4659 FIXME: Should a warning be issued? */
4660 if (e->ts.kind != case_expr->ts.kind)
4661 gfc_convert_type_warn (e, &case_expr->ts, 2, 0);
4665 gfc_error ("Expression in CASE statement at %L must be scalar",
4674 /* Given a completely parsed select statement, we:
4676 - Validate all expressions and code within the SELECT.
4677 - Make sure that the selection expression is not of the wrong type.
4678 - Make sure that no case ranges overlap.
4679 - Eliminate unreachable cases and unreachable code resulting from
4680 removing case labels.
4682 The standard does allow unreachable cases, e.g. CASE (5:3). But
4683 they are a hassle for code generation, and to prevent that, we just
4684 cut them out here. This is not necessary for overlapping cases
4685 because they are illegal and we never even try to generate code.
4687 We have the additional caveat that a SELECT construct could have
4688 been a computed GOTO in the source code. Fortunately we can fairly
4689 easily work around that here: The case_expr for a "real" SELECT CASE
4690 is in code->expr1, but for a computed GOTO it is in code->expr2. All
4691 we have to do is make sure that the case_expr is a scalar integer
4695 resolve_select (gfc_code *code)
4698 gfc_expr *case_expr;
4699 gfc_case *cp, *default_case, *tail, *head;
4700 int seen_unreachable;
4706 if (code->expr == NULL)
4708 /* This was actually a computed GOTO statement. */
4709 case_expr = code->expr2;
4710 if (case_expr->ts.type != BT_INTEGER|| case_expr->rank != 0)
4711 gfc_error ("Selection expression in computed GOTO statement "
4712 "at %L must be a scalar integer expression",
4715 /* Further checking is not necessary because this SELECT was built
4716 by the compiler, so it should always be OK. Just move the
4717 case_expr from expr2 to expr so that we can handle computed
4718 GOTOs as normal SELECTs from here on. */
4719 code->expr = code->expr2;
4724 case_expr = code->expr;
4726 type = case_expr->ts.type;
4727 if (type != BT_LOGICAL && type != BT_INTEGER && type != BT_CHARACTER)
4729 gfc_error ("Argument of SELECT statement at %L cannot be %s",
4730 &case_expr->where, gfc_typename (&case_expr->ts));
4732 /* Punt. Going on here just produce more garbage error messages. */
4736 if (case_expr->rank != 0)
4738 gfc_error ("Argument of SELECT statement at %L must be a scalar "
4739 "expression", &case_expr->where);
4745 /* PR 19168 has a long discussion concerning a mismatch of the kinds
4746 of the SELECT CASE expression and its CASE values. Walk the lists
4747 of case values, and if we find a mismatch, promote case_expr to
4748 the appropriate kind. */
4750 if (type == BT_LOGICAL || type == BT_INTEGER)
4752 for (body = code->block; body; body = body->block)
4754 /* Walk the case label list. */
4755 for (cp = body->ext.case_list; cp; cp = cp->next)
4757 /* Intercept the DEFAULT case. It does not have a kind. */
4758 if (cp->low == NULL && cp->high == NULL)
4761 /* Unreachable case ranges are discarded, so ignore. */
4762 if (cp->low != NULL && cp->high != NULL
4763 && cp->low != cp->high
4764 && gfc_compare_expr (cp->low, cp->high) > 0)
4767 /* FIXME: Should a warning be issued? */
4769 && case_expr->ts.kind != gfc_kind_max(case_expr, cp->low))
4770 gfc_convert_type_warn (case_expr, &cp->low->ts, 2, 0);
4772 if (cp->high != NULL
4773 && case_expr->ts.kind != gfc_kind_max(case_expr, cp->high))
4774 gfc_convert_type_warn (case_expr, &cp->high->ts, 2, 0);
4779 /* Assume there is no DEFAULT case. */
4780 default_case = NULL;
4785 for (body = code->block; body; body = body->block)
4787 /* Assume the CASE list is OK, and all CASE labels can be matched. */
4789 seen_unreachable = 0;
4791 /* Walk the case label list, making sure that all case labels
4793 for (cp = body->ext.case_list; cp; cp = cp->next)
4795 /* Count the number of cases in the whole construct. */
4798 /* Intercept the DEFAULT case. */
4799 if (cp->low == NULL && cp->high == NULL)
4801 if (default_case != NULL)
4803 gfc_error ("The DEFAULT CASE at %L cannot be followed "
4804 "by a second DEFAULT CASE at %L",
4805 &default_case->where, &cp->where);
4816 /* Deal with single value cases and case ranges. Errors are
4817 issued from the validation function. */
4818 if(validate_case_label_expr (cp->low, case_expr) != SUCCESS
4819 || validate_case_label_expr (cp->high, case_expr) != SUCCESS)
4825 if (type == BT_LOGICAL
4826 && ((cp->low == NULL || cp->high == NULL)
4827 || cp->low != cp->high))
4829 gfc_error ("Logical range in CASE statement at %L is not "
4830 "allowed", &cp->low->where);
4835 if (type == BT_LOGICAL && cp->low->expr_type == EXPR_CONSTANT)
4838 value = cp->low->value.logical == 0 ? 2 : 1;
4839 if (value & seen_logical)
4841 gfc_error ("constant logical value in CASE statement "
4842 "is repeated at %L",
4847 seen_logical |= value;
4850 if (cp->low != NULL && cp->high != NULL
4851 && cp->low != cp->high
4852 && gfc_compare_expr (cp->low, cp->high) > 0)
4854 if (gfc_option.warn_surprising)
4855 gfc_warning ("Range specification at %L can never "
4856 "be matched", &cp->where);
4858 cp->unreachable = 1;
4859 seen_unreachable = 1;
4863 /* If the case range can be matched, it can also overlap with
4864 other cases. To make sure it does not, we put it in a
4865 double linked list here. We sort that with a merge sort
4866 later on to detect any overlapping cases. */
4870 head->right = head->left = NULL;
4875 tail->right->left = tail;
4882 /* It there was a failure in the previous case label, give up
4883 for this case label list. Continue with the next block. */
4887 /* See if any case labels that are unreachable have been seen.
4888 If so, we eliminate them. This is a bit of a kludge because
4889 the case lists for a single case statement (label) is a
4890 single forward linked lists. */
4891 if (seen_unreachable)
4893 /* Advance until the first case in the list is reachable. */
4894 while (body->ext.case_list != NULL
4895 && body->ext.case_list->unreachable)
4897 gfc_case *n = body->ext.case_list;
4898 body->ext.case_list = body->ext.case_list->next;
4900 gfc_free_case_list (n);
4903 /* Strip all other unreachable cases. */
4904 if (body->ext.case_list)
4906 for (cp = body->ext.case_list; cp->next; cp = cp->next)
4908 if (cp->next->unreachable)
4910 gfc_case *n = cp->next;
4911 cp->next = cp->next->next;
4913 gfc_free_case_list (n);
4920 /* See if there were overlapping cases. If the check returns NULL,
4921 there was overlap. In that case we don't do anything. If head
4922 is non-NULL, we prepend the DEFAULT case. The sorted list can
4923 then used during code generation for SELECT CASE constructs with
4924 a case expression of a CHARACTER type. */
4927 head = check_case_overlap (head);
4929 /* Prepend the default_case if it is there. */
4930 if (head != NULL && default_case)
4932 default_case->left = NULL;
4933 default_case->right = head;
4934 head->left = default_case;
4938 /* Eliminate dead blocks that may be the result if we've seen
4939 unreachable case labels for a block. */
4940 for (body = code; body && body->block; body = body->block)
4942 if (body->block->ext.case_list == NULL)
4944 /* Cut the unreachable block from the code chain. */
4945 gfc_code *c = body->block;
4946 body->block = c->block;
4948 /* Kill the dead block, but not the blocks below it. */
4950 gfc_free_statements (c);
4954 /* More than two cases is legal but insane for logical selects.
4955 Issue a warning for it. */
4956 if (gfc_option.warn_surprising && type == BT_LOGICAL
4958 gfc_warning ("Logical SELECT CASE block at %L has more that two cases",
4963 /* Resolve a transfer statement. This is making sure that:
4964 -- a derived type being transferred has only non-pointer components
4965 -- a derived type being transferred doesn't have private components, unless
4966 it's being transferred from the module where the type was defined
4967 -- we're not trying to transfer a whole assumed size array. */
4970 resolve_transfer (gfc_code *code)
4979 if (exp->expr_type != EXPR_VARIABLE && exp->expr_type != EXPR_FUNCTION)
4982 sym = exp->symtree->n.sym;
4985 /* Go to actual component transferred. */
4986 for (ref = code->expr->ref; ref; ref = ref->next)
4987 if (ref->type == REF_COMPONENT)
4988 ts = &ref->u.c.component->ts;
4990 if (ts->type == BT_DERIVED)
4992 /* Check that transferred derived type doesn't contain POINTER
4994 if (derived_pointer (ts->derived))
4996 gfc_error ("Data transfer element at %L cannot have "
4997 "POINTER components", &code->loc);
5001 if (ts->derived->attr.alloc_comp)
5003 gfc_error ("Data transfer element at %L cannot have "
5004 "ALLOCATABLE components", &code->loc);
5008 if (derived_inaccessible (ts->derived))
5010 gfc_error ("Data transfer element at %L cannot have "
5011 "PRIVATE components",&code->loc);
5016 if (sym->as != NULL && sym->as->type == AS_ASSUMED_SIZE
5017 && exp->ref->type == REF_ARRAY && exp->ref->u.ar.type == AR_FULL)
5019 gfc_error ("Data transfer element at %L cannot be a full reference to "
5020 "an assumed-size array", &code->loc);
5026 /*********** Toplevel code resolution subroutines ***********/
5028 /* Find the set of labels that are reachable from this block. We also
5029 record the last statement in each block so that we don't have to do
5030 a linear search to find the END DO statements of the blocks. */
5033 reachable_labels (gfc_code *block)
5040 cs_base->reachable_labels = bitmap_obstack_alloc (&labels_obstack);
5042 /* Collect labels in this block. */
5043 for (c = block; c; c = c->next)
5046 bitmap_set_bit (cs_base->reachable_labels, c->here->value);
5048 if (!c->next && cs_base->prev)
5049 cs_base->prev->tail = c;
5052 /* Merge with labels from parent block. */
5055 gcc_assert (cs_base->prev->reachable_labels);
5056 bitmap_ior_into (cs_base->reachable_labels,
5057 cs_base->prev->reachable_labels);
5061 /* Given a branch to a label and a namespace, if the branch is conforming.
5062 The code node describes where the branch is located. */
5065 resolve_branch (gfc_st_label *label, gfc_code *code)
5072 /* Step one: is this a valid branching target? */
5074 if (label->defined == ST_LABEL_UNKNOWN)
5076 gfc_error ("Label %d referenced at %L is never defined", label->value,
5081 if (label->defined != ST_LABEL_TARGET)
5083 gfc_error ("Statement at %L is not a valid branch target statement "
5084 "for the branch statement at %L", &label->where, &code->loc);
5088 /* Step two: make sure this branch is not a branch to itself ;-) */
5090 if (code->here == label)
5092 gfc_warning ("Branch at %L causes an infinite loop", &code->loc);
5096 /* Step three: See if the label is in the same block as the
5097 branching statement. The hard work has been done by setting up
5098 the bitmap reachable_labels. */
5100 if (!bitmap_bit_p (cs_base->reachable_labels, label->value))
5102 /* The label is not in an enclosing block, so illegal. This was
5103 allowed in Fortran 66, so we allow it as extension. No
5104 further checks are necessary in this case. */
5105 gfc_notify_std (GFC_STD_LEGACY, "Label at %L is not in the same block "
5106 "as the GOTO statement at %L", &label->where,
5111 /* Step four: Make sure that the branching target is legal if
5112 the statement is an END {SELECT,IF}. */
5114 for (stack = cs_base; stack; stack = stack->prev)
5115 if (stack->current->next && stack->current->next->here == label)
5118 if (stack && stack->current->next->op == EXEC_NOP)
5120 gfc_notify_std (GFC_STD_F95_DEL, "Deleted feature: GOTO at %L jumps to "
5121 "END of construct at %L", &code->loc,
5122 &stack->current->next->loc);
5123 return; /* We know this is not an END DO. */
5126 /* Step five: Make sure that we're not jumping to the end of a DO
5127 loop from within the loop. */
5129 for (stack = cs_base; stack; stack = stack->prev)
5130 if ((stack->current->op == EXEC_DO
5131 || stack->current->op == EXEC_DO_WHILE)
5132 && stack->tail->here == label && stack->tail->op == EXEC_NOP)
5134 gfc_notify_std (GFC_STD_F95_DEL, "Deleted feature: GOTO at %L jumps "
5135 "to END of construct at %L", &code->loc,
5143 /* Check whether EXPR1 has the same shape as EXPR2. */
5146 resolve_where_shape (gfc_expr *expr1, gfc_expr *expr2)
5148 mpz_t shape[GFC_MAX_DIMENSIONS];
5149 mpz_t shape2[GFC_MAX_DIMENSIONS];
5150 try result = FAILURE;
5153 /* Compare the rank. */
5154 if (expr1->rank != expr2->rank)
5157 /* Compare the size of each dimension. */
5158 for (i=0; i<expr1->rank; i++)
5160 if (gfc_array_dimen_size (expr1, i, &shape[i]) == FAILURE)
5163 if (gfc_array_dimen_size (expr2, i, &shape2[i]) == FAILURE)
5166 if (mpz_cmp (shape[i], shape2[i]))
5170 /* When either of the two expression is an assumed size array, we
5171 ignore the comparison of dimension sizes. */
5176 for (i--; i >= 0; i--)
5178 mpz_clear (shape[i]);
5179 mpz_clear (shape2[i]);
5185 /* Check whether a WHERE assignment target or a WHERE mask expression
5186 has the same shape as the outmost WHERE mask expression. */
5189 resolve_where (gfc_code *code, gfc_expr *mask)
5195 cblock = code->block;
5197 /* Store the first WHERE mask-expr of the WHERE statement or construct.
5198 In case of nested WHERE, only the outmost one is stored. */
5199 if (mask == NULL) /* outmost WHERE */
5201 else /* inner WHERE */
5208 /* Check if the mask-expr has a consistent shape with the
5209 outmost WHERE mask-expr. */
5210 if (resolve_where_shape (cblock->expr, e) == FAILURE)
5211 gfc_error ("WHERE mask at %L has inconsistent shape",
5212 &cblock->expr->where);
5215 /* the assignment statement of a WHERE statement, or the first
5216 statement in where-body-construct of a WHERE construct */
5217 cnext = cblock->next;
5222 /* WHERE assignment statement */
5225 /* Check shape consistent for WHERE assignment target. */
5226 if (e && resolve_where_shape (cnext->expr, e) == FAILURE)
5227 gfc_error ("WHERE assignment target at %L has "
5228 "inconsistent shape", &cnext->expr->where);
5232 case EXEC_ASSIGN_CALL:
5233 resolve_call (cnext);
5236 /* WHERE or WHERE construct is part of a where-body-construct */
5238 resolve_where (cnext, e);
5242 gfc_error ("Unsupported statement inside WHERE at %L",
5245 /* the next statement within the same where-body-construct */
5246 cnext = cnext->next;
5248 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
5249 cblock = cblock->block;
5254 /* Check whether the FORALL index appears in the expression or not. */
5257 gfc_find_forall_index (gfc_expr *expr, gfc_symbol *symbol)
5261 gfc_actual_arglist *args;
5264 switch (expr->expr_type)
5267 gcc_assert (expr->symtree->n.sym);
5269 /* A scalar assignment */
5272 if (expr->symtree->n.sym == symbol)
5278 /* the expr is array ref, substring or struct component. */
5285 /* Check if the symbol appears in the array subscript. */
5287 for (i = 0; i < GFC_MAX_DIMENSIONS; i++)
5290 if (gfc_find_forall_index (ar.start[i], symbol) == SUCCESS)
5294 if (gfc_find_forall_index (ar.end[i], symbol) == SUCCESS)
5298 if (gfc_find_forall_index (ar.stride[i], symbol) == SUCCESS)
5304 if (expr->symtree->n.sym == symbol)
5307 /* Check if the symbol appears in the substring section. */
5308 if (gfc_find_forall_index (tmp->u.ss.start, symbol) == SUCCESS)
5310 if (gfc_find_forall_index (tmp->u.ss.end, symbol) == SUCCESS)
5318 gfc_error("expression reference type error at %L", &expr->where);
5324 /* If the expression is a function call, then check if the symbol
5325 appears in the actual arglist of the function. */
5327 for (args = expr->value.function.actual; args; args = args->next)
5329 if (gfc_find_forall_index(args->expr,symbol) == SUCCESS)
5334 /* It seems not to happen. */
5335 case EXPR_SUBSTRING:
5339 gcc_assert (expr->ref->type == REF_SUBSTRING);
5340 if (gfc_find_forall_index (tmp->u.ss.start, symbol) == SUCCESS)
5342 if (gfc_find_forall_index (tmp->u.ss.end, symbol) == SUCCESS)
5347 /* It seems not to happen. */
5348 case EXPR_STRUCTURE:
5350 gfc_error ("Unsupported statement while finding forall index in "
5355 /* Find the FORALL index in the first operand. */
5356 if (expr->value.op.op1)
5358 if (gfc_find_forall_index (expr->value.op.op1, symbol) == SUCCESS)
5362 /* Find the FORALL index in the second operand. */
5363 if (expr->value.op.op2)
5365 if (gfc_find_forall_index (expr->value.op.op2, symbol) == SUCCESS)
5378 /* Resolve assignment in FORALL construct.
5379 NVAR is the number of FORALL index variables, and VAR_EXPR records the
5380 FORALL index variables. */
5383 gfc_resolve_assign_in_forall (gfc_code *code, int nvar, gfc_expr **var_expr)
5387 for (n = 0; n < nvar; n++)
5389 gfc_symbol *forall_index;
5391 forall_index = var_expr[n]->symtree->n.sym;
5393 /* Check whether the assignment target is one of the FORALL index
5395 if ((code->expr->expr_type == EXPR_VARIABLE)
5396 && (code->expr->symtree->n.sym == forall_index))
5397 gfc_error ("Assignment to a FORALL index variable at %L",
5398 &code->expr->where);
5401 /* If one of the FORALL index variables doesn't appear in the
5402 assignment target, then there will be a many-to-one
5404 if (gfc_find_forall_index (code->expr, forall_index) == FAILURE)
5405 gfc_error ("The FORALL with index '%s' cause more than one "
5406 "assignment to this object at %L",
5407 var_expr[n]->symtree->name, &code->expr->where);
5413 /* Resolve WHERE statement in FORALL construct. */
5416 gfc_resolve_where_code_in_forall (gfc_code *code, int nvar,
5417 gfc_expr **var_expr)
5422 cblock = code->block;
5425 /* the assignment statement of a WHERE statement, or the first
5426 statement in where-body-construct of a WHERE construct */
5427 cnext = cblock->next;
5432 /* WHERE assignment statement */
5434 gfc_resolve_assign_in_forall (cnext, nvar, var_expr);
5437 /* WHERE operator assignment statement */
5438 case EXEC_ASSIGN_CALL:
5439 resolve_call (cnext);
5442 /* WHERE or WHERE construct is part of a where-body-construct */
5444 gfc_resolve_where_code_in_forall (cnext, nvar, var_expr);
5448 gfc_error ("Unsupported statement inside WHERE at %L",
5451 /* the next statement within the same where-body-construct */
5452 cnext = cnext->next;
5454 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
5455 cblock = cblock->block;
5460 /* Traverse the FORALL body to check whether the following errors exist:
5461 1. For assignment, check if a many-to-one assignment happens.
5462 2. For WHERE statement, check the WHERE body to see if there is any
5463 many-to-one assignment. */
5466 gfc_resolve_forall_body (gfc_code *code, int nvar, gfc_expr **var_expr)
5470 c = code->block->next;
5476 case EXEC_POINTER_ASSIGN:
5477 gfc_resolve_assign_in_forall (c, nvar, var_expr);
5480 case EXEC_ASSIGN_CALL:
5484 /* Because the gfc_resolve_blocks() will handle the nested FORALL,
5485 there is no need to handle it here. */
5489 gfc_resolve_where_code_in_forall(c, nvar, var_expr);
5494 /* The next statement in the FORALL body. */
5500 /* Given a FORALL construct, first resolve the FORALL iterator, then call
5501 gfc_resolve_forall_body to resolve the FORALL body. */
5504 gfc_resolve_forall (gfc_code *code, gfc_namespace *ns, int forall_save)
5506 static gfc_expr **var_expr;
5507 static int total_var = 0;
5508 static int nvar = 0;
5509 gfc_forall_iterator *fa;
5510 gfc_symbol *forall_index;
5514 /* Start to resolve a FORALL construct */
5515 if (forall_save == 0)
5517 /* Count the total number of FORALL index in the nested FORALL
5518 construct in order to allocate the VAR_EXPR with proper size. */
5520 while ((next != NULL) && (next->op == EXEC_FORALL))
5522 for (fa = next->ext.forall_iterator; fa; fa = fa->next)
5524 next = next->block->next;
5527 /* Allocate VAR_EXPR with NUMBER_OF_FORALL_INDEX elements. */
5528 var_expr = (gfc_expr **) gfc_getmem (total_var * sizeof (gfc_expr *));
5531 /* The information about FORALL iterator, including FORALL index start, end
5532 and stride. The FORALL index can not appear in start, end or stride. */
5533 for (fa = code->ext.forall_iterator; fa; fa = fa->next)
5535 /* Check if any outer FORALL index name is the same as the current
5537 for (i = 0; i < nvar; i++)
5539 if (fa->var->symtree->n.sym == var_expr[i]->symtree->n.sym)
5541 gfc_error ("An outer FORALL construct already has an index "
5542 "with this name %L", &fa->var->where);
5546 /* Record the current FORALL index. */
5547 var_expr[nvar] = gfc_copy_expr (fa->var);
5549 forall_index = fa->var->symtree->n.sym;
5551 /* Check if the FORALL index appears in start, end or stride. */
5552 if (gfc_find_forall_index (fa->start, forall_index) == SUCCESS)
5553 gfc_error ("A FORALL index must not appear in a limit or stride "
5554 "expression in the same FORALL at %L", &fa->start->where);
5555 if (gfc_find_forall_index (fa->end, forall_index) == SUCCESS)
5556 gfc_error ("A FORALL index must not appear in a limit or stride "
5557 "expression in the same FORALL at %L", &fa->end->where);
5558 if (gfc_find_forall_index (fa->stride, forall_index) == SUCCESS)
5559 gfc_error ("A FORALL index must not appear in a limit or stride "
5560 "expression in the same FORALL at %L", &fa->stride->where);
5564 /* Resolve the FORALL body. */
5565 gfc_resolve_forall_body (code, nvar, var_expr);
5567 /* May call gfc_resolve_forall to resolve the inner FORALL loop. */
5568 gfc_resolve_blocks (code->block, ns);
5570 /* Free VAR_EXPR after the whole FORALL construct resolved. */
5571 for (i = 0; i < total_var; i++)
5572 gfc_free_expr (var_expr[i]);
5574 /* Reset the counters. */
5580 /* Resolve lists of blocks found in IF, SELECT CASE, WHERE, FORALL ,GOTO and
5583 static void resolve_code (gfc_code *, gfc_namespace *);
5586 gfc_resolve_blocks (gfc_code *b, gfc_namespace *ns)
5590 for (; b; b = b->block)
5592 t = gfc_resolve_expr (b->expr);
5593 if (gfc_resolve_expr (b->expr2) == FAILURE)
5599 if (t == SUCCESS && b->expr != NULL
5600 && (b->expr->ts.type != BT_LOGICAL || b->expr->rank != 0))
5601 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
5608 && (b->expr->ts.type != BT_LOGICAL || b->expr->rank == 0))
5609 gfc_error ("WHERE/ELSEWHERE clause at %L requires a LOGICAL array",
5614 resolve_branch (b->label, b);
5626 case EXEC_OMP_ATOMIC:
5627 case EXEC_OMP_CRITICAL:
5629 case EXEC_OMP_MASTER:
5630 case EXEC_OMP_ORDERED:
5631 case EXEC_OMP_PARALLEL:
5632 case EXEC_OMP_PARALLEL_DO:
5633 case EXEC_OMP_PARALLEL_SECTIONS:
5634 case EXEC_OMP_PARALLEL_WORKSHARE:
5635 case EXEC_OMP_SECTIONS:
5636 case EXEC_OMP_SINGLE:
5637 case EXEC_OMP_WORKSHARE:
5641 gfc_internal_error ("resolve_block(): Bad block type");
5644 resolve_code (b->next, ns);
5649 /* Given a block of code, recursively resolve everything pointed to by this
5653 resolve_code (gfc_code *code, gfc_namespace *ns)
5655 int omp_workshare_save;
5661 frame.prev = cs_base;
5665 reachable_labels (code);
5667 for (; code; code = code->next)
5669 frame.current = code;
5670 forall_save = forall_flag;
5672 if (code->op == EXEC_FORALL)
5675 gfc_resolve_forall (code, ns, forall_save);
5678 else if (code->block)
5680 omp_workshare_save = -1;
5683 case EXEC_OMP_PARALLEL_WORKSHARE:
5684 omp_workshare_save = omp_workshare_flag;
5685 omp_workshare_flag = 1;
5686 gfc_resolve_omp_parallel_blocks (code, ns);
5688 case EXEC_OMP_PARALLEL:
5689 case EXEC_OMP_PARALLEL_DO:
5690 case EXEC_OMP_PARALLEL_SECTIONS:
5691 omp_workshare_save = omp_workshare_flag;
5692 omp_workshare_flag = 0;
5693 gfc_resolve_omp_parallel_blocks (code, ns);
5696 gfc_resolve_omp_do_blocks (code, ns);
5698 case EXEC_OMP_WORKSHARE:
5699 omp_workshare_save = omp_workshare_flag;
5700 omp_workshare_flag = 1;
5703 gfc_resolve_blocks (code->block, ns);
5707 if (omp_workshare_save != -1)
5708 omp_workshare_flag = omp_workshare_save;
5711 t = gfc_resolve_expr (code->expr);
5712 forall_flag = forall_save;
5714 if (gfc_resolve_expr (code->expr2) == FAILURE)
5729 /* Keep track of which entry we are up to. */
5730 current_entry_id = code->ext.entry->id;
5734 resolve_where (code, NULL);
5738 if (code->expr != NULL)
5740 if (code->expr->ts.type != BT_INTEGER)
5741 gfc_error ("ASSIGNED GOTO statement at %L requires an "
5742 "INTEGER variable", &code->expr->where);
5743 else if (code->expr->symtree->n.sym->attr.assign != 1)
5744 gfc_error ("Variable '%s' has not been assigned a target "
5745 "label at %L", code->expr->symtree->n.sym->name,
5746 &code->expr->where);
5749 resolve_branch (code->label, code);
5753 if (code->expr != NULL
5754 && (code->expr->ts.type != BT_INTEGER || code->expr->rank))
5755 gfc_error ("Alternate RETURN statement at %L requires a SCALAR-"
5756 "INTEGER return specifier", &code->expr->where);
5759 case EXEC_INIT_ASSIGN:
5766 if (gfc_extend_assign (code, ns) == SUCCESS)
5768 if (gfc_pure (NULL) && !gfc_pure (code->symtree->n.sym))
5770 gfc_error ("Subroutine '%s' called instead of assignment at "
5771 "%L must be PURE", code->symtree->n.sym->name,
5778 if (code->expr->ts.type == BT_CHARACTER
5779 && gfc_option.warn_character_truncation)
5781 int llen = 0, rlen = 0;
5783 if (code->expr->ts.cl != NULL
5784 && code->expr->ts.cl->length != NULL
5785 && code->expr->ts.cl->length->expr_type == EXPR_CONSTANT)
5786 llen = mpz_get_si (code->expr->ts.cl->length->value.integer);
5788 if (code->expr2->expr_type == EXPR_CONSTANT)
5789 rlen = code->expr2->value.character.length;
5791 else if (code->expr2->ts.cl != NULL
5792 && code->expr2->ts.cl->length != NULL
5793 && code->expr2->ts.cl->length->expr_type
5795 rlen = mpz_get_si (code->expr2->ts.cl->length->value.integer);
5797 if (rlen && llen && rlen > llen)
5798 gfc_warning_now ("CHARACTER expression will be truncated "
5799 "in assignment (%d/%d) at %L",
5800 llen, rlen, &code->loc);
5803 if (gfc_pure (NULL))
5805 if (gfc_impure_variable (code->expr->symtree->n.sym))
5807 gfc_error ("Cannot assign to variable '%s' in PURE "
5809 code->expr->symtree->n.sym->name,
5810 &code->expr->where);
5814 if (code->expr->ts.type == BT_DERIVED
5815 && code->expr->expr_type == EXPR_VARIABLE
5816 && derived_pointer (code->expr->ts.derived)
5817 && gfc_impure_variable (code->expr2->symtree->n.sym))
5819 gfc_error ("The impure variable at %L is assigned to "
5820 "a derived type variable with a POINTER "
5821 "component in a PURE procedure (12.6)",
5822 &code->expr2->where);
5827 gfc_check_assign (code->expr, code->expr2, 1);
5830 case EXEC_LABEL_ASSIGN:
5831 if (code->label->defined == ST_LABEL_UNKNOWN)
5832 gfc_error ("Label %d referenced at %L is never defined",
5833 code->label->value, &code->label->where);
5835 && (code->expr->expr_type != EXPR_VARIABLE
5836 || code->expr->symtree->n.sym->ts.type != BT_INTEGER
5837 || code->expr->symtree->n.sym->ts.kind
5838 != gfc_default_integer_kind
5839 || code->expr->symtree->n.sym->as != NULL))
5840 gfc_error ("ASSIGN statement at %L requires a scalar "
5841 "default INTEGER variable", &code->expr->where);
5844 case EXEC_POINTER_ASSIGN:
5848 gfc_check_pointer_assign (code->expr, code->expr2);
5851 case EXEC_ARITHMETIC_IF:
5853 && code->expr->ts.type != BT_INTEGER
5854 && code->expr->ts.type != BT_REAL)
5855 gfc_error ("Arithmetic IF statement at %L requires a numeric "
5856 "expression", &code->expr->where);
5858 resolve_branch (code->label, code);
5859 resolve_branch (code->label2, code);
5860 resolve_branch (code->label3, code);
5864 if (t == SUCCESS && code->expr != NULL
5865 && (code->expr->ts.type != BT_LOGICAL
5866 || code->expr->rank != 0))
5867 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
5868 &code->expr->where);
5873 resolve_call (code);
5877 /* Select is complicated. Also, a SELECT construct could be
5878 a transformed computed GOTO. */
5879 resolve_select (code);
5883 if (code->ext.iterator != NULL)
5885 gfc_iterator *iter = code->ext.iterator;
5886 if (gfc_resolve_iterator (iter, true) != FAILURE)
5887 gfc_resolve_do_iterator (code, iter->var->symtree->n.sym);
5892 if (code->expr == NULL)
5893 gfc_internal_error ("resolve_code(): No expression on DO WHILE");
5895 && (code->expr->rank != 0
5896 || code->expr->ts.type != BT_LOGICAL))
5897 gfc_error ("Exit condition of DO WHILE loop at %L must be "
5898 "a scalar LOGICAL expression", &code->expr->where);
5902 if (t == SUCCESS && code->expr != NULL
5903 && code->expr->ts.type != BT_INTEGER)
5904 gfc_error ("STAT tag in ALLOCATE statement at %L must be "
5905 "of type INTEGER", &code->expr->where);
5907 for (a = code->ext.alloc_list; a; a = a->next)
5908 resolve_allocate_expr (a->expr, code);
5912 case EXEC_DEALLOCATE:
5913 if (t == SUCCESS && code->expr != NULL
5914 && code->expr->ts.type != BT_INTEGER)
5916 ("STAT tag in DEALLOCATE statement at %L must be of type "
5917 "INTEGER", &code->expr->where);
5919 for (a = code->ext.alloc_list; a; a = a->next)
5920 resolve_deallocate_expr (a->expr);
5925 if (gfc_resolve_open (code->ext.open) == FAILURE)
5928 resolve_branch (code->ext.open->err, code);
5932 if (gfc_resolve_close (code->ext.close) == FAILURE)
5935 resolve_branch (code->ext.close->err, code);
5938 case EXEC_BACKSPACE:
5942 if (gfc_resolve_filepos (code->ext.filepos) == FAILURE)
5945 resolve_branch (code->ext.filepos->err, code);
5949 if (gfc_resolve_inquire (code->ext.inquire) == FAILURE)
5952 resolve_branch (code->ext.inquire->err, code);
5956 gcc_assert (code->ext.inquire != NULL);
5957 if (gfc_resolve_inquire (code->ext.inquire) == FAILURE)
5960 resolve_branch (code->ext.inquire->err, code);
5965 if (gfc_resolve_dt (code->ext.dt) == FAILURE)
5968 resolve_branch (code->ext.dt->err, code);
5969 resolve_branch (code->ext.dt->end, code);
5970 resolve_branch (code->ext.dt->eor, code);
5974 resolve_transfer (code);
5978 resolve_forall_iterators (code->ext.forall_iterator);
5980 if (code->expr != NULL && code->expr->ts.type != BT_LOGICAL)
5981 gfc_error ("FORALL mask clause at %L requires a LOGICAL "
5982 "expression", &code->expr->where);
5985 case EXEC_OMP_ATOMIC:
5986 case EXEC_OMP_BARRIER:
5987 case EXEC_OMP_CRITICAL:
5988 case EXEC_OMP_FLUSH:
5990 case EXEC_OMP_MASTER:
5991 case EXEC_OMP_ORDERED:
5992 case EXEC_OMP_SECTIONS:
5993 case EXEC_OMP_SINGLE:
5994 case EXEC_OMP_WORKSHARE:
5995 gfc_resolve_omp_directive (code, ns);
5998 case EXEC_OMP_PARALLEL:
5999 case EXEC_OMP_PARALLEL_DO:
6000 case EXEC_OMP_PARALLEL_SECTIONS:
6001 case EXEC_OMP_PARALLEL_WORKSHARE:
6002 omp_workshare_save = omp_workshare_flag;
6003 omp_workshare_flag = 0;
6004 gfc_resolve_omp_directive (code, ns);
6005 omp_workshare_flag = omp_workshare_save;
6009 gfc_internal_error ("resolve_code(): Bad statement code");
6013 cs_base = frame.prev;
6017 /* Resolve initial values and make sure they are compatible with
6021 resolve_values (gfc_symbol *sym)
6023 if (sym->value == NULL)
6026 if (gfc_resolve_expr (sym->value) == FAILURE)
6029 gfc_check_assign_symbol (sym, sym->value);
6033 /* Verify the binding labels for common blocks that are BIND(C). The label
6034 for a BIND(C) common block must be identical in all scoping units in which
6035 the common block is declared. Further, the binding label can not collide
6036 with any other global entity in the program. */
6039 resolve_bind_c_comms (gfc_symtree *comm_block_tree)
6041 if (comm_block_tree->n.common->is_bind_c == 1)
6043 gfc_gsymbol *binding_label_gsym;
6044 gfc_gsymbol *comm_name_gsym;
6046 /* See if a global symbol exists by the common block's name. It may
6047 be NULL if the common block is use-associated. */
6048 comm_name_gsym = gfc_find_gsymbol (gfc_gsym_root,
6049 comm_block_tree->n.common->name);
6050 if (comm_name_gsym != NULL && comm_name_gsym->type != GSYM_COMMON)
6051 gfc_error ("Binding label '%s' for common block '%s' at %L collides "
6052 "with the global entity '%s' at %L",
6053 comm_block_tree->n.common->binding_label,
6054 comm_block_tree->n.common->name,
6055 &(comm_block_tree->n.common->where),
6056 comm_name_gsym->name, &(comm_name_gsym->where));
6057 else if (comm_name_gsym != NULL
6058 && strcmp (comm_name_gsym->name,
6059 comm_block_tree->n.common->name) == 0)
6061 /* TODO: Need to make sure the fields of gfc_gsymbol are initialized
6063 if (comm_name_gsym->binding_label == NULL)
6064 /* No binding label for common block stored yet; save this one. */
6065 comm_name_gsym->binding_label =
6066 comm_block_tree->n.common->binding_label;
6068 if (strcmp (comm_name_gsym->binding_label,
6069 comm_block_tree->n.common->binding_label) != 0)
6071 /* Common block names match but binding labels do not. */
6072 gfc_error ("Binding label '%s' for common block '%s' at %L "
6073 "does not match the binding label '%s' for common "
6075 comm_block_tree->n.common->binding_label,
6076 comm_block_tree->n.common->name,
6077 &(comm_block_tree->n.common->where),
6078 comm_name_gsym->binding_label,
6079 comm_name_gsym->name,
6080 &(comm_name_gsym->where));
6085 /* There is no binding label (NAME="") so we have nothing further to
6086 check and nothing to add as a global symbol for the label. */
6087 if (comm_block_tree->n.common->binding_label[0] == '\0' )
6090 binding_label_gsym =
6091 gfc_find_gsymbol (gfc_gsym_root,
6092 comm_block_tree->n.common->binding_label);
6093 if (binding_label_gsym == NULL)
6095 /* Need to make a global symbol for the binding label to prevent
6096 it from colliding with another. */
6097 binding_label_gsym =
6098 gfc_get_gsymbol (comm_block_tree->n.common->binding_label);
6099 binding_label_gsym->sym_name = comm_block_tree->n.common->name;
6100 binding_label_gsym->type = GSYM_COMMON;
6104 /* If comm_name_gsym is NULL, the name common block is use
6105 associated and the name could be colliding. */
6106 if (binding_label_gsym->type != GSYM_COMMON)
6107 gfc_error ("Binding label '%s' for common block '%s' at %L "
6108 "collides with the global entity '%s' at %L",
6109 comm_block_tree->n.common->binding_label,
6110 comm_block_tree->n.common->name,
6111 &(comm_block_tree->n.common->where),
6112 binding_label_gsym->name,
6113 &(binding_label_gsym->where));
6114 else if (comm_name_gsym != NULL
6115 && (strcmp (binding_label_gsym->name,
6116 comm_name_gsym->binding_label) != 0)
6117 && (strcmp (binding_label_gsym->sym_name,
6118 comm_name_gsym->name) != 0))
6119 gfc_error ("Binding label '%s' for common block '%s' at %L "
6120 "collides with global entity '%s' at %L",
6121 binding_label_gsym->name, binding_label_gsym->sym_name,
6122 &(comm_block_tree->n.common->where),
6123 comm_name_gsym->name, &(comm_name_gsym->where));
6131 /* Verify any BIND(C) derived types in the namespace so we can report errors
6132 for them once, rather than for each variable declared of that type. */
6135 resolve_bind_c_derived_types (gfc_symbol *derived_sym)
6137 if (derived_sym != NULL && derived_sym->attr.flavor == FL_DERIVED
6138 && derived_sym->attr.is_bind_c == 1)
6139 verify_bind_c_derived_type (derived_sym);
6145 /* Verify that any binding labels used in a given namespace do not collide
6146 with the names or binding labels of any global symbols. */
6149 gfc_verify_binding_labels (gfc_symbol *sym)
6153 if (sym != NULL && sym->attr.is_bind_c && sym->attr.is_iso_c == 0
6154 && sym->attr.flavor != FL_DERIVED && sym->binding_label[0] != '\0')
6156 gfc_gsymbol *bind_c_sym;
6158 bind_c_sym = gfc_find_gsymbol (gfc_gsym_root, sym->binding_label);
6159 if (bind_c_sym != NULL
6160 && strcmp (bind_c_sym->name, sym->binding_label) == 0)
6162 if (sym->attr.if_source == IFSRC_DECL
6163 && (bind_c_sym->type != GSYM_SUBROUTINE
6164 && bind_c_sym->type != GSYM_FUNCTION)
6165 && ((sym->attr.contained == 1
6166 && strcmp (bind_c_sym->sym_name, sym->name) != 0)
6167 || (sym->attr.use_assoc == 1
6168 && (strcmp (bind_c_sym->mod_name, sym->module) != 0))))
6170 /* Make sure global procedures don't collide with anything. */
6171 gfc_error ("Binding label '%s' at %L collides with the global "
6172 "entity '%s' at %L", sym->binding_label,
6173 &(sym->declared_at), bind_c_sym->name,
6174 &(bind_c_sym->where));
6177 else if (sym->attr.contained == 0
6178 && (sym->attr.if_source == IFSRC_IFBODY
6179 && sym->attr.flavor == FL_PROCEDURE)
6180 && (bind_c_sym->sym_name != NULL
6181 && strcmp (bind_c_sym->sym_name, sym->name) != 0))
6183 /* Make sure procedures in interface bodies don't collide. */
6184 gfc_error ("Binding label '%s' in interface body at %L collides "
6185 "with the global entity '%s' at %L",
6187 &(sym->declared_at), bind_c_sym->name,
6188 &(bind_c_sym->where));
6191 else if (sym->attr.contained == 0
6192 && (sym->attr.if_source == IFSRC_UNKNOWN))
6193 if ((sym->attr.use_assoc
6194 && (strcmp (bind_c_sym->mod_name, sym->module) != 0))
6195 || sym->attr.use_assoc == 0)
6197 gfc_error ("Binding label '%s' at %L collides with global "
6198 "entity '%s' at %L", sym->binding_label,
6199 &(sym->declared_at), bind_c_sym->name,
6200 &(bind_c_sym->where));
6205 /* Clear the binding label to prevent checking multiple times. */
6206 sym->binding_label[0] = '\0';
6208 else if (bind_c_sym == NULL)
6210 bind_c_sym = gfc_get_gsymbol (sym->binding_label);
6211 bind_c_sym->where = sym->declared_at;
6212 bind_c_sym->sym_name = sym->name;
6214 if (sym->attr.use_assoc == 1)
6215 bind_c_sym->mod_name = sym->module;
6217 if (sym->ns->proc_name != NULL)
6218 bind_c_sym->mod_name = sym->ns->proc_name->name;
6220 if (sym->attr.contained == 0)
6222 if (sym->attr.subroutine)
6223 bind_c_sym->type = GSYM_SUBROUTINE;
6224 else if (sym->attr.function)
6225 bind_c_sym->type = GSYM_FUNCTION;
6233 /* Resolve an index expression. */
6236 resolve_index_expr (gfc_expr *e)
6238 if (gfc_resolve_expr (e) == FAILURE)
6241 if (gfc_simplify_expr (e, 0) == FAILURE)
6244 if (gfc_specification_expr (e) == FAILURE)
6250 /* Resolve a charlen structure. */
6253 resolve_charlen (gfc_charlen *cl)
6262 specification_expr = 1;
6264 if (resolve_index_expr (cl->length) == FAILURE)
6266 specification_expr = 0;
6270 /* "If the character length parameter value evaluates to a negative
6271 value, the length of character entities declared is zero." */
6272 if (cl->length && !gfc_extract_int (cl->length, &i) && i <= 0)
6274 gfc_warning_now ("CHARACTER variable has zero length at %L",
6275 &cl->length->where);
6276 gfc_replace_expr (cl->length, gfc_int_expr (0));
6283 /* Test for non-constant shape arrays. */
6286 is_non_constant_shape_array (gfc_symbol *sym)
6292 not_constant = false;
6293 if (sym->as != NULL)
6295 /* Unfortunately, !gfc_is_compile_time_shape hits a legal case that
6296 has not been simplified; parameter array references. Do the
6297 simplification now. */
6298 for (i = 0; i < sym->as->rank; i++)
6300 e = sym->as->lower[i];
6301 if (e && (resolve_index_expr (e) == FAILURE
6302 || !gfc_is_constant_expr (e)))
6303 not_constant = true;
6305 e = sym->as->upper[i];
6306 if (e && (resolve_index_expr (e) == FAILURE
6307 || !gfc_is_constant_expr (e)))
6308 not_constant = true;
6311 return not_constant;
6315 /* Assign the default initializer to a derived type variable or result. */
6318 apply_default_init (gfc_symbol *sym)
6321 gfc_expr *init = NULL;
6323 gfc_namespace *ns = sym->ns;
6325 if (sym->attr.flavor != FL_VARIABLE && !sym->attr.function)
6328 if (sym->ts.type == BT_DERIVED && sym->ts.derived)
6329 init = gfc_default_initializer (&sym->ts);
6334 /* Search for the function namespace if this is a contained
6335 function without an explicit result. */
6336 if (sym->attr.function && sym == sym->result
6337 && sym->name != sym->ns->proc_name->name)
6340 for (;ns; ns = ns->sibling)
6341 if (strcmp (ns->proc_name->name, sym->name) == 0)
6347 gfc_free_expr (init);
6351 /* Build an l-value expression for the result. */
6352 lval = gfc_get_expr ();
6353 lval->expr_type = EXPR_VARIABLE;
6354 lval->where = sym->declared_at;
6356 lval->symtree = gfc_find_symtree (sym->ns->sym_root, sym->name);
6358 /* It will always be a full array. */
6359 lval->rank = sym->as ? sym->as->rank : 0;
6362 lval->ref = gfc_get_ref ();
6363 lval->ref->type = REF_ARRAY;
6364 lval->ref->u.ar.type = AR_FULL;
6365 lval->ref->u.ar.dimen = lval->rank;
6366 lval->ref->u.ar.where = sym->declared_at;
6367 lval->ref->u.ar.as = sym->as;
6370 /* Add the code at scope entry. */
6371 init_st = gfc_get_code ();
6372 init_st->next = ns->code;
6375 /* Assign the default initializer to the l-value. */
6376 init_st->loc = sym->declared_at;
6377 init_st->op = EXEC_INIT_ASSIGN;
6378 init_st->expr = lval;
6379 init_st->expr2 = init;
6383 /* Resolution of common features of flavors variable and procedure. */
6386 resolve_fl_var_and_proc (gfc_symbol *sym, int mp_flag)
6388 /* Constraints on deferred shape variable. */
6389 if (sym->as == NULL || sym->as->type != AS_DEFERRED)
6391 if (sym->attr.allocatable)
6393 if (sym->attr.dimension)
6394 gfc_error ("Allocatable array '%s' at %L must have "
6395 "a deferred shape", sym->name, &sym->declared_at);
6397 gfc_error ("Scalar object '%s' at %L may not be ALLOCATABLE",
6398 sym->name, &sym->declared_at);
6402 if (sym->attr.pointer && sym->attr.dimension)
6404 gfc_error ("Array pointer '%s' at %L must have a deferred shape",
6405 sym->name, &sym->declared_at);
6412 if (!mp_flag && !sym->attr.allocatable
6413 && !sym->attr.pointer && !sym->attr.dummy)
6415 gfc_error ("Array '%s' at %L cannot have a deferred shape",
6416 sym->name, &sym->declared_at);
6424 static gfc_component *
6425 has_default_initializer (gfc_symbol *der)
6428 for (c = der->components; c; c = c->next)
6429 if ((c->ts.type != BT_DERIVED && c->initializer)
6430 || (c->ts.type == BT_DERIVED
6432 && has_default_initializer (c->ts.derived)))
6439 /* Resolve symbols with flavor variable. */
6442 resolve_fl_variable (gfc_symbol *sym, int mp_flag)
6448 const char *auto_save_msg;
6450 auto_save_msg = "automatic object '%s' at %L cannot have the "
6453 if (resolve_fl_var_and_proc (sym, mp_flag) == FAILURE)
6456 /* Set this flag to check that variables are parameters of all entries.
6457 This check is effected by the call to gfc_resolve_expr through
6458 is_non_constant_shape_array. */
6459 specification_expr = 1;
6461 if (!sym->attr.use_assoc
6462 && !sym->attr.allocatable
6463 && !sym->attr.pointer
6464 && is_non_constant_shape_array (sym))
6466 /* The shape of a main program or module array needs to be
6468 if (sym->ns->proc_name
6469 && (sym->ns->proc_name->attr.flavor == FL_MODULE
6470 || sym->ns->proc_name->attr.is_main_program))
6472 gfc_error ("The module or main program array '%s' at %L must "
6473 "have constant shape", sym->name, &sym->declared_at);
6474 specification_expr = 0;
6479 if (sym->ts.type == BT_CHARACTER)
6481 /* Make sure that character string variables with assumed length are
6483 e = sym->ts.cl->length;
6484 if (e == NULL && !sym->attr.dummy && !sym->attr.result)
6486 gfc_error ("Entity with assumed character length at %L must be a "
6487 "dummy argument or a PARAMETER", &sym->declared_at);
6491 if (e && sym->attr.save && !gfc_is_constant_expr (e))
6493 gfc_error (auto_save_msg, sym->name, &sym->declared_at);
6497 if (!gfc_is_constant_expr (e)
6498 && !(e->expr_type == EXPR_VARIABLE
6499 && e->symtree->n.sym->attr.flavor == FL_PARAMETER)
6500 && sym->ns->proc_name
6501 && (sym->ns->proc_name->attr.flavor == FL_MODULE
6502 || sym->ns->proc_name->attr.is_main_program)
6503 && !sym->attr.use_assoc)
6505 gfc_error ("'%s' at %L must have constant character length "
6506 "in this context", sym->name, &sym->declared_at);
6511 /* Can the symbol have an initializer? */
6513 if (sym->attr.allocatable || sym->attr.external || sym->attr.dummy
6514 || sym->attr.intrinsic || sym->attr.result)
6516 else if (sym->attr.dimension && !sym->attr.pointer)
6518 /* Don't allow initialization of automatic arrays. */
6519 for (i = 0; i < sym->as->rank; i++)
6521 if (sym->as->lower[i] == NULL
6522 || sym->as->lower[i]->expr_type != EXPR_CONSTANT
6523 || sym->as->upper[i] == NULL
6524 || sym->as->upper[i]->expr_type != EXPR_CONSTANT)
6531 /* Also, they must not have the SAVE attribute.
6532 SAVE_IMPLICIT is checked below. */
6533 if (flag && sym->attr.save == SAVE_EXPLICIT)
6535 gfc_error (auto_save_msg, sym->name, &sym->declared_at);
6540 /* Reject illegal initializers. */
6541 if (sym->value && flag)
6543 if (sym->attr.allocatable)
6544 gfc_error ("Allocatable '%s' at %L cannot have an initializer",
6545 sym->name, &sym->declared_at);
6546 else if (sym->attr.external)
6547 gfc_error ("External '%s' at %L cannot have an initializer",
6548 sym->name, &sym->declared_at);
6549 else if (sym->attr.dummy
6550 && !(sym->ts.type == BT_DERIVED && sym->attr.intent == INTENT_OUT))
6551 gfc_error ("Dummy '%s' at %L cannot have an initializer",
6552 sym->name, &sym->declared_at);
6553 else if (sym->attr.intrinsic)
6554 gfc_error ("Intrinsic '%s' at %L cannot have an initializer",
6555 sym->name, &sym->declared_at);
6556 else if (sym->attr.result)
6557 gfc_error ("Function result '%s' at %L cannot have an initializer",
6558 sym->name, &sym->declared_at);
6560 gfc_error ("Automatic array '%s' at %L cannot have an initializer",
6561 sym->name, &sym->declared_at);
6568 /* Check to see if a derived type is blocked from being host associated
6569 by the presence of another class I symbol in the same namespace.
6570 14.6.1.3 of the standard and the discussion on comp.lang.fortran. */
6571 if (sym->ts.type == BT_DERIVED && sym->ns != sym->ts.derived->ns
6572 && sym->ns->proc_name->attr.if_source != IFSRC_IFBODY)
6575 gfc_find_symbol (sym->ts.derived->name, sym->ns, 0, &s);
6576 if (s && (s->attr.flavor != FL_DERIVED
6577 || !gfc_compare_derived_types (s, sym->ts.derived)))
6579 gfc_error ("The type %s cannot be host associated at %L because "
6580 "it is blocked by an incompatible object of the same "
6581 "name at %L", sym->ts.derived->name, &sym->declared_at,
6587 /* Do not use gfc_default_initializer to test for a default initializer
6588 in the fortran because it generates a hidden default for allocatable
6591 if (sym->ts.type == BT_DERIVED && !(sym->value || flag))
6592 c = has_default_initializer (sym->ts.derived);
6594 /* 4th constraint in section 11.3: "If an object of a type for which
6595 component-initialization is specified (R429) appears in the
6596 specification-part of a module and does not have the ALLOCATABLE
6597 or POINTER attribute, the object shall have the SAVE attribute." */
6598 if (c && sym->ns->proc_name
6599 && sym->ns->proc_name->attr.flavor == FL_MODULE
6600 && !sym->ns->save_all && !sym->attr.save
6601 && !sym->attr.pointer && !sym->attr.allocatable)
6603 gfc_error("Object '%s' at %L must have the SAVE attribute %s",
6604 sym->name, &sym->declared_at,
6605 "for default initialization of a component");
6609 /* Assign default initializer. */
6610 if (sym->ts.type == BT_DERIVED
6612 && !sym->attr.pointer
6613 && !sym->attr.allocatable
6614 && (!flag || sym->attr.intent == INTENT_OUT))
6615 sym->value = gfc_default_initializer (&sym->ts);
6621 /* Resolve a procedure. */
6624 resolve_fl_procedure (gfc_symbol *sym, int mp_flag)
6626 gfc_formal_arglist *arg;
6628 if (sym->attr.ambiguous_interfaces && !sym->attr.referenced)
6629 gfc_warning ("Although not referenced, '%s' at %L has ambiguous "
6630 "interfaces", sym->name, &sym->declared_at);
6632 if (sym->attr.function
6633 && resolve_fl_var_and_proc (sym, mp_flag) == FAILURE)
6636 if (sym->ts.type == BT_CHARACTER)
6638 gfc_charlen *cl = sym->ts.cl;
6640 if (cl && cl->length && gfc_is_constant_expr (cl->length)
6641 && resolve_charlen (cl) == FAILURE)
6644 if (!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT)
6646 if (sym->attr.proc == PROC_ST_FUNCTION)
6648 gfc_error ("Character-valued statement function '%s' at %L must "
6649 "have constant length", sym->name, &sym->declared_at);
6653 if (sym->attr.external && sym->formal == NULL
6654 && cl && cl->length && cl->length->expr_type != EXPR_CONSTANT)
6656 gfc_error ("Automatic character length function '%s' at %L must "
6657 "have an explicit interface", sym->name,
6664 /* Ensure that derived type for are not of a private type. Internal
6665 module procedures are excluded by 2.2.3.3 - ie. they are not
6666 externally accessible and can access all the objects accessible in
6668 if (!(sym->ns->parent
6669 && sym->ns->parent->proc_name->attr.flavor == FL_MODULE)
6670 && gfc_check_access(sym->attr.access, sym->ns->default_access))
6672 gfc_interface *iface;
6674 for (arg = sym->formal; arg; arg = arg->next)
6677 && arg->sym->ts.type == BT_DERIVED
6678 && !arg->sym->ts.derived->attr.use_assoc
6679 && !gfc_check_access (arg->sym->ts.derived->attr.access,
6680 arg->sym->ts.derived->ns->default_access))
6682 gfc_error_now ("'%s' is of a PRIVATE type and cannot be "
6683 "a dummy argument of '%s', which is "
6684 "PUBLIC at %L", arg->sym->name, sym->name,
6686 /* Stop this message from recurring. */
6687 arg->sym->ts.derived->attr.access = ACCESS_PUBLIC;
6692 /* PUBLIC interfaces may expose PRIVATE procedures that take types
6693 PRIVATE to the containing module. */
6694 for (iface = sym->generic; iface; iface = iface->next)
6696 for (arg = iface->sym->formal; arg; arg = arg->next)
6699 && arg->sym->ts.type == BT_DERIVED
6700 && !arg->sym->ts.derived->attr.use_assoc
6701 && !gfc_check_access (arg->sym->ts.derived->attr.access,
6702 arg->sym->ts.derived->ns->default_access))
6704 gfc_error_now ("Procedure '%s' in PUBLIC interface '%s' at %L takes "
6705 "dummy arguments of '%s' which is PRIVATE",
6706 iface->sym->name, sym->name, &iface->sym->declared_at,
6707 gfc_typename(&arg->sym->ts));
6708 /* Stop this message from recurring. */
6709 arg->sym->ts.derived->attr.access = ACCESS_PUBLIC;
6715 /* PUBLIC interfaces may expose PRIVATE procedures that take types
6716 PRIVATE to the containing module. */
6717 for (iface = sym->generic; iface; iface = iface->next)
6719 for (arg = iface->sym->formal; arg; arg = arg->next)
6722 && arg->sym->ts.type == BT_DERIVED
6723 && !arg->sym->ts.derived->attr.use_assoc
6724 && !gfc_check_access (arg->sym->ts.derived->attr.access,
6725 arg->sym->ts.derived->ns->default_access))
6727 gfc_error_now ("Procedure '%s' in PUBLIC interface '%s' at %L takes "
6728 "dummy arguments of '%s' which is PRIVATE",
6729 iface->sym->name, sym->name, &iface->sym->declared_at,
6730 gfc_typename(&arg->sym->ts));
6731 /* Stop this message from recurring. */
6732 arg->sym->ts.derived->attr.access = ACCESS_PUBLIC;
6739 /* An external symbol may not have an initializer because it is taken to be
6741 if (sym->attr.external && sym->value)
6743 gfc_error ("External object '%s' at %L may not have an initializer",
6744 sym->name, &sym->declared_at);
6748 /* An elemental function is required to return a scalar 12.7.1 */
6749 if (sym->attr.elemental && sym->attr.function && sym->as)
6751 gfc_error ("ELEMENTAL function '%s' at %L must have a scalar "
6752 "result", sym->name, &sym->declared_at);
6753 /* Reset so that the error only occurs once. */
6754 sym->attr.elemental = 0;
6758 /* 5.1.1.5 of the Standard: A function name declared with an asterisk
6759 char-len-param shall not be array-valued, pointer-valued, recursive
6760 or pure. ....snip... A character value of * may only be used in the
6761 following ways: (i) Dummy arg of procedure - dummy associates with
6762 actual length; (ii) To declare a named constant; or (iii) External
6763 function - but length must be declared in calling scoping unit. */
6764 if (sym->attr.function
6765 && sym->ts.type == BT_CHARACTER
6766 && sym->ts.cl && sym->ts.cl->length == NULL)
6768 if ((sym->as && sym->as->rank) || (sym->attr.pointer)
6769 || (sym->attr.recursive) || (sym->attr.pure))
6771 if (sym->as && sym->as->rank)
6772 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
6773 "array-valued", sym->name, &sym->declared_at);
6775 if (sym->attr.pointer)
6776 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
6777 "pointer-valued", sym->name, &sym->declared_at);
6780 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
6781 "pure", sym->name, &sym->declared_at);
6783 if (sym->attr.recursive)
6784 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
6785 "recursive", sym->name, &sym->declared_at);
6790 /* Appendix B.2 of the standard. Contained functions give an
6791 error anyway. Fixed-form is likely to be F77/legacy. */
6792 if (!sym->attr.contained && gfc_current_form != FORM_FIXED)
6793 gfc_notify_std (GFC_STD_F95_OBS, "CHARACTER(*) function "
6794 "'%s' at %L is obsolescent in fortran 95",
6795 sym->name, &sym->declared_at);
6798 if (sym->attr.is_bind_c && sym->attr.is_c_interop != 1)
6800 gfc_formal_arglist *curr_arg;
6802 if (verify_bind_c_sym (sym, &(sym->ts), sym->attr.in_common,
6803 sym->common_block) == FAILURE)
6805 /* Clear these to prevent looking at them again if there was an
6807 sym->attr.is_bind_c = 0;
6808 sym->attr.is_c_interop = 0;
6809 sym->ts.is_c_interop = 0;
6813 /* So far, no errors have been found. */
6814 sym->attr.is_c_interop = 1;
6815 sym->ts.is_c_interop = 1;
6818 curr_arg = sym->formal;
6819 while (curr_arg != NULL)
6821 /* Skip implicitly typed dummy args here. */
6822 if (curr_arg->sym->attr.implicit_type == 0
6823 && verify_c_interop_param (curr_arg->sym) == FAILURE)
6825 /* If something is found to fail, mark the symbol for the
6826 procedure as not being BIND(C) to try and prevent multiple
6827 errors being reported. */
6828 sym->attr.is_c_interop = 0;
6829 sym->ts.is_c_interop = 0;
6830 sym->attr.is_bind_c = 0;
6832 curr_arg = curr_arg->next;
6840 /* Resolve the components of a derived type. */
6843 resolve_fl_derived (gfc_symbol *sym)
6846 gfc_dt_list * dt_list;
6849 for (c = sym->components; c != NULL; c = c->next)
6851 if (c->ts.type == BT_CHARACTER)
6853 if (c->ts.cl->length == NULL
6854 || (resolve_charlen (c->ts.cl) == FAILURE)
6855 || !gfc_is_constant_expr (c->ts.cl->length))
6857 gfc_error ("Character length of component '%s' needs to "
6858 "be a constant specification expression at %L",
6860 c->ts.cl->length ? &c->ts.cl->length->where : &c->loc);
6865 if (c->ts.type == BT_DERIVED
6866 && sym->component_access != ACCESS_PRIVATE
6867 && gfc_check_access (sym->attr.access, sym->ns->default_access)
6868 && !c->ts.derived->attr.use_assoc
6869 && !gfc_check_access (c->ts.derived->attr.access,
6870 c->ts.derived->ns->default_access))
6872 gfc_error ("The component '%s' is a PRIVATE type and cannot be "
6873 "a component of '%s', which is PUBLIC at %L",
6874 c->name, sym->name, &sym->declared_at);
6878 if (sym->attr.sequence)
6880 if (c->ts.type == BT_DERIVED && c->ts.derived->attr.sequence == 0)
6882 gfc_error ("Component %s of SEQUENCE type declared at %L does "
6883 "not have the SEQUENCE attribute",
6884 c->ts.derived->name, &sym->declared_at);
6889 if (c->ts.type == BT_DERIVED && c->pointer
6890 && c->ts.derived->components == NULL)
6892 gfc_error ("The pointer component '%s' of '%s' at %L is a type "
6893 "that has not been declared", c->name, sym->name,
6898 if (c->pointer || c->allocatable || c->as == NULL)
6901 for (i = 0; i < c->as->rank; i++)
6903 if (c->as->lower[i] == NULL
6904 || !gfc_is_constant_expr (c->as->lower[i])
6905 || (resolve_index_expr (c->as->lower[i]) == FAILURE)
6906 || c->as->upper[i] == NULL
6907 || (resolve_index_expr (c->as->upper[i]) == FAILURE)
6908 || !gfc_is_constant_expr (c->as->upper[i]))
6910 gfc_error ("Component '%s' of '%s' at %L must have "
6911 "constant array bounds",
6912 c->name, sym->name, &c->loc);
6918 /* Add derived type to the derived type list. */
6919 for (dt_list = gfc_derived_types; dt_list; dt_list = dt_list->next)
6920 if (sym == dt_list->derived)
6923 if (dt_list == NULL)
6925 dt_list = gfc_get_dt_list ();
6926 dt_list->next = gfc_derived_types;
6927 dt_list->derived = sym;
6928 gfc_derived_types = dt_list;
6936 resolve_fl_namelist (gfc_symbol *sym)
6941 /* Reject PRIVATE objects in a PUBLIC namelist. */
6942 if (gfc_check_access(sym->attr.access, sym->ns->default_access))
6944 for (nl = sym->namelist; nl; nl = nl->next)
6946 if (!nl->sym->attr.use_assoc
6947 && !(sym->ns->parent == nl->sym->ns)
6948 && !gfc_check_access(nl->sym->attr.access,
6949 nl->sym->ns->default_access))
6951 gfc_error ("PRIVATE symbol '%s' cannot be member of "
6952 "PUBLIC namelist at %L", nl->sym->name,
6959 /* Reject namelist arrays that are not constant shape. */
6960 for (nl = sym->namelist; nl; nl = nl->next)
6962 if (is_non_constant_shape_array (nl->sym))
6964 gfc_error ("The array '%s' must have constant shape to be "
6965 "a NAMELIST object at %L", nl->sym->name,
6971 /* Namelist objects cannot have allocatable components. */
6972 for (nl = sym->namelist; nl; nl = nl->next)
6974 if (nl->sym->ts.type == BT_DERIVED
6975 && nl->sym->ts.derived->attr.alloc_comp)
6977 gfc_error ("NAMELIST object '%s' at %L cannot have ALLOCATABLE "
6978 "components", nl->sym->name, &sym->declared_at);
6983 /* 14.1.2 A module or internal procedure represent local entities
6984 of the same type as a namelist member and so are not allowed. */
6985 for (nl = sym->namelist; nl; nl = nl->next)
6987 if (nl->sym->ts.kind != 0 && nl->sym->attr.flavor == FL_VARIABLE)
6990 if (nl->sym->attr.function && nl->sym == nl->sym->result)
6991 if ((nl->sym == sym->ns->proc_name)
6993 (sym->ns->parent && nl->sym == sym->ns->parent->proc_name))
6997 if (nl->sym && nl->sym->name)
6998 gfc_find_symbol (nl->sym->name, sym->ns, 1, &nlsym);
6999 if (nlsym && nlsym->attr.flavor == FL_PROCEDURE)
7001 gfc_error ("PROCEDURE attribute conflicts with NAMELIST "
7002 "attribute in '%s' at %L", nlsym->name,
7013 resolve_fl_parameter (gfc_symbol *sym)
7015 /* A parameter array's shape needs to be constant. */
7016 if (sym->as != NULL && !gfc_is_compile_time_shape (sym->as))
7018 gfc_error ("Parameter array '%s' at %L cannot be automatic "
7019 "or assumed shape", sym->name, &sym->declared_at);
7023 /* Make sure a parameter that has been implicitly typed still
7024 matches the implicit type, since PARAMETER statements can precede
7025 IMPLICIT statements. */
7026 if (sym->attr.implicit_type
7027 && !gfc_compare_types (&sym->ts, gfc_get_default_type (sym, sym->ns)))
7029 gfc_error ("Implicitly typed PARAMETER '%s' at %L doesn't match a "
7030 "later IMPLICIT type", sym->name, &sym->declared_at);
7034 /* Make sure the types of derived parameters are consistent. This
7035 type checking is deferred until resolution because the type may
7036 refer to a derived type from the host. */
7037 if (sym->ts.type == BT_DERIVED
7038 && !gfc_compare_types (&sym->ts, &sym->value->ts))
7040 gfc_error ("Incompatible derived type in PARAMETER at %L",
7041 &sym->value->where);
7048 /* Do anything necessary to resolve a symbol. Right now, we just
7049 assume that an otherwise unknown symbol is a variable. This sort
7050 of thing commonly happens for symbols in module. */
7053 resolve_symbol (gfc_symbol *sym)
7055 int check_constant, mp_flag;
7056 gfc_symtree *symtree;
7057 gfc_symtree *this_symtree;
7061 if (sym->attr.flavor == FL_UNKNOWN)
7064 /* If we find that a flavorless symbol is an interface in one of the
7065 parent namespaces, find its symtree in this namespace, free the
7066 symbol and set the symtree to point to the interface symbol. */
7067 for (ns = gfc_current_ns->parent; ns; ns = ns->parent)
7069 symtree = gfc_find_symtree (ns->sym_root, sym->name);
7070 if (symtree && symtree->n.sym->generic)
7072 this_symtree = gfc_find_symtree (gfc_current_ns->sym_root,
7076 gfc_free_symbol (sym);
7077 symtree->n.sym->refs++;
7078 this_symtree->n.sym = symtree->n.sym;
7083 /* Otherwise give it a flavor according to such attributes as
7085 if (sym->attr.external == 0 && sym->attr.intrinsic == 0)
7086 sym->attr.flavor = FL_VARIABLE;
7089 sym->attr.flavor = FL_PROCEDURE;
7090 if (sym->attr.dimension)
7091 sym->attr.function = 1;
7095 if (sym->attr.flavor == FL_DERIVED && resolve_fl_derived (sym) == FAILURE)
7098 /* Symbols that are module procedures with results (functions) have
7099 the types and array specification copied for type checking in
7100 procedures that call them, as well as for saving to a module
7101 file. These symbols can't stand the scrutiny that their results
7103 mp_flag = (sym->result != NULL && sym->result != sym);
7106 /* Make sure that the intrinsic is consistent with its internal
7107 representation. This needs to be done before assigning a default
7108 type to avoid spurious warnings. */
7109 if (sym->attr.flavor != FL_MODULE && sym->attr.intrinsic)
7111 if (gfc_intrinsic_name (sym->name, 0))
7113 if (sym->ts.type != BT_UNKNOWN && gfc_option.warn_surprising)
7114 gfc_warning ("Type specified for intrinsic function '%s' at %L is ignored",
7115 sym->name, &sym->declared_at);
7117 else if (gfc_intrinsic_name (sym->name, 1))
7119 if (sym->ts.type != BT_UNKNOWN)
7121 gfc_error ("Intrinsic subroutine '%s' at %L shall not have a type specifier",
7122 sym->name, &sym->declared_at);
7128 gfc_error ("Intrinsic '%s' at %L does not exist", sym->name, &sym->declared_at);
7133 /* Assign default type to symbols that need one and don't have one. */
7134 if (sym->ts.type == BT_UNKNOWN)
7136 if (sym->attr.flavor == FL_VARIABLE || sym->attr.flavor == FL_PARAMETER)
7137 gfc_set_default_type (sym, 1, NULL);
7139 if (sym->attr.flavor == FL_PROCEDURE && sym->attr.function)
7141 /* The specific case of an external procedure should emit an error
7142 in the case that there is no implicit type. */
7144 gfc_set_default_type (sym, sym->attr.external, NULL);
7147 /* Result may be in another namespace. */
7148 resolve_symbol (sym->result);
7150 sym->ts = sym->result->ts;
7151 sym->as = gfc_copy_array_spec (sym->result->as);
7152 sym->attr.dimension = sym->result->attr.dimension;
7153 sym->attr.pointer = sym->result->attr.pointer;
7154 sym->attr.allocatable = sym->result->attr.allocatable;
7159 /* Assumed size arrays and assumed shape arrays must be dummy
7163 && (sym->as->type == AS_ASSUMED_SIZE
7164 || sym->as->type == AS_ASSUMED_SHAPE)
7165 && sym->attr.dummy == 0)
7167 if (sym->as->type == AS_ASSUMED_SIZE)
7168 gfc_error ("Assumed size array at %L must be a dummy argument",
7171 gfc_error ("Assumed shape array at %L must be a dummy argument",
7176 /* Make sure symbols with known intent or optional are really dummy
7177 variable. Because of ENTRY statement, this has to be deferred
7178 until resolution time. */
7180 if (!sym->attr.dummy
7181 && (sym->attr.optional || sym->attr.intent != INTENT_UNKNOWN))
7183 gfc_error ("Symbol at %L is not a DUMMY variable", &sym->declared_at);
7187 if (sym->attr.value && !sym->attr.dummy)
7189 gfc_error ("'%s' at %L cannot have the VALUE attribute because "
7190 "it is not a dummy argument", sym->name, &sym->declared_at);
7194 if (sym->attr.value && sym->ts.type == BT_CHARACTER)
7196 gfc_charlen *cl = sym->ts.cl;
7197 if (!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT)
7199 gfc_error ("Character dummy variable '%s' at %L with VALUE "
7200 "attribute must have constant length",
7201 sym->name, &sym->declared_at);
7205 if (sym->ts.is_c_interop
7206 && mpz_cmp_si (cl->length->value.integer, 1) != 0)
7208 gfc_error ("C interoperable character dummy variable '%s' at %L "
7209 "with VALUE attribute must have length one",
7210 sym->name, &sym->declared_at);
7215 /* If the symbol is marked as bind(c), verify it's type and kind. Do not
7216 do this for something that was implicitly typed because that is handled
7217 in gfc_set_default_type. Handle dummy arguments and procedure
7218 definitions separately. Also, anything that is use associated is not
7219 handled here but instead is handled in the module it is declared in.
7220 Finally, derived type definitions are allowed to be BIND(C) since that
7221 only implies that they're interoperable, and they are checked fully for
7222 interoperability when a variable is declared of that type. */
7223 if (sym->attr.is_bind_c && sym->attr.implicit_type == 0 &&
7224 sym->attr.use_assoc == 0 && sym->attr.dummy == 0 &&
7225 sym->attr.flavor != FL_PROCEDURE && sym->attr.flavor != FL_DERIVED)
7229 /* First, make sure the variable is declared at the
7230 module-level scope (J3/04-007, Section 15.3). */
7231 if (sym->ns->proc_name->attr.flavor != FL_MODULE &&
7232 sym->attr.in_common == 0)
7234 gfc_error ("Variable '%s' at %L cannot be BIND(C) because it "
7235 "is neither a COMMON block nor declared at the "
7236 "module level scope", sym->name, &(sym->declared_at));
7239 else if (sym->common_head != NULL)
7241 t = verify_com_block_vars_c_interop (sym->common_head);
7245 /* If type() declaration, we need to verify that the components
7246 of the given type are all C interoperable, etc. */
7247 if (sym->ts.type == BT_DERIVED &&
7248 sym->ts.derived->attr.is_c_interop != 1)
7250 /* Make sure the user marked the derived type as BIND(C). If
7251 not, call the verify routine. This could print an error
7252 for the derived type more than once if multiple variables
7253 of that type are declared. */
7254 if (sym->ts.derived->attr.is_bind_c != 1)
7255 verify_bind_c_derived_type (sym->ts.derived);
7259 /* Verify the variable itself as C interoperable if it
7260 is BIND(C). It is not possible for this to succeed if
7261 the verify_bind_c_derived_type failed, so don't have to handle
7262 any error returned by verify_bind_c_derived_type. */
7263 t = verify_bind_c_sym (sym, &(sym->ts), sym->attr.in_common,
7269 /* clear the is_bind_c flag to prevent reporting errors more than
7270 once if something failed. */
7271 sym->attr.is_bind_c = 0;
7276 /* If a derived type symbol has reached this point, without its
7277 type being declared, we have an error. Notice that most
7278 conditions that produce undefined derived types have already
7279 been dealt with. However, the likes of:
7280 implicit type(t) (t) ..... call foo (t) will get us here if
7281 the type is not declared in the scope of the implicit
7282 statement. Change the type to BT_UNKNOWN, both because it is so
7283 and to prevent an ICE. */
7284 if (sym->ts.type == BT_DERIVED && sym->ts.derived->components == NULL)
7286 gfc_error ("The derived type '%s' at %L is of type '%s', "
7287 "which has not been defined", sym->name,
7288 &sym->declared_at, sym->ts.derived->name);
7289 sym->ts.type = BT_UNKNOWN;
7293 /* An assumed-size array with INTENT(OUT) shall not be of a type for which
7294 default initialization is defined (5.1.2.4.4). */
7295 if (sym->ts.type == BT_DERIVED
7297 && sym->attr.intent == INTENT_OUT
7299 && sym->as->type == AS_ASSUMED_SIZE)
7301 for (c = sym->ts.derived->components; c; c = c->next)
7305 gfc_error ("The INTENT(OUT) dummy argument '%s' at %L is "
7306 "ASSUMED SIZE and so cannot have a default initializer",
7307 sym->name, &sym->declared_at);
7313 switch (sym->attr.flavor)
7316 if (resolve_fl_variable (sym, mp_flag) == FAILURE)
7321 if (resolve_fl_procedure (sym, mp_flag) == FAILURE)
7326 if (resolve_fl_namelist (sym) == FAILURE)
7331 if (resolve_fl_parameter (sym) == FAILURE)
7339 /* Resolve array specifier. Check as well some constraints
7340 on COMMON blocks. */
7342 check_constant = sym->attr.in_common && !sym->attr.pointer;
7344 /* Set the formal_arg_flag so that check_conflict will not throw
7345 an error for host associated variables in the specification
7346 expression for an array_valued function. */
7347 if (sym->attr.function && sym->as)
7348 formal_arg_flag = 1;
7350 gfc_resolve_array_spec (sym->as, check_constant);
7352 formal_arg_flag = 0;
7354 /* Resolve formal namespaces. */
7355 if (sym->formal_ns && sym->formal_ns != gfc_current_ns)
7356 gfc_resolve (sym->formal_ns);
7358 /* Check threadprivate restrictions. */
7359 if (sym->attr.threadprivate && !sym->attr.save && !sym->ns->save_all
7360 && (!sym->attr.in_common
7361 && sym->module == NULL
7362 && (sym->ns->proc_name == NULL
7363 || sym->ns->proc_name->attr.flavor != FL_MODULE)))
7364 gfc_error ("Threadprivate at %L isn't SAVEd", &sym->declared_at);
7366 /* If we have come this far we can apply default-initializers, as
7367 described in 14.7.5, to those variables that have not already
7368 been assigned one. */
7369 if (sym->ts.type == BT_DERIVED
7370 && sym->attr.referenced
7371 && sym->ns == gfc_current_ns
7373 && !sym->attr.allocatable
7374 && !sym->attr.alloc_comp)
7376 symbol_attribute *a = &sym->attr;
7378 if ((!a->save && !a->dummy && !a->pointer
7379 && !a->in_common && !a->use_assoc
7380 && !(a->function && sym != sym->result))
7381 || (a->dummy && a->intent == INTENT_OUT))
7382 apply_default_init (sym);
7387 /************* Resolve DATA statements *************/
7391 gfc_data_value *vnode;
7397 /* Advance the values structure to point to the next value in the data list. */
7400 next_data_value (void)
7402 while (values.left == 0)
7404 if (values.vnode->next == NULL)
7407 values.vnode = values.vnode->next;
7408 values.left = values.vnode->repeat;
7416 check_data_variable (gfc_data_variable *var, locus *where)
7422 ar_type mark = AR_UNKNOWN;
7424 mpz_t section_index[GFC_MAX_DIMENSIONS];
7428 if (gfc_resolve_expr (var->expr) == FAILURE)
7432 mpz_init_set_si (offset, 0);
7435 if (e->expr_type != EXPR_VARIABLE)
7436 gfc_internal_error ("check_data_variable(): Bad expression");
7438 if (e->symtree->n.sym->ns->is_block_data
7439 && !e->symtree->n.sym->attr.in_common)
7441 gfc_error ("BLOCK DATA element '%s' at %L must be in COMMON",
7442 e->symtree->n.sym->name, &e->symtree->n.sym->declared_at);
7447 mpz_init_set_ui (size, 1);
7454 /* Find the array section reference. */
7455 for (ref = e->ref; ref; ref = ref->next)
7457 if (ref->type != REF_ARRAY)
7459 if (ref->u.ar.type == AR_ELEMENT)
7465 /* Set marks according to the reference pattern. */
7466 switch (ref->u.ar.type)
7474 /* Get the start position of array section. */
7475 gfc_get_section_index (ar, section_index, &offset);
7483 if (gfc_array_size (e, &size) == FAILURE)
7485 gfc_error ("Nonconstant array section at %L in DATA statement",
7494 while (mpz_cmp_ui (size, 0) > 0)
7496 if (next_data_value () == FAILURE)
7498 gfc_error ("DATA statement at %L has more variables than values",
7504 t = gfc_check_assign (var->expr, values.vnode->expr, 0);
7508 /* If we have more than one element left in the repeat count,
7509 and we have more than one element left in the target variable,
7510 then create a range assignment. */
7511 /* ??? Only done for full arrays for now, since array sections
7513 if (mark == AR_FULL && ref && ref->next == NULL
7514 && values.left > 1 && mpz_cmp_ui (size, 1) > 0)
7518 if (mpz_cmp_ui (size, values.left) >= 0)
7520 mpz_init_set_ui (range, values.left);
7521 mpz_sub_ui (size, size, values.left);
7526 mpz_init_set (range, size);
7527 values.left -= mpz_get_ui (size);
7528 mpz_set_ui (size, 0);
7531 gfc_assign_data_value_range (var->expr, values.vnode->expr,
7534 mpz_add (offset, offset, range);
7538 /* Assign initial value to symbol. */
7542 mpz_sub_ui (size, size, 1);
7544 t = gfc_assign_data_value (var->expr, values.vnode->expr, offset);
7548 if (mark == AR_FULL)
7549 mpz_add_ui (offset, offset, 1);
7551 /* Modify the array section indexes and recalculate the offset
7552 for next element. */
7553 else if (mark == AR_SECTION)
7554 gfc_advance_section (section_index, ar, &offset);
7558 if (mark == AR_SECTION)
7560 for (i = 0; i < ar->dimen; i++)
7561 mpz_clear (section_index[i]);
7571 static try traverse_data_var (gfc_data_variable *, locus *);
7573 /* Iterate over a list of elements in a DATA statement. */
7576 traverse_data_list (gfc_data_variable *var, locus *where)
7579 iterator_stack frame;
7580 gfc_expr *e, *start, *end, *step;
7581 try retval = SUCCESS;
7583 mpz_init (frame.value);
7585 start = gfc_copy_expr (var->iter.start);
7586 end = gfc_copy_expr (var->iter.end);
7587 step = gfc_copy_expr (var->iter.step);
7589 if (gfc_simplify_expr (start, 1) == FAILURE
7590 || start->expr_type != EXPR_CONSTANT)
7592 gfc_error ("iterator start at %L does not simplify", &start->where);
7596 if (gfc_simplify_expr (end, 1) == FAILURE
7597 || end->expr_type != EXPR_CONSTANT)
7599 gfc_error ("iterator end at %L does not simplify", &end->where);
7603 if (gfc_simplify_expr (step, 1) == FAILURE
7604 || step->expr_type != EXPR_CONSTANT)
7606 gfc_error ("iterator step at %L does not simplify", &step->where);
7611 mpz_init_set (trip, end->value.integer);
7612 mpz_sub (trip, trip, start->value.integer);
7613 mpz_add (trip, trip, step->value.integer);
7615 mpz_div (trip, trip, step->value.integer);
7617 mpz_set (frame.value, start->value.integer);
7619 frame.prev = iter_stack;
7620 frame.variable = var->iter.var->symtree;
7621 iter_stack = &frame;
7623 while (mpz_cmp_ui (trip, 0) > 0)
7625 if (traverse_data_var (var->list, where) == FAILURE)
7632 e = gfc_copy_expr (var->expr);
7633 if (gfc_simplify_expr (e, 1) == FAILURE)
7641 mpz_add (frame.value, frame.value, step->value.integer);
7643 mpz_sub_ui (trip, trip, 1);
7648 mpz_clear (frame.value);
7650 gfc_free_expr (start);
7651 gfc_free_expr (end);
7652 gfc_free_expr (step);
7654 iter_stack = frame.prev;
7659 /* Type resolve variables in the variable list of a DATA statement. */
7662 traverse_data_var (gfc_data_variable *var, locus *where)
7666 for (; var; var = var->next)
7668 if (var->expr == NULL)
7669 t = traverse_data_list (var, where);
7671 t = check_data_variable (var, where);
7681 /* Resolve the expressions and iterators associated with a data statement.
7682 This is separate from the assignment checking because data lists should
7683 only be resolved once. */
7686 resolve_data_variables (gfc_data_variable *d)
7688 for (; d; d = d->next)
7690 if (d->list == NULL)
7692 if (gfc_resolve_expr (d->expr) == FAILURE)
7697 if (gfc_resolve_iterator (&d->iter, false) == FAILURE)
7700 if (resolve_data_variables (d->list) == FAILURE)
7709 /* Resolve a single DATA statement. We implement this by storing a pointer to
7710 the value list into static variables, and then recursively traversing the
7711 variables list, expanding iterators and such. */
7714 resolve_data (gfc_data * d)
7716 if (resolve_data_variables (d->var) == FAILURE)
7719 values.vnode = d->value;
7720 values.left = (d->value == NULL) ? 0 : d->value->repeat;
7722 if (traverse_data_var (d->var, &d->where) == FAILURE)
7725 /* At this point, we better not have any values left. */
7727 if (next_data_value () == SUCCESS)
7728 gfc_error ("DATA statement at %L has more values than variables",
7733 /* 12.6 Constraint: In a pure subprogram any variable which is in common or
7734 accessed by host or use association, is a dummy argument to a pure function,
7735 is a dummy argument with INTENT (IN) to a pure subroutine, or an object that
7736 is storage associated with any such variable, shall not be used in the
7737 following contexts: (clients of this function). */
7739 /* Determines if a variable is not 'pure', ie not assignable within a pure
7740 procedure. Returns zero if assignment is OK, nonzero if there is a
7743 gfc_impure_variable (gfc_symbol *sym)
7747 if (sym->attr.use_assoc || sym->attr.in_common)
7750 if (sym->ns != gfc_current_ns)
7751 return !sym->attr.function;
7753 proc = sym->ns->proc_name;
7754 if (sym->attr.dummy && gfc_pure (proc)
7755 && ((proc->attr.subroutine && sym->attr.intent == INTENT_IN)
7757 proc->attr.function))
7760 /* TODO: Sort out what can be storage associated, if anything, and include
7761 it here. In principle equivalences should be scanned but it does not
7762 seem to be possible to storage associate an impure variable this way. */
7767 /* Test whether a symbol is pure or not. For a NULL pointer, checks the
7768 symbol of the current procedure. */
7771 gfc_pure (gfc_symbol *sym)
7773 symbol_attribute attr;
7776 sym = gfc_current_ns->proc_name;
7782 return attr.flavor == FL_PROCEDURE && (attr.pure || attr.elemental);
7786 /* Test whether the current procedure is elemental or not. */
7789 gfc_elemental (gfc_symbol *sym)
7791 symbol_attribute attr;
7794 sym = gfc_current_ns->proc_name;
7799 return attr.flavor == FL_PROCEDURE && attr.elemental;
7803 /* Warn about unused labels. */
7806 warn_unused_fortran_label (gfc_st_label *label)
7811 warn_unused_fortran_label (label->left);
7813 if (label->defined == ST_LABEL_UNKNOWN)
7816 switch (label->referenced)
7818 case ST_LABEL_UNKNOWN:
7819 gfc_warning ("Label %d at %L defined but not used", label->value,
7823 case ST_LABEL_BAD_TARGET:
7824 gfc_warning ("Label %d at %L defined but cannot be used",
7825 label->value, &label->where);
7832 warn_unused_fortran_label (label->right);
7836 /* Returns the sequence type of a symbol or sequence. */
7839 sequence_type (gfc_typespec ts)
7848 if (ts.derived->components == NULL)
7849 return SEQ_NONDEFAULT;
7851 result = sequence_type (ts.derived->components->ts);
7852 for (c = ts.derived->components->next; c; c = c->next)
7853 if (sequence_type (c->ts) != result)
7859 if (ts.kind != gfc_default_character_kind)
7860 return SEQ_NONDEFAULT;
7862 return SEQ_CHARACTER;
7865 if (ts.kind != gfc_default_integer_kind)
7866 return SEQ_NONDEFAULT;
7871 if (!(ts.kind == gfc_default_real_kind
7872 || ts.kind == gfc_default_double_kind))
7873 return SEQ_NONDEFAULT;
7878 if (ts.kind != gfc_default_complex_kind)
7879 return SEQ_NONDEFAULT;
7884 if (ts.kind != gfc_default_logical_kind)
7885 return SEQ_NONDEFAULT;
7890 return SEQ_NONDEFAULT;
7895 /* Resolve derived type EQUIVALENCE object. */
7898 resolve_equivalence_derived (gfc_symbol *derived, gfc_symbol *sym, gfc_expr *e)
7901 gfc_component *c = derived->components;
7906 /* Shall not be an object of nonsequence derived type. */
7907 if (!derived->attr.sequence)
7909 gfc_error ("Derived type variable '%s' at %L must have SEQUENCE "
7910 "attribute to be an EQUIVALENCE object", sym->name,
7915 /* Shall not have allocatable components. */
7916 if (derived->attr.alloc_comp)
7918 gfc_error ("Derived type variable '%s' at %L cannot have ALLOCATABLE "
7919 "components to be an EQUIVALENCE object",sym->name,
7924 for (; c ; c = c->next)
7928 && (resolve_equivalence_derived (c->ts.derived, sym, e) == FAILURE))
7931 /* Shall not be an object of sequence derived type containing a pointer
7932 in the structure. */
7935 gfc_error ("Derived type variable '%s' at %L with pointer "
7936 "component(s) cannot be an EQUIVALENCE object",
7937 sym->name, &e->where);
7945 /* Resolve equivalence object.
7946 An EQUIVALENCE object shall not be a dummy argument, a pointer, a target,
7947 an allocatable array, an object of nonsequence derived type, an object of
7948 sequence derived type containing a pointer at any level of component
7949 selection, an automatic object, a function name, an entry name, a result
7950 name, a named constant, a structure component, or a subobject of any of
7951 the preceding objects. A substring shall not have length zero. A
7952 derived type shall not have components with default initialization nor
7953 shall two objects of an equivalence group be initialized.
7954 Either all or none of the objects shall have an protected attribute.
7955 The simple constraints are done in symbol.c(check_conflict) and the rest
7956 are implemented here. */
7959 resolve_equivalence (gfc_equiv *eq)
7962 gfc_symbol *derived;
7963 gfc_symbol *first_sym;
7966 locus *last_where = NULL;
7967 seq_type eq_type, last_eq_type;
7968 gfc_typespec *last_ts;
7969 int object, cnt_protected;
7970 const char *value_name;
7974 last_ts = &eq->expr->symtree->n.sym->ts;
7976 first_sym = eq->expr->symtree->n.sym;
7980 for (object = 1; eq; eq = eq->eq, object++)
7984 e->ts = e->symtree->n.sym->ts;
7985 /* match_varspec might not know yet if it is seeing
7986 array reference or substring reference, as it doesn't
7988 if (e->ref && e->ref->type == REF_ARRAY)
7990 gfc_ref *ref = e->ref;
7991 sym = e->symtree->n.sym;
7993 if (sym->attr.dimension)
7995 ref->u.ar.as = sym->as;
7999 /* For substrings, convert REF_ARRAY into REF_SUBSTRING. */
8000 if (e->ts.type == BT_CHARACTER
8002 && ref->type == REF_ARRAY
8003 && ref->u.ar.dimen == 1
8004 && ref->u.ar.dimen_type[0] == DIMEN_RANGE
8005 && ref->u.ar.stride[0] == NULL)
8007 gfc_expr *start = ref->u.ar.start[0];
8008 gfc_expr *end = ref->u.ar.end[0];
8011 /* Optimize away the (:) reference. */
8012 if (start == NULL && end == NULL)
8017 e->ref->next = ref->next;
8022 ref->type = REF_SUBSTRING;
8024 start = gfc_int_expr (1);
8025 ref->u.ss.start = start;
8026 if (end == NULL && e->ts.cl)
8027 end = gfc_copy_expr (e->ts.cl->length);
8028 ref->u.ss.end = end;
8029 ref->u.ss.length = e->ts.cl;
8036 /* Any further ref is an error. */
8039 gcc_assert (ref->type == REF_ARRAY);
8040 gfc_error ("Syntax error in EQUIVALENCE statement at %L",
8046 if (gfc_resolve_expr (e) == FAILURE)
8049 sym = e->symtree->n.sym;
8051 if (sym->attr.protected)
8053 if (cnt_protected > 0 && cnt_protected != object)
8055 gfc_error ("Either all or none of the objects in the "
8056 "EQUIVALENCE set at %L shall have the "
8057 "PROTECTED attribute",
8062 /* Shall not equivalence common block variables in a PURE procedure. */
8063 if (sym->ns->proc_name
8064 && sym->ns->proc_name->attr.pure
8065 && sym->attr.in_common)
8067 gfc_error ("Common block member '%s' at %L cannot be an EQUIVALENCE "
8068 "object in the pure procedure '%s'",
8069 sym->name, &e->where, sym->ns->proc_name->name);
8073 /* Shall not be a named constant. */
8074 if (e->expr_type == EXPR_CONSTANT)
8076 gfc_error ("Named constant '%s' at %L cannot be an EQUIVALENCE "
8077 "object", sym->name, &e->where);
8081 derived = e->ts.derived;
8082 if (derived && resolve_equivalence_derived (derived, sym, e) == FAILURE)
8085 /* Check that the types correspond correctly:
8087 A numeric sequence structure may be equivalenced to another sequence
8088 structure, an object of default integer type, default real type, double
8089 precision real type, default logical type such that components of the
8090 structure ultimately only become associated to objects of the same
8091 kind. A character sequence structure may be equivalenced to an object
8092 of default character kind or another character sequence structure.
8093 Other objects may be equivalenced only to objects of the same type and
8096 /* Identical types are unconditionally OK. */
8097 if (object == 1 || gfc_compare_types (last_ts, &sym->ts))
8098 goto identical_types;
8100 last_eq_type = sequence_type (*last_ts);
8101 eq_type = sequence_type (sym->ts);
8103 /* Since the pair of objects is not of the same type, mixed or
8104 non-default sequences can be rejected. */
8106 msg = "Sequence %s with mixed components in EQUIVALENCE "
8107 "statement at %L with different type objects";
8109 && last_eq_type == SEQ_MIXED
8110 && gfc_notify_std (GFC_STD_GNU, msg, first_sym->name, last_where)
8112 || (eq_type == SEQ_MIXED
8113 && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
8114 &e->where) == FAILURE))
8117 msg = "Non-default type object or sequence %s in EQUIVALENCE "
8118 "statement at %L with objects of different type";
8120 && last_eq_type == SEQ_NONDEFAULT
8121 && gfc_notify_std (GFC_STD_GNU, msg, first_sym->name,
8122 last_where) == FAILURE)
8123 || (eq_type == SEQ_NONDEFAULT
8124 && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
8125 &e->where) == FAILURE))
8128 msg ="Non-CHARACTER object '%s' in default CHARACTER "
8129 "EQUIVALENCE statement at %L";
8130 if (last_eq_type == SEQ_CHARACTER
8131 && eq_type != SEQ_CHARACTER
8132 && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
8133 &e->where) == FAILURE)
8136 msg ="Non-NUMERIC object '%s' in default NUMERIC "
8137 "EQUIVALENCE statement at %L";
8138 if (last_eq_type == SEQ_NUMERIC
8139 && eq_type != SEQ_NUMERIC
8140 && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
8141 &e->where) == FAILURE)
8146 last_where = &e->where;
8151 /* Shall not be an automatic array. */
8152 if (e->ref->type == REF_ARRAY
8153 && gfc_resolve_array_spec (e->ref->u.ar.as, 1) == FAILURE)
8155 gfc_error ("Array '%s' at %L with non-constant bounds cannot be "
8156 "an EQUIVALENCE object", sym->name, &e->where);
8163 /* Shall not be a structure component. */
8164 if (r->type == REF_COMPONENT)
8166 gfc_error ("Structure component '%s' at %L cannot be an "
8167 "EQUIVALENCE object",
8168 r->u.c.component->name, &e->where);
8172 /* A substring shall not have length zero. */
8173 if (r->type == REF_SUBSTRING)
8175 if (compare_bound (r->u.ss.start, r->u.ss.end) == CMP_GT)
8177 gfc_error ("Substring at %L has length zero",
8178 &r->u.ss.start->where);
8188 /* Resolve function and ENTRY types, issue diagnostics if needed. */
8191 resolve_fntype (gfc_namespace *ns)
8196 if (ns->proc_name == NULL || !ns->proc_name->attr.function)
8199 /* If there are any entries, ns->proc_name is the entry master
8200 synthetic symbol and ns->entries->sym actual FUNCTION symbol. */
8202 sym = ns->entries->sym;
8204 sym = ns->proc_name;
8205 if (sym->result == sym
8206 && sym->ts.type == BT_UNKNOWN
8207 && gfc_set_default_type (sym, 0, NULL) == FAILURE
8208 && !sym->attr.untyped)
8210 gfc_error ("Function '%s' at %L has no IMPLICIT type",
8211 sym->name, &sym->declared_at);
8212 sym->attr.untyped = 1;
8215 if (sym->ts.type == BT_DERIVED && !sym->ts.derived->attr.use_assoc
8216 && !gfc_check_access (sym->ts.derived->attr.access,
8217 sym->ts.derived->ns->default_access)
8218 && gfc_check_access (sym->attr.access, sym->ns->default_access))
8220 gfc_error ("PUBLIC function '%s' at %L cannot be of PRIVATE type '%s'",
8221 sym->name, &sym->declared_at, sym->ts.derived->name);
8225 for (el = ns->entries->next; el; el = el->next)
8227 if (el->sym->result == el->sym
8228 && el->sym->ts.type == BT_UNKNOWN
8229 && gfc_set_default_type (el->sym, 0, NULL) == FAILURE
8230 && !el->sym->attr.untyped)
8232 gfc_error ("ENTRY '%s' at %L has no IMPLICIT type",
8233 el->sym->name, &el->sym->declared_at);
8234 el->sym->attr.untyped = 1;
8239 /* 12.3.2.1.1 Defined operators. */
8242 gfc_resolve_uops (gfc_symtree *symtree)
8246 gfc_formal_arglist *formal;
8248 if (symtree == NULL)
8251 gfc_resolve_uops (symtree->left);
8252 gfc_resolve_uops (symtree->right);
8254 for (itr = symtree->n.uop->operator; itr; itr = itr->next)
8257 if (!sym->attr.function)
8258 gfc_error ("User operator procedure '%s' at %L must be a FUNCTION",
8259 sym->name, &sym->declared_at);
8261 if (sym->ts.type == BT_CHARACTER
8262 && !(sym->ts.cl && sym->ts.cl->length)
8263 && !(sym->result && sym->result->ts.cl
8264 && sym->result->ts.cl->length))
8265 gfc_error ("User operator procedure '%s' at %L cannot be assumed "
8266 "character length", sym->name, &sym->declared_at);
8268 formal = sym->formal;
8269 if (!formal || !formal->sym)
8271 gfc_error ("User operator procedure '%s' at %L must have at least "
8272 "one argument", sym->name, &sym->declared_at);
8276 if (formal->sym->attr.intent != INTENT_IN)
8277 gfc_error ("First argument of operator interface at %L must be "
8278 "INTENT(IN)", &sym->declared_at);
8280 if (formal->sym->attr.optional)
8281 gfc_error ("First argument of operator interface at %L cannot be "
8282 "optional", &sym->declared_at);
8284 formal = formal->next;
8285 if (!formal || !formal->sym)
8288 if (formal->sym->attr.intent != INTENT_IN)
8289 gfc_error ("Second argument of operator interface at %L must be "
8290 "INTENT(IN)", &sym->declared_at);
8292 if (formal->sym->attr.optional)
8293 gfc_error ("Second argument of operator interface at %L cannot be "
8294 "optional", &sym->declared_at);
8297 gfc_error ("Operator interface at %L must have, at most, two "
8298 "arguments", &sym->declared_at);
8303 /* Examine all of the expressions associated with a program unit,
8304 assign types to all intermediate expressions, make sure that all
8305 assignments are to compatible types and figure out which names
8306 refer to which functions or subroutines. It doesn't check code
8307 block, which is handled by resolve_code. */
8310 resolve_types (gfc_namespace *ns)
8317 gfc_current_ns = ns;
8319 resolve_entries (ns);
8321 resolve_common_blocks (ns->common_root);
8323 resolve_contained_functions (ns);
8325 gfc_traverse_ns (ns, resolve_bind_c_derived_types);
8327 for (cl = ns->cl_list; cl; cl = cl->next)
8328 resolve_charlen (cl);
8330 gfc_traverse_ns (ns, resolve_symbol);
8332 resolve_fntype (ns);
8334 for (n = ns->contained; n; n = n->sibling)
8336 if (gfc_pure (ns->proc_name) && !gfc_pure (n->proc_name))
8337 gfc_error ("Contained procedure '%s' at %L of a PURE procedure must "
8338 "also be PURE", n->proc_name->name,
8339 &n->proc_name->declared_at);
8345 gfc_check_interfaces (ns);
8347 gfc_traverse_ns (ns, resolve_values);
8353 for (d = ns->data; d; d = d->next)
8357 gfc_traverse_ns (ns, gfc_formalize_init_value);
8359 gfc_traverse_ns (ns, gfc_verify_binding_labels);
8361 if (ns->common_root != NULL)
8362 gfc_traverse_symtree (ns->common_root, resolve_bind_c_comms);
8364 for (eq = ns->equiv; eq; eq = eq->next)
8365 resolve_equivalence (eq);
8367 /* Warn about unused labels. */
8368 if (warn_unused_label)
8369 warn_unused_fortran_label (ns->st_labels);
8371 gfc_resolve_uops (ns->uop_root);
8375 /* Call resolve_code recursively. */
8378 resolve_codes (gfc_namespace *ns)
8382 for (n = ns->contained; n; n = n->sibling)
8385 gfc_current_ns = ns;
8387 /* Set to an out of range value. */
8388 current_entry_id = -1;
8390 bitmap_obstack_initialize (&labels_obstack);
8391 resolve_code (ns->code, ns);
8392 bitmap_obstack_release (&labels_obstack);
8396 /* This function is called after a complete program unit has been compiled.
8397 Its purpose is to examine all of the expressions associated with a program
8398 unit, assign types to all intermediate expressions, make sure that all
8399 assignments are to compatible types and figure out which names refer to
8400 which functions or subroutines. */
8403 gfc_resolve (gfc_namespace *ns)
8405 gfc_namespace *old_ns;
8407 old_ns = gfc_current_ns;
8412 gfc_current_ns = old_ns;