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);
798 return generic_sym (s);
805 /* Determine if a symbol is specific or not. */
808 specific_sym (gfc_symbol *sym)
812 if (sym->attr.if_source == IFSRC_IFBODY
813 || sym->attr.proc == PROC_MODULE
814 || sym->attr.proc == PROC_INTERNAL
815 || sym->attr.proc == PROC_ST_FUNCTION
816 || (sym->attr.intrinsic && gfc_specific_intrinsic (sym->name))
817 || sym->attr.external)
820 if (was_declared (sym) || sym->ns->parent == NULL)
823 gfc_find_symbol (sym->name, sym->ns->parent, 1, &s);
825 return (s == NULL) ? 0 : specific_sym (s);
829 /* Figure out if the procedure is specific, generic or unknown. */
832 { PTYPE_GENERIC = 1, PTYPE_SPECIFIC, PTYPE_UNKNOWN }
836 procedure_kind (gfc_symbol *sym)
838 if (generic_sym (sym))
839 return PTYPE_GENERIC;
841 if (specific_sym (sym))
842 return PTYPE_SPECIFIC;
844 return PTYPE_UNKNOWN;
847 /* Check references to assumed size arrays. The flag need_full_assumed_size
848 is nonzero when matching actual arguments. */
850 static int need_full_assumed_size = 0;
853 check_assumed_size_reference (gfc_symbol *sym, gfc_expr *e)
859 if (need_full_assumed_size || !(sym->as && sym->as->type == AS_ASSUMED_SIZE))
862 for (ref = e->ref; ref; ref = ref->next)
863 if (ref->type == REF_ARRAY)
864 for (dim = 0; dim < ref->u.ar.as->rank; dim++)
865 last = (ref->u.ar.end[dim] == NULL)
866 && (ref->u.ar.type == DIMEN_ELEMENT);
870 gfc_error ("The upper bound in the last dimension must "
871 "appear in the reference to the assumed size "
872 "array '%s' at %L", sym->name, &e->where);
879 /* Look for bad assumed size array references in argument expressions
880 of elemental and array valued intrinsic procedures. Since this is
881 called from procedure resolution functions, it only recurses at
885 resolve_assumed_size_actual (gfc_expr *e)
890 switch (e->expr_type)
893 if (e->symtree && check_assumed_size_reference (e->symtree->n.sym, e))
898 if (resolve_assumed_size_actual (e->value.op.op1)
899 || resolve_assumed_size_actual (e->value.op.op2))
910 /* Resolve an actual argument list. Most of the time, this is just
911 resolving the expressions in the list.
912 The exception is that we sometimes have to decide whether arguments
913 that look like procedure arguments are really simple variable
917 resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype)
920 gfc_symtree *parent_st;
923 for (; arg; arg = arg->next)
928 /* Check the label is a valid branching target. */
931 if (arg->label->defined == ST_LABEL_UNKNOWN)
933 gfc_error ("Label %d referenced at %L is never defined",
934 arg->label->value, &arg->label->where);
941 if (e->ts.type != BT_PROCEDURE)
943 if (gfc_resolve_expr (e) != SUCCESS)
948 /* See if the expression node should really be a variable reference. */
950 sym = e->symtree->n.sym;
952 if (sym->attr.flavor == FL_PROCEDURE
953 || sym->attr.intrinsic
954 || sym->attr.external)
958 /* If a procedure is not already determined to be something else
959 check if it is intrinsic. */
960 if (!sym->attr.intrinsic
961 && !(sym->attr.external || sym->attr.use_assoc
962 || sym->attr.if_source == IFSRC_IFBODY)
963 && gfc_intrinsic_name (sym->name, sym->attr.subroutine))
964 sym->attr.intrinsic = 1;
966 if (sym->attr.proc == PROC_ST_FUNCTION)
968 gfc_error ("Statement function '%s' at %L is not allowed as an "
969 "actual argument", sym->name, &e->where);
972 actual_ok = gfc_intrinsic_actual_ok (sym->name,
973 sym->attr.subroutine);
974 if (sym->attr.intrinsic && actual_ok == 0)
976 gfc_error ("Intrinsic '%s' at %L is not allowed as an "
977 "actual argument", sym->name, &e->where);
980 if (sym->attr.contained && !sym->attr.use_assoc
981 && sym->ns->proc_name->attr.flavor != FL_MODULE)
983 gfc_error ("Internal procedure '%s' is not allowed as an "
984 "actual argument at %L", sym->name, &e->where);
987 if (sym->attr.elemental && !sym->attr.intrinsic)
989 gfc_error ("ELEMENTAL non-INTRINSIC procedure '%s' is not "
990 "allowed as an actual argument at %L", sym->name,
994 /* Check if a generic interface has a specific procedure
995 with the same name before emitting an error. */
996 if (sym->attr.generic)
999 for (p = sym->generic; p; p = p->next)
1000 if (strcmp (sym->name, p->sym->name) == 0)
1002 e->symtree = gfc_find_symtree
1003 (p->sym->ns->sym_root, sym->name);
1008 if (p == NULL || e->symtree == NULL)
1009 gfc_error ("GENERIC non-INTRINSIC procedure '%s' is not "
1010 "allowed as an actual argument at %L", sym->name,
1014 /* If the symbol is the function that names the current (or
1015 parent) scope, then we really have a variable reference. */
1017 if (sym->attr.function && sym->result == sym
1018 && (sym->ns->proc_name == sym
1019 || (sym->ns->parent != NULL
1020 && sym->ns->parent->proc_name == sym)))
1023 /* If all else fails, see if we have a specific intrinsic. */
1024 if (sym->attr.function
1025 && sym->ts.type == BT_UNKNOWN && sym->attr.intrinsic)
1027 gfc_intrinsic_sym *isym;
1028 isym = gfc_find_function (sym->name);
1029 if (isym == NULL || !isym->specific)
1031 gfc_error ("Unable to find a specific INTRINSIC procedure "
1032 "for the reference '%s' at %L", sym->name,
1040 /* See if the name is a module procedure in a parent unit. */
1042 if (was_declared (sym) || sym->ns->parent == NULL)
1045 if (gfc_find_sym_tree (sym->name, sym->ns->parent, 1, &parent_st))
1047 gfc_error ("Symbol '%s' at %L is ambiguous", sym->name, &e->where);
1051 if (parent_st == NULL)
1054 sym = parent_st->n.sym;
1055 e->symtree = parent_st; /* Point to the right thing. */
1057 if (sym->attr.flavor == FL_PROCEDURE
1058 || sym->attr.intrinsic
1059 || sym->attr.external)
1065 e->expr_type = EXPR_VARIABLE;
1067 if (sym->as != NULL)
1069 e->rank = sym->as->rank;
1070 e->ref = gfc_get_ref ();
1071 e->ref->type = REF_ARRAY;
1072 e->ref->u.ar.type = AR_FULL;
1073 e->ref->u.ar.as = sym->as;
1076 /* Expressions are assigned a default ts.type of BT_PROCEDURE in
1077 primary.c (match_actual_arg). If above code determines that it
1078 is a variable instead, it needs to be resolved as it was not
1079 done at the beginning of this function. */
1080 if (gfc_resolve_expr (e) != SUCCESS)
1084 /* Check argument list functions %VAL, %LOC and %REF. There is
1085 nothing to do for %REF. */
1086 if (arg->name && arg->name[0] == '%')
1088 if (strncmp ("%VAL", arg->name, 4) == 0)
1090 if (e->ts.type == BT_CHARACTER || e->ts.type == BT_DERIVED)
1092 gfc_error ("By-value argument at %L is not of numeric "
1099 gfc_error ("By-value argument at %L cannot be an array or "
1100 "an array section", &e->where);
1104 /* Intrinsics are still PROC_UNKNOWN here. However,
1105 since same file external procedures are not resolvable
1106 in gfortran, it is a good deal easier to leave them to
1108 if (ptype != PROC_UNKNOWN
1109 && ptype != PROC_DUMMY
1110 && ptype != PROC_EXTERNAL
1111 && ptype != PROC_MODULE)
1113 gfc_error ("By-value argument at %L is not allowed "
1114 "in this context", &e->where);
1119 /* Statement functions have already been excluded above. */
1120 else if (strncmp ("%LOC", arg->name, 4) == 0
1121 && e->ts.type == BT_PROCEDURE)
1123 if (e->symtree->n.sym->attr.proc == PROC_INTERNAL)
1125 gfc_error ("Passing internal procedure at %L by location "
1126 "not allowed", &e->where);
1137 /* Do the checks of the actual argument list that are specific to elemental
1138 procedures. If called with c == NULL, we have a function, otherwise if
1139 expr == NULL, we have a subroutine. */
1142 resolve_elemental_actual (gfc_expr *expr, gfc_code *c)
1144 gfc_actual_arglist *arg0;
1145 gfc_actual_arglist *arg;
1146 gfc_symbol *esym = NULL;
1147 gfc_intrinsic_sym *isym = NULL;
1149 gfc_intrinsic_arg *iformal = NULL;
1150 gfc_formal_arglist *eformal = NULL;
1151 bool formal_optional = false;
1152 bool set_by_optional = false;
1156 /* Is this an elemental procedure? */
1157 if (expr && expr->value.function.actual != NULL)
1159 if (expr->value.function.esym != NULL
1160 && expr->value.function.esym->attr.elemental)
1162 arg0 = expr->value.function.actual;
1163 esym = expr->value.function.esym;
1165 else if (expr->value.function.isym != NULL
1166 && expr->value.function.isym->elemental)
1168 arg0 = expr->value.function.actual;
1169 isym = expr->value.function.isym;
1174 else if (c && c->ext.actual != NULL && c->symtree->n.sym->attr.elemental)
1176 arg0 = c->ext.actual;
1177 esym = c->symtree->n.sym;
1182 /* The rank of an elemental is the rank of its array argument(s). */
1183 for (arg = arg0; arg; arg = arg->next)
1185 if (arg->expr != NULL && arg->expr->rank > 0)
1187 rank = arg->expr->rank;
1188 if (arg->expr->expr_type == EXPR_VARIABLE
1189 && arg->expr->symtree->n.sym->attr.optional)
1190 set_by_optional = true;
1192 /* Function specific; set the result rank and shape. */
1196 if (!expr->shape && arg->expr->shape)
1198 expr->shape = gfc_get_shape (rank);
1199 for (i = 0; i < rank; i++)
1200 mpz_init_set (expr->shape[i], arg->expr->shape[i]);
1207 /* If it is an array, it shall not be supplied as an actual argument
1208 to an elemental procedure unless an array of the same rank is supplied
1209 as an actual argument corresponding to a nonoptional dummy argument of
1210 that elemental procedure(12.4.1.5). */
1211 formal_optional = false;
1213 iformal = isym->formal;
1215 eformal = esym->formal;
1217 for (arg = arg0; arg; arg = arg->next)
1221 if (eformal->sym && eformal->sym->attr.optional)
1222 formal_optional = true;
1223 eformal = eformal->next;
1225 else if (isym && iformal)
1227 if (iformal->optional)
1228 formal_optional = true;
1229 iformal = iformal->next;
1232 formal_optional = true;
1234 if (pedantic && arg->expr != NULL
1235 && arg->expr->expr_type == EXPR_VARIABLE
1236 && arg->expr->symtree->n.sym->attr.optional
1239 && (set_by_optional || arg->expr->rank != rank)
1240 && !(isym && isym->id == GFC_ISYM_CONVERSION))
1242 gfc_warning ("'%s' at %L is an array and OPTIONAL; IF IT IS "
1243 "MISSING, it cannot be the actual argument of an "
1244 "ELEMENTAL procedure unless there is a non-optional "
1245 "argument with the same rank (12.4.1.5)",
1246 arg->expr->symtree->n.sym->name, &arg->expr->where);
1251 for (arg = arg0; arg; arg = arg->next)
1253 if (arg->expr == NULL || arg->expr->rank == 0)
1256 /* Being elemental, the last upper bound of an assumed size array
1257 argument must be present. */
1258 if (resolve_assumed_size_actual (arg->expr))
1264 /* Elemental subroutine array actual arguments must conform. */
1267 if (gfc_check_conformance ("elemental subroutine", arg->expr, e)
1279 /* Go through each actual argument in ACTUAL and see if it can be
1280 implemented as an inlined, non-copying intrinsic. FNSYM is the
1281 function being called, or NULL if not known. */
1284 find_noncopying_intrinsics (gfc_symbol *fnsym, gfc_actual_arglist *actual)
1286 gfc_actual_arglist *ap;
1289 for (ap = actual; ap; ap = ap->next)
1291 && (expr = gfc_get_noncopying_intrinsic_argument (ap->expr))
1292 && !gfc_check_fncall_dependency (expr, INTENT_IN, fnsym, actual))
1293 ap->expr->inline_noncopying_intrinsic = 1;
1297 /* This function does the checking of references to global procedures
1298 as defined in sections 18.1 and 14.1, respectively, of the Fortran
1299 77 and 95 standards. It checks for a gsymbol for the name, making
1300 one if it does not already exist. If it already exists, then the
1301 reference being resolved must correspond to the type of gsymbol.
1302 Otherwise, the new symbol is equipped with the attributes of the
1303 reference. The corresponding code that is called in creating
1304 global entities is parse.c. */
1307 resolve_global_procedure (gfc_symbol *sym, locus *where, int sub)
1312 type = sub ? GSYM_SUBROUTINE : GSYM_FUNCTION;
1314 gsym = gfc_get_gsymbol (sym->name);
1316 if ((gsym->type != GSYM_UNKNOWN && gsym->type != type))
1317 global_used (gsym, where);
1319 if (gsym->type == GSYM_UNKNOWN)
1322 gsym->where = *where;
1329 /************* Function resolution *************/
1331 /* Resolve a function call known to be generic.
1332 Section 14.1.2.4.1. */
1335 resolve_generic_f0 (gfc_expr *expr, gfc_symbol *sym)
1339 if (sym->attr.generic)
1341 s = gfc_search_interface (sym->generic, 0, &expr->value.function.actual);
1344 expr->value.function.name = s->name;
1345 expr->value.function.esym = s;
1347 if (s->ts.type != BT_UNKNOWN)
1349 else if (s->result != NULL && s->result->ts.type != BT_UNKNOWN)
1350 expr->ts = s->result->ts;
1353 expr->rank = s->as->rank;
1354 else if (s->result != NULL && s->result->as != NULL)
1355 expr->rank = s->result->as->rank;
1360 /* TODO: Need to search for elemental references in generic
1364 if (sym->attr.intrinsic)
1365 return gfc_intrinsic_func_interface (expr, 0);
1372 resolve_generic_f (gfc_expr *expr)
1377 sym = expr->symtree->n.sym;
1381 m = resolve_generic_f0 (expr, sym);
1384 else if (m == MATCH_ERROR)
1388 if (sym->ns->parent == NULL)
1390 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
1394 if (!generic_sym (sym))
1398 /* Last ditch attempt. See if the reference is to an intrinsic
1399 that possesses a matching interface. 14.1.2.4 */
1400 if (sym && !gfc_intrinsic_name (sym->name, 0))
1402 gfc_error ("There is no specific function for the generic '%s' at %L",
1403 expr->symtree->n.sym->name, &expr->where);
1407 m = gfc_intrinsic_func_interface (expr, 0);
1411 gfc_error ("Generic function '%s' at %L is not consistent with a "
1412 "specific intrinsic interface", expr->symtree->n.sym->name,
1419 /* Resolve a function call known to be specific. */
1422 resolve_specific_f0 (gfc_symbol *sym, gfc_expr *expr)
1426 if (sym->attr.external || sym->attr.if_source == IFSRC_IFBODY)
1428 if (sym->attr.dummy)
1430 sym->attr.proc = PROC_DUMMY;
1434 sym->attr.proc = PROC_EXTERNAL;
1438 if (sym->attr.proc == PROC_MODULE
1439 || sym->attr.proc == PROC_ST_FUNCTION
1440 || sym->attr.proc == PROC_INTERNAL)
1443 if (sym->attr.intrinsic)
1445 m = gfc_intrinsic_func_interface (expr, 1);
1449 gfc_error ("Function '%s' at %L is INTRINSIC but is not compatible "
1450 "with an intrinsic", sym->name, &expr->where);
1458 gfc_procedure_use (sym, &expr->value.function.actual, &expr->where);
1461 expr->value.function.name = sym->name;
1462 expr->value.function.esym = sym;
1463 if (sym->as != NULL)
1464 expr->rank = sym->as->rank;
1471 resolve_specific_f (gfc_expr *expr)
1476 sym = expr->symtree->n.sym;
1480 m = resolve_specific_f0 (sym, expr);
1483 if (m == MATCH_ERROR)
1486 if (sym->ns->parent == NULL)
1489 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
1495 gfc_error ("Unable to resolve the specific function '%s' at %L",
1496 expr->symtree->n.sym->name, &expr->where);
1502 /* Resolve a procedure call not known to be generic nor specific. */
1505 resolve_unknown_f (gfc_expr *expr)
1510 sym = expr->symtree->n.sym;
1512 if (sym->attr.dummy)
1514 sym->attr.proc = PROC_DUMMY;
1515 expr->value.function.name = sym->name;
1519 /* See if we have an intrinsic function reference. */
1521 if (gfc_intrinsic_name (sym->name, 0))
1523 if (gfc_intrinsic_func_interface (expr, 1) == MATCH_YES)
1528 /* The reference is to an external name. */
1530 sym->attr.proc = PROC_EXTERNAL;
1531 expr->value.function.name = sym->name;
1532 expr->value.function.esym = expr->symtree->n.sym;
1534 if (sym->as != NULL)
1535 expr->rank = sym->as->rank;
1537 /* Type of the expression is either the type of the symbol or the
1538 default type of the symbol. */
1541 gfc_procedure_use (sym, &expr->value.function.actual, &expr->where);
1543 if (sym->ts.type != BT_UNKNOWN)
1547 ts = gfc_get_default_type (sym, sym->ns);
1549 if (ts->type == BT_UNKNOWN)
1551 gfc_error ("Function '%s' at %L has no IMPLICIT type",
1552 sym->name, &expr->where);
1563 /* Return true, if the symbol is an external procedure. */
1565 is_external_proc (gfc_symbol *sym)
1567 if (!sym->attr.dummy && !sym->attr.contained
1568 && !(sym->attr.intrinsic
1569 || gfc_intrinsic_name (sym->name, sym->attr.subroutine))
1570 && sym->attr.proc != PROC_ST_FUNCTION
1571 && !sym->attr.use_assoc
1579 /* Figure out if a function reference is pure or not. Also set the name
1580 of the function for a potential error message. Return nonzero if the
1581 function is PURE, zero if not. */
1584 pure_function (gfc_expr *e, const char **name)
1590 if (e->symtree != NULL
1591 && e->symtree->n.sym != NULL
1592 && e->symtree->n.sym->attr.proc == PROC_ST_FUNCTION)
1595 if (e->value.function.esym)
1597 pure = gfc_pure (e->value.function.esym);
1598 *name = e->value.function.esym->name;
1600 else if (e->value.function.isym)
1602 pure = e->value.function.isym->pure
1603 || e->value.function.isym->elemental;
1604 *name = e->value.function.isym->name;
1608 /* Implicit functions are not pure. */
1610 *name = e->value.function.name;
1618 is_scalar_expr_ptr (gfc_expr *expr)
1620 try retval = SUCCESS;
1625 /* See if we have a gfc_ref, which means we have a substring, array
1626 reference, or a component. */
1627 if (expr->ref != NULL)
1630 while (ref->next != NULL)
1636 if (ref->u.ss.length != NULL
1637 && ref->u.ss.length->length != NULL
1639 && ref->u.ss.start->expr_type == EXPR_CONSTANT
1641 && ref->u.ss.end->expr_type == EXPR_CONSTANT)
1643 start = (int) mpz_get_si (ref->u.ss.start->value.integer);
1644 end = (int) mpz_get_si (ref->u.ss.end->value.integer);
1645 if (end - start + 1 != 1)
1652 if (ref->u.ar.type == AR_ELEMENT)
1654 else if (ref->u.ar.type == AR_FULL)
1656 /* The user can give a full array if the array is of size 1. */
1657 if (ref->u.ar.as != NULL
1658 && ref->u.ar.as->rank == 1
1659 && ref->u.ar.as->type == AS_EXPLICIT
1660 && ref->u.ar.as->lower[0] != NULL
1661 && ref->u.ar.as->lower[0]->expr_type == EXPR_CONSTANT
1662 && ref->u.ar.as->upper[0] != NULL
1663 && ref->u.ar.as->upper[0]->expr_type == EXPR_CONSTANT)
1665 /* If we have a character string, we need to check if
1666 its length is one. */
1667 if (expr->ts.type == BT_CHARACTER)
1669 if (expr->ts.cl == NULL
1670 || expr->ts.cl->length == NULL
1671 || mpz_cmp_si (expr->ts.cl->length->value.integer, 1)
1677 /* We have constant lower and upper bounds. If the
1678 difference between is 1, it can be considered a
1680 start = (int) mpz_get_si
1681 (ref->u.ar.as->lower[0]->value.integer);
1682 end = (int) mpz_get_si
1683 (ref->u.ar.as->upper[0]->value.integer);
1684 if (end - start + 1 != 1)
1699 else if (expr->ts.type == BT_CHARACTER && expr->rank == 0)
1701 /* Character string. Make sure it's of length 1. */
1702 if (expr->ts.cl == NULL
1703 || expr->ts.cl->length == NULL
1704 || mpz_cmp_si (expr->ts.cl->length->value.integer, 1) != 0)
1707 else if (expr->rank != 0)
1714 /* Match one of the iso_c_binding functions (c_associated or c_loc)
1715 and, in the case of c_associated, set the binding label based on
1719 gfc_iso_c_func_interface (gfc_symbol *sym, gfc_actual_arglist *args,
1720 gfc_symbol **new_sym)
1722 char name[GFC_MAX_SYMBOL_LEN + 1];
1723 char binding_label[GFC_MAX_BINDING_LABEL_LEN + 1];
1724 int optional_arg = 0;
1725 try retval = SUCCESS;
1726 gfc_symbol *args_sym;
1728 if (args->expr->expr_type == EXPR_CONSTANT
1729 || args->expr->expr_type == EXPR_OP
1730 || args->expr->expr_type == EXPR_NULL)
1732 gfc_error ("Argument to '%s' at %L is not a variable",
1733 sym->name, &(args->expr->where));
1737 args_sym = args->expr->symtree->n.sym;
1739 if (sym->intmod_sym_id == ISOCBINDING_ASSOCIATED)
1741 /* If the user gave two args then they are providing something for
1742 the optional arg (the second cptr). Therefore, set the name and
1743 binding label to the c_associated for two cptrs. Otherwise,
1744 set c_associated to expect one cptr. */
1748 sprintf (name, "%s_2", sym->name);
1749 sprintf (binding_label, "%s_2", sym->binding_label);
1755 sprintf (name, "%s_1", sym->name);
1756 sprintf (binding_label, "%s_1", sym->binding_label);
1760 /* Get a new symbol for the version of c_associated that
1762 *new_sym = get_iso_c_sym (sym, name, binding_label, optional_arg);
1764 else if (sym->intmod_sym_id == ISOCBINDING_LOC
1765 || sym->intmod_sym_id == ISOCBINDING_FUNLOC)
1767 sprintf (name, "%s", sym->name);
1768 sprintf (binding_label, "%s", sym->binding_label);
1770 /* Error check the call. */
1771 if (args->next != NULL)
1773 gfc_error_now ("More actual than formal arguments in '%s' "
1774 "call at %L", name, &(args->expr->where));
1777 else if (sym->intmod_sym_id == ISOCBINDING_LOC)
1779 /* Make sure we have either the target or pointer attribute. */
1780 if (!(args->expr->symtree->n.sym->attr.target)
1781 && !(args->expr->symtree->n.sym->attr.pointer))
1783 gfc_error_now ("Parameter '%s' to '%s' at %L must be either "
1784 "a TARGET or an associated pointer",
1785 args->expr->symtree->n.sym->name,
1786 sym->name, &(args->expr->where));
1790 /* See if we have interoperable type and type param. */
1791 if (verify_c_interop (&(args->expr->symtree->n.sym->ts),
1792 args->expr->symtree->n.sym->name,
1793 &(args->expr->where)) == SUCCESS
1794 || gfc_check_any_c_kind (&(args_sym->ts)) == SUCCESS)
1796 if (args_sym->attr.target == 1)
1798 /* Case 1a, section 15.1.2.5, J3/04-007: variable that
1799 has the target attribute and is interoperable. */
1800 /* Case 1b, section 15.1.2.5, J3/04-007: allocated
1801 allocatable variable that has the TARGET attribute and
1802 is not an array of zero size. */
1803 if (args_sym->attr.allocatable == 1)
1805 if (args_sym->attr.dimension != 0
1806 && (args_sym->as && args_sym->as->rank == 0))
1808 gfc_error_now ("Allocatable variable '%s' used as a "
1809 "parameter to '%s' at %L must not be "
1810 "an array of zero size",
1811 args_sym->name, sym->name,
1812 &(args->expr->where));
1818 /* A non-allocatable target variable with C
1819 interoperable type and type parameters must be
1821 if (args_sym && args_sym->attr.dimension)
1823 if (args_sym->as->type == AS_ASSUMED_SHAPE)
1825 gfc_error ("Assumed-shape array '%s' at %L "
1826 "cannot be an argument to the "
1827 "procedure '%s' because "
1828 "it is not C interoperable",
1830 &(args->expr->where), sym->name);
1833 else if (args_sym->as->type == AS_DEFERRED)
1835 gfc_error ("Deferred-shape array '%s' at %L "
1836 "cannot be an argument to the "
1837 "procedure '%s' because "
1838 "it is not C interoperable",
1840 &(args->expr->where), sym->name);
1845 /* Make sure it's not a character string. Arrays of
1846 any type should be ok if the variable is of a C
1847 interoperable type. */
1848 if (args_sym->ts.type == BT_CHARACTER)
1849 if (args_sym->ts.cl != NULL
1850 && (args_sym->ts.cl->length == NULL
1851 || args_sym->ts.cl->length->expr_type
1854 (args_sym->ts.cl->length->value.integer, 1)
1856 && is_scalar_expr_ptr (args->expr) != SUCCESS)
1858 gfc_error_now ("CHARACTER argument '%s' to '%s' "
1859 "at %L must have a length of 1",
1860 args_sym->name, sym->name,
1861 &(args->expr->where));
1866 else if (args_sym->attr.pointer == 1
1867 && is_scalar_expr_ptr (args->expr) != SUCCESS)
1869 /* Case 1c, section 15.1.2.5, J3/04-007: an associated
1871 gfc_error_now ("Argument '%s' to '%s' at %L must be an "
1872 "associated scalar POINTER", args_sym->name,
1873 sym->name, &(args->expr->where));
1879 /* The parameter is not required to be C interoperable. If it
1880 is not C interoperable, it must be a nonpolymorphic scalar
1881 with no length type parameters. It still must have either
1882 the pointer or target attribute, and it can be
1883 allocatable (but must be allocated when c_loc is called). */
1884 if (args_sym->attr.dimension != 0
1885 && is_scalar_expr_ptr (args->expr) != SUCCESS)
1887 gfc_error_now ("Parameter '%s' to '%s' at %L must be a "
1888 "scalar", args_sym->name, sym->name,
1889 &(args->expr->where));
1892 else if (args_sym->ts.type == BT_CHARACTER
1893 && is_scalar_expr_ptr (args->expr) != SUCCESS)
1895 gfc_error_now ("CHARACTER argument '%s' to '%s' at "
1896 "%L must have a length of 1",
1897 args_sym->name, sym->name,
1898 &(args->expr->where));
1903 else if (sym->intmod_sym_id == ISOCBINDING_FUNLOC)
1905 if (args->expr->symtree->n.sym->attr.flavor != FL_PROCEDURE)
1907 /* TODO: Update this error message to allow for procedure
1908 pointers once they are implemented. */
1909 gfc_error_now ("Parameter '%s' to '%s' at %L must be a "
1911 args->expr->symtree->n.sym->name, sym->name,
1912 &(args->expr->where));
1915 else if (args->expr->symtree->n.sym->attr.is_bind_c != 1)
1917 gfc_error_now ("Parameter '%s' to '%s' at %L must be "
1919 args->expr->symtree->n.sym->name, sym->name,
1920 &(args->expr->where));
1925 /* for c_loc/c_funloc, the new symbol is the same as the old one */
1930 gfc_internal_error ("gfc_iso_c_func_interface(): Unhandled "
1931 "iso_c_binding function: '%s'!\n", sym->name);
1938 /* Resolve a function call, which means resolving the arguments, then figuring
1939 out which entity the name refers to. */
1940 /* TODO: Check procedure arguments so that an INTENT(IN) isn't passed
1941 to INTENT(OUT) or INTENT(INOUT). */
1944 resolve_function (gfc_expr *expr)
1946 gfc_actual_arglist *arg;
1951 procedure_type p = PROC_INTRINSIC;
1955 sym = expr->symtree->n.sym;
1957 if (sym && sym->attr.flavor == FL_VARIABLE)
1959 gfc_error ("'%s' at %L is not a function", sym->name, &expr->where);
1963 /* If the procedure is external, check for usage. */
1964 if (sym && is_external_proc (sym))
1965 resolve_global_procedure (sym, &expr->where, 0);
1967 /* Switch off assumed size checking and do this again for certain kinds
1968 of procedure, once the procedure itself is resolved. */
1969 need_full_assumed_size++;
1971 if (expr->symtree && expr->symtree->n.sym)
1972 p = expr->symtree->n.sym->attr.proc;
1974 if (resolve_actual_arglist (expr->value.function.actual, p) == FAILURE)
1977 /* Need to setup the call to the correct c_associated, depending on
1978 the number of cptrs to user gives to compare. */
1979 if (sym && sym->attr.is_iso_c == 1)
1981 if (gfc_iso_c_func_interface (sym, expr->value.function.actual, &sym)
1985 /* Get the symtree for the new symbol (resolved func).
1986 the old one will be freed later, when it's no longer used. */
1987 gfc_find_sym_tree (sym->name, sym->ns, 1, &(expr->symtree));
1990 /* Resume assumed_size checking. */
1991 need_full_assumed_size--;
1993 if (sym && sym->ts.type == BT_CHARACTER
1995 && sym->ts.cl->length == NULL
1997 && expr->value.function.esym == NULL
1998 && !sym->attr.contained)
2000 /* Internal procedures are taken care of in resolve_contained_fntype. */
2001 gfc_error ("Function '%s' is declared CHARACTER(*) and cannot "
2002 "be used at %L since it is not a dummy argument",
2003 sym->name, &expr->where);
2007 /* See if function is already resolved. */
2009 if (expr->value.function.name != NULL)
2011 if (expr->ts.type == BT_UNKNOWN)
2017 /* Apply the rules of section 14.1.2. */
2019 switch (procedure_kind (sym))
2022 t = resolve_generic_f (expr);
2025 case PTYPE_SPECIFIC:
2026 t = resolve_specific_f (expr);
2030 t = resolve_unknown_f (expr);
2034 gfc_internal_error ("resolve_function(): bad function type");
2038 /* If the expression is still a function (it might have simplified),
2039 then we check to see if we are calling an elemental function. */
2041 if (expr->expr_type != EXPR_FUNCTION)
2044 temp = need_full_assumed_size;
2045 need_full_assumed_size = 0;
2047 if (resolve_elemental_actual (expr, NULL) == FAILURE)
2050 if (omp_workshare_flag
2051 && expr->value.function.esym
2052 && ! gfc_elemental (expr->value.function.esym))
2054 gfc_error ("User defined non-ELEMENTAL function '%s' at %L not allowed "
2055 "in WORKSHARE construct", expr->value.function.esym->name,
2060 #define GENERIC_ID expr->value.function.isym->id
2061 else if (expr->value.function.actual != NULL
2062 && expr->value.function.isym != NULL
2063 && GENERIC_ID != GFC_ISYM_LBOUND
2064 && GENERIC_ID != GFC_ISYM_LEN
2065 && GENERIC_ID != GFC_ISYM_LOC
2066 && GENERIC_ID != GFC_ISYM_PRESENT)
2068 /* Array intrinsics must also have the last upper bound of an
2069 assumed size array argument. UBOUND and SIZE have to be
2070 excluded from the check if the second argument is anything
2073 inquiry = GENERIC_ID == GFC_ISYM_UBOUND
2074 || GENERIC_ID == GFC_ISYM_SIZE;
2076 for (arg = expr->value.function.actual; arg; arg = arg->next)
2078 if (inquiry && arg->next != NULL && arg->next->expr)
2080 if (arg->next->expr->expr_type != EXPR_CONSTANT)
2083 if ((int)mpz_get_si (arg->next->expr->value.integer)
2088 if (arg->expr != NULL
2089 && arg->expr->rank > 0
2090 && resolve_assumed_size_actual (arg->expr))
2096 need_full_assumed_size = temp;
2099 if (!pure_function (expr, &name) && name)
2103 gfc_error ("reference to non-PURE function '%s' at %L inside a "
2104 "FORALL %s", name, &expr->where,
2105 forall_flag == 2 ? "mask" : "block");
2108 else if (gfc_pure (NULL))
2110 gfc_error ("Function reference to '%s' at %L is to a non-PURE "
2111 "procedure within a PURE procedure", name, &expr->where);
2116 /* Functions without the RECURSIVE attribution are not allowed to
2117 * call themselves. */
2118 if (expr->value.function.esym && !expr->value.function.esym->attr.recursive)
2120 gfc_symbol *esym, *proc;
2121 esym = expr->value.function.esym;
2122 proc = gfc_current_ns->proc_name;
2125 gfc_error ("Function '%s' at %L cannot call itself, as it is not "
2126 "RECURSIVE", name, &expr->where);
2130 if (esym->attr.entry && esym->ns->entries && proc->ns->entries
2131 && esym->ns->entries->sym == proc->ns->entries->sym)
2133 gfc_error ("Call to ENTRY '%s' at %L is recursive, but function "
2134 "'%s' is not declared as RECURSIVE",
2135 esym->name, &expr->where, esym->ns->entries->sym->name);
2140 /* Character lengths of use associated functions may contains references to
2141 symbols not referenced from the current program unit otherwise. Make sure
2142 those symbols are marked as referenced. */
2144 if (expr->ts.type == BT_CHARACTER && expr->value.function.esym
2145 && expr->value.function.esym->attr.use_assoc)
2147 gfc_expr_set_symbols_referenced (expr->ts.cl->length);
2151 find_noncopying_intrinsics (expr->value.function.esym,
2152 expr->value.function.actual);
2154 /* Make sure that the expression has a typespec that works. */
2155 if (expr->ts.type == BT_UNKNOWN)
2157 if (expr->symtree->n.sym->result
2158 && expr->symtree->n.sym->result->ts.type != BT_UNKNOWN)
2159 expr->ts = expr->symtree->n.sym->result->ts;
2166 /************* Subroutine resolution *************/
2169 pure_subroutine (gfc_code *c, gfc_symbol *sym)
2175 gfc_error ("Subroutine call to '%s' in FORALL block at %L is not PURE",
2176 sym->name, &c->loc);
2177 else if (gfc_pure (NULL))
2178 gfc_error ("Subroutine call to '%s' at %L is not PURE", sym->name,
2184 resolve_generic_s0 (gfc_code *c, gfc_symbol *sym)
2188 if (sym->attr.generic)
2190 s = gfc_search_interface (sym->generic, 1, &c->ext.actual);
2193 c->resolved_sym = s;
2194 pure_subroutine (c, s);
2198 /* TODO: Need to search for elemental references in generic interface. */
2201 if (sym->attr.intrinsic)
2202 return gfc_intrinsic_sub_interface (c, 0);
2209 resolve_generic_s (gfc_code *c)
2214 sym = c->symtree->n.sym;
2218 m = resolve_generic_s0 (c, sym);
2221 else if (m == MATCH_ERROR)
2225 if (sym->ns->parent == NULL)
2227 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
2231 if (!generic_sym (sym))
2235 /* Last ditch attempt. See if the reference is to an intrinsic
2236 that possesses a matching interface. 14.1.2.4 */
2237 sym = c->symtree->n.sym;
2239 if (!gfc_intrinsic_name (sym->name, 1))
2241 gfc_error ("There is no specific subroutine for the generic '%s' at %L",
2242 sym->name, &c->loc);
2246 m = gfc_intrinsic_sub_interface (c, 0);
2250 gfc_error ("Generic subroutine '%s' at %L is not consistent with an "
2251 "intrinsic subroutine interface", sym->name, &c->loc);
2257 /* Set the name and binding label of the subroutine symbol in the call
2258 expression represented by 'c' to include the type and kind of the
2259 second parameter. This function is for resolving the appropriate
2260 version of c_f_pointer() and c_f_procpointer(). For example, a
2261 call to c_f_pointer() for a default integer pointer could have a
2262 name of c_f_pointer_i4. If no second arg exists, which is an error
2263 for these two functions, it defaults to the generic symbol's name
2264 and binding label. */
2267 set_name_and_label (gfc_code *c, gfc_symbol *sym,
2268 char *name, char *binding_label)
2270 gfc_expr *arg = NULL;
2274 /* The second arg of c_f_pointer and c_f_procpointer determines
2275 the type and kind for the procedure name. */
2276 arg = c->ext.actual->next->expr;
2280 /* Set up the name to have the given symbol's name,
2281 plus the type and kind. */
2282 /* a derived type is marked with the type letter 'u' */
2283 if (arg->ts.type == BT_DERIVED)
2286 kind = 0; /* set the kind as 0 for now */
2290 type = gfc_type_letter (arg->ts.type);
2291 kind = arg->ts.kind;
2294 if (arg->ts.type == BT_CHARACTER)
2295 /* Kind info for character strings not needed. */
2298 sprintf (name, "%s_%c%d", sym->name, type, kind);
2299 /* Set up the binding label as the given symbol's label plus
2300 the type and kind. */
2301 sprintf (binding_label, "%s_%c%d", sym->binding_label, type, kind);
2305 /* If the second arg is missing, set the name and label as
2306 was, cause it should at least be found, and the missing
2307 arg error will be caught by compare_parameters(). */
2308 sprintf (name, "%s", sym->name);
2309 sprintf (binding_label, "%s", sym->binding_label);
2316 /* Resolve a generic version of the iso_c_binding procedure given
2317 (sym) to the specific one based on the type and kind of the
2318 argument(s). Currently, this function resolves c_f_pointer() and
2319 c_f_procpointer based on the type and kind of the second argument
2320 (FPTR). Other iso_c_binding procedures aren't specially handled.
2321 Upon successfully exiting, c->resolved_sym will hold the resolved
2322 symbol. Returns MATCH_ERROR if an error occurred; MATCH_YES
2326 gfc_iso_c_sub_interface (gfc_code *c, gfc_symbol *sym)
2328 gfc_symbol *new_sym;
2329 /* this is fine, since we know the names won't use the max */
2330 char name[GFC_MAX_SYMBOL_LEN + 1];
2331 char binding_label[GFC_MAX_BINDING_LABEL_LEN + 1];
2332 /* default to success; will override if find error */
2333 match m = MATCH_YES;
2335 /* Make sure the actual arguments are in the necessary order (based on the
2336 formal args) before resolving. */
2337 gfc_procedure_use (sym, &c->ext.actual, &(c->loc));
2339 /* Give the optional SHAPE formal arg a type now that we've done our
2340 initial checking against the actual. */
2341 if (sym->intmod_sym_id == ISOCBINDING_F_POINTER)
2342 sym->formal->next->next->sym->ts.type = BT_INTEGER;
2344 if ((sym->intmod_sym_id == ISOCBINDING_F_POINTER) ||
2345 (sym->intmod_sym_id == ISOCBINDING_F_PROCPOINTER))
2347 set_name_and_label (c, sym, name, binding_label);
2349 if (sym->intmod_sym_id == ISOCBINDING_F_POINTER)
2351 if (c->ext.actual != NULL && c->ext.actual->next != NULL)
2353 /* Make sure we got a third arg if the second arg has non-zero
2354 rank. We must also check that the type and rank are
2355 correct since we short-circuit this check in
2356 gfc_procedure_use() (called above to sort actual args). */
2357 if (c->ext.actual->next->expr->rank != 0)
2359 if(c->ext.actual->next->next == NULL
2360 || c->ext.actual->next->next->expr == NULL)
2363 gfc_error ("Missing SHAPE parameter for call to %s "
2364 "at %L", sym->name, &(c->loc));
2366 else if (c->ext.actual->next->next->expr->ts.type
2368 || c->ext.actual->next->next->expr->rank != 1)
2371 gfc_error ("SHAPE parameter for call to %s at %L must "
2372 "be a rank 1 INTEGER array", sym->name,
2379 if (m != MATCH_ERROR)
2381 /* the 1 means to add the optional arg to formal list */
2382 new_sym = get_iso_c_sym (sym, name, binding_label, 1);
2384 /* Set the kind for the SHAPE array to that of the actual
2386 if (c->ext.actual != NULL && c->ext.actual->next != NULL
2387 && c->ext.actual->next->expr->rank != 0)
2388 new_sym->formal->next->next->sym->ts.kind =
2389 c->ext.actual->next->next->expr->ts.kind;
2391 /* for error reporting, say it's declared where the original was */
2392 new_sym->declared_at = sym->declared_at;
2395 else if (sym->intmod_sym_id == ISOCBINDING_ASSOCIATED)
2397 /* TODO: Figure out if this is even reachable; this part of the
2398 conditional may not be necessary. */
2400 if (c->ext.actual->next == NULL)
2402 /* The user did not give two args, so resolve to the version
2403 of c_associated expecting one arg. */
2405 /* get rid of the second arg */
2406 /* TODO!! Should free up the memory here! */
2407 sym->formal->next = NULL;
2415 sprintf (name, "%s_%d", sym->name, num_args);
2416 sprintf (binding_label, "%s_%d", sym->binding_label, num_args);
2417 sym->name = gfc_get_string (name);
2418 strcpy (sym->binding_label, binding_label);
2422 /* no differences for c_loc or c_funloc */
2426 /* set the resolved symbol */
2427 if (m != MATCH_ERROR)
2428 c->resolved_sym = new_sym;
2430 c->resolved_sym = sym;
2436 /* Resolve a subroutine call known to be specific. */
2439 resolve_specific_s0 (gfc_code *c, gfc_symbol *sym)
2443 if(sym->attr.is_iso_c)
2445 m = gfc_iso_c_sub_interface (c,sym);
2449 if (sym->attr.external || sym->attr.if_source == IFSRC_IFBODY)
2451 if (sym->attr.dummy)
2453 sym->attr.proc = PROC_DUMMY;
2457 sym->attr.proc = PROC_EXTERNAL;
2461 if (sym->attr.proc == PROC_MODULE || sym->attr.proc == PROC_INTERNAL)
2464 if (sym->attr.intrinsic)
2466 m = gfc_intrinsic_sub_interface (c, 1);
2470 gfc_error ("Subroutine '%s' at %L is INTRINSIC but is not compatible "
2471 "with an intrinsic", sym->name, &c->loc);
2479 gfc_procedure_use (sym, &c->ext.actual, &c->loc);
2481 c->resolved_sym = sym;
2482 pure_subroutine (c, sym);
2489 resolve_specific_s (gfc_code *c)
2494 sym = c->symtree->n.sym;
2498 m = resolve_specific_s0 (c, sym);
2501 if (m == MATCH_ERROR)
2504 if (sym->ns->parent == NULL)
2507 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
2513 sym = c->symtree->n.sym;
2514 gfc_error ("Unable to resolve the specific subroutine '%s' at %L",
2515 sym->name, &c->loc);
2521 /* Resolve a subroutine call not known to be generic nor specific. */
2524 resolve_unknown_s (gfc_code *c)
2528 sym = c->symtree->n.sym;
2530 if (sym->attr.dummy)
2532 sym->attr.proc = PROC_DUMMY;
2536 /* See if we have an intrinsic function reference. */
2538 if (gfc_intrinsic_name (sym->name, 1))
2540 if (gfc_intrinsic_sub_interface (c, 1) == MATCH_YES)
2545 /* The reference is to an external name. */
2548 gfc_procedure_use (sym, &c->ext.actual, &c->loc);
2550 c->resolved_sym = sym;
2552 pure_subroutine (c, sym);
2558 /* Resolve a subroutine call. Although it was tempting to use the same code
2559 for functions, subroutines and functions are stored differently and this
2560 makes things awkward. */
2563 resolve_call (gfc_code *c)
2566 procedure_type ptype = PROC_INTRINSIC;
2568 if (c->symtree && c->symtree->n.sym
2569 && c->symtree->n.sym->ts.type != BT_UNKNOWN)
2571 gfc_error ("'%s' at %L has a type, which is not consistent with "
2572 "the CALL at %L", c->symtree->n.sym->name,
2573 &c->symtree->n.sym->declared_at, &c->loc);
2577 /* If external, check for usage. */
2578 if (c->symtree && is_external_proc (c->symtree->n.sym))
2579 resolve_global_procedure (c->symtree->n.sym, &c->loc, 1);
2581 /* Subroutines without the RECURSIVE attribution are not allowed to
2582 * call themselves. */
2583 if (c->symtree && c->symtree->n.sym && !c->symtree->n.sym->attr.recursive)
2585 gfc_symbol *csym, *proc;
2586 csym = c->symtree->n.sym;
2587 proc = gfc_current_ns->proc_name;
2590 gfc_error ("SUBROUTINE '%s' at %L cannot call itself, as it is not "
2591 "RECURSIVE", csym->name, &c->loc);
2595 if (csym->attr.entry && csym->ns->entries && proc->ns->entries
2596 && csym->ns->entries->sym == proc->ns->entries->sym)
2598 gfc_error ("Call to ENTRY '%s' at %L is recursive, but subroutine "
2599 "'%s' is not declared as RECURSIVE",
2600 csym->name, &c->loc, csym->ns->entries->sym->name);
2605 /* Switch off assumed size checking and do this again for certain kinds
2606 of procedure, once the procedure itself is resolved. */
2607 need_full_assumed_size++;
2609 if (c->symtree && c->symtree->n.sym)
2610 ptype = c->symtree->n.sym->attr.proc;
2612 if (resolve_actual_arglist (c->ext.actual, ptype) == FAILURE)
2615 /* Resume assumed_size checking. */
2616 need_full_assumed_size--;
2619 if (c->resolved_sym == NULL)
2620 switch (procedure_kind (c->symtree->n.sym))
2623 t = resolve_generic_s (c);
2626 case PTYPE_SPECIFIC:
2627 t = resolve_specific_s (c);
2631 t = resolve_unknown_s (c);
2635 gfc_internal_error ("resolve_subroutine(): bad function type");
2638 /* Some checks of elemental subroutine actual arguments. */
2639 if (resolve_elemental_actual (NULL, c) == FAILURE)
2643 find_noncopying_intrinsics (c->resolved_sym, c->ext.actual);
2648 /* Compare the shapes of two arrays that have non-NULL shapes. If both
2649 op1->shape and op2->shape are non-NULL return SUCCESS if their shapes
2650 match. If both op1->shape and op2->shape are non-NULL return FAILURE
2651 if their shapes do not match. If either op1->shape or op2->shape is
2652 NULL, return SUCCESS. */
2655 compare_shapes (gfc_expr *op1, gfc_expr *op2)
2662 if (op1->shape != NULL && op2->shape != NULL)
2664 for (i = 0; i < op1->rank; i++)
2666 if (mpz_cmp (op1->shape[i], op2->shape[i]) != 0)
2668 gfc_error ("Shapes for operands at %L and %L are not conformable",
2669 &op1->where, &op2->where);
2680 /* Resolve an operator expression node. This can involve replacing the
2681 operation with a user defined function call. */
2684 resolve_operator (gfc_expr *e)
2686 gfc_expr *op1, *op2;
2688 bool dual_locus_error;
2691 /* Resolve all subnodes-- give them types. */
2693 switch (e->value.op.operator)
2696 if (gfc_resolve_expr (e->value.op.op2) == FAILURE)
2699 /* Fall through... */
2702 case INTRINSIC_UPLUS:
2703 case INTRINSIC_UMINUS:
2704 case INTRINSIC_PARENTHESES:
2705 if (gfc_resolve_expr (e->value.op.op1) == FAILURE)
2710 /* Typecheck the new node. */
2712 op1 = e->value.op.op1;
2713 op2 = e->value.op.op2;
2714 dual_locus_error = false;
2716 if ((op1 && op1->expr_type == EXPR_NULL)
2717 || (op2 && op2->expr_type == EXPR_NULL))
2719 sprintf (msg, _("Invalid context for NULL() pointer at %%L"));
2723 switch (e->value.op.operator)
2725 case INTRINSIC_UPLUS:
2726 case INTRINSIC_UMINUS:
2727 if (op1->ts.type == BT_INTEGER
2728 || op1->ts.type == BT_REAL
2729 || op1->ts.type == BT_COMPLEX)
2735 sprintf (msg, _("Operand of unary numeric operator '%s' at %%L is %s"),
2736 gfc_op2string (e->value.op.operator), gfc_typename (&e->ts));
2739 case INTRINSIC_PLUS:
2740 case INTRINSIC_MINUS:
2741 case INTRINSIC_TIMES:
2742 case INTRINSIC_DIVIDE:
2743 case INTRINSIC_POWER:
2744 if (gfc_numeric_ts (&op1->ts) && gfc_numeric_ts (&op2->ts))
2746 gfc_type_convert_binary (e);
2751 _("Operands of binary numeric operator '%s' at %%L are %s/%s"),
2752 gfc_op2string (e->value.op.operator), gfc_typename (&op1->ts),
2753 gfc_typename (&op2->ts));
2756 case INTRINSIC_CONCAT:
2757 if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER)
2759 e->ts.type = BT_CHARACTER;
2760 e->ts.kind = op1->ts.kind;
2765 _("Operands of string concatenation operator at %%L are %s/%s"),
2766 gfc_typename (&op1->ts), gfc_typename (&op2->ts));
2772 case INTRINSIC_NEQV:
2773 if (op1->ts.type == BT_LOGICAL && op2->ts.type == BT_LOGICAL)
2775 e->ts.type = BT_LOGICAL;
2776 e->ts.kind = gfc_kind_max (op1, op2);
2777 if (op1->ts.kind < e->ts.kind)
2778 gfc_convert_type (op1, &e->ts, 2);
2779 else if (op2->ts.kind < e->ts.kind)
2780 gfc_convert_type (op2, &e->ts, 2);
2784 sprintf (msg, _("Operands of logical operator '%s' at %%L are %s/%s"),
2785 gfc_op2string (e->value.op.operator), gfc_typename (&op1->ts),
2786 gfc_typename (&op2->ts));
2791 if (op1->ts.type == BT_LOGICAL)
2793 e->ts.type = BT_LOGICAL;
2794 e->ts.kind = op1->ts.kind;
2798 sprintf (msg, _("Operand of .not. operator at %%L is %s"),
2799 gfc_typename (&op1->ts));
2803 case INTRINSIC_GT_OS:
2805 case INTRINSIC_GE_OS:
2807 case INTRINSIC_LT_OS:
2809 case INTRINSIC_LE_OS:
2810 if (op1->ts.type == BT_COMPLEX || op2->ts.type == BT_COMPLEX)
2812 strcpy (msg, _("COMPLEX quantities cannot be compared at %L"));
2816 /* Fall through... */
2819 case INTRINSIC_EQ_OS:
2821 case INTRINSIC_NE_OS:
2822 if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER)
2824 e->ts.type = BT_LOGICAL;
2825 e->ts.kind = gfc_default_logical_kind;
2829 if (gfc_numeric_ts (&op1->ts) && gfc_numeric_ts (&op2->ts))
2831 gfc_type_convert_binary (e);
2833 e->ts.type = BT_LOGICAL;
2834 e->ts.kind = gfc_default_logical_kind;
2838 if (op1->ts.type == BT_LOGICAL && op2->ts.type == BT_LOGICAL)
2840 _("Logicals at %%L must be compared with %s instead of %s"),
2841 (e->value.op.operator == INTRINSIC_EQ
2842 || e->value.op.operator == INTRINSIC_EQ_OS)
2843 ? ".eqv." : ".neqv.", gfc_op2string (e->value.op.operator));
2846 _("Operands of comparison operator '%s' at %%L are %s/%s"),
2847 gfc_op2string (e->value.op.operator), gfc_typename (&op1->ts),
2848 gfc_typename (&op2->ts));
2852 case INTRINSIC_USER:
2853 if (e->value.op.uop->operator == NULL)
2854 sprintf (msg, _("Unknown operator '%s' at %%L"), e->value.op.uop->name);
2855 else if (op2 == NULL)
2856 sprintf (msg, _("Operand of user operator '%s' at %%L is %s"),
2857 e->value.op.uop->name, gfc_typename (&op1->ts));
2859 sprintf (msg, _("Operands of user operator '%s' at %%L are %s/%s"),
2860 e->value.op.uop->name, gfc_typename (&op1->ts),
2861 gfc_typename (&op2->ts));
2865 case INTRINSIC_PARENTHESES:
2869 gfc_internal_error ("resolve_operator(): Bad intrinsic");
2872 /* Deal with arrayness of an operand through an operator. */
2876 switch (e->value.op.operator)
2878 case INTRINSIC_PLUS:
2879 case INTRINSIC_MINUS:
2880 case INTRINSIC_TIMES:
2881 case INTRINSIC_DIVIDE:
2882 case INTRINSIC_POWER:
2883 case INTRINSIC_CONCAT:
2887 case INTRINSIC_NEQV:
2889 case INTRINSIC_EQ_OS:
2891 case INTRINSIC_NE_OS:
2893 case INTRINSIC_GT_OS:
2895 case INTRINSIC_GE_OS:
2897 case INTRINSIC_LT_OS:
2899 case INTRINSIC_LE_OS:
2901 if (op1->rank == 0 && op2->rank == 0)
2904 if (op1->rank == 0 && op2->rank != 0)
2906 e->rank = op2->rank;
2908 if (e->shape == NULL)
2909 e->shape = gfc_copy_shape (op2->shape, op2->rank);
2912 if (op1->rank != 0 && op2->rank == 0)
2914 e->rank = op1->rank;
2916 if (e->shape == NULL)
2917 e->shape = gfc_copy_shape (op1->shape, op1->rank);
2920 if (op1->rank != 0 && op2->rank != 0)
2922 if (op1->rank == op2->rank)
2924 e->rank = op1->rank;
2925 if (e->shape == NULL)
2927 t = compare_shapes(op1, op2);
2931 e->shape = gfc_copy_shape (op1->shape, op1->rank);
2936 /* Allow higher level expressions to work. */
2939 /* Try user-defined operators, and otherwise throw an error. */
2940 dual_locus_error = true;
2942 _("Inconsistent ranks for operator at %%L and %%L"));
2949 case INTRINSIC_PARENTHESES:
2951 /* This is always correct and sometimes necessary! */
2952 if (e->ts.type == BT_UNKNOWN)
2955 if (e->ts.type == BT_CHARACTER && !e->ts.cl)
2956 e->ts.cl = op1->ts.cl;
2959 case INTRINSIC_UPLUS:
2960 case INTRINSIC_UMINUS:
2961 /* Simply copy arrayness attribute */
2962 e->rank = op1->rank;
2964 if (e->shape == NULL)
2965 e->shape = gfc_copy_shape (op1->shape, op1->rank);
2973 /* Attempt to simplify the expression. */
2976 t = gfc_simplify_expr (e, 0);
2977 /* Some calls do not succeed in simplification and return FAILURE
2978 even though there is no error; eg. variable references to
2979 PARAMETER arrays. */
2980 if (!gfc_is_constant_expr (e))
2987 if (gfc_extend_expr (e) == SUCCESS)
2990 if (dual_locus_error)
2991 gfc_error (msg, &op1->where, &op2->where);
2993 gfc_error (msg, &e->where);
2999 /************** Array resolution subroutines **************/
3002 { CMP_LT, CMP_EQ, CMP_GT, CMP_UNKNOWN }
3005 /* Compare two integer expressions. */
3008 compare_bound (gfc_expr *a, gfc_expr *b)
3012 if (a == NULL || a->expr_type != EXPR_CONSTANT
3013 || b == NULL || b->expr_type != EXPR_CONSTANT)
3016 if (a->ts.type != BT_INTEGER || b->ts.type != BT_INTEGER)
3017 gfc_internal_error ("compare_bound(): Bad expression");
3019 i = mpz_cmp (a->value.integer, b->value.integer);
3029 /* Compare an integer expression with an integer. */
3032 compare_bound_int (gfc_expr *a, int b)
3036 if (a == NULL || a->expr_type != EXPR_CONSTANT)
3039 if (a->ts.type != BT_INTEGER)
3040 gfc_internal_error ("compare_bound_int(): Bad expression");
3042 i = mpz_cmp_si (a->value.integer, b);
3052 /* Compare an integer expression with a mpz_t. */
3055 compare_bound_mpz_t (gfc_expr *a, mpz_t b)
3059 if (a == NULL || a->expr_type != EXPR_CONSTANT)
3062 if (a->ts.type != BT_INTEGER)
3063 gfc_internal_error ("compare_bound_int(): Bad expression");
3065 i = mpz_cmp (a->value.integer, b);
3075 /* Compute the last value of a sequence given by a triplet.
3076 Return 0 if it wasn't able to compute the last value, or if the
3077 sequence if empty, and 1 otherwise. */
3080 compute_last_value_for_triplet (gfc_expr *start, gfc_expr *end,
3081 gfc_expr *stride, mpz_t last)
3085 if (start == NULL || start->expr_type != EXPR_CONSTANT
3086 || end == NULL || end->expr_type != EXPR_CONSTANT
3087 || (stride != NULL && stride->expr_type != EXPR_CONSTANT))
3090 if (start->ts.type != BT_INTEGER || end->ts.type != BT_INTEGER
3091 || (stride != NULL && stride->ts.type != BT_INTEGER))
3094 if (stride == NULL || compare_bound_int(stride, 1) == CMP_EQ)
3096 if (compare_bound (start, end) == CMP_GT)
3098 mpz_set (last, end->value.integer);
3102 if (compare_bound_int (stride, 0) == CMP_GT)
3104 /* Stride is positive */
3105 if (mpz_cmp (start->value.integer, end->value.integer) > 0)
3110 /* Stride is negative */
3111 if (mpz_cmp (start->value.integer, end->value.integer) < 0)
3116 mpz_sub (rem, end->value.integer, start->value.integer);
3117 mpz_tdiv_r (rem, rem, stride->value.integer);
3118 mpz_sub (last, end->value.integer, rem);
3125 /* Compare a single dimension of an array reference to the array
3129 check_dimension (int i, gfc_array_ref *ar, gfc_array_spec *as)
3133 /* Given start, end and stride values, calculate the minimum and
3134 maximum referenced indexes. */
3142 if (compare_bound (ar->start[i], as->lower[i]) == CMP_LT)
3144 if (compare_bound (ar->start[i], as->upper[i]) == CMP_GT)
3151 #define AR_START (ar->start[i] ? ar->start[i] : as->lower[i])
3152 #define AR_END (ar->end[i] ? ar->end[i] : as->upper[i])
3154 comparison comp_start_end = compare_bound (AR_START, AR_END);
3156 /* Check for zero stride, which is not allowed. */
3157 if (compare_bound_int (ar->stride[i], 0) == CMP_EQ)
3159 gfc_error ("Illegal stride of zero at %L", &ar->c_where[i]);
3163 /* if start == len || (stride > 0 && start < len)
3164 || (stride < 0 && start > len),
3165 then the array section contains at least one element. In this
3166 case, there is an out-of-bounds access if
3167 (start < lower || start > upper). */
3168 if (compare_bound (AR_START, AR_END) == CMP_EQ
3169 || ((compare_bound_int (ar->stride[i], 0) == CMP_GT
3170 || ar->stride[i] == NULL) && comp_start_end == CMP_LT)
3171 || (compare_bound_int (ar->stride[i], 0) == CMP_LT
3172 && comp_start_end == CMP_GT))
3174 if (compare_bound (AR_START, as->lower[i]) == CMP_LT
3175 || compare_bound (AR_START, as->upper[i]) == CMP_GT)
3179 /* If we can compute the highest index of the array section,
3180 then it also has to be between lower and upper. */
3181 mpz_init (last_value);
3182 if (compute_last_value_for_triplet (AR_START, AR_END, ar->stride[i],
3185 if (compare_bound_mpz_t (as->lower[i], last_value) == CMP_GT
3186 || compare_bound_mpz_t (as->upper[i], last_value) == CMP_LT)
3188 mpz_clear (last_value);
3192 mpz_clear (last_value);
3200 gfc_internal_error ("check_dimension(): Bad array reference");
3206 gfc_warning ("Array reference at %L is out of bounds", &ar->c_where[i]);
3211 /* Compare an array reference with an array specification. */
3214 compare_spec_to_ref (gfc_array_ref *ar)
3221 /* TODO: Full array sections are only allowed as actual parameters. */
3222 if (as->type == AS_ASSUMED_SIZE
3223 && (/*ar->type == AR_FULL
3224 ||*/ (ar->type == AR_SECTION
3225 && ar->dimen_type[i] == DIMEN_RANGE && ar->end[i] == NULL)))
3227 gfc_error ("Rightmost upper bound of assumed size array section "
3228 "not specified at %L", &ar->where);
3232 if (ar->type == AR_FULL)
3235 if (as->rank != ar->dimen)
3237 gfc_error ("Rank mismatch in array reference at %L (%d/%d)",
3238 &ar->where, ar->dimen, as->rank);
3242 for (i = 0; i < as->rank; i++)
3243 if (check_dimension (i, ar, as) == FAILURE)
3250 /* Resolve one part of an array index. */
3253 gfc_resolve_index (gfc_expr *index, int check_scalar)
3260 if (gfc_resolve_expr (index) == FAILURE)
3263 if (check_scalar && index->rank != 0)
3265 gfc_error ("Array index at %L must be scalar", &index->where);
3269 if (index->ts.type != BT_INTEGER && index->ts.type != BT_REAL)
3271 gfc_error ("Array index at %L must be of INTEGER type",
3276 if (index->ts.type == BT_REAL)
3277 if (gfc_notify_std (GFC_STD_LEGACY, "Extension: REAL array index at %L",
3278 &index->where) == FAILURE)
3281 if (index->ts.kind != gfc_index_integer_kind
3282 || index->ts.type != BT_INTEGER)
3285 ts.type = BT_INTEGER;
3286 ts.kind = gfc_index_integer_kind;
3288 gfc_convert_type_warn (index, &ts, 2, 0);
3294 /* Resolve a dim argument to an intrinsic function. */
3297 gfc_resolve_dim_arg (gfc_expr *dim)
3302 if (gfc_resolve_expr (dim) == FAILURE)
3307 gfc_error ("Argument dim at %L must be scalar", &dim->where);
3311 if (dim->ts.type != BT_INTEGER)
3313 gfc_error ("Argument dim at %L must be of INTEGER type", &dim->where);
3316 if (dim->ts.kind != gfc_index_integer_kind)
3320 ts.type = BT_INTEGER;
3321 ts.kind = gfc_index_integer_kind;
3323 gfc_convert_type_warn (dim, &ts, 2, 0);
3329 /* Given an expression that contains array references, update those array
3330 references to point to the right array specifications. While this is
3331 filled in during matching, this information is difficult to save and load
3332 in a module, so we take care of it here.
3334 The idea here is that the original array reference comes from the
3335 base symbol. We traverse the list of reference structures, setting
3336 the stored reference to references. Component references can
3337 provide an additional array specification. */
3340 find_array_spec (gfc_expr *e)
3344 gfc_symbol *derived;
3347 as = e->symtree->n.sym->as;
3350 for (ref = e->ref; ref; ref = ref->next)
3355 gfc_internal_error ("find_array_spec(): Missing spec");
3362 if (derived == NULL)
3363 derived = e->symtree->n.sym->ts.derived;
3365 c = derived->components;
3367 for (; c; c = c->next)
3368 if (c == ref->u.c.component)
3370 /* Track the sequence of component references. */
3371 if (c->ts.type == BT_DERIVED)
3372 derived = c->ts.derived;
3377 gfc_internal_error ("find_array_spec(): Component not found");
3382 gfc_internal_error ("find_array_spec(): unused as(1)");
3393 gfc_internal_error ("find_array_spec(): unused as(2)");
3397 /* Resolve an array reference. */
3400 resolve_array_ref (gfc_array_ref *ar)
3402 int i, check_scalar;
3405 for (i = 0; i < ar->dimen; i++)
3407 check_scalar = ar->dimen_type[i] == DIMEN_RANGE;
3409 if (gfc_resolve_index (ar->start[i], check_scalar) == FAILURE)
3411 if (gfc_resolve_index (ar->end[i], check_scalar) == FAILURE)
3413 if (gfc_resolve_index (ar->stride[i], check_scalar) == FAILURE)
3418 if (ar->dimen_type[i] == DIMEN_UNKNOWN)
3422 ar->dimen_type[i] = DIMEN_ELEMENT;
3426 ar->dimen_type[i] = DIMEN_VECTOR;
3427 if (e->expr_type == EXPR_VARIABLE
3428 && e->symtree->n.sym->ts.type == BT_DERIVED)
3429 ar->start[i] = gfc_get_parentheses (e);
3433 gfc_error ("Array index at %L is an array of rank %d",
3434 &ar->c_where[i], e->rank);
3439 /* If the reference type is unknown, figure out what kind it is. */
3441 if (ar->type == AR_UNKNOWN)
3443 ar->type = AR_ELEMENT;
3444 for (i = 0; i < ar->dimen; i++)
3445 if (ar->dimen_type[i] == DIMEN_RANGE
3446 || ar->dimen_type[i] == DIMEN_VECTOR)
3448 ar->type = AR_SECTION;
3453 if (!ar->as->cray_pointee && compare_spec_to_ref (ar) == FAILURE)
3461 resolve_substring (gfc_ref *ref)
3463 if (ref->u.ss.start != NULL)
3465 if (gfc_resolve_expr (ref->u.ss.start) == FAILURE)
3468 if (ref->u.ss.start->ts.type != BT_INTEGER)
3470 gfc_error ("Substring start index at %L must be of type INTEGER",
3471 &ref->u.ss.start->where);
3475 if (ref->u.ss.start->rank != 0)
3477 gfc_error ("Substring start index at %L must be scalar",
3478 &ref->u.ss.start->where);
3482 if (compare_bound_int (ref->u.ss.start, 1) == CMP_LT
3483 && (compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_EQ
3484 || compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_GT))
3486 gfc_error ("Substring start index at %L is less than one",
3487 &ref->u.ss.start->where);
3492 if (ref->u.ss.end != NULL)
3494 if (gfc_resolve_expr (ref->u.ss.end) == FAILURE)
3497 if (ref->u.ss.end->ts.type != BT_INTEGER)
3499 gfc_error ("Substring end index at %L must be of type INTEGER",
3500 &ref->u.ss.end->where);
3504 if (ref->u.ss.end->rank != 0)
3506 gfc_error ("Substring end index at %L must be scalar",
3507 &ref->u.ss.end->where);
3511 if (ref->u.ss.length != NULL
3512 && compare_bound (ref->u.ss.end, ref->u.ss.length->length) == CMP_GT
3513 && (compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_EQ
3514 || compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_GT))
3516 gfc_error ("Substring end index at %L exceeds the string length",
3517 &ref->u.ss.start->where);
3526 /* Resolve subtype references. */
3529 resolve_ref (gfc_expr *expr)
3531 int current_part_dimension, n_components, seen_part_dimension;
3534 for (ref = expr->ref; ref; ref = ref->next)
3535 if (ref->type == REF_ARRAY && ref->u.ar.as == NULL)
3537 find_array_spec (expr);
3541 for (ref = expr->ref; ref; ref = ref->next)
3545 if (resolve_array_ref (&ref->u.ar) == FAILURE)
3553 resolve_substring (ref);
3557 /* Check constraints on part references. */
3559 current_part_dimension = 0;
3560 seen_part_dimension = 0;
3563 for (ref = expr->ref; ref; ref = ref->next)
3568 switch (ref->u.ar.type)
3572 current_part_dimension = 1;
3576 current_part_dimension = 0;
3580 gfc_internal_error ("resolve_ref(): Bad array reference");
3586 if (current_part_dimension || seen_part_dimension)
3588 if (ref->u.c.component->pointer)
3590 gfc_error ("Component to the right of a part reference "
3591 "with nonzero rank must not have the POINTER "
3592 "attribute at %L", &expr->where);
3595 else if (ref->u.c.component->allocatable)
3597 gfc_error ("Component to the right of a part reference "
3598 "with nonzero rank must not have the ALLOCATABLE "
3599 "attribute at %L", &expr->where);
3611 if (((ref->type == REF_COMPONENT && n_components > 1)
3612 || ref->next == NULL)
3613 && current_part_dimension
3614 && seen_part_dimension)
3616 gfc_error ("Two or more part references with nonzero rank must "
3617 "not be specified at %L", &expr->where);
3621 if (ref->type == REF_COMPONENT)
3623 if (current_part_dimension)
3624 seen_part_dimension = 1;
3626 /* reset to make sure */
3627 current_part_dimension = 0;
3635 /* Given an expression, determine its shape. This is easier than it sounds.
3636 Leaves the shape array NULL if it is not possible to determine the shape. */
3639 expression_shape (gfc_expr *e)
3641 mpz_t array[GFC_MAX_DIMENSIONS];
3644 if (e->rank == 0 || e->shape != NULL)
3647 for (i = 0; i < e->rank; i++)
3648 if (gfc_array_dimen_size (e, i, &array[i]) == FAILURE)
3651 e->shape = gfc_get_shape (e->rank);
3653 memcpy (e->shape, array, e->rank * sizeof (mpz_t));
3658 for (i--; i >= 0; i--)
3659 mpz_clear (array[i]);
3663 /* Given a variable expression node, compute the rank of the expression by
3664 examining the base symbol and any reference structures it may have. */
3667 expression_rank (gfc_expr *e)
3674 if (e->expr_type == EXPR_ARRAY)
3676 /* Constructors can have a rank different from one via RESHAPE(). */
3678 if (e->symtree == NULL)
3684 e->rank = (e->symtree->n.sym->as == NULL)
3685 ? 0 : e->symtree->n.sym->as->rank;
3691 for (ref = e->ref; ref; ref = ref->next)
3693 if (ref->type != REF_ARRAY)
3696 if (ref->u.ar.type == AR_FULL)
3698 rank = ref->u.ar.as->rank;
3702 if (ref->u.ar.type == AR_SECTION)
3704 /* Figure out the rank of the section. */
3706 gfc_internal_error ("expression_rank(): Two array specs");
3708 for (i = 0; i < ref->u.ar.dimen; i++)
3709 if (ref->u.ar.dimen_type[i] == DIMEN_RANGE
3710 || ref->u.ar.dimen_type[i] == DIMEN_VECTOR)
3720 expression_shape (e);
3724 /* Resolve a variable expression. */
3727 resolve_variable (gfc_expr *e)
3734 if (e->symtree == NULL)
3737 if (e->ref && resolve_ref (e) == FAILURE)
3740 sym = e->symtree->n.sym;
3741 if (sym->attr.flavor == FL_PROCEDURE && !sym->attr.function)
3743 e->ts.type = BT_PROCEDURE;
3747 if (sym->ts.type != BT_UNKNOWN)
3748 gfc_variable_attr (e, &e->ts);
3751 /* Must be a simple variable reference. */
3752 if (gfc_set_default_type (sym, 1, sym->ns) == FAILURE)
3757 if (check_assumed_size_reference (sym, e))
3760 /* Deal with forward references to entries during resolve_code, to
3761 satisfy, at least partially, 12.5.2.5. */
3762 if (gfc_current_ns->entries
3763 && current_entry_id == sym->entry_id
3766 && cs_base->current->op != EXEC_ENTRY)
3768 gfc_entry_list *entry;
3769 gfc_formal_arglist *formal;
3773 /* If the symbol is a dummy... */
3774 if (sym->attr.dummy)
3776 entry = gfc_current_ns->entries;
3779 /* ...test if the symbol is a parameter of previous entries. */
3780 for (; entry && entry->id <= current_entry_id; entry = entry->next)
3781 for (formal = entry->sym->formal; formal; formal = formal->next)
3783 if (formal->sym && sym->name == formal->sym->name)
3787 /* If it has not been seen as a dummy, this is an error. */
3790 if (specification_expr)
3791 gfc_error ("Variable '%s',used in a specification expression, "
3792 "is referenced at %L before the ENTRY statement "
3793 "in which it is a parameter",
3794 sym->name, &cs_base->current->loc);
3796 gfc_error ("Variable '%s' is used at %L before the ENTRY "
3797 "statement in which it is a parameter",
3798 sym->name, &cs_base->current->loc);
3803 /* Now do the same check on the specification expressions. */
3804 specification_expr = 1;
3805 if (sym->ts.type == BT_CHARACTER
3806 && gfc_resolve_expr (sym->ts.cl->length) == FAILURE)
3810 for (n = 0; n < sym->as->rank; n++)
3812 specification_expr = 1;
3813 if (gfc_resolve_expr (sym->as->lower[n]) == FAILURE)
3815 specification_expr = 1;
3816 if (gfc_resolve_expr (sym->as->upper[n]) == FAILURE)
3819 specification_expr = 0;
3822 /* Update the symbol's entry level. */
3823 sym->entry_id = current_entry_id + 1;
3830 /* Checks to see that the correct symbol has been host associated.
3831 The only situation where this arises is that in which a twice
3832 contained function is parsed after the host association is made.
3833 Therefore, on detecting this, the line is rematched, having got
3834 rid of the existing references and actual_arg_list. */
3836 check_host_association (gfc_expr *e)
3838 gfc_symbol *sym, *old_sym;
3842 bool retval = e->expr_type == EXPR_FUNCTION;
3844 if (e->symtree == NULL || e->symtree->n.sym == NULL)
3847 old_sym = e->symtree->n.sym;
3849 if (old_sym->attr.use_assoc)
3852 if (gfc_current_ns->parent
3853 && gfc_current_ns->parent->parent
3854 && old_sym->ns != gfc_current_ns)
3856 gfc_find_symbol (old_sym->name, gfc_current_ns->parent, 1, &sym);
3857 if (sym && old_sym != sym && sym->attr.flavor == FL_PROCEDURE)
3859 temp_locus = gfc_current_locus;
3860 gfc_current_locus = e->where;
3862 gfc_buffer_error (1);
3864 gfc_free_ref_list (e->ref);
3869 gfc_free_actual_arglist (e->value.function.actual);
3870 e->value.function.actual = NULL;
3873 if (e->shape != NULL)
3875 for (n = 0; n < e->rank; n++)
3876 mpz_clear (e->shape[n]);
3878 gfc_free (e->shape);
3881 gfc_match_rvalue (&expr);
3883 gfc_buffer_error (0);
3885 gcc_assert (expr && sym == expr->symtree->n.sym);
3891 gfc_current_locus = temp_locus;
3894 /* This might have changed! */
3895 return e->expr_type == EXPR_FUNCTION;
3899 /* Resolve an expression. That is, make sure that types of operands agree
3900 with their operators, intrinsic operators are converted to function calls
3901 for overloaded types and unresolved function references are resolved. */
3904 gfc_resolve_expr (gfc_expr *e)
3911 switch (e->expr_type)
3914 t = resolve_operator (e);
3920 if (check_host_association (e))
3921 t = resolve_function (e);
3924 t = resolve_variable (e);
3926 expression_rank (e);
3930 case EXPR_SUBSTRING:
3931 t = resolve_ref (e);
3941 if (resolve_ref (e) == FAILURE)
3944 t = gfc_resolve_array_constructor (e);
3945 /* Also try to expand a constructor. */
3948 expression_rank (e);
3949 gfc_expand_constructor (e);
3952 /* This provides the opportunity for the length of constructors with
3953 character valued function elements to propagate the string length
3954 to the expression. */
3955 if (e->ts.type == BT_CHARACTER)
3956 gfc_resolve_character_array_constructor (e);
3960 case EXPR_STRUCTURE:
3961 t = resolve_ref (e);
3965 t = resolve_structure_cons (e);
3969 t = gfc_simplify_expr (e, 0);
3973 gfc_internal_error ("gfc_resolve_expr(): Bad expression type");
3980 /* Resolve an expression from an iterator. They must be scalar and have
3981 INTEGER or (optionally) REAL type. */
3984 gfc_resolve_iterator_expr (gfc_expr *expr, bool real_ok,
3985 const char *name_msgid)
3987 if (gfc_resolve_expr (expr) == FAILURE)
3990 if (expr->rank != 0)
3992 gfc_error ("%s at %L must be a scalar", _(name_msgid), &expr->where);
3996 if (expr->ts.type != BT_INTEGER)
3998 if (expr->ts.type == BT_REAL)
4001 return gfc_notify_std (GFC_STD_F95_DEL,
4002 "Deleted feature: %s at %L must be integer",
4003 _(name_msgid), &expr->where);
4006 gfc_error ("%s at %L must be INTEGER", _(name_msgid),
4013 gfc_error ("%s at %L must be INTEGER", _(name_msgid), &expr->where);
4021 /* Resolve the expressions in an iterator structure. If REAL_OK is
4022 false allow only INTEGER type iterators, otherwise allow REAL types. */
4025 gfc_resolve_iterator (gfc_iterator *iter, bool real_ok)
4027 if (gfc_resolve_iterator_expr (iter->var, real_ok, "Loop variable")
4031 if (gfc_pure (NULL) && gfc_impure_variable (iter->var->symtree->n.sym))
4033 gfc_error ("Cannot assign to loop variable in PURE procedure at %L",
4038 if (gfc_resolve_iterator_expr (iter->start, real_ok,
4039 "Start expression in DO loop") == FAILURE)
4042 if (gfc_resolve_iterator_expr (iter->end, real_ok,
4043 "End expression in DO loop") == FAILURE)
4046 if (gfc_resolve_iterator_expr (iter->step, real_ok,
4047 "Step expression in DO loop") == FAILURE)
4050 if (iter->step->expr_type == EXPR_CONSTANT)
4052 if ((iter->step->ts.type == BT_INTEGER
4053 && mpz_cmp_ui (iter->step->value.integer, 0) == 0)
4054 || (iter->step->ts.type == BT_REAL
4055 && mpfr_sgn (iter->step->value.real) == 0))
4057 gfc_error ("Step expression in DO loop at %L cannot be zero",
4058 &iter->step->where);
4063 /* Convert start, end, and step to the same type as var. */
4064 if (iter->start->ts.kind != iter->var->ts.kind
4065 || iter->start->ts.type != iter->var->ts.type)
4066 gfc_convert_type (iter->start, &iter->var->ts, 2);
4068 if (iter->end->ts.kind != iter->var->ts.kind
4069 || iter->end->ts.type != iter->var->ts.type)
4070 gfc_convert_type (iter->end, &iter->var->ts, 2);
4072 if (iter->step->ts.kind != iter->var->ts.kind
4073 || iter->step->ts.type != iter->var->ts.type)
4074 gfc_convert_type (iter->step, &iter->var->ts, 2);
4080 /* Resolve a list of FORALL iterators. The FORALL index-name is constrained
4081 to be a scalar INTEGER variable. The subscripts and stride are scalar
4082 INTEGERs, and if stride is a constant it must be nonzero. */
4085 resolve_forall_iterators (gfc_forall_iterator *iter)
4089 if (gfc_resolve_expr (iter->var) == SUCCESS
4090 && (iter->var->ts.type != BT_INTEGER || iter->var->rank != 0))
4091 gfc_error ("FORALL index-name at %L must be a scalar INTEGER",
4094 if (gfc_resolve_expr (iter->start) == SUCCESS
4095 && (iter->start->ts.type != BT_INTEGER || iter->start->rank != 0))
4096 gfc_error ("FORALL start expression at %L must be a scalar INTEGER",
4097 &iter->start->where);
4098 if (iter->var->ts.kind != iter->start->ts.kind)
4099 gfc_convert_type (iter->start, &iter->var->ts, 2);
4101 if (gfc_resolve_expr (iter->end) == SUCCESS
4102 && (iter->end->ts.type != BT_INTEGER || iter->end->rank != 0))
4103 gfc_error ("FORALL end expression at %L must be a scalar INTEGER",
4105 if (iter->var->ts.kind != iter->end->ts.kind)
4106 gfc_convert_type (iter->end, &iter->var->ts, 2);
4108 if (gfc_resolve_expr (iter->stride) == SUCCESS)
4110 if (iter->stride->ts.type != BT_INTEGER || iter->stride->rank != 0)
4111 gfc_error ("FORALL stride expression at %L must be a scalar %s",
4112 &iter->stride->where, "INTEGER");
4114 if (iter->stride->expr_type == EXPR_CONSTANT
4115 && mpz_cmp_ui(iter->stride->value.integer, 0) == 0)
4116 gfc_error ("FORALL stride expression at %L cannot be zero",
4117 &iter->stride->where);
4119 if (iter->var->ts.kind != iter->stride->ts.kind)
4120 gfc_convert_type (iter->stride, &iter->var->ts, 2);
4127 /* Given a pointer to a symbol that is a derived type, see if any components
4128 have the POINTER attribute. The search is recursive if necessary.
4129 Returns zero if no pointer components are found, nonzero otherwise. */
4132 derived_pointer (gfc_symbol *sym)
4136 for (c = sym->components; c; c = c->next)
4141 if (c->ts.type == BT_DERIVED && derived_pointer (c->ts.derived))
4149 /* Given a pointer to a symbol that is a derived type, see if it's
4150 inaccessible, i.e. if it's defined in another module and the components are
4151 PRIVATE. The search is recursive if necessary. Returns zero if no
4152 inaccessible components are found, nonzero otherwise. */
4155 derived_inaccessible (gfc_symbol *sym)
4159 if (sym->attr.use_assoc && sym->component_access == ACCESS_PRIVATE)
4162 for (c = sym->components; c; c = c->next)
4164 if (c->ts.type == BT_DERIVED && derived_inaccessible (c->ts.derived))
4172 /* Resolve the argument of a deallocate expression. The expression must be
4173 a pointer or a full array. */
4176 resolve_deallocate_expr (gfc_expr *e)
4178 symbol_attribute attr;
4179 int allocatable, pointer, check_intent_in;
4182 /* Check INTENT(IN), unless the object is a sub-component of a pointer. */
4183 check_intent_in = 1;
4185 if (gfc_resolve_expr (e) == FAILURE)
4188 if (e->expr_type != EXPR_VARIABLE)
4191 allocatable = e->symtree->n.sym->attr.allocatable;
4192 pointer = e->symtree->n.sym->attr.pointer;
4193 for (ref = e->ref; ref; ref = ref->next)
4196 check_intent_in = 0;
4201 if (ref->u.ar.type != AR_FULL)
4206 allocatable = (ref->u.c.component->as != NULL
4207 && ref->u.c.component->as->type == AS_DEFERRED);
4208 pointer = ref->u.c.component->pointer;
4217 attr = gfc_expr_attr (e);
4219 if (allocatable == 0 && attr.pointer == 0)
4222 gfc_error ("Expression in DEALLOCATE statement at %L must be "
4223 "ALLOCATABLE or a POINTER", &e->where);
4227 && e->symtree->n.sym->attr.intent == INTENT_IN)
4229 gfc_error ("Cannot deallocate INTENT(IN) variable '%s' at %L",
4230 e->symtree->n.sym->name, &e->where);
4238 /* Returns true if the expression e contains a reference the symbol sym. */
4240 find_sym_in_expr (gfc_symbol *sym, gfc_expr *e)
4242 gfc_actual_arglist *arg;
4250 switch (e->expr_type)
4253 for (arg = e->value.function.actual; arg; arg = arg->next)
4254 rv = rv || find_sym_in_expr (sym, arg->expr);
4257 /* If the variable is not the same as the dependent, 'sym', and
4258 it is not marked as being declared and it is in the same
4259 namespace as 'sym', add it to the local declarations. */
4261 if (sym == e->symtree->n.sym)
4266 rv = rv || find_sym_in_expr (sym, e->value.op.op1);
4267 rv = rv || find_sym_in_expr (sym, e->value.op.op2);
4276 for (ref = e->ref; ref; ref = ref->next)
4281 for (i = 0; i < ref->u.ar.dimen; i++)
4283 rv = rv || find_sym_in_expr (sym, ref->u.ar.start[i]);
4284 rv = rv || find_sym_in_expr (sym, ref->u.ar.end[i]);
4285 rv = rv || find_sym_in_expr (sym, ref->u.ar.stride[i]);
4290 rv = rv || find_sym_in_expr (sym, ref->u.ss.start);
4291 rv = rv || find_sym_in_expr (sym, ref->u.ss.end);
4295 if (ref->u.c.component->ts.type == BT_CHARACTER
4296 && ref->u.c.component->ts.cl->length->expr_type
4299 || find_sym_in_expr (sym,
4300 ref->u.c.component->ts.cl->length);
4302 if (ref->u.c.component->as)
4303 for (i = 0; i < ref->u.c.component->as->rank; i++)
4306 || find_sym_in_expr (sym,
4307 ref->u.c.component->as->lower[i]);
4309 || find_sym_in_expr (sym,
4310 ref->u.c.component->as->upper[i]);
4320 /* Given the expression node e for an allocatable/pointer of derived type to be
4321 allocated, get the expression node to be initialized afterwards (needed for
4322 derived types with default initializers, and derived types with allocatable
4323 components that need nullification.) */
4326 expr_to_initialize (gfc_expr *e)
4332 result = gfc_copy_expr (e);
4334 /* Change the last array reference from AR_ELEMENT to AR_FULL. */
4335 for (ref = result->ref; ref; ref = ref->next)
4336 if (ref->type == REF_ARRAY && ref->next == NULL)
4338 ref->u.ar.type = AR_FULL;
4340 for (i = 0; i < ref->u.ar.dimen; i++)
4341 ref->u.ar.start[i] = ref->u.ar.end[i] = ref->u.ar.stride[i] = NULL;
4343 result->rank = ref->u.ar.dimen;
4351 /* Resolve the expression in an ALLOCATE statement, doing the additional
4352 checks to see whether the expression is OK or not. The expression must
4353 have a trailing array reference that gives the size of the array. */
4356 resolve_allocate_expr (gfc_expr *e, gfc_code *code)
4358 int i, pointer, allocatable, dimension, check_intent_in;
4359 symbol_attribute attr;
4360 gfc_ref *ref, *ref2;
4367 /* Check INTENT(IN), unless the object is a sub-component of a pointer. */
4368 check_intent_in = 1;
4370 if (gfc_resolve_expr (e) == FAILURE)
4373 if (code->expr && code->expr->expr_type == EXPR_VARIABLE)
4374 sym = code->expr->symtree->n.sym;
4378 /* Make sure the expression is allocatable or a pointer. If it is
4379 pointer, the next-to-last reference must be a pointer. */
4383 if (e->expr_type != EXPR_VARIABLE)
4386 attr = gfc_expr_attr (e);
4387 pointer = attr.pointer;
4388 dimension = attr.dimension;
4392 allocatable = e->symtree->n.sym->attr.allocatable;
4393 pointer = e->symtree->n.sym->attr.pointer;
4394 dimension = e->symtree->n.sym->attr.dimension;
4396 if (sym == e->symtree->n.sym && sym->ts.type != BT_DERIVED)
4398 gfc_error ("The STAT variable '%s' in an ALLOCATE statement must "
4399 "not be allocated in the same statement at %L",
4400 sym->name, &e->where);
4404 for (ref = e->ref; ref; ref2 = ref, ref = ref->next)
4407 check_intent_in = 0;
4412 if (ref->next != NULL)
4417 allocatable = (ref->u.c.component->as != NULL
4418 && ref->u.c.component->as->type == AS_DEFERRED);
4420 pointer = ref->u.c.component->pointer;
4421 dimension = ref->u.c.component->dimension;
4432 if (allocatable == 0 && pointer == 0)
4434 gfc_error ("Expression in ALLOCATE statement at %L must be "
4435 "ALLOCATABLE or a POINTER", &e->where);
4440 && e->symtree->n.sym->attr.intent == INTENT_IN)
4442 gfc_error ("Cannot allocate INTENT(IN) variable '%s' at %L",
4443 e->symtree->n.sym->name, &e->where);
4447 /* Add default initializer for those derived types that need them. */
4448 if (e->ts.type == BT_DERIVED && (init_e = gfc_default_initializer (&e->ts)))
4450 init_st = gfc_get_code ();
4451 init_st->loc = code->loc;
4452 init_st->op = EXEC_INIT_ASSIGN;
4453 init_st->expr = expr_to_initialize (e);
4454 init_st->expr2 = init_e;
4455 init_st->next = code->next;
4456 code->next = init_st;
4459 if (pointer && dimension == 0)
4462 /* Make sure the next-to-last reference node is an array specification. */
4464 if (ref2 == NULL || ref2->type != REF_ARRAY || ref2->u.ar.type == AR_FULL)
4466 gfc_error ("Array specification required in ALLOCATE statement "
4467 "at %L", &e->where);
4471 /* Make sure that the array section reference makes sense in the
4472 context of an ALLOCATE specification. */
4476 for (i = 0; i < ar->dimen; i++)
4478 if (ref2->u.ar.type == AR_ELEMENT)
4481 switch (ar->dimen_type[i])
4487 if (ar->start[i] != NULL
4488 && ar->end[i] != NULL
4489 && ar->stride[i] == NULL)
4492 /* Fall Through... */
4496 gfc_error ("Bad array specification in ALLOCATE statement at %L",
4503 for (a = code->ext.alloc_list; a; a = a->next)
4505 sym = a->expr->symtree->n.sym;
4507 /* TODO - check derived type components. */
4508 if (sym->ts.type == BT_DERIVED)
4511 if ((ar->start[i] != NULL && find_sym_in_expr (sym, ar->start[i]))
4512 || (ar->end[i] != NULL && find_sym_in_expr (sym, ar->end[i])))
4514 gfc_error ("'%s' must not appear an the array specification at "
4515 "%L in the same ALLOCATE statement where it is "
4516 "itself allocated", sym->name, &ar->where);
4526 /************ SELECT CASE resolution subroutines ************/
4528 /* Callback function for our mergesort variant. Determines interval
4529 overlaps for CASEs. Return <0 if op1 < op2, 0 for overlap, >0 for
4530 op1 > op2. Assumes we're not dealing with the default case.
4531 We have op1 = (:L), (K:L) or (K:) and op2 = (:N), (M:N) or (M:).
4532 There are nine situations to check. */
4535 compare_cases (const gfc_case *op1, const gfc_case *op2)
4539 if (op1->low == NULL) /* op1 = (:L) */
4541 /* op2 = (:N), so overlap. */
4543 /* op2 = (M:) or (M:N), L < M */
4544 if (op2->low != NULL
4545 && gfc_compare_expr (op1->high, op2->low) < 0)
4548 else if (op1->high == NULL) /* op1 = (K:) */
4550 /* op2 = (M:), so overlap. */
4552 /* op2 = (:N) or (M:N), K > N */
4553 if (op2->high != NULL
4554 && gfc_compare_expr (op1->low, op2->high) > 0)
4557 else /* op1 = (K:L) */
4559 if (op2->low == NULL) /* op2 = (:N), K > N */
4560 retval = (gfc_compare_expr (op1->low, op2->high) > 0) ? 1 : 0;
4561 else if (op2->high == NULL) /* op2 = (M:), L < M */
4562 retval = (gfc_compare_expr (op1->high, op2->low) < 0) ? -1 : 0;
4563 else /* op2 = (M:N) */
4567 if (gfc_compare_expr (op1->high, op2->low) < 0)
4570 else if (gfc_compare_expr (op1->low, op2->high) > 0)
4579 /* Merge-sort a double linked case list, detecting overlap in the
4580 process. LIST is the head of the double linked case list before it
4581 is sorted. Returns the head of the sorted list if we don't see any
4582 overlap, or NULL otherwise. */
4585 check_case_overlap (gfc_case *list)
4587 gfc_case *p, *q, *e, *tail;
4588 int insize, nmerges, psize, qsize, cmp, overlap_seen;
4590 /* If the passed list was empty, return immediately. */
4597 /* Loop unconditionally. The only exit from this loop is a return
4598 statement, when we've finished sorting the case list. */
4605 /* Count the number of merges we do in this pass. */
4608 /* Loop while there exists a merge to be done. */
4613 /* Count this merge. */
4616 /* Cut the list in two pieces by stepping INSIZE places
4617 forward in the list, starting from P. */
4620 for (i = 0; i < insize; i++)
4629 /* Now we have two lists. Merge them! */
4630 while (psize > 0 || (qsize > 0 && q != NULL))
4632 /* See from which the next case to merge comes from. */
4635 /* P is empty so the next case must come from Q. */
4640 else if (qsize == 0 || q == NULL)
4649 cmp = compare_cases (p, q);
4652 /* The whole case range for P is less than the
4660 /* The whole case range for Q is greater than
4661 the case range for P. */
4668 /* The cases overlap, or they are the same
4669 element in the list. Either way, we must
4670 issue an error and get the next case from P. */
4671 /* FIXME: Sort P and Q by line number. */
4672 gfc_error ("CASE label at %L overlaps with CASE "
4673 "label at %L", &p->where, &q->where);
4681 /* Add the next element to the merged list. */
4690 /* P has now stepped INSIZE places along, and so has Q. So
4691 they're the same. */
4696 /* If we have done only one merge or none at all, we've
4697 finished sorting the cases. */
4706 /* Otherwise repeat, merging lists twice the size. */
4712 /* Check to see if an expression is suitable for use in a CASE statement.
4713 Makes sure that all case expressions are scalar constants of the same
4714 type. Return FAILURE if anything is wrong. */
4717 validate_case_label_expr (gfc_expr *e, gfc_expr *case_expr)
4719 if (e == NULL) return SUCCESS;
4721 if (e->ts.type != case_expr->ts.type)
4723 gfc_error ("Expression in CASE statement at %L must be of type %s",
4724 &e->where, gfc_basic_typename (case_expr->ts.type));
4728 /* C805 (R808) For a given case-construct, each case-value shall be of
4729 the same type as case-expr. For character type, length differences
4730 are allowed, but the kind type parameters shall be the same. */
4732 if (case_expr->ts.type == BT_CHARACTER && e->ts.kind != case_expr->ts.kind)
4734 gfc_error("Expression in CASE statement at %L must be kind %d",
4735 &e->where, case_expr->ts.kind);
4739 /* Convert the case value kind to that of case expression kind, if needed.
4740 FIXME: Should a warning be issued? */
4741 if (e->ts.kind != case_expr->ts.kind)
4742 gfc_convert_type_warn (e, &case_expr->ts, 2, 0);
4746 gfc_error ("Expression in CASE statement at %L must be scalar",
4755 /* Given a completely parsed select statement, we:
4757 - Validate all expressions and code within the SELECT.
4758 - Make sure that the selection expression is not of the wrong type.
4759 - Make sure that no case ranges overlap.
4760 - Eliminate unreachable cases and unreachable code resulting from
4761 removing case labels.
4763 The standard does allow unreachable cases, e.g. CASE (5:3). But
4764 they are a hassle for code generation, and to prevent that, we just
4765 cut them out here. This is not necessary for overlapping cases
4766 because they are illegal and we never even try to generate code.
4768 We have the additional caveat that a SELECT construct could have
4769 been a computed GOTO in the source code. Fortunately we can fairly
4770 easily work around that here: The case_expr for a "real" SELECT CASE
4771 is in code->expr1, but for a computed GOTO it is in code->expr2. All
4772 we have to do is make sure that the case_expr is a scalar integer
4776 resolve_select (gfc_code *code)
4779 gfc_expr *case_expr;
4780 gfc_case *cp, *default_case, *tail, *head;
4781 int seen_unreachable;
4787 if (code->expr == NULL)
4789 /* This was actually a computed GOTO statement. */
4790 case_expr = code->expr2;
4791 if (case_expr->ts.type != BT_INTEGER|| case_expr->rank != 0)
4792 gfc_error ("Selection expression in computed GOTO statement "
4793 "at %L must be a scalar integer expression",
4796 /* Further checking is not necessary because this SELECT was built
4797 by the compiler, so it should always be OK. Just move the
4798 case_expr from expr2 to expr so that we can handle computed
4799 GOTOs as normal SELECTs from here on. */
4800 code->expr = code->expr2;
4805 case_expr = code->expr;
4807 type = case_expr->ts.type;
4808 if (type != BT_LOGICAL && type != BT_INTEGER && type != BT_CHARACTER)
4810 gfc_error ("Argument of SELECT statement at %L cannot be %s",
4811 &case_expr->where, gfc_typename (&case_expr->ts));
4813 /* Punt. Going on here just produce more garbage error messages. */
4817 if (case_expr->rank != 0)
4819 gfc_error ("Argument of SELECT statement at %L must be a scalar "
4820 "expression", &case_expr->where);
4826 /* PR 19168 has a long discussion concerning a mismatch of the kinds
4827 of the SELECT CASE expression and its CASE values. Walk the lists
4828 of case values, and if we find a mismatch, promote case_expr to
4829 the appropriate kind. */
4831 if (type == BT_LOGICAL || type == BT_INTEGER)
4833 for (body = code->block; body; body = body->block)
4835 /* Walk the case label list. */
4836 for (cp = body->ext.case_list; cp; cp = cp->next)
4838 /* Intercept the DEFAULT case. It does not have a kind. */
4839 if (cp->low == NULL && cp->high == NULL)
4842 /* Unreachable case ranges are discarded, so ignore. */
4843 if (cp->low != NULL && cp->high != NULL
4844 && cp->low != cp->high
4845 && gfc_compare_expr (cp->low, cp->high) > 0)
4848 /* FIXME: Should a warning be issued? */
4850 && case_expr->ts.kind != gfc_kind_max(case_expr, cp->low))
4851 gfc_convert_type_warn (case_expr, &cp->low->ts, 2, 0);
4853 if (cp->high != NULL
4854 && case_expr->ts.kind != gfc_kind_max(case_expr, cp->high))
4855 gfc_convert_type_warn (case_expr, &cp->high->ts, 2, 0);
4860 /* Assume there is no DEFAULT case. */
4861 default_case = NULL;
4866 for (body = code->block; body; body = body->block)
4868 /* Assume the CASE list is OK, and all CASE labels can be matched. */
4870 seen_unreachable = 0;
4872 /* Walk the case label list, making sure that all case labels
4874 for (cp = body->ext.case_list; cp; cp = cp->next)
4876 /* Count the number of cases in the whole construct. */
4879 /* Intercept the DEFAULT case. */
4880 if (cp->low == NULL && cp->high == NULL)
4882 if (default_case != NULL)
4884 gfc_error ("The DEFAULT CASE at %L cannot be followed "
4885 "by a second DEFAULT CASE at %L",
4886 &default_case->where, &cp->where);
4897 /* Deal with single value cases and case ranges. Errors are
4898 issued from the validation function. */
4899 if(validate_case_label_expr (cp->low, case_expr) != SUCCESS
4900 || validate_case_label_expr (cp->high, case_expr) != SUCCESS)
4906 if (type == BT_LOGICAL
4907 && ((cp->low == NULL || cp->high == NULL)
4908 || cp->low != cp->high))
4910 gfc_error ("Logical range in CASE statement at %L is not "
4911 "allowed", &cp->low->where);
4916 if (type == BT_LOGICAL && cp->low->expr_type == EXPR_CONSTANT)
4919 value = cp->low->value.logical == 0 ? 2 : 1;
4920 if (value & seen_logical)
4922 gfc_error ("constant logical value in CASE statement "
4923 "is repeated at %L",
4928 seen_logical |= value;
4931 if (cp->low != NULL && cp->high != NULL
4932 && cp->low != cp->high
4933 && gfc_compare_expr (cp->low, cp->high) > 0)
4935 if (gfc_option.warn_surprising)
4936 gfc_warning ("Range specification at %L can never "
4937 "be matched", &cp->where);
4939 cp->unreachable = 1;
4940 seen_unreachable = 1;
4944 /* If the case range can be matched, it can also overlap with
4945 other cases. To make sure it does not, we put it in a
4946 double linked list here. We sort that with a merge sort
4947 later on to detect any overlapping cases. */
4951 head->right = head->left = NULL;
4956 tail->right->left = tail;
4963 /* It there was a failure in the previous case label, give up
4964 for this case label list. Continue with the next block. */
4968 /* See if any case labels that are unreachable have been seen.
4969 If so, we eliminate them. This is a bit of a kludge because
4970 the case lists for a single case statement (label) is a
4971 single forward linked lists. */
4972 if (seen_unreachable)
4974 /* Advance until the first case in the list is reachable. */
4975 while (body->ext.case_list != NULL
4976 && body->ext.case_list->unreachable)
4978 gfc_case *n = body->ext.case_list;
4979 body->ext.case_list = body->ext.case_list->next;
4981 gfc_free_case_list (n);
4984 /* Strip all other unreachable cases. */
4985 if (body->ext.case_list)
4987 for (cp = body->ext.case_list; cp->next; cp = cp->next)
4989 if (cp->next->unreachable)
4991 gfc_case *n = cp->next;
4992 cp->next = cp->next->next;
4994 gfc_free_case_list (n);
5001 /* See if there were overlapping cases. If the check returns NULL,
5002 there was overlap. In that case we don't do anything. If head
5003 is non-NULL, we prepend the DEFAULT case. The sorted list can
5004 then used during code generation for SELECT CASE constructs with
5005 a case expression of a CHARACTER type. */
5008 head = check_case_overlap (head);
5010 /* Prepend the default_case if it is there. */
5011 if (head != NULL && default_case)
5013 default_case->left = NULL;
5014 default_case->right = head;
5015 head->left = default_case;
5019 /* Eliminate dead blocks that may be the result if we've seen
5020 unreachable case labels for a block. */
5021 for (body = code; body && body->block; body = body->block)
5023 if (body->block->ext.case_list == NULL)
5025 /* Cut the unreachable block from the code chain. */
5026 gfc_code *c = body->block;
5027 body->block = c->block;
5029 /* Kill the dead block, but not the blocks below it. */
5031 gfc_free_statements (c);
5035 /* More than two cases is legal but insane for logical selects.
5036 Issue a warning for it. */
5037 if (gfc_option.warn_surprising && type == BT_LOGICAL
5039 gfc_warning ("Logical SELECT CASE block at %L has more that two cases",
5044 /* Resolve a transfer statement. This is making sure that:
5045 -- a derived type being transferred has only non-pointer components
5046 -- a derived type being transferred doesn't have private components, unless
5047 it's being transferred from the module where the type was defined
5048 -- we're not trying to transfer a whole assumed size array. */
5051 resolve_transfer (gfc_code *code)
5060 if (exp->expr_type != EXPR_VARIABLE && exp->expr_type != EXPR_FUNCTION)
5063 sym = exp->symtree->n.sym;
5066 /* Go to actual component transferred. */
5067 for (ref = code->expr->ref; ref; ref = ref->next)
5068 if (ref->type == REF_COMPONENT)
5069 ts = &ref->u.c.component->ts;
5071 if (ts->type == BT_DERIVED)
5073 /* Check that transferred derived type doesn't contain POINTER
5075 if (derived_pointer (ts->derived))
5077 gfc_error ("Data transfer element at %L cannot have "
5078 "POINTER components", &code->loc);
5082 if (ts->derived->attr.alloc_comp)
5084 gfc_error ("Data transfer element at %L cannot have "
5085 "ALLOCATABLE components", &code->loc);
5089 if (derived_inaccessible (ts->derived))
5091 gfc_error ("Data transfer element at %L cannot have "
5092 "PRIVATE components",&code->loc);
5097 if (sym->as != NULL && sym->as->type == AS_ASSUMED_SIZE
5098 && exp->ref->type == REF_ARRAY && exp->ref->u.ar.type == AR_FULL)
5100 gfc_error ("Data transfer element at %L cannot be a full reference to "
5101 "an assumed-size array", &code->loc);
5107 /*********** Toplevel code resolution subroutines ***********/
5109 /* Find the set of labels that are reachable from this block. We also
5110 record the last statement in each block so that we don't have to do
5111 a linear search to find the END DO statements of the blocks. */
5114 reachable_labels (gfc_code *block)
5121 cs_base->reachable_labels = bitmap_obstack_alloc (&labels_obstack);
5123 /* Collect labels in this block. */
5124 for (c = block; c; c = c->next)
5127 bitmap_set_bit (cs_base->reachable_labels, c->here->value);
5129 if (!c->next && cs_base->prev)
5130 cs_base->prev->tail = c;
5133 /* Merge with labels from parent block. */
5136 gcc_assert (cs_base->prev->reachable_labels);
5137 bitmap_ior_into (cs_base->reachable_labels,
5138 cs_base->prev->reachable_labels);
5142 /* Given a branch to a label and a namespace, if the branch is conforming.
5143 The code node describes where the branch is located. */
5146 resolve_branch (gfc_st_label *label, gfc_code *code)
5153 /* Step one: is this a valid branching target? */
5155 if (label->defined == ST_LABEL_UNKNOWN)
5157 gfc_error ("Label %d referenced at %L is never defined", label->value,
5162 if (label->defined != ST_LABEL_TARGET)
5164 gfc_error ("Statement at %L is not a valid branch target statement "
5165 "for the branch statement at %L", &label->where, &code->loc);
5169 /* Step two: make sure this branch is not a branch to itself ;-) */
5171 if (code->here == label)
5173 gfc_warning ("Branch at %L causes an infinite loop", &code->loc);
5177 /* Step three: See if the label is in the same block as the
5178 branching statement. The hard work has been done by setting up
5179 the bitmap reachable_labels. */
5181 if (!bitmap_bit_p (cs_base->reachable_labels, label->value))
5183 /* The label is not in an enclosing block, so illegal. This was
5184 allowed in Fortran 66, so we allow it as extension. No
5185 further checks are necessary in this case. */
5186 gfc_notify_std (GFC_STD_LEGACY, "Label at %L is not in the same block "
5187 "as the GOTO statement at %L", &label->where,
5192 /* Step four: Make sure that the branching target is legal if
5193 the statement is an END {SELECT,IF}. */
5195 for (stack = cs_base; stack; stack = stack->prev)
5196 if (stack->current->next && stack->current->next->here == label)
5199 if (stack && stack->current->next->op == EXEC_NOP)
5201 gfc_notify_std (GFC_STD_F95_DEL, "Deleted feature: GOTO at %L jumps to "
5202 "END of construct at %L", &code->loc,
5203 &stack->current->next->loc);
5204 return; /* We know this is not an END DO. */
5207 /* Step five: Make sure that we're not jumping to the end of a DO
5208 loop from within the loop. */
5210 for (stack = cs_base; stack; stack = stack->prev)
5211 if ((stack->current->op == EXEC_DO
5212 || stack->current->op == EXEC_DO_WHILE)
5213 && stack->tail->here == label && stack->tail->op == EXEC_NOP)
5215 gfc_notify_std (GFC_STD_F95_DEL, "Deleted feature: GOTO at %L jumps "
5216 "to END of construct at %L", &code->loc,
5224 /* Check whether EXPR1 has the same shape as EXPR2. */
5227 resolve_where_shape (gfc_expr *expr1, gfc_expr *expr2)
5229 mpz_t shape[GFC_MAX_DIMENSIONS];
5230 mpz_t shape2[GFC_MAX_DIMENSIONS];
5231 try result = FAILURE;
5234 /* Compare the rank. */
5235 if (expr1->rank != expr2->rank)
5238 /* Compare the size of each dimension. */
5239 for (i=0; i<expr1->rank; i++)
5241 if (gfc_array_dimen_size (expr1, i, &shape[i]) == FAILURE)
5244 if (gfc_array_dimen_size (expr2, i, &shape2[i]) == FAILURE)
5247 if (mpz_cmp (shape[i], shape2[i]))
5251 /* When either of the two expression is an assumed size array, we
5252 ignore the comparison of dimension sizes. */
5257 for (i--; i >= 0; i--)
5259 mpz_clear (shape[i]);
5260 mpz_clear (shape2[i]);
5266 /* Check whether a WHERE assignment target or a WHERE mask expression
5267 has the same shape as the outmost WHERE mask expression. */
5270 resolve_where (gfc_code *code, gfc_expr *mask)
5276 cblock = code->block;
5278 /* Store the first WHERE mask-expr of the WHERE statement or construct.
5279 In case of nested WHERE, only the outmost one is stored. */
5280 if (mask == NULL) /* outmost WHERE */
5282 else /* inner WHERE */
5289 /* Check if the mask-expr has a consistent shape with the
5290 outmost WHERE mask-expr. */
5291 if (resolve_where_shape (cblock->expr, e) == FAILURE)
5292 gfc_error ("WHERE mask at %L has inconsistent shape",
5293 &cblock->expr->where);
5296 /* the assignment statement of a WHERE statement, or the first
5297 statement in where-body-construct of a WHERE construct */
5298 cnext = cblock->next;
5303 /* WHERE assignment statement */
5306 /* Check shape consistent for WHERE assignment target. */
5307 if (e && resolve_where_shape (cnext->expr, e) == FAILURE)
5308 gfc_error ("WHERE assignment target at %L has "
5309 "inconsistent shape", &cnext->expr->where);
5313 case EXEC_ASSIGN_CALL:
5314 resolve_call (cnext);
5317 /* WHERE or WHERE construct is part of a where-body-construct */
5319 resolve_where (cnext, e);
5323 gfc_error ("Unsupported statement inside WHERE at %L",
5326 /* the next statement within the same where-body-construct */
5327 cnext = cnext->next;
5329 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
5330 cblock = cblock->block;
5335 /* Check whether the FORALL index appears in the expression or not. */
5338 gfc_find_forall_index (gfc_expr *expr, gfc_symbol *symbol)
5342 gfc_actual_arglist *args;
5345 switch (expr->expr_type)
5348 gcc_assert (expr->symtree->n.sym);
5350 /* A scalar assignment */
5353 if (expr->symtree->n.sym == symbol)
5359 /* the expr is array ref, substring or struct component. */
5366 /* Check if the symbol appears in the array subscript. */
5368 for (i = 0; i < GFC_MAX_DIMENSIONS; i++)
5371 if (gfc_find_forall_index (ar.start[i], symbol) == SUCCESS)
5375 if (gfc_find_forall_index (ar.end[i], symbol) == SUCCESS)
5379 if (gfc_find_forall_index (ar.stride[i], symbol) == SUCCESS)
5385 if (expr->symtree->n.sym == symbol)
5388 /* Check if the symbol appears in the substring section. */
5389 if (gfc_find_forall_index (tmp->u.ss.start, symbol) == SUCCESS)
5391 if (gfc_find_forall_index (tmp->u.ss.end, symbol) == SUCCESS)
5399 gfc_error("expression reference type error at %L", &expr->where);
5405 /* If the expression is a function call, then check if the symbol
5406 appears in the actual arglist of the function. */
5408 for (args = expr->value.function.actual; args; args = args->next)
5410 if (gfc_find_forall_index(args->expr,symbol) == SUCCESS)
5415 /* It seems not to happen. */
5416 case EXPR_SUBSTRING:
5420 gcc_assert (expr->ref->type == REF_SUBSTRING);
5421 if (gfc_find_forall_index (tmp->u.ss.start, symbol) == SUCCESS)
5423 if (gfc_find_forall_index (tmp->u.ss.end, symbol) == SUCCESS)
5428 /* It seems not to happen. */
5429 case EXPR_STRUCTURE:
5431 gfc_error ("Unsupported statement while finding forall index in "
5436 /* Find the FORALL index in the first operand. */
5437 if (expr->value.op.op1)
5439 if (gfc_find_forall_index (expr->value.op.op1, symbol) == SUCCESS)
5443 /* Find the FORALL index in the second operand. */
5444 if (expr->value.op.op2)
5446 if (gfc_find_forall_index (expr->value.op.op2, symbol) == SUCCESS)
5459 /* Resolve assignment in FORALL construct.
5460 NVAR is the number of FORALL index variables, and VAR_EXPR records the
5461 FORALL index variables. */
5464 gfc_resolve_assign_in_forall (gfc_code *code, int nvar, gfc_expr **var_expr)
5468 for (n = 0; n < nvar; n++)
5470 gfc_symbol *forall_index;
5472 forall_index = var_expr[n]->symtree->n.sym;
5474 /* Check whether the assignment target is one of the FORALL index
5476 if ((code->expr->expr_type == EXPR_VARIABLE)
5477 && (code->expr->symtree->n.sym == forall_index))
5478 gfc_error ("Assignment to a FORALL index variable at %L",
5479 &code->expr->where);
5482 /* If one of the FORALL index variables doesn't appear in the
5483 assignment target, then there will be a many-to-one
5485 if (gfc_find_forall_index (code->expr, forall_index) == FAILURE)
5486 gfc_error ("The FORALL with index '%s' cause more than one "
5487 "assignment to this object at %L",
5488 var_expr[n]->symtree->name, &code->expr->where);
5494 /* Resolve WHERE statement in FORALL construct. */
5497 gfc_resolve_where_code_in_forall (gfc_code *code, int nvar,
5498 gfc_expr **var_expr)
5503 cblock = code->block;
5506 /* the assignment statement of a WHERE statement, or the first
5507 statement in where-body-construct of a WHERE construct */
5508 cnext = cblock->next;
5513 /* WHERE assignment statement */
5515 gfc_resolve_assign_in_forall (cnext, nvar, var_expr);
5518 /* WHERE operator assignment statement */
5519 case EXEC_ASSIGN_CALL:
5520 resolve_call (cnext);
5523 /* WHERE or WHERE construct is part of a where-body-construct */
5525 gfc_resolve_where_code_in_forall (cnext, nvar, var_expr);
5529 gfc_error ("Unsupported statement inside WHERE at %L",
5532 /* the next statement within the same where-body-construct */
5533 cnext = cnext->next;
5535 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
5536 cblock = cblock->block;
5541 /* Traverse the FORALL body to check whether the following errors exist:
5542 1. For assignment, check if a many-to-one assignment happens.
5543 2. For WHERE statement, check the WHERE body to see if there is any
5544 many-to-one assignment. */
5547 gfc_resolve_forall_body (gfc_code *code, int nvar, gfc_expr **var_expr)
5551 c = code->block->next;
5557 case EXEC_POINTER_ASSIGN:
5558 gfc_resolve_assign_in_forall (c, nvar, var_expr);
5561 case EXEC_ASSIGN_CALL:
5565 /* Because the gfc_resolve_blocks() will handle the nested FORALL,
5566 there is no need to handle it here. */
5570 gfc_resolve_where_code_in_forall(c, nvar, var_expr);
5575 /* The next statement in the FORALL body. */
5581 /* Given a FORALL construct, first resolve the FORALL iterator, then call
5582 gfc_resolve_forall_body to resolve the FORALL body. */
5585 gfc_resolve_forall (gfc_code *code, gfc_namespace *ns, int forall_save)
5587 static gfc_expr **var_expr;
5588 static int total_var = 0;
5589 static int nvar = 0;
5590 gfc_forall_iterator *fa;
5591 gfc_symbol *forall_index;
5595 /* Start to resolve a FORALL construct */
5596 if (forall_save == 0)
5598 /* Count the total number of FORALL index in the nested FORALL
5599 construct in order to allocate the VAR_EXPR with proper size. */
5601 while ((next != NULL) && (next->op == EXEC_FORALL))
5603 for (fa = next->ext.forall_iterator; fa; fa = fa->next)
5605 next = next->block->next;
5608 /* Allocate VAR_EXPR with NUMBER_OF_FORALL_INDEX elements. */
5609 var_expr = (gfc_expr **) gfc_getmem (total_var * sizeof (gfc_expr *));
5612 /* The information about FORALL iterator, including FORALL index start, end
5613 and stride. The FORALL index can not appear in start, end or stride. */
5614 for (fa = code->ext.forall_iterator; fa; fa = fa->next)
5616 /* Check if any outer FORALL index name is the same as the current
5618 for (i = 0; i < nvar; i++)
5620 if (fa->var->symtree->n.sym == var_expr[i]->symtree->n.sym)
5622 gfc_error ("An outer FORALL construct already has an index "
5623 "with this name %L", &fa->var->where);
5627 /* Record the current FORALL index. */
5628 var_expr[nvar] = gfc_copy_expr (fa->var);
5630 forall_index = fa->var->symtree->n.sym;
5632 /* Check if the FORALL index appears in start, end or stride. */
5633 if (gfc_find_forall_index (fa->start, forall_index) == SUCCESS)
5634 gfc_error ("A FORALL index must not appear in a limit or stride "
5635 "expression in the same FORALL at %L", &fa->start->where);
5636 if (gfc_find_forall_index (fa->end, forall_index) == SUCCESS)
5637 gfc_error ("A FORALL index must not appear in a limit or stride "
5638 "expression in the same FORALL at %L", &fa->end->where);
5639 if (gfc_find_forall_index (fa->stride, forall_index) == SUCCESS)
5640 gfc_error ("A FORALL index must not appear in a limit or stride "
5641 "expression in the same FORALL at %L", &fa->stride->where);
5645 /* Resolve the FORALL body. */
5646 gfc_resolve_forall_body (code, nvar, var_expr);
5648 /* May call gfc_resolve_forall to resolve the inner FORALL loop. */
5649 gfc_resolve_blocks (code->block, ns);
5651 /* Free VAR_EXPR after the whole FORALL construct resolved. */
5652 for (i = 0; i < total_var; i++)
5653 gfc_free_expr (var_expr[i]);
5655 /* Reset the counters. */
5661 /* Resolve lists of blocks found in IF, SELECT CASE, WHERE, FORALL ,GOTO and
5664 static void resolve_code (gfc_code *, gfc_namespace *);
5667 gfc_resolve_blocks (gfc_code *b, gfc_namespace *ns)
5671 for (; b; b = b->block)
5673 t = gfc_resolve_expr (b->expr);
5674 if (gfc_resolve_expr (b->expr2) == FAILURE)
5680 if (t == SUCCESS && b->expr != NULL
5681 && (b->expr->ts.type != BT_LOGICAL || b->expr->rank != 0))
5682 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
5689 && (b->expr->ts.type != BT_LOGICAL || b->expr->rank == 0))
5690 gfc_error ("WHERE/ELSEWHERE clause at %L requires a LOGICAL array",
5695 resolve_branch (b->label, b);
5707 case EXEC_OMP_ATOMIC:
5708 case EXEC_OMP_CRITICAL:
5710 case EXEC_OMP_MASTER:
5711 case EXEC_OMP_ORDERED:
5712 case EXEC_OMP_PARALLEL:
5713 case EXEC_OMP_PARALLEL_DO:
5714 case EXEC_OMP_PARALLEL_SECTIONS:
5715 case EXEC_OMP_PARALLEL_WORKSHARE:
5716 case EXEC_OMP_SECTIONS:
5717 case EXEC_OMP_SINGLE:
5718 case EXEC_OMP_WORKSHARE:
5722 gfc_internal_error ("resolve_block(): Bad block type");
5725 resolve_code (b->next, ns);
5730 static gfc_component *
5731 has_default_initializer (gfc_symbol *der)
5734 for (c = der->components; c; c = c->next)
5735 if ((c->ts.type != BT_DERIVED && c->initializer)
5736 || (c->ts.type == BT_DERIVED
5738 && has_default_initializer (c->ts.derived)))
5745 /* Given a block of code, recursively resolve everything pointed to by this
5749 resolve_code (gfc_code *code, gfc_namespace *ns)
5751 int omp_workshare_save;
5757 frame.prev = cs_base;
5761 reachable_labels (code);
5763 for (; code; code = code->next)
5765 frame.current = code;
5766 forall_save = forall_flag;
5768 if (code->op == EXEC_FORALL)
5771 gfc_resolve_forall (code, ns, forall_save);
5774 else if (code->block)
5776 omp_workshare_save = -1;
5779 case EXEC_OMP_PARALLEL_WORKSHARE:
5780 omp_workshare_save = omp_workshare_flag;
5781 omp_workshare_flag = 1;
5782 gfc_resolve_omp_parallel_blocks (code, ns);
5784 case EXEC_OMP_PARALLEL:
5785 case EXEC_OMP_PARALLEL_DO:
5786 case EXEC_OMP_PARALLEL_SECTIONS:
5787 omp_workshare_save = omp_workshare_flag;
5788 omp_workshare_flag = 0;
5789 gfc_resolve_omp_parallel_blocks (code, ns);
5792 gfc_resolve_omp_do_blocks (code, ns);
5794 case EXEC_OMP_WORKSHARE:
5795 omp_workshare_save = omp_workshare_flag;
5796 omp_workshare_flag = 1;
5799 gfc_resolve_blocks (code->block, ns);
5803 if (omp_workshare_save != -1)
5804 omp_workshare_flag = omp_workshare_save;
5807 t = gfc_resolve_expr (code->expr);
5808 forall_flag = forall_save;
5810 if (gfc_resolve_expr (code->expr2) == FAILURE)
5825 /* Keep track of which entry we are up to. */
5826 current_entry_id = code->ext.entry->id;
5830 resolve_where (code, NULL);
5834 if (code->expr != NULL)
5836 if (code->expr->ts.type != BT_INTEGER)
5837 gfc_error ("ASSIGNED GOTO statement at %L requires an "
5838 "INTEGER variable", &code->expr->where);
5839 else if (code->expr->symtree->n.sym->attr.assign != 1)
5840 gfc_error ("Variable '%s' has not been assigned a target "
5841 "label at %L", code->expr->symtree->n.sym->name,
5842 &code->expr->where);
5845 resolve_branch (code->label, code);
5849 if (code->expr != NULL
5850 && (code->expr->ts.type != BT_INTEGER || code->expr->rank))
5851 gfc_error ("Alternate RETURN statement at %L requires a SCALAR-"
5852 "INTEGER return specifier", &code->expr->where);
5855 case EXEC_INIT_ASSIGN:
5862 if (gfc_extend_assign (code, ns) == SUCCESS)
5864 gfc_expr *lhs = code->ext.actual->expr;
5865 gfc_expr *rhs = code->ext.actual->next->expr;
5867 if (gfc_pure (NULL) && !gfc_pure (code->symtree->n.sym))
5869 gfc_error ("Subroutine '%s' called instead of assignment at "
5870 "%L must be PURE", code->symtree->n.sym->name,
5875 /* Make a temporary rhs when there is a default initializer
5876 and rhs is the same symbol as the lhs. */
5877 if (rhs->expr_type == EXPR_VARIABLE
5878 && rhs->symtree->n.sym->ts.type == BT_DERIVED
5879 && has_default_initializer (rhs->symtree->n.sym->ts.derived)
5880 && (lhs->symtree->n.sym == rhs->symtree->n.sym))
5881 code->ext.actual->next->expr = gfc_get_parentheses (rhs);
5886 if (code->expr->ts.type == BT_CHARACTER
5887 && gfc_option.warn_character_truncation)
5889 int llen = 0, rlen = 0;
5891 if (code->expr->ts.cl != NULL
5892 && code->expr->ts.cl->length != NULL
5893 && code->expr->ts.cl->length->expr_type == EXPR_CONSTANT)
5894 llen = mpz_get_si (code->expr->ts.cl->length->value.integer);
5896 if (code->expr2->expr_type == EXPR_CONSTANT)
5897 rlen = code->expr2->value.character.length;
5899 else if (code->expr2->ts.cl != NULL
5900 && code->expr2->ts.cl->length != NULL
5901 && code->expr2->ts.cl->length->expr_type
5903 rlen = mpz_get_si (code->expr2->ts.cl->length->value.integer);
5905 if (rlen && llen && rlen > llen)
5906 gfc_warning_now ("CHARACTER expression will be truncated "
5907 "in assignment (%d/%d) at %L",
5908 llen, rlen, &code->loc);
5911 if (gfc_pure (NULL))
5913 if (gfc_impure_variable (code->expr->symtree->n.sym))
5915 gfc_error ("Cannot assign to variable '%s' in PURE "
5917 code->expr->symtree->n.sym->name,
5918 &code->expr->where);
5922 if (code->expr->ts.type == BT_DERIVED
5923 && code->expr->expr_type == EXPR_VARIABLE
5924 && derived_pointer (code->expr->ts.derived)
5925 && gfc_impure_variable (code->expr2->symtree->n.sym))
5927 gfc_error ("The impure variable at %L is assigned to "
5928 "a derived type variable with a POINTER "
5929 "component in a PURE procedure (12.6)",
5930 &code->expr2->where);
5935 gfc_check_assign (code->expr, code->expr2, 1);
5938 case EXEC_LABEL_ASSIGN:
5939 if (code->label->defined == ST_LABEL_UNKNOWN)
5940 gfc_error ("Label %d referenced at %L is never defined",
5941 code->label->value, &code->label->where);
5943 && (code->expr->expr_type != EXPR_VARIABLE
5944 || code->expr->symtree->n.sym->ts.type != BT_INTEGER
5945 || code->expr->symtree->n.sym->ts.kind
5946 != gfc_default_integer_kind
5947 || code->expr->symtree->n.sym->as != NULL))
5948 gfc_error ("ASSIGN statement at %L requires a scalar "
5949 "default INTEGER variable", &code->expr->where);
5952 case EXEC_POINTER_ASSIGN:
5956 gfc_check_pointer_assign (code->expr, code->expr2);
5959 case EXEC_ARITHMETIC_IF:
5961 && code->expr->ts.type != BT_INTEGER
5962 && code->expr->ts.type != BT_REAL)
5963 gfc_error ("Arithmetic IF statement at %L requires a numeric "
5964 "expression", &code->expr->where);
5966 resolve_branch (code->label, code);
5967 resolve_branch (code->label2, code);
5968 resolve_branch (code->label3, code);
5972 if (t == SUCCESS && code->expr != NULL
5973 && (code->expr->ts.type != BT_LOGICAL
5974 || code->expr->rank != 0))
5975 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
5976 &code->expr->where);
5981 resolve_call (code);
5985 /* Select is complicated. Also, a SELECT construct could be
5986 a transformed computed GOTO. */
5987 resolve_select (code);
5991 if (code->ext.iterator != NULL)
5993 gfc_iterator *iter = code->ext.iterator;
5994 if (gfc_resolve_iterator (iter, true) != FAILURE)
5995 gfc_resolve_do_iterator (code, iter->var->symtree->n.sym);
6000 if (code->expr == NULL)
6001 gfc_internal_error ("resolve_code(): No expression on DO WHILE");
6003 && (code->expr->rank != 0
6004 || code->expr->ts.type != BT_LOGICAL))
6005 gfc_error ("Exit condition of DO WHILE loop at %L must be "
6006 "a scalar LOGICAL expression", &code->expr->where);
6010 if (t == SUCCESS && code->expr != NULL
6011 && code->expr->ts.type != BT_INTEGER)
6012 gfc_error ("STAT tag in ALLOCATE statement at %L must be "
6013 "of type INTEGER", &code->expr->where);
6015 for (a = code->ext.alloc_list; a; a = a->next)
6016 resolve_allocate_expr (a->expr, code);
6020 case EXEC_DEALLOCATE:
6021 if (t == SUCCESS && code->expr != NULL
6022 && code->expr->ts.type != BT_INTEGER)
6024 ("STAT tag in DEALLOCATE statement at %L must be of type "
6025 "INTEGER", &code->expr->where);
6027 for (a = code->ext.alloc_list; a; a = a->next)
6028 resolve_deallocate_expr (a->expr);
6033 if (gfc_resolve_open (code->ext.open) == FAILURE)
6036 resolve_branch (code->ext.open->err, code);
6040 if (gfc_resolve_close (code->ext.close) == FAILURE)
6043 resolve_branch (code->ext.close->err, code);
6046 case EXEC_BACKSPACE:
6050 if (gfc_resolve_filepos (code->ext.filepos) == FAILURE)
6053 resolve_branch (code->ext.filepos->err, code);
6057 if (gfc_resolve_inquire (code->ext.inquire) == FAILURE)
6060 resolve_branch (code->ext.inquire->err, code);
6064 gcc_assert (code->ext.inquire != NULL);
6065 if (gfc_resolve_inquire (code->ext.inquire) == FAILURE)
6068 resolve_branch (code->ext.inquire->err, code);
6073 if (gfc_resolve_dt (code->ext.dt) == FAILURE)
6076 resolve_branch (code->ext.dt->err, code);
6077 resolve_branch (code->ext.dt->end, code);
6078 resolve_branch (code->ext.dt->eor, code);
6082 resolve_transfer (code);
6086 resolve_forall_iterators (code->ext.forall_iterator);
6088 if (code->expr != NULL && code->expr->ts.type != BT_LOGICAL)
6089 gfc_error ("FORALL mask clause at %L requires a LOGICAL "
6090 "expression", &code->expr->where);
6093 case EXEC_OMP_ATOMIC:
6094 case EXEC_OMP_BARRIER:
6095 case EXEC_OMP_CRITICAL:
6096 case EXEC_OMP_FLUSH:
6098 case EXEC_OMP_MASTER:
6099 case EXEC_OMP_ORDERED:
6100 case EXEC_OMP_SECTIONS:
6101 case EXEC_OMP_SINGLE:
6102 case EXEC_OMP_WORKSHARE:
6103 gfc_resolve_omp_directive (code, ns);
6106 case EXEC_OMP_PARALLEL:
6107 case EXEC_OMP_PARALLEL_DO:
6108 case EXEC_OMP_PARALLEL_SECTIONS:
6109 case EXEC_OMP_PARALLEL_WORKSHARE:
6110 omp_workshare_save = omp_workshare_flag;
6111 omp_workshare_flag = 0;
6112 gfc_resolve_omp_directive (code, ns);
6113 omp_workshare_flag = omp_workshare_save;
6117 gfc_internal_error ("resolve_code(): Bad statement code");
6121 cs_base = frame.prev;
6125 /* Resolve initial values and make sure they are compatible with
6129 resolve_values (gfc_symbol *sym)
6131 if (sym->value == NULL)
6134 if (gfc_resolve_expr (sym->value) == FAILURE)
6137 gfc_check_assign_symbol (sym, sym->value);
6141 /* Verify the binding labels for common blocks that are BIND(C). The label
6142 for a BIND(C) common block must be identical in all scoping units in which
6143 the common block is declared. Further, the binding label can not collide
6144 with any other global entity in the program. */
6147 resolve_bind_c_comms (gfc_symtree *comm_block_tree)
6149 if (comm_block_tree->n.common->is_bind_c == 1)
6151 gfc_gsymbol *binding_label_gsym;
6152 gfc_gsymbol *comm_name_gsym;
6154 /* See if a global symbol exists by the common block's name. It may
6155 be NULL if the common block is use-associated. */
6156 comm_name_gsym = gfc_find_gsymbol (gfc_gsym_root,
6157 comm_block_tree->n.common->name);
6158 if (comm_name_gsym != NULL && comm_name_gsym->type != GSYM_COMMON)
6159 gfc_error ("Binding label '%s' for common block '%s' at %L collides "
6160 "with the global entity '%s' at %L",
6161 comm_block_tree->n.common->binding_label,
6162 comm_block_tree->n.common->name,
6163 &(comm_block_tree->n.common->where),
6164 comm_name_gsym->name, &(comm_name_gsym->where));
6165 else if (comm_name_gsym != NULL
6166 && strcmp (comm_name_gsym->name,
6167 comm_block_tree->n.common->name) == 0)
6169 /* TODO: Need to make sure the fields of gfc_gsymbol are initialized
6171 if (comm_name_gsym->binding_label == NULL)
6172 /* No binding label for common block stored yet; save this one. */
6173 comm_name_gsym->binding_label =
6174 comm_block_tree->n.common->binding_label;
6176 if (strcmp (comm_name_gsym->binding_label,
6177 comm_block_tree->n.common->binding_label) != 0)
6179 /* Common block names match but binding labels do not. */
6180 gfc_error ("Binding label '%s' for common block '%s' at %L "
6181 "does not match the binding label '%s' for common "
6183 comm_block_tree->n.common->binding_label,
6184 comm_block_tree->n.common->name,
6185 &(comm_block_tree->n.common->where),
6186 comm_name_gsym->binding_label,
6187 comm_name_gsym->name,
6188 &(comm_name_gsym->where));
6193 /* There is no binding label (NAME="") so we have nothing further to
6194 check and nothing to add as a global symbol for the label. */
6195 if (comm_block_tree->n.common->binding_label[0] == '\0' )
6198 binding_label_gsym =
6199 gfc_find_gsymbol (gfc_gsym_root,
6200 comm_block_tree->n.common->binding_label);
6201 if (binding_label_gsym == NULL)
6203 /* Need to make a global symbol for the binding label to prevent
6204 it from colliding with another. */
6205 binding_label_gsym =
6206 gfc_get_gsymbol (comm_block_tree->n.common->binding_label);
6207 binding_label_gsym->sym_name = comm_block_tree->n.common->name;
6208 binding_label_gsym->type = GSYM_COMMON;
6212 /* If comm_name_gsym is NULL, the name common block is use
6213 associated and the name could be colliding. */
6214 if (binding_label_gsym->type != GSYM_COMMON)
6215 gfc_error ("Binding label '%s' for common block '%s' at %L "
6216 "collides with the global entity '%s' at %L",
6217 comm_block_tree->n.common->binding_label,
6218 comm_block_tree->n.common->name,
6219 &(comm_block_tree->n.common->where),
6220 binding_label_gsym->name,
6221 &(binding_label_gsym->where));
6222 else if (comm_name_gsym != NULL
6223 && (strcmp (binding_label_gsym->name,
6224 comm_name_gsym->binding_label) != 0)
6225 && (strcmp (binding_label_gsym->sym_name,
6226 comm_name_gsym->name) != 0))
6227 gfc_error ("Binding label '%s' for common block '%s' at %L "
6228 "collides with global entity '%s' at %L",
6229 binding_label_gsym->name, binding_label_gsym->sym_name,
6230 &(comm_block_tree->n.common->where),
6231 comm_name_gsym->name, &(comm_name_gsym->where));
6239 /* Verify any BIND(C) derived types in the namespace so we can report errors
6240 for them once, rather than for each variable declared of that type. */
6243 resolve_bind_c_derived_types (gfc_symbol *derived_sym)
6245 if (derived_sym != NULL && derived_sym->attr.flavor == FL_DERIVED
6246 && derived_sym->attr.is_bind_c == 1)
6247 verify_bind_c_derived_type (derived_sym);
6253 /* Verify that any binding labels used in a given namespace do not collide
6254 with the names or binding labels of any global symbols. */
6257 gfc_verify_binding_labels (gfc_symbol *sym)
6261 if (sym != NULL && sym->attr.is_bind_c && sym->attr.is_iso_c == 0
6262 && sym->attr.flavor != FL_DERIVED && sym->binding_label[0] != '\0')
6264 gfc_gsymbol *bind_c_sym;
6266 bind_c_sym = gfc_find_gsymbol (gfc_gsym_root, sym->binding_label);
6267 if (bind_c_sym != NULL
6268 && strcmp (bind_c_sym->name, sym->binding_label) == 0)
6270 if (sym->attr.if_source == IFSRC_DECL
6271 && (bind_c_sym->type != GSYM_SUBROUTINE
6272 && bind_c_sym->type != GSYM_FUNCTION)
6273 && ((sym->attr.contained == 1
6274 && strcmp (bind_c_sym->sym_name, sym->name) != 0)
6275 || (sym->attr.use_assoc == 1
6276 && (strcmp (bind_c_sym->mod_name, sym->module) != 0))))
6278 /* Make sure global procedures don't collide with anything. */
6279 gfc_error ("Binding label '%s' at %L collides with the global "
6280 "entity '%s' at %L", sym->binding_label,
6281 &(sym->declared_at), bind_c_sym->name,
6282 &(bind_c_sym->where));
6285 else if (sym->attr.contained == 0
6286 && (sym->attr.if_source == IFSRC_IFBODY
6287 && sym->attr.flavor == FL_PROCEDURE)
6288 && (bind_c_sym->sym_name != NULL
6289 && strcmp (bind_c_sym->sym_name, sym->name) != 0))
6291 /* Make sure procedures in interface bodies don't collide. */
6292 gfc_error ("Binding label '%s' in interface body at %L collides "
6293 "with the global entity '%s' at %L",
6295 &(sym->declared_at), bind_c_sym->name,
6296 &(bind_c_sym->where));
6299 else if (sym->attr.contained == 0
6300 && (sym->attr.if_source == IFSRC_UNKNOWN))
6301 if ((sym->attr.use_assoc
6302 && (strcmp (bind_c_sym->mod_name, sym->module) != 0))
6303 || sym->attr.use_assoc == 0)
6305 gfc_error ("Binding label '%s' at %L collides with global "
6306 "entity '%s' at %L", sym->binding_label,
6307 &(sym->declared_at), bind_c_sym->name,
6308 &(bind_c_sym->where));
6313 /* Clear the binding label to prevent checking multiple times. */
6314 sym->binding_label[0] = '\0';
6316 else if (bind_c_sym == NULL)
6318 bind_c_sym = gfc_get_gsymbol (sym->binding_label);
6319 bind_c_sym->where = sym->declared_at;
6320 bind_c_sym->sym_name = sym->name;
6322 if (sym->attr.use_assoc == 1)
6323 bind_c_sym->mod_name = sym->module;
6325 if (sym->ns->proc_name != NULL)
6326 bind_c_sym->mod_name = sym->ns->proc_name->name;
6328 if (sym->attr.contained == 0)
6330 if (sym->attr.subroutine)
6331 bind_c_sym->type = GSYM_SUBROUTINE;
6332 else if (sym->attr.function)
6333 bind_c_sym->type = GSYM_FUNCTION;
6341 /* Resolve an index expression. */
6344 resolve_index_expr (gfc_expr *e)
6346 if (gfc_resolve_expr (e) == FAILURE)
6349 if (gfc_simplify_expr (e, 0) == FAILURE)
6352 if (gfc_specification_expr (e) == FAILURE)
6358 /* Resolve a charlen structure. */
6361 resolve_charlen (gfc_charlen *cl)
6370 specification_expr = 1;
6372 if (resolve_index_expr (cl->length) == FAILURE)
6374 specification_expr = 0;
6378 /* "If the character length parameter value evaluates to a negative
6379 value, the length of character entities declared is zero." */
6380 if (cl->length && !gfc_extract_int (cl->length, &i) && i <= 0)
6382 gfc_warning_now ("CHARACTER variable has zero length at %L",
6383 &cl->length->where);
6384 gfc_replace_expr (cl->length, gfc_int_expr (0));
6391 /* Test for non-constant shape arrays. */
6394 is_non_constant_shape_array (gfc_symbol *sym)
6400 not_constant = false;
6401 if (sym->as != NULL)
6403 /* Unfortunately, !gfc_is_compile_time_shape hits a legal case that
6404 has not been simplified; parameter array references. Do the
6405 simplification now. */
6406 for (i = 0; i < sym->as->rank; i++)
6408 e = sym->as->lower[i];
6409 if (e && (resolve_index_expr (e) == FAILURE
6410 || !gfc_is_constant_expr (e)))
6411 not_constant = true;
6413 e = sym->as->upper[i];
6414 if (e && (resolve_index_expr (e) == FAILURE
6415 || !gfc_is_constant_expr (e)))
6416 not_constant = true;
6419 return not_constant;
6423 /* Assign the default initializer to a derived type variable or result. */
6426 apply_default_init (gfc_symbol *sym)
6429 gfc_expr *init = NULL;
6431 gfc_namespace *ns = sym->ns;
6433 if (sym->attr.flavor != FL_VARIABLE && !sym->attr.function)
6436 if (sym->ts.type == BT_DERIVED && sym->ts.derived)
6437 init = gfc_default_initializer (&sym->ts);
6442 /* Search for the function namespace if this is a contained
6443 function without an explicit result. */
6444 if (sym->attr.function && sym == sym->result
6445 && sym->name != sym->ns->proc_name->name)
6448 for (;ns; ns = ns->sibling)
6449 if (strcmp (ns->proc_name->name, sym->name) == 0)
6455 gfc_free_expr (init);
6459 /* Build an l-value expression for the result. */
6460 lval = gfc_lval_expr_from_sym (sym);
6462 /* Add the code at scope entry. */
6463 init_st = gfc_get_code ();
6464 init_st->next = ns->code;
6467 /* Assign the default initializer to the l-value. */
6468 init_st->loc = sym->declared_at;
6469 init_st->op = EXEC_INIT_ASSIGN;
6470 init_st->expr = lval;
6471 init_st->expr2 = init;
6475 /* Resolution of common features of flavors variable and procedure. */
6478 resolve_fl_var_and_proc (gfc_symbol *sym, int mp_flag)
6480 /* Constraints on deferred shape variable. */
6481 if (sym->as == NULL || sym->as->type != AS_DEFERRED)
6483 if (sym->attr.allocatable)
6485 if (sym->attr.dimension)
6486 gfc_error ("Allocatable array '%s' at %L must have "
6487 "a deferred shape", sym->name, &sym->declared_at);
6489 gfc_error ("Scalar object '%s' at %L may not be ALLOCATABLE",
6490 sym->name, &sym->declared_at);
6494 if (sym->attr.pointer && sym->attr.dimension)
6496 gfc_error ("Array pointer '%s' at %L must have a deferred shape",
6497 sym->name, &sym->declared_at);
6504 if (!mp_flag && !sym->attr.allocatable
6505 && !sym->attr.pointer && !sym->attr.dummy)
6507 gfc_error ("Array '%s' at %L cannot have a deferred shape",
6508 sym->name, &sym->declared_at);
6516 /* Resolve symbols with flavor variable. */
6519 resolve_fl_variable (gfc_symbol *sym, int mp_flag)
6525 const char *auto_save_msg;
6527 auto_save_msg = "automatic object '%s' at %L cannot have the "
6530 if (resolve_fl_var_and_proc (sym, mp_flag) == FAILURE)
6533 /* Set this flag to check that variables are parameters of all entries.
6534 This check is effected by the call to gfc_resolve_expr through
6535 is_non_constant_shape_array. */
6536 specification_expr = 1;
6538 if (!sym->attr.use_assoc
6539 && !sym->attr.allocatable
6540 && !sym->attr.pointer
6541 && is_non_constant_shape_array (sym))
6543 /* The shape of a main program or module array needs to be
6545 if (sym->ns->proc_name
6546 && (sym->ns->proc_name->attr.flavor == FL_MODULE
6547 || sym->ns->proc_name->attr.is_main_program))
6549 gfc_error ("The module or main program array '%s' at %L must "
6550 "have constant shape", sym->name, &sym->declared_at);
6551 specification_expr = 0;
6556 if (sym->ts.type == BT_CHARACTER)
6558 /* Make sure that character string variables with assumed length are
6560 e = sym->ts.cl->length;
6561 if (e == NULL && !sym->attr.dummy && !sym->attr.result)
6563 gfc_error ("Entity with assumed character length at %L must be a "
6564 "dummy argument or a PARAMETER", &sym->declared_at);
6568 if (e && sym->attr.save && !gfc_is_constant_expr (e))
6570 gfc_error (auto_save_msg, sym->name, &sym->declared_at);
6574 if (!gfc_is_constant_expr (e)
6575 && !(e->expr_type == EXPR_VARIABLE
6576 && e->symtree->n.sym->attr.flavor == FL_PARAMETER)
6577 && sym->ns->proc_name
6578 && (sym->ns->proc_name->attr.flavor == FL_MODULE
6579 || sym->ns->proc_name->attr.is_main_program)
6580 && !sym->attr.use_assoc)
6582 gfc_error ("'%s' at %L must have constant character length "
6583 "in this context", sym->name, &sym->declared_at);
6588 /* Can the symbol have an initializer? */
6590 if (sym->attr.allocatable || sym->attr.external || sym->attr.dummy
6591 || sym->attr.intrinsic || sym->attr.result)
6593 else if (sym->attr.dimension && !sym->attr.pointer)
6595 /* Don't allow initialization of automatic arrays. */
6596 for (i = 0; i < sym->as->rank; i++)
6598 if (sym->as->lower[i] == NULL
6599 || sym->as->lower[i]->expr_type != EXPR_CONSTANT
6600 || sym->as->upper[i] == NULL
6601 || sym->as->upper[i]->expr_type != EXPR_CONSTANT)
6608 /* Also, they must not have the SAVE attribute.
6609 SAVE_IMPLICIT is checked below. */
6610 if (flag && sym->attr.save == SAVE_EXPLICIT)
6612 gfc_error (auto_save_msg, sym->name, &sym->declared_at);
6617 /* Reject illegal initializers. */
6618 if (!sym->mark && sym->value && flag)
6620 if (sym->attr.allocatable)
6621 gfc_error ("Allocatable '%s' at %L cannot have an initializer",
6622 sym->name, &sym->declared_at);
6623 else if (sym->attr.external)
6624 gfc_error ("External '%s' at %L cannot have an initializer",
6625 sym->name, &sym->declared_at);
6626 else if (sym->attr.dummy
6627 && !(sym->ts.type == BT_DERIVED && sym->attr.intent == INTENT_OUT))
6628 gfc_error ("Dummy '%s' at %L cannot have an initializer",
6629 sym->name, &sym->declared_at);
6630 else if (sym->attr.intrinsic)
6631 gfc_error ("Intrinsic '%s' at %L cannot have an initializer",
6632 sym->name, &sym->declared_at);
6633 else if (sym->attr.result)
6634 gfc_error ("Function result '%s' at %L cannot have an initializer",
6635 sym->name, &sym->declared_at);
6637 gfc_error ("Automatic array '%s' at %L cannot have an initializer",
6638 sym->name, &sym->declared_at);
6645 /* Check to see if a derived type is blocked from being host associated
6646 by the presence of another class I symbol in the same namespace.
6647 14.6.1.3 of the standard and the discussion on comp.lang.fortran. */
6648 if (sym->ts.type == BT_DERIVED && sym->ns != sym->ts.derived->ns
6649 && sym->ns->proc_name->attr.if_source != IFSRC_IFBODY)
6652 gfc_find_symbol (sym->ts.derived->name, sym->ns, 0, &s);
6653 if (s && (s->attr.flavor != FL_DERIVED
6654 || !gfc_compare_derived_types (s, sym->ts.derived)))
6656 gfc_error ("The type %s cannot be host associated at %L because "
6657 "it is blocked by an incompatible object of the same "
6658 "name at %L", sym->ts.derived->name, &sym->declared_at,
6664 /* Do not use gfc_default_initializer to test for a default initializer
6665 in the fortran because it generates a hidden default for allocatable
6668 if (sym->ts.type == BT_DERIVED && !(sym->value || flag))
6669 c = has_default_initializer (sym->ts.derived);
6671 /* 4th constraint in section 11.3: "If an object of a type for which
6672 component-initialization is specified (R429) appears in the
6673 specification-part of a module and does not have the ALLOCATABLE
6674 or POINTER attribute, the object shall have the SAVE attribute." */
6675 if (c && sym->ns->proc_name
6676 && sym->ns->proc_name->attr.flavor == FL_MODULE
6677 && !sym->ns->save_all && !sym->attr.save
6678 && !sym->attr.pointer && !sym->attr.allocatable)
6680 gfc_error("Object '%s' at %L must have the SAVE attribute %s",
6681 sym->name, &sym->declared_at,
6682 "for default initialization of a component");
6686 /* Assign default initializer. */
6687 if (sym->ts.type == BT_DERIVED
6689 && !sym->attr.pointer
6690 && !sym->attr.allocatable
6691 && (!flag || sym->attr.intent == INTENT_OUT))
6692 sym->value = gfc_default_initializer (&sym->ts);
6698 /* Resolve a procedure. */
6701 resolve_fl_procedure (gfc_symbol *sym, int mp_flag)
6703 gfc_formal_arglist *arg;
6705 if (sym->attr.ambiguous_interfaces && !sym->attr.referenced)
6706 gfc_warning ("Although not referenced, '%s' at %L has ambiguous "
6707 "interfaces", sym->name, &sym->declared_at);
6709 if (sym->attr.function
6710 && resolve_fl_var_and_proc (sym, mp_flag) == FAILURE)
6713 if (sym->ts.type == BT_CHARACTER)
6715 gfc_charlen *cl = sym->ts.cl;
6717 if (cl && cl->length && gfc_is_constant_expr (cl->length)
6718 && resolve_charlen (cl) == FAILURE)
6721 if (!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT)
6723 if (sym->attr.proc == PROC_ST_FUNCTION)
6725 gfc_error ("Character-valued statement function '%s' at %L must "
6726 "have constant length", sym->name, &sym->declared_at);
6730 if (sym->attr.external && sym->formal == NULL
6731 && cl && cl->length && cl->length->expr_type != EXPR_CONSTANT)
6733 gfc_error ("Automatic character length function '%s' at %L must "
6734 "have an explicit interface", sym->name,
6741 /* Ensure that derived type for are not of a private type. Internal
6742 module procedures are excluded by 2.2.3.3 - ie. they are not
6743 externally accessible and can access all the objects accessible in
6745 if (!(sym->ns->parent
6746 && sym->ns->parent->proc_name->attr.flavor == FL_MODULE)
6747 && gfc_check_access(sym->attr.access, sym->ns->default_access))
6749 gfc_interface *iface;
6751 for (arg = sym->formal; arg; arg = arg->next)
6754 && arg->sym->ts.type == BT_DERIVED
6755 && !arg->sym->ts.derived->attr.use_assoc
6756 && !gfc_check_access (arg->sym->ts.derived->attr.access,
6757 arg->sym->ts.derived->ns->default_access))
6759 gfc_error_now ("'%s' is of a PRIVATE type and cannot be "
6760 "a dummy argument of '%s', which is "
6761 "PUBLIC at %L", arg->sym->name, sym->name,
6763 /* Stop this message from recurring. */
6764 arg->sym->ts.derived->attr.access = ACCESS_PUBLIC;
6769 /* PUBLIC interfaces may expose PRIVATE procedures that take types
6770 PRIVATE to the containing module. */
6771 for (iface = sym->generic; iface; iface = iface->next)
6773 for (arg = iface->sym->formal; arg; arg = arg->next)
6776 && arg->sym->ts.type == BT_DERIVED
6777 && !arg->sym->ts.derived->attr.use_assoc
6778 && !gfc_check_access (arg->sym->ts.derived->attr.access,
6779 arg->sym->ts.derived->ns->default_access))
6781 gfc_error_now ("Procedure '%s' in PUBLIC interface '%s' at %L takes "
6782 "dummy arguments of '%s' which is PRIVATE",
6783 iface->sym->name, sym->name, &iface->sym->declared_at,
6784 gfc_typename(&arg->sym->ts));
6785 /* Stop this message from recurring. */
6786 arg->sym->ts.derived->attr.access = ACCESS_PUBLIC;
6792 /* PUBLIC interfaces may expose PRIVATE procedures that take types
6793 PRIVATE to the containing module. */
6794 for (iface = sym->generic; iface; iface = iface->next)
6796 for (arg = iface->sym->formal; arg; arg = arg->next)
6799 && arg->sym->ts.type == BT_DERIVED
6800 && !arg->sym->ts.derived->attr.use_assoc
6801 && !gfc_check_access (arg->sym->ts.derived->attr.access,
6802 arg->sym->ts.derived->ns->default_access))
6804 gfc_error_now ("Procedure '%s' in PUBLIC interface '%s' at %L takes "
6805 "dummy arguments of '%s' which is PRIVATE",
6806 iface->sym->name, sym->name, &iface->sym->declared_at,
6807 gfc_typename(&arg->sym->ts));
6808 /* Stop this message from recurring. */
6809 arg->sym->ts.derived->attr.access = ACCESS_PUBLIC;
6816 if (sym->attr.function && sym->value && sym->attr.proc != PROC_ST_FUNCTION)
6818 gfc_error ("Function '%s' at %L cannot have an initializer",
6819 sym->name, &sym->declared_at);
6823 /* An external symbol may not have an initializer because it is taken to be
6825 if (sym->attr.external && sym->value)
6827 gfc_error ("External object '%s' at %L may not have an initializer",
6828 sym->name, &sym->declared_at);
6832 /* An elemental function is required to return a scalar 12.7.1 */
6833 if (sym->attr.elemental && sym->attr.function && sym->as)
6835 gfc_error ("ELEMENTAL function '%s' at %L must have a scalar "
6836 "result", sym->name, &sym->declared_at);
6837 /* Reset so that the error only occurs once. */
6838 sym->attr.elemental = 0;
6842 /* 5.1.1.5 of the Standard: A function name declared with an asterisk
6843 char-len-param shall not be array-valued, pointer-valued, recursive
6844 or pure. ....snip... A character value of * may only be used in the
6845 following ways: (i) Dummy arg of procedure - dummy associates with
6846 actual length; (ii) To declare a named constant; or (iii) External
6847 function - but length must be declared in calling scoping unit. */
6848 if (sym->attr.function
6849 && sym->ts.type == BT_CHARACTER
6850 && sym->ts.cl && sym->ts.cl->length == NULL)
6852 if ((sym->as && sym->as->rank) || (sym->attr.pointer)
6853 || (sym->attr.recursive) || (sym->attr.pure))
6855 if (sym->as && sym->as->rank)
6856 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
6857 "array-valued", sym->name, &sym->declared_at);
6859 if (sym->attr.pointer)
6860 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
6861 "pointer-valued", sym->name, &sym->declared_at);
6864 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
6865 "pure", sym->name, &sym->declared_at);
6867 if (sym->attr.recursive)
6868 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
6869 "recursive", sym->name, &sym->declared_at);
6874 /* Appendix B.2 of the standard. Contained functions give an
6875 error anyway. Fixed-form is likely to be F77/legacy. */
6876 if (!sym->attr.contained && gfc_current_form != FORM_FIXED)
6877 gfc_notify_std (GFC_STD_F95_OBS, "CHARACTER(*) function "
6878 "'%s' at %L is obsolescent in fortran 95",
6879 sym->name, &sym->declared_at);
6882 if (sym->attr.is_bind_c && sym->attr.is_c_interop != 1)
6884 gfc_formal_arglist *curr_arg;
6885 int has_non_interop_arg = 0;
6887 if (verify_bind_c_sym (sym, &(sym->ts), sym->attr.in_common,
6888 sym->common_block) == FAILURE)
6890 /* Clear these to prevent looking at them again if there was an
6892 sym->attr.is_bind_c = 0;
6893 sym->attr.is_c_interop = 0;
6894 sym->ts.is_c_interop = 0;
6898 /* So far, no errors have been found. */
6899 sym->attr.is_c_interop = 1;
6900 sym->ts.is_c_interop = 1;
6903 curr_arg = sym->formal;
6904 while (curr_arg != NULL)
6906 /* Skip implicitly typed dummy args here. */
6907 if (curr_arg->sym->attr.implicit_type == 0)
6908 if (verify_c_interop_param (curr_arg->sym) == FAILURE)
6909 /* If something is found to fail, record the fact so we
6910 can mark the symbol for the procedure as not being
6911 BIND(C) to try and prevent multiple errors being
6913 has_non_interop_arg = 1;
6915 curr_arg = curr_arg->next;
6918 /* See if any of the arguments were not interoperable and if so, clear
6919 the procedure symbol to prevent duplicate error messages. */
6920 if (has_non_interop_arg != 0)
6922 sym->attr.is_c_interop = 0;
6923 sym->ts.is_c_interop = 0;
6924 sym->attr.is_bind_c = 0;
6932 /* Resolve the components of a derived type. */
6935 resolve_fl_derived (gfc_symbol *sym)
6938 gfc_dt_list * dt_list;
6941 for (c = sym->components; c != NULL; c = c->next)
6943 if (c->ts.type == BT_CHARACTER)
6945 if (c->ts.cl->length == NULL
6946 || (resolve_charlen (c->ts.cl) == FAILURE)
6947 || !gfc_is_constant_expr (c->ts.cl->length))
6949 gfc_error ("Character length of component '%s' needs to "
6950 "be a constant specification expression at %L",
6952 c->ts.cl->length ? &c->ts.cl->length->where : &c->loc);
6957 if (c->ts.type == BT_DERIVED
6958 && sym->component_access != ACCESS_PRIVATE
6959 && gfc_check_access (sym->attr.access, sym->ns->default_access)
6960 && !c->ts.derived->attr.use_assoc
6961 && !gfc_check_access (c->ts.derived->attr.access,
6962 c->ts.derived->ns->default_access))
6964 gfc_error ("The component '%s' is a PRIVATE type and cannot be "
6965 "a component of '%s', which is PUBLIC at %L",
6966 c->name, sym->name, &sym->declared_at);
6970 if (sym->attr.sequence)
6972 if (c->ts.type == BT_DERIVED && c->ts.derived->attr.sequence == 0)
6974 gfc_error ("Component %s of SEQUENCE type declared at %L does "
6975 "not have the SEQUENCE attribute",
6976 c->ts.derived->name, &sym->declared_at);
6981 if (c->ts.type == BT_DERIVED && c->pointer
6982 && c->ts.derived->components == NULL)
6984 gfc_error ("The pointer component '%s' of '%s' at %L is a type "
6985 "that has not been declared", c->name, sym->name,
6990 if (c->pointer || c->allocatable || c->as == NULL)
6993 for (i = 0; i < c->as->rank; i++)
6995 if (c->as->lower[i] == NULL
6996 || !gfc_is_constant_expr (c->as->lower[i])
6997 || (resolve_index_expr (c->as->lower[i]) == FAILURE)
6998 || c->as->upper[i] == NULL
6999 || (resolve_index_expr (c->as->upper[i]) == FAILURE)
7000 || !gfc_is_constant_expr (c->as->upper[i]))
7002 gfc_error ("Component '%s' of '%s' at %L must have "
7003 "constant array bounds",
7004 c->name, sym->name, &c->loc);
7010 /* Add derived type to the derived type list. */
7011 for (dt_list = gfc_derived_types; dt_list; dt_list = dt_list->next)
7012 if (sym == dt_list->derived)
7015 if (dt_list == NULL)
7017 dt_list = gfc_get_dt_list ();
7018 dt_list->next = gfc_derived_types;
7019 dt_list->derived = sym;
7020 gfc_derived_types = dt_list;
7028 resolve_fl_namelist (gfc_symbol *sym)
7033 /* Reject PRIVATE objects in a PUBLIC namelist. */
7034 if (gfc_check_access(sym->attr.access, sym->ns->default_access))
7036 for (nl = sym->namelist; nl; nl = nl->next)
7038 if (nl->sym->attr.use_assoc
7039 || (sym->ns->parent == nl->sym->ns)
7041 && sym->ns->parent->parent == nl->sym->ns))
7044 if (!gfc_check_access(nl->sym->attr.access,
7045 nl->sym->ns->default_access))
7047 gfc_error ("NAMELIST object '%s' was declared PRIVATE and "
7048 "cannot be member of PUBLIC namelist '%s' at %L",
7049 nl->sym->name, sym->name, &sym->declared_at);
7053 if (nl->sym->ts.type == BT_DERIVED
7054 && !gfc_check_access (nl->sym->ts.derived->attr.private_comp
7055 ? ACCESS_PRIVATE : ACCESS_UNKNOWN,
7056 nl->sym->ns->default_access))
7058 gfc_error ("NAMELIST object '%s' has PRIVATE components and "
7059 "cannot be a member of PUBLIC namelist '%s' at %L",
7060 nl->sym->name, sym->name, &sym->declared_at);
7066 for (nl = sym->namelist; nl; nl = nl->next)
7068 /* Reject namelist arrays of assumed shape. */
7069 if (nl->sym->as && nl->sym->as->type == AS_ASSUMED_SHAPE
7070 && gfc_notify_std (GFC_STD_F2003, "NAMELIST array object '%s' "
7071 "must not have assumed shape in namelist "
7072 "'%s' at %L", nl->sym->name, sym->name,
7073 &sym->declared_at) == FAILURE)
7076 /* Reject namelist arrays that are not constant shape. */
7077 if (is_non_constant_shape_array (nl->sym))
7079 gfc_error ("NAMELIST array object '%s' must have constant "
7080 "shape in namelist '%s' at %L", nl->sym->name,
7081 sym->name, &sym->declared_at);
7085 /* Namelist objects cannot have allocatable or pointer components. */
7086 if (nl->sym->ts.type != BT_DERIVED)
7089 if (nl->sym->ts.derived->attr.alloc_comp)
7091 gfc_error ("NAMELIST object '%s' in namelist '%s' at %L cannot "
7092 "have ALLOCATABLE components",
7093 nl->sym->name, sym->name, &sym->declared_at);
7097 if (nl->sym->ts.derived->attr.pointer_comp)
7099 gfc_error ("NAMELIST object '%s' in namelist '%s' at %L cannot "
7100 "have POINTER components",
7101 nl->sym->name, sym->name, &sym->declared_at);
7107 /* 14.1.2 A module or internal procedure represent local entities
7108 of the same type as a namelist member and so are not allowed. */
7109 for (nl = sym->namelist; nl; nl = nl->next)
7111 if (nl->sym->ts.kind != 0 && nl->sym->attr.flavor == FL_VARIABLE)
7114 if (nl->sym->attr.function && nl->sym == nl->sym->result)
7115 if ((nl->sym == sym->ns->proc_name)
7117 (sym->ns->parent && nl->sym == sym->ns->parent->proc_name))
7121 if (nl->sym && nl->sym->name)
7122 gfc_find_symbol (nl->sym->name, sym->ns, 1, &nlsym);
7123 if (nlsym && nlsym->attr.flavor == FL_PROCEDURE)
7125 gfc_error ("PROCEDURE attribute conflicts with NAMELIST "
7126 "attribute in '%s' at %L", nlsym->name,
7137 resolve_fl_parameter (gfc_symbol *sym)
7139 /* A parameter array's shape needs to be constant. */
7140 if (sym->as != NULL && !gfc_is_compile_time_shape (sym->as))
7142 gfc_error ("Parameter array '%s' at %L cannot be automatic "
7143 "or assumed shape", sym->name, &sym->declared_at);
7147 /* Make sure a parameter that has been implicitly typed still
7148 matches the implicit type, since PARAMETER statements can precede
7149 IMPLICIT statements. */
7150 if (sym->attr.implicit_type
7151 && !gfc_compare_types (&sym->ts, gfc_get_default_type (sym, sym->ns)))
7153 gfc_error ("Implicitly typed PARAMETER '%s' at %L doesn't match a "
7154 "later IMPLICIT type", sym->name, &sym->declared_at);
7158 /* Make sure the types of derived parameters are consistent. This
7159 type checking is deferred until resolution because the type may
7160 refer to a derived type from the host. */
7161 if (sym->ts.type == BT_DERIVED
7162 && !gfc_compare_types (&sym->ts, &sym->value->ts))
7164 gfc_error ("Incompatible derived type in PARAMETER at %L",
7165 &sym->value->where);
7172 /* Do anything necessary to resolve a symbol. Right now, we just
7173 assume that an otherwise unknown symbol is a variable. This sort
7174 of thing commonly happens for symbols in module. */
7177 resolve_symbol (gfc_symbol *sym)
7179 int check_constant, mp_flag;
7180 gfc_symtree *symtree;
7181 gfc_symtree *this_symtree;
7185 if (sym->attr.flavor == FL_UNKNOWN)
7188 /* If we find that a flavorless symbol is an interface in one of the
7189 parent namespaces, find its symtree in this namespace, free the
7190 symbol and set the symtree to point to the interface symbol. */
7191 for (ns = gfc_current_ns->parent; ns; ns = ns->parent)
7193 symtree = gfc_find_symtree (ns->sym_root, sym->name);
7194 if (symtree && symtree->n.sym->generic)
7196 this_symtree = gfc_find_symtree (gfc_current_ns->sym_root,
7200 gfc_free_symbol (sym);
7201 symtree->n.sym->refs++;
7202 this_symtree->n.sym = symtree->n.sym;
7207 /* Otherwise give it a flavor according to such attributes as
7209 if (sym->attr.external == 0 && sym->attr.intrinsic == 0)
7210 sym->attr.flavor = FL_VARIABLE;
7213 sym->attr.flavor = FL_PROCEDURE;
7214 if (sym->attr.dimension)
7215 sym->attr.function = 1;
7219 if (sym->attr.flavor == FL_DERIVED && resolve_fl_derived (sym) == FAILURE)
7222 /* Symbols that are module procedures with results (functions) have
7223 the types and array specification copied for type checking in
7224 procedures that call them, as well as for saving to a module
7225 file. These symbols can't stand the scrutiny that their results
7227 mp_flag = (sym->result != NULL && sym->result != sym);
7230 /* Make sure that the intrinsic is consistent with its internal
7231 representation. This needs to be done before assigning a default
7232 type to avoid spurious warnings. */
7233 if (sym->attr.flavor != FL_MODULE && sym->attr.intrinsic)
7235 if (gfc_intrinsic_name (sym->name, 0))
7237 if (sym->ts.type != BT_UNKNOWN && gfc_option.warn_surprising)
7238 gfc_warning ("Type specified for intrinsic function '%s' at %L is ignored",
7239 sym->name, &sym->declared_at);
7241 else if (gfc_intrinsic_name (sym->name, 1))
7243 if (sym->ts.type != BT_UNKNOWN)
7245 gfc_error ("Intrinsic subroutine '%s' at %L shall not have a type specifier",
7246 sym->name, &sym->declared_at);
7252 gfc_error ("Intrinsic '%s' at %L does not exist", sym->name, &sym->declared_at);
7257 /* Assign default type to symbols that need one and don't have one. */
7258 if (sym->ts.type == BT_UNKNOWN)
7260 if (sym->attr.flavor == FL_VARIABLE || sym->attr.flavor == FL_PARAMETER)
7261 gfc_set_default_type (sym, 1, NULL);
7263 if (sym->attr.flavor == FL_PROCEDURE && sym->attr.function)
7265 /* The specific case of an external procedure should emit an error
7266 in the case that there is no implicit type. */
7268 gfc_set_default_type (sym, sym->attr.external, NULL);
7271 /* Result may be in another namespace. */
7272 resolve_symbol (sym->result);
7274 sym->ts = sym->result->ts;
7275 sym->as = gfc_copy_array_spec (sym->result->as);
7276 sym->attr.dimension = sym->result->attr.dimension;
7277 sym->attr.pointer = sym->result->attr.pointer;
7278 sym->attr.allocatable = sym->result->attr.allocatable;
7283 /* Assumed size arrays and assumed shape arrays must be dummy
7287 && (sym->as->type == AS_ASSUMED_SIZE
7288 || sym->as->type == AS_ASSUMED_SHAPE)
7289 && sym->attr.dummy == 0)
7291 if (sym->as->type == AS_ASSUMED_SIZE)
7292 gfc_error ("Assumed size array at %L must be a dummy argument",
7295 gfc_error ("Assumed shape array at %L must be a dummy argument",
7300 /* Make sure symbols with known intent or optional are really dummy
7301 variable. Because of ENTRY statement, this has to be deferred
7302 until resolution time. */
7304 if (!sym->attr.dummy
7305 && (sym->attr.optional || sym->attr.intent != INTENT_UNKNOWN))
7307 gfc_error ("Symbol at %L is not a DUMMY variable", &sym->declared_at);
7311 if (sym->attr.value && !sym->attr.dummy)
7313 gfc_error ("'%s' at %L cannot have the VALUE attribute because "
7314 "it is not a dummy argument", sym->name, &sym->declared_at);
7318 if (sym->attr.value && sym->ts.type == BT_CHARACTER)
7320 gfc_charlen *cl = sym->ts.cl;
7321 if (!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT)
7323 gfc_error ("Character dummy variable '%s' at %L with VALUE "
7324 "attribute must have constant length",
7325 sym->name, &sym->declared_at);
7329 if (sym->ts.is_c_interop
7330 && mpz_cmp_si (cl->length->value.integer, 1) != 0)
7332 gfc_error ("C interoperable character dummy variable '%s' at %L "
7333 "with VALUE attribute must have length one",
7334 sym->name, &sym->declared_at);
7339 /* If the symbol is marked as bind(c), verify it's type and kind. Do not
7340 do this for something that was implicitly typed because that is handled
7341 in gfc_set_default_type. Handle dummy arguments and procedure
7342 definitions separately. Also, anything that is use associated is not
7343 handled here but instead is handled in the module it is declared in.
7344 Finally, derived type definitions are allowed to be BIND(C) since that
7345 only implies that they're interoperable, and they are checked fully for
7346 interoperability when a variable is declared of that type. */
7347 if (sym->attr.is_bind_c && sym->attr.implicit_type == 0 &&
7348 sym->attr.use_assoc == 0 && sym->attr.dummy == 0 &&
7349 sym->attr.flavor != FL_PROCEDURE && sym->attr.flavor != FL_DERIVED)
7353 /* First, make sure the variable is declared at the
7354 module-level scope (J3/04-007, Section 15.3). */
7355 if (sym->ns->proc_name->attr.flavor != FL_MODULE &&
7356 sym->attr.in_common == 0)
7358 gfc_error ("Variable '%s' at %L cannot be BIND(C) because it "
7359 "is neither a COMMON block nor declared at the "
7360 "module level scope", sym->name, &(sym->declared_at));
7363 else if (sym->common_head != NULL)
7365 t = verify_com_block_vars_c_interop (sym->common_head);
7369 /* If type() declaration, we need to verify that the components
7370 of the given type are all C interoperable, etc. */
7371 if (sym->ts.type == BT_DERIVED &&
7372 sym->ts.derived->attr.is_c_interop != 1)
7374 /* Make sure the user marked the derived type as BIND(C). If
7375 not, call the verify routine. This could print an error
7376 for the derived type more than once if multiple variables
7377 of that type are declared. */
7378 if (sym->ts.derived->attr.is_bind_c != 1)
7379 verify_bind_c_derived_type (sym->ts.derived);
7383 /* Verify the variable itself as C interoperable if it
7384 is BIND(C). It is not possible for this to succeed if
7385 the verify_bind_c_derived_type failed, so don't have to handle
7386 any error returned by verify_bind_c_derived_type. */
7387 t = verify_bind_c_sym (sym, &(sym->ts), sym->attr.in_common,
7393 /* clear the is_bind_c flag to prevent reporting errors more than
7394 once if something failed. */
7395 sym->attr.is_bind_c = 0;
7400 /* If a derived type symbol has reached this point, without its
7401 type being declared, we have an error. Notice that most
7402 conditions that produce undefined derived types have already
7403 been dealt with. However, the likes of:
7404 implicit type(t) (t) ..... call foo (t) will get us here if
7405 the type is not declared in the scope of the implicit
7406 statement. Change the type to BT_UNKNOWN, both because it is so
7407 and to prevent an ICE. */
7408 if (sym->ts.type == BT_DERIVED && sym->ts.derived->components == NULL)
7410 gfc_error ("The derived type '%s' at %L is of type '%s', "
7411 "which has not been defined", sym->name,
7412 &sym->declared_at, sym->ts.derived->name);
7413 sym->ts.type = BT_UNKNOWN;
7417 /* An assumed-size array with INTENT(OUT) shall not be of a type for which
7418 default initialization is defined (5.1.2.4.4). */
7419 if (sym->ts.type == BT_DERIVED
7421 && sym->attr.intent == INTENT_OUT
7423 && sym->as->type == AS_ASSUMED_SIZE)
7425 for (c = sym->ts.derived->components; c; c = c->next)
7429 gfc_error ("The INTENT(OUT) dummy argument '%s' at %L is "
7430 "ASSUMED SIZE and so cannot have a default initializer",
7431 sym->name, &sym->declared_at);
7437 switch (sym->attr.flavor)
7440 if (resolve_fl_variable (sym, mp_flag) == FAILURE)
7445 if (resolve_fl_procedure (sym, mp_flag) == FAILURE)
7450 if (resolve_fl_namelist (sym) == FAILURE)
7455 if (resolve_fl_parameter (sym) == FAILURE)
7463 /* Resolve array specifier. Check as well some constraints
7464 on COMMON blocks. */
7466 check_constant = sym->attr.in_common && !sym->attr.pointer;
7468 /* Set the formal_arg_flag so that check_conflict will not throw
7469 an error for host associated variables in the specification
7470 expression for an array_valued function. */
7471 if (sym->attr.function && sym->as)
7472 formal_arg_flag = 1;
7474 gfc_resolve_array_spec (sym->as, check_constant);
7476 formal_arg_flag = 0;
7478 /* Resolve formal namespaces. */
7479 if (sym->formal_ns && sym->formal_ns != gfc_current_ns)
7480 gfc_resolve (sym->formal_ns);
7482 /* Check threadprivate restrictions. */
7483 if (sym->attr.threadprivate && !sym->attr.save && !sym->ns->save_all
7484 && (!sym->attr.in_common
7485 && sym->module == NULL
7486 && (sym->ns->proc_name == NULL
7487 || sym->ns->proc_name->attr.flavor != FL_MODULE)))
7488 gfc_error ("Threadprivate at %L isn't SAVEd", &sym->declared_at);
7490 /* If we have come this far we can apply default-initializers, as
7491 described in 14.7.5, to those variables that have not already
7492 been assigned one. */
7493 if (sym->ts.type == BT_DERIVED
7494 && sym->attr.referenced
7495 && sym->ns == gfc_current_ns
7497 && !sym->attr.allocatable
7498 && !sym->attr.alloc_comp)
7500 symbol_attribute *a = &sym->attr;
7502 if ((!a->save && !a->dummy && !a->pointer
7503 && !a->in_common && !a->use_assoc
7504 && !(a->function && sym != sym->result))
7505 || (a->dummy && a->intent == INTENT_OUT))
7506 apply_default_init (sym);
7511 /************* Resolve DATA statements *************/
7515 gfc_data_value *vnode;
7521 /* Advance the values structure to point to the next value in the data list. */
7524 next_data_value (void)
7526 while (values.left == 0)
7528 if (values.vnode->next == NULL)
7531 values.vnode = values.vnode->next;
7532 values.left = values.vnode->repeat;
7540 check_data_variable (gfc_data_variable *var, locus *where)
7546 ar_type mark = AR_UNKNOWN;
7548 mpz_t section_index[GFC_MAX_DIMENSIONS];
7552 if (gfc_resolve_expr (var->expr) == FAILURE)
7556 mpz_init_set_si (offset, 0);
7559 if (e->expr_type != EXPR_VARIABLE)
7560 gfc_internal_error ("check_data_variable(): Bad expression");
7562 if (e->symtree->n.sym->ns->is_block_data
7563 && !e->symtree->n.sym->attr.in_common)
7565 gfc_error ("BLOCK DATA element '%s' at %L must be in COMMON",
7566 e->symtree->n.sym->name, &e->symtree->n.sym->declared_at);
7571 mpz_init_set_ui (size, 1);
7578 /* Find the array section reference. */
7579 for (ref = e->ref; ref; ref = ref->next)
7581 if (ref->type != REF_ARRAY)
7583 if (ref->u.ar.type == AR_ELEMENT)
7589 /* Set marks according to the reference pattern. */
7590 switch (ref->u.ar.type)
7598 /* Get the start position of array section. */
7599 gfc_get_section_index (ar, section_index, &offset);
7607 if (gfc_array_size (e, &size) == FAILURE)
7609 gfc_error ("Nonconstant array section at %L in DATA statement",
7618 while (mpz_cmp_ui (size, 0) > 0)
7620 if (next_data_value () == FAILURE)
7622 gfc_error ("DATA statement at %L has more variables than values",
7628 t = gfc_check_assign (var->expr, values.vnode->expr, 0);
7632 /* If we have more than one element left in the repeat count,
7633 and we have more than one element left in the target variable,
7634 then create a range assignment. */
7635 /* ??? Only done for full arrays for now, since array sections
7637 if (mark == AR_FULL && ref && ref->next == NULL
7638 && values.left > 1 && mpz_cmp_ui (size, 1) > 0)
7642 if (mpz_cmp_ui (size, values.left) >= 0)
7644 mpz_init_set_ui (range, values.left);
7645 mpz_sub_ui (size, size, values.left);
7650 mpz_init_set (range, size);
7651 values.left -= mpz_get_ui (size);
7652 mpz_set_ui (size, 0);
7655 gfc_assign_data_value_range (var->expr, values.vnode->expr,
7658 mpz_add (offset, offset, range);
7662 /* Assign initial value to symbol. */
7666 mpz_sub_ui (size, size, 1);
7668 t = gfc_assign_data_value (var->expr, values.vnode->expr, offset);
7672 if (mark == AR_FULL)
7673 mpz_add_ui (offset, offset, 1);
7675 /* Modify the array section indexes and recalculate the offset
7676 for next element. */
7677 else if (mark == AR_SECTION)
7678 gfc_advance_section (section_index, ar, &offset);
7682 if (mark == AR_SECTION)
7684 for (i = 0; i < ar->dimen; i++)
7685 mpz_clear (section_index[i]);
7695 static try traverse_data_var (gfc_data_variable *, locus *);
7697 /* Iterate over a list of elements in a DATA statement. */
7700 traverse_data_list (gfc_data_variable *var, locus *where)
7703 iterator_stack frame;
7704 gfc_expr *e, *start, *end, *step;
7705 try retval = SUCCESS;
7707 mpz_init (frame.value);
7709 start = gfc_copy_expr (var->iter.start);
7710 end = gfc_copy_expr (var->iter.end);
7711 step = gfc_copy_expr (var->iter.step);
7713 if (gfc_simplify_expr (start, 1) == FAILURE
7714 || start->expr_type != EXPR_CONSTANT)
7716 gfc_error ("iterator start at %L does not simplify", &start->where);
7720 if (gfc_simplify_expr (end, 1) == FAILURE
7721 || end->expr_type != EXPR_CONSTANT)
7723 gfc_error ("iterator end at %L does not simplify", &end->where);
7727 if (gfc_simplify_expr (step, 1) == FAILURE
7728 || step->expr_type != EXPR_CONSTANT)
7730 gfc_error ("iterator step at %L does not simplify", &step->where);
7735 mpz_init_set (trip, end->value.integer);
7736 mpz_sub (trip, trip, start->value.integer);
7737 mpz_add (trip, trip, step->value.integer);
7739 mpz_div (trip, trip, step->value.integer);
7741 mpz_set (frame.value, start->value.integer);
7743 frame.prev = iter_stack;
7744 frame.variable = var->iter.var->symtree;
7745 iter_stack = &frame;
7747 while (mpz_cmp_ui (trip, 0) > 0)
7749 if (traverse_data_var (var->list, where) == FAILURE)
7756 e = gfc_copy_expr (var->expr);
7757 if (gfc_simplify_expr (e, 1) == FAILURE)
7765 mpz_add (frame.value, frame.value, step->value.integer);
7767 mpz_sub_ui (trip, trip, 1);
7772 mpz_clear (frame.value);
7774 gfc_free_expr (start);
7775 gfc_free_expr (end);
7776 gfc_free_expr (step);
7778 iter_stack = frame.prev;
7783 /* Type resolve variables in the variable list of a DATA statement. */
7786 traverse_data_var (gfc_data_variable *var, locus *where)
7790 for (; var; var = var->next)
7792 if (var->expr == NULL)
7793 t = traverse_data_list (var, where);
7795 t = check_data_variable (var, where);
7805 /* Resolve the expressions and iterators associated with a data statement.
7806 This is separate from the assignment checking because data lists should
7807 only be resolved once. */
7810 resolve_data_variables (gfc_data_variable *d)
7812 for (; d; d = d->next)
7814 if (d->list == NULL)
7816 if (gfc_resolve_expr (d->expr) == FAILURE)
7821 if (gfc_resolve_iterator (&d->iter, false) == FAILURE)
7824 if (resolve_data_variables (d->list) == FAILURE)
7833 /* Resolve a single DATA statement. We implement this by storing a pointer to
7834 the value list into static variables, and then recursively traversing the
7835 variables list, expanding iterators and such. */
7838 resolve_data (gfc_data * d)
7840 if (resolve_data_variables (d->var) == FAILURE)
7843 values.vnode = d->value;
7844 values.left = (d->value == NULL) ? 0 : d->value->repeat;
7846 if (traverse_data_var (d->var, &d->where) == FAILURE)
7849 /* At this point, we better not have any values left. */
7851 if (next_data_value () == SUCCESS)
7852 gfc_error ("DATA statement at %L has more values than variables",
7857 /* 12.6 Constraint: In a pure subprogram any variable which is in common or
7858 accessed by host or use association, is a dummy argument to a pure function,
7859 is a dummy argument with INTENT (IN) to a pure subroutine, or an object that
7860 is storage associated with any such variable, shall not be used in the
7861 following contexts: (clients of this function). */
7863 /* Determines if a variable is not 'pure', ie not assignable within a pure
7864 procedure. Returns zero if assignment is OK, nonzero if there is a
7867 gfc_impure_variable (gfc_symbol *sym)
7871 if (sym->attr.use_assoc || sym->attr.in_common)
7874 if (sym->ns != gfc_current_ns)
7875 return !sym->attr.function;
7877 proc = sym->ns->proc_name;
7878 if (sym->attr.dummy && gfc_pure (proc)
7879 && ((proc->attr.subroutine && sym->attr.intent == INTENT_IN)
7881 proc->attr.function))
7884 /* TODO: Sort out what can be storage associated, if anything, and include
7885 it here. In principle equivalences should be scanned but it does not
7886 seem to be possible to storage associate an impure variable this way. */
7891 /* Test whether a symbol is pure or not. For a NULL pointer, checks the
7892 symbol of the current procedure. */
7895 gfc_pure (gfc_symbol *sym)
7897 symbol_attribute attr;
7900 sym = gfc_current_ns->proc_name;
7906 return attr.flavor == FL_PROCEDURE && (attr.pure || attr.elemental);
7910 /* Test whether the current procedure is elemental or not. */
7913 gfc_elemental (gfc_symbol *sym)
7915 symbol_attribute attr;
7918 sym = gfc_current_ns->proc_name;
7923 return attr.flavor == FL_PROCEDURE && attr.elemental;
7927 /* Warn about unused labels. */
7930 warn_unused_fortran_label (gfc_st_label *label)
7935 warn_unused_fortran_label (label->left);
7937 if (label->defined == ST_LABEL_UNKNOWN)
7940 switch (label->referenced)
7942 case ST_LABEL_UNKNOWN:
7943 gfc_warning ("Label %d at %L defined but not used", label->value,
7947 case ST_LABEL_BAD_TARGET:
7948 gfc_warning ("Label %d at %L defined but cannot be used",
7949 label->value, &label->where);
7956 warn_unused_fortran_label (label->right);
7960 /* Returns the sequence type of a symbol or sequence. */
7963 sequence_type (gfc_typespec ts)
7972 if (ts.derived->components == NULL)
7973 return SEQ_NONDEFAULT;
7975 result = sequence_type (ts.derived->components->ts);
7976 for (c = ts.derived->components->next; c; c = c->next)
7977 if (sequence_type (c->ts) != result)
7983 if (ts.kind != gfc_default_character_kind)
7984 return SEQ_NONDEFAULT;
7986 return SEQ_CHARACTER;
7989 if (ts.kind != gfc_default_integer_kind)
7990 return SEQ_NONDEFAULT;
7995 if (!(ts.kind == gfc_default_real_kind
7996 || ts.kind == gfc_default_double_kind))
7997 return SEQ_NONDEFAULT;
8002 if (ts.kind != gfc_default_complex_kind)
8003 return SEQ_NONDEFAULT;
8008 if (ts.kind != gfc_default_logical_kind)
8009 return SEQ_NONDEFAULT;
8014 return SEQ_NONDEFAULT;
8019 /* Resolve derived type EQUIVALENCE object. */
8022 resolve_equivalence_derived (gfc_symbol *derived, gfc_symbol *sym, gfc_expr *e)
8025 gfc_component *c = derived->components;
8030 /* Shall not be an object of nonsequence derived type. */
8031 if (!derived->attr.sequence)
8033 gfc_error ("Derived type variable '%s' at %L must have SEQUENCE "
8034 "attribute to be an EQUIVALENCE object", sym->name,
8039 /* Shall not have allocatable components. */
8040 if (derived->attr.alloc_comp)
8042 gfc_error ("Derived type variable '%s' at %L cannot have ALLOCATABLE "
8043 "components to be an EQUIVALENCE object",sym->name,
8048 for (; c ; c = c->next)
8052 && (resolve_equivalence_derived (c->ts.derived, sym, e) == FAILURE))
8055 /* Shall not be an object of sequence derived type containing a pointer
8056 in the structure. */
8059 gfc_error ("Derived type variable '%s' at %L with pointer "
8060 "component(s) cannot be an EQUIVALENCE object",
8061 sym->name, &e->where);
8069 /* Resolve equivalence object.
8070 An EQUIVALENCE object shall not be a dummy argument, a pointer, a target,
8071 an allocatable array, an object of nonsequence derived type, an object of
8072 sequence derived type containing a pointer at any level of component
8073 selection, an automatic object, a function name, an entry name, a result
8074 name, a named constant, a structure component, or a subobject of any of
8075 the preceding objects. A substring shall not have length zero. A
8076 derived type shall not have components with default initialization nor
8077 shall two objects of an equivalence group be initialized.
8078 Either all or none of the objects shall have an protected attribute.
8079 The simple constraints are done in symbol.c(check_conflict) and the rest
8080 are implemented here. */
8083 resolve_equivalence (gfc_equiv *eq)
8086 gfc_symbol *derived;
8087 gfc_symbol *first_sym;
8090 locus *last_where = NULL;
8091 seq_type eq_type, last_eq_type;
8092 gfc_typespec *last_ts;
8093 int object, cnt_protected;
8094 const char *value_name;
8098 last_ts = &eq->expr->symtree->n.sym->ts;
8100 first_sym = eq->expr->symtree->n.sym;
8104 for (object = 1; eq; eq = eq->eq, object++)
8108 e->ts = e->symtree->n.sym->ts;
8109 /* match_varspec might not know yet if it is seeing
8110 array reference or substring reference, as it doesn't
8112 if (e->ref && e->ref->type == REF_ARRAY)
8114 gfc_ref *ref = e->ref;
8115 sym = e->symtree->n.sym;
8117 if (sym->attr.dimension)
8119 ref->u.ar.as = sym->as;
8123 /* For substrings, convert REF_ARRAY into REF_SUBSTRING. */
8124 if (e->ts.type == BT_CHARACTER
8126 && ref->type == REF_ARRAY
8127 && ref->u.ar.dimen == 1
8128 && ref->u.ar.dimen_type[0] == DIMEN_RANGE
8129 && ref->u.ar.stride[0] == NULL)
8131 gfc_expr *start = ref->u.ar.start[0];
8132 gfc_expr *end = ref->u.ar.end[0];
8135 /* Optimize away the (:) reference. */
8136 if (start == NULL && end == NULL)
8141 e->ref->next = ref->next;
8146 ref->type = REF_SUBSTRING;
8148 start = gfc_int_expr (1);
8149 ref->u.ss.start = start;
8150 if (end == NULL && e->ts.cl)
8151 end = gfc_copy_expr (e->ts.cl->length);
8152 ref->u.ss.end = end;
8153 ref->u.ss.length = e->ts.cl;
8160 /* Any further ref is an error. */
8163 gcc_assert (ref->type == REF_ARRAY);
8164 gfc_error ("Syntax error in EQUIVALENCE statement at %L",
8170 if (gfc_resolve_expr (e) == FAILURE)
8173 sym = e->symtree->n.sym;
8175 if (sym->attr.protected)
8177 if (cnt_protected > 0 && cnt_protected != object)
8179 gfc_error ("Either all or none of the objects in the "
8180 "EQUIVALENCE set at %L shall have the "
8181 "PROTECTED attribute",
8186 /* Shall not equivalence common block variables in a PURE procedure. */
8187 if (sym->ns->proc_name
8188 && sym->ns->proc_name->attr.pure
8189 && sym->attr.in_common)
8191 gfc_error ("Common block member '%s' at %L cannot be an EQUIVALENCE "
8192 "object in the pure procedure '%s'",
8193 sym->name, &e->where, sym->ns->proc_name->name);
8197 /* Shall not be a named constant. */
8198 if (e->expr_type == EXPR_CONSTANT)
8200 gfc_error ("Named constant '%s' at %L cannot be an EQUIVALENCE "
8201 "object", sym->name, &e->where);
8205 derived = e->ts.derived;
8206 if (derived && resolve_equivalence_derived (derived, sym, e) == FAILURE)
8209 /* Check that the types correspond correctly:
8211 A numeric sequence structure may be equivalenced to another sequence
8212 structure, an object of default integer type, default real type, double
8213 precision real type, default logical type such that components of the
8214 structure ultimately only become associated to objects of the same
8215 kind. A character sequence structure may be equivalenced to an object
8216 of default character kind or another character sequence structure.
8217 Other objects may be equivalenced only to objects of the same type and
8220 /* Identical types are unconditionally OK. */
8221 if (object == 1 || gfc_compare_types (last_ts, &sym->ts))
8222 goto identical_types;
8224 last_eq_type = sequence_type (*last_ts);
8225 eq_type = sequence_type (sym->ts);
8227 /* Since the pair of objects is not of the same type, mixed or
8228 non-default sequences can be rejected. */
8230 msg = "Sequence %s with mixed components in EQUIVALENCE "
8231 "statement at %L with different type objects";
8233 && last_eq_type == SEQ_MIXED
8234 && gfc_notify_std (GFC_STD_GNU, msg, first_sym->name, last_where)
8236 || (eq_type == SEQ_MIXED
8237 && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
8238 &e->where) == FAILURE))
8241 msg = "Non-default type object or sequence %s in EQUIVALENCE "
8242 "statement at %L with objects of different type";
8244 && last_eq_type == SEQ_NONDEFAULT
8245 && gfc_notify_std (GFC_STD_GNU, msg, first_sym->name,
8246 last_where) == FAILURE)
8247 || (eq_type == SEQ_NONDEFAULT
8248 && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
8249 &e->where) == FAILURE))
8252 msg ="Non-CHARACTER object '%s' in default CHARACTER "
8253 "EQUIVALENCE statement at %L";
8254 if (last_eq_type == SEQ_CHARACTER
8255 && eq_type != SEQ_CHARACTER
8256 && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
8257 &e->where) == FAILURE)
8260 msg ="Non-NUMERIC object '%s' in default NUMERIC "
8261 "EQUIVALENCE statement at %L";
8262 if (last_eq_type == SEQ_NUMERIC
8263 && eq_type != SEQ_NUMERIC
8264 && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
8265 &e->where) == FAILURE)
8270 last_where = &e->where;
8275 /* Shall not be an automatic array. */
8276 if (e->ref->type == REF_ARRAY
8277 && gfc_resolve_array_spec (e->ref->u.ar.as, 1) == FAILURE)
8279 gfc_error ("Array '%s' at %L with non-constant bounds cannot be "
8280 "an EQUIVALENCE object", sym->name, &e->where);
8287 /* Shall not be a structure component. */
8288 if (r->type == REF_COMPONENT)
8290 gfc_error ("Structure component '%s' at %L cannot be an "
8291 "EQUIVALENCE object",
8292 r->u.c.component->name, &e->where);
8296 /* A substring shall not have length zero. */
8297 if (r->type == REF_SUBSTRING)
8299 if (compare_bound (r->u.ss.start, r->u.ss.end) == CMP_GT)
8301 gfc_error ("Substring at %L has length zero",
8302 &r->u.ss.start->where);
8312 /* Resolve function and ENTRY types, issue diagnostics if needed. */
8315 resolve_fntype (gfc_namespace *ns)
8320 if (ns->proc_name == NULL || !ns->proc_name->attr.function)
8323 /* If there are any entries, ns->proc_name is the entry master
8324 synthetic symbol and ns->entries->sym actual FUNCTION symbol. */
8326 sym = ns->entries->sym;
8328 sym = ns->proc_name;
8329 if (sym->result == sym
8330 && sym->ts.type == BT_UNKNOWN
8331 && gfc_set_default_type (sym, 0, NULL) == FAILURE
8332 && !sym->attr.untyped)
8334 gfc_error ("Function '%s' at %L has no IMPLICIT type",
8335 sym->name, &sym->declared_at);
8336 sym->attr.untyped = 1;
8339 if (sym->ts.type == BT_DERIVED && !sym->ts.derived->attr.use_assoc
8340 && !gfc_check_access (sym->ts.derived->attr.access,
8341 sym->ts.derived->ns->default_access)
8342 && gfc_check_access (sym->attr.access, sym->ns->default_access))
8344 gfc_error ("PUBLIC function '%s' at %L cannot be of PRIVATE type '%s'",
8345 sym->name, &sym->declared_at, sym->ts.derived->name);
8349 for (el = ns->entries->next; el; el = el->next)
8351 if (el->sym->result == el->sym
8352 && el->sym->ts.type == BT_UNKNOWN
8353 && gfc_set_default_type (el->sym, 0, NULL) == FAILURE
8354 && !el->sym->attr.untyped)
8356 gfc_error ("ENTRY '%s' at %L has no IMPLICIT type",
8357 el->sym->name, &el->sym->declared_at);
8358 el->sym->attr.untyped = 1;
8363 /* 12.3.2.1.1 Defined operators. */
8366 gfc_resolve_uops (gfc_symtree *symtree)
8370 gfc_formal_arglist *formal;
8372 if (symtree == NULL)
8375 gfc_resolve_uops (symtree->left);
8376 gfc_resolve_uops (symtree->right);
8378 for (itr = symtree->n.uop->operator; itr; itr = itr->next)
8381 if (!sym->attr.function)
8382 gfc_error ("User operator procedure '%s' at %L must be a FUNCTION",
8383 sym->name, &sym->declared_at);
8385 if (sym->ts.type == BT_CHARACTER
8386 && !(sym->ts.cl && sym->ts.cl->length)
8387 && !(sym->result && sym->result->ts.cl
8388 && sym->result->ts.cl->length))
8389 gfc_error ("User operator procedure '%s' at %L cannot be assumed "
8390 "character length", sym->name, &sym->declared_at);
8392 formal = sym->formal;
8393 if (!formal || !formal->sym)
8395 gfc_error ("User operator procedure '%s' at %L must have at least "
8396 "one argument", sym->name, &sym->declared_at);
8400 if (formal->sym->attr.intent != INTENT_IN)
8401 gfc_error ("First argument of operator interface at %L must be "
8402 "INTENT(IN)", &sym->declared_at);
8404 if (formal->sym->attr.optional)
8405 gfc_error ("First argument of operator interface at %L cannot be "
8406 "optional", &sym->declared_at);
8408 formal = formal->next;
8409 if (!formal || !formal->sym)
8412 if (formal->sym->attr.intent != INTENT_IN)
8413 gfc_error ("Second argument of operator interface at %L must be "
8414 "INTENT(IN)", &sym->declared_at);
8416 if (formal->sym->attr.optional)
8417 gfc_error ("Second argument of operator interface at %L cannot be "
8418 "optional", &sym->declared_at);
8421 gfc_error ("Operator interface at %L must have, at most, two "
8422 "arguments", &sym->declared_at);
8427 /* Examine all of the expressions associated with a program unit,
8428 assign types to all intermediate expressions, make sure that all
8429 assignments are to compatible types and figure out which names
8430 refer to which functions or subroutines. It doesn't check code
8431 block, which is handled by resolve_code. */
8434 resolve_types (gfc_namespace *ns)
8441 gfc_current_ns = ns;
8443 resolve_entries (ns);
8445 resolve_common_blocks (ns->common_root);
8447 resolve_contained_functions (ns);
8449 gfc_traverse_ns (ns, resolve_bind_c_derived_types);
8451 for (cl = ns->cl_list; cl; cl = cl->next)
8452 resolve_charlen (cl);
8454 gfc_traverse_ns (ns, resolve_symbol);
8456 resolve_fntype (ns);
8458 for (n = ns->contained; n; n = n->sibling)
8460 if (gfc_pure (ns->proc_name) && !gfc_pure (n->proc_name))
8461 gfc_error ("Contained procedure '%s' at %L of a PURE procedure must "
8462 "also be PURE", n->proc_name->name,
8463 &n->proc_name->declared_at);
8469 gfc_check_interfaces (ns);
8471 gfc_traverse_ns (ns, resolve_values);
8477 for (d = ns->data; d; d = d->next)
8481 gfc_traverse_ns (ns, gfc_formalize_init_value);
8483 gfc_traverse_ns (ns, gfc_verify_binding_labels);
8485 if (ns->common_root != NULL)
8486 gfc_traverse_symtree (ns->common_root, resolve_bind_c_comms);
8488 for (eq = ns->equiv; eq; eq = eq->next)
8489 resolve_equivalence (eq);
8491 /* Warn about unused labels. */
8492 if (warn_unused_label)
8493 warn_unused_fortran_label (ns->st_labels);
8495 gfc_resolve_uops (ns->uop_root);
8499 /* Call resolve_code recursively. */
8502 resolve_codes (gfc_namespace *ns)
8506 for (n = ns->contained; n; n = n->sibling)
8509 gfc_current_ns = ns;
8511 /* Set to an out of range value. */
8512 current_entry_id = -1;
8514 bitmap_obstack_initialize (&labels_obstack);
8515 resolve_code (ns->code, ns);
8516 bitmap_obstack_release (&labels_obstack);
8520 /* This function is called after a complete program unit has been compiled.
8521 Its purpose is to examine all of the expressions associated with a program
8522 unit, assign types to all intermediate expressions, make sure that all
8523 assignments are to compatible types and figure out which names refer to
8524 which functions or subroutines. */
8527 gfc_resolve (gfc_namespace *ns)
8529 gfc_namespace *old_ns;
8531 old_ns = gfc_current_ns;
8536 gfc_current_ns = old_ns;