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 3, 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 COPYING3. If not see
20 <http://www.gnu.org/licenses/>. */
28 #include "arith.h" /* For gfc_compare_expr(). */
29 #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 /* Do the same for entries where the master is not a module
435 procedure. These are retained in the module namespace because
436 of the module procedure declaration. */
437 for (el = el->next; el; el = el->next)
438 if (el->sym->ns->proc_name->attr.flavor == FL_MODULE
439 && el->sym->attr.mod_proc)
443 /* Add an entry statement for it. */
450 /* Create a new symbol for the master function. */
451 /* Give the internal function a unique name (within this file).
452 Also include the function name so the user has some hope of figuring
453 out what is going on. */
454 snprintf (name, GFC_MAX_SYMBOL_LEN, "master.%d.%s",
455 master_count++, ns->proc_name->name);
456 gfc_get_ha_symbol (name, &proc);
457 gcc_assert (proc != NULL);
459 gfc_add_procedure (&proc->attr, PROC_INTERNAL, proc->name, NULL);
460 if (ns->proc_name->attr.subroutine)
461 gfc_add_subroutine (&proc->attr, proc->name, NULL);
465 gfc_typespec *ts, *fts;
466 gfc_array_spec *as, *fas;
467 gfc_add_function (&proc->attr, proc->name, NULL);
469 fas = ns->entries->sym->as;
470 fas = fas ? fas : ns->entries->sym->result->as;
471 fts = &ns->entries->sym->result->ts;
472 if (fts->type == BT_UNKNOWN)
473 fts = gfc_get_default_type (ns->entries->sym->result, NULL);
474 for (el = ns->entries->next; el; el = el->next)
476 ts = &el->sym->result->ts;
478 as = as ? as : el->sym->result->as;
479 if (ts->type == BT_UNKNOWN)
480 ts = gfc_get_default_type (el->sym->result, NULL);
482 if (! gfc_compare_types (ts, fts)
483 || (el->sym->result->attr.dimension
484 != ns->entries->sym->result->attr.dimension)
485 || (el->sym->result->attr.pointer
486 != ns->entries->sym->result->attr.pointer))
489 else if (as && fas && gfc_compare_array_spec (as, fas) == 0)
490 gfc_error ("Procedure %s at %L has entries with mismatched "
491 "array specifications", ns->entries->sym->name,
492 &ns->entries->sym->declared_at);
497 sym = ns->entries->sym->result;
498 /* All result types the same. */
500 if (sym->attr.dimension)
501 gfc_set_array_spec (proc, gfc_copy_array_spec (sym->as), NULL);
502 if (sym->attr.pointer)
503 gfc_add_pointer (&proc->attr, NULL);
507 /* Otherwise the result will be passed through a union by
509 proc->attr.mixed_entry_master = 1;
510 for (el = ns->entries; el; el = el->next)
512 sym = el->sym->result;
513 if (sym->attr.dimension)
515 if (el == ns->entries)
516 gfc_error ("FUNCTION result %s can't be an array in "
517 "FUNCTION %s at %L", sym->name,
518 ns->entries->sym->name, &sym->declared_at);
520 gfc_error ("ENTRY result %s can't be an array in "
521 "FUNCTION %s at %L", sym->name,
522 ns->entries->sym->name, &sym->declared_at);
524 else if (sym->attr.pointer)
526 if (el == ns->entries)
527 gfc_error ("FUNCTION result %s can't be a POINTER in "
528 "FUNCTION %s at %L", sym->name,
529 ns->entries->sym->name, &sym->declared_at);
531 gfc_error ("ENTRY result %s can't be a POINTER in "
532 "FUNCTION %s at %L", sym->name,
533 ns->entries->sym->name, &sym->declared_at);
538 if (ts->type == BT_UNKNOWN)
539 ts = gfc_get_default_type (sym, NULL);
543 if (ts->kind == gfc_default_integer_kind)
547 if (ts->kind == gfc_default_real_kind
548 || ts->kind == gfc_default_double_kind)
552 if (ts->kind == gfc_default_complex_kind)
556 if (ts->kind == gfc_default_logical_kind)
560 /* We will issue error elsewhere. */
568 if (el == ns->entries)
569 gfc_error ("FUNCTION result %s can't be of type %s "
570 "in FUNCTION %s at %L", sym->name,
571 gfc_typename (ts), ns->entries->sym->name,
574 gfc_error ("ENTRY result %s can't be of type %s "
575 "in FUNCTION %s at %L", sym->name,
576 gfc_typename (ts), ns->entries->sym->name,
583 proc->attr.access = ACCESS_PRIVATE;
584 proc->attr.entry_master = 1;
586 /* Merge all the entry point arguments. */
587 for (el = ns->entries; el; el = el->next)
588 merge_argument_lists (proc, el->sym->formal);
590 /* Check the master formal arguments for any that are not
591 present in all entry points. */
592 for (el = ns->entries; el; el = el->next)
593 check_argument_lists (proc, el->sym->formal);
595 /* Use the master function for the function body. */
596 ns->proc_name = proc;
598 /* Finalize the new symbols. */
599 gfc_commit_symbols ();
601 /* Restore the original namespace. */
602 gfc_current_ns = old_ns;
607 has_default_initializer (gfc_symbol *der)
611 gcc_assert (der->attr.flavor == FL_DERIVED);
612 for (c = der->components; c; c = c->next)
613 if ((c->ts.type != BT_DERIVED && c->initializer)
614 || (c->ts.type == BT_DERIVED
615 && (!c->pointer && has_default_initializer (c->ts.derived))))
622 /* Resolve common blocks. */
624 resolve_common_blocks (gfc_symtree *common_root)
626 gfc_symbol *sym, *csym;
628 if (common_root == NULL)
631 if (common_root->left)
632 resolve_common_blocks (common_root->left);
633 if (common_root->right)
634 resolve_common_blocks (common_root->right);
636 for (csym = common_root->n.common->head; csym; csym = csym->common_next)
638 if (csym->ts.type != BT_DERIVED)
641 if (!(csym->ts.derived->attr.sequence
642 || csym->ts.derived->attr.is_bind_c))
643 gfc_error_now ("Derived type variable '%s' in COMMON at %L "
644 "has neither the SEQUENCE nor the BIND(C) "
645 "attribute", csym->name, &csym->declared_at);
646 if (csym->ts.derived->attr.alloc_comp)
647 gfc_error_now ("Derived type variable '%s' in COMMON at %L "
648 "has an ultimate component that is "
649 "allocatable", csym->name, &csym->declared_at);
650 if (has_default_initializer (csym->ts.derived))
651 gfc_error_now ("Derived type variable '%s' in COMMON at %L "
652 "may not have default initializer", csym->name,
656 gfc_find_symbol (common_root->name, gfc_current_ns, 0, &sym);
660 if (sym->attr.flavor == FL_PARAMETER)
661 gfc_error ("COMMON block '%s' at %L is used as PARAMETER at %L",
662 sym->name, &common_root->n.common->where, &sym->declared_at);
664 if (sym->attr.intrinsic)
665 gfc_error ("COMMON block '%s' at %L is also an intrinsic procedure",
666 sym->name, &common_root->n.common->where);
667 else if (sym->attr.result
668 ||(sym->attr.function && gfc_current_ns->proc_name == sym))
669 gfc_notify_std (GFC_STD_F2003, "Fortran 2003: COMMON block '%s' at %L "
670 "that is also a function result", sym->name,
671 &common_root->n.common->where);
672 else if (sym->attr.flavor == FL_PROCEDURE && sym->attr.proc != PROC_INTERNAL
673 && sym->attr.proc != PROC_ST_FUNCTION)
674 gfc_notify_std (GFC_STD_F2003, "Fortran 2003: COMMON block '%s' at %L "
675 "that is also a global procedure", sym->name,
676 &common_root->n.common->where);
680 /* Resolve contained function types. Because contained functions can call one
681 another, they have to be worked out before any of the contained procedures
684 The good news is that if a function doesn't already have a type, the only
685 way it can get one is through an IMPLICIT type or a RESULT variable, because
686 by definition contained functions are contained namespace they're contained
687 in, not in a sibling or parent namespace. */
690 resolve_contained_functions (gfc_namespace *ns)
692 gfc_namespace *child;
695 resolve_formal_arglists (ns);
697 for (child = ns->contained; child; child = child->sibling)
699 /* Resolve alternate entry points first. */
700 resolve_entries (child);
702 /* Then check function return types. */
703 resolve_contained_fntype (child->proc_name, child);
704 for (el = child->entries; el; el = el->next)
705 resolve_contained_fntype (el->sym, child);
710 /* Resolve all of the elements of a structure constructor and make sure that
711 the types are correct. */
714 resolve_structure_cons (gfc_expr *expr)
716 gfc_constructor *cons;
722 cons = expr->value.constructor;
723 /* A constructor may have references if it is the result of substituting a
724 parameter variable. In this case we just pull out the component we
727 comp = expr->ref->u.c.sym->components;
729 comp = expr->ts.derived->components;
731 for (; comp; comp = comp->next, cons = cons->next)
736 if (gfc_resolve_expr (cons->expr) == FAILURE)
742 if (cons->expr->expr_type != EXPR_NULL
743 && comp->as && comp->as->rank != cons->expr->rank
744 && (comp->allocatable || cons->expr->rank))
746 gfc_error ("The rank of the element in the derived type "
747 "constructor at %L does not match that of the "
748 "component (%d/%d)", &cons->expr->where,
749 cons->expr->rank, comp->as ? comp->as->rank : 0);
753 /* If we don't have the right type, try to convert it. */
755 if (!gfc_compare_types (&cons->expr->ts, &comp->ts))
758 if (comp->pointer && cons->expr->ts.type != BT_UNKNOWN)
759 gfc_error ("The element in the derived type constructor at %L, "
760 "for pointer component '%s', is %s but should be %s",
761 &cons->expr->where, comp->name,
762 gfc_basic_typename (cons->expr->ts.type),
763 gfc_basic_typename (comp->ts.type));
765 t = gfc_convert_type (cons->expr, &comp->ts, 1);
768 if (!comp->pointer || cons->expr->expr_type == EXPR_NULL)
771 a = gfc_expr_attr (cons->expr);
773 if (!a.pointer && !a.target)
776 gfc_error ("The element in the derived type constructor at %L, "
777 "for pointer component '%s' should be a POINTER or "
778 "a TARGET", &cons->expr->where, comp->name);
786 /****************** Expression name resolution ******************/
788 /* Returns 0 if a symbol was not declared with a type or
789 attribute declaration statement, nonzero otherwise. */
792 was_declared (gfc_symbol *sym)
798 if (!a.implicit_type && sym->ts.type != BT_UNKNOWN)
801 if (a.allocatable || a.dimension || a.dummy || a.external || a.intrinsic
802 || a.optional || a.pointer || a.save || a.target || a.volatile_
803 || a.value || a.access != ACCESS_UNKNOWN || a.intent != INTENT_UNKNOWN)
810 /* Determine if a symbol is generic or not. */
813 generic_sym (gfc_symbol *sym)
817 if (sym->attr.generic ||
818 (sym->attr.intrinsic && gfc_generic_intrinsic (sym->name)))
821 if (was_declared (sym) || sym->ns->parent == NULL)
824 gfc_find_symbol (sym->name, sym->ns->parent, 1, &s);
831 return generic_sym (s);
838 /* Determine if a symbol is specific or not. */
841 specific_sym (gfc_symbol *sym)
845 if (sym->attr.if_source == IFSRC_IFBODY
846 || sym->attr.proc == PROC_MODULE
847 || sym->attr.proc == PROC_INTERNAL
848 || sym->attr.proc == PROC_ST_FUNCTION
849 || (sym->attr.intrinsic && gfc_specific_intrinsic (sym->name))
850 || sym->attr.external)
853 if (was_declared (sym) || sym->ns->parent == NULL)
856 gfc_find_symbol (sym->name, sym->ns->parent, 1, &s);
858 return (s == NULL) ? 0 : specific_sym (s);
862 /* Figure out if the procedure is specific, generic or unknown. */
865 { PTYPE_GENERIC = 1, PTYPE_SPECIFIC, PTYPE_UNKNOWN }
869 procedure_kind (gfc_symbol *sym)
871 if (generic_sym (sym))
872 return PTYPE_GENERIC;
874 if (specific_sym (sym))
875 return PTYPE_SPECIFIC;
877 return PTYPE_UNKNOWN;
880 /* Check references to assumed size arrays. The flag need_full_assumed_size
881 is nonzero when matching actual arguments. */
883 static int need_full_assumed_size = 0;
886 check_assumed_size_reference (gfc_symbol *sym, gfc_expr *e)
892 if (need_full_assumed_size || !(sym->as && sym->as->type == AS_ASSUMED_SIZE))
895 for (ref = e->ref; ref; ref = ref->next)
896 if (ref->type == REF_ARRAY)
897 for (dim = 0; dim < ref->u.ar.as->rank; dim++)
898 last = (ref->u.ar.end[dim] == NULL)
899 && (ref->u.ar.type == DIMEN_ELEMENT);
903 gfc_error ("The upper bound in the last dimension must "
904 "appear in the reference to the assumed size "
905 "array '%s' at %L", sym->name, &e->where);
912 /* Look for bad assumed size array references in argument expressions
913 of elemental and array valued intrinsic procedures. Since this is
914 called from procedure resolution functions, it only recurses at
918 resolve_assumed_size_actual (gfc_expr *e)
923 switch (e->expr_type)
926 if (e->symtree && check_assumed_size_reference (e->symtree->n.sym, e))
931 if (resolve_assumed_size_actual (e->value.op.op1)
932 || resolve_assumed_size_actual (e->value.op.op2))
943 /* Resolve an actual argument list. Most of the time, this is just
944 resolving the expressions in the list.
945 The exception is that we sometimes have to decide whether arguments
946 that look like procedure arguments are really simple variable
950 resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype)
953 gfc_symtree *parent_st;
956 for (; arg; arg = arg->next)
961 /* Check the label is a valid branching target. */
964 if (arg->label->defined == ST_LABEL_UNKNOWN)
966 gfc_error ("Label %d referenced at %L is never defined",
967 arg->label->value, &arg->label->where);
974 if (e->expr_type == FL_VARIABLE && e->symtree->ambiguous)
976 gfc_error ("'%s' at %L is ambiguous", e->symtree->n.sym->name,
981 if (e->ts.type != BT_PROCEDURE)
983 if (gfc_resolve_expr (e) != SUCCESS)
988 /* See if the expression node should really be a variable reference. */
990 sym = e->symtree->n.sym;
992 if (sym->attr.flavor == FL_PROCEDURE
993 || sym->attr.intrinsic
994 || sym->attr.external)
998 /* If a procedure is not already determined to be something else
999 check if it is intrinsic. */
1000 if (!sym->attr.intrinsic
1001 && !(sym->attr.external || sym->attr.use_assoc
1002 || sym->attr.if_source == IFSRC_IFBODY)
1003 && gfc_intrinsic_name (sym->name, sym->attr.subroutine))
1004 sym->attr.intrinsic = 1;
1006 if (sym->attr.proc == PROC_ST_FUNCTION)
1008 gfc_error ("Statement function '%s' at %L is not allowed as an "
1009 "actual argument", sym->name, &e->where);
1012 actual_ok = gfc_intrinsic_actual_ok (sym->name,
1013 sym->attr.subroutine);
1014 if (sym->attr.intrinsic && actual_ok == 0)
1016 gfc_error ("Intrinsic '%s' at %L is not allowed as an "
1017 "actual argument", sym->name, &e->where);
1020 if (sym->attr.contained && !sym->attr.use_assoc
1021 && sym->ns->proc_name->attr.flavor != FL_MODULE)
1023 gfc_error ("Internal procedure '%s' is not allowed as an "
1024 "actual argument at %L", sym->name, &e->where);
1027 if (sym->attr.elemental && !sym->attr.intrinsic)
1029 gfc_error ("ELEMENTAL non-INTRINSIC procedure '%s' is not "
1030 "allowed as an actual argument at %L", sym->name,
1034 /* Check if a generic interface has a specific procedure
1035 with the same name before emitting an error. */
1036 if (sym->attr.generic)
1039 for (p = sym->generic; p; p = p->next)
1040 if (strcmp (sym->name, p->sym->name) == 0)
1042 e->symtree = gfc_find_symtree
1043 (p->sym->ns->sym_root, sym->name);
1048 if (p == NULL || e->symtree == NULL)
1049 gfc_error ("GENERIC non-INTRINSIC procedure '%s' is not "
1050 "allowed as an actual argument at %L", sym->name,
1054 /* If the symbol is the function that names the current (or
1055 parent) scope, then we really have a variable reference. */
1057 if (sym->attr.function && sym->result == sym
1058 && (sym->ns->proc_name == sym
1059 || (sym->ns->parent != NULL
1060 && sym->ns->parent->proc_name == sym)))
1063 /* If all else fails, see if we have a specific intrinsic. */
1064 if (sym->attr.function
1065 && sym->ts.type == BT_UNKNOWN && sym->attr.intrinsic)
1067 gfc_intrinsic_sym *isym;
1068 isym = gfc_find_function (sym->name);
1069 if (isym == NULL || !isym->specific)
1071 gfc_error ("Unable to find a specific INTRINSIC procedure "
1072 "for the reference '%s' at %L", sym->name,
1080 /* See if the name is a module procedure in a parent unit. */
1082 if (was_declared (sym) || sym->ns->parent == NULL)
1085 if (gfc_find_sym_tree (sym->name, sym->ns->parent, 1, &parent_st))
1087 gfc_error ("Symbol '%s' at %L is ambiguous", sym->name, &e->where);
1091 if (parent_st == NULL)
1094 sym = parent_st->n.sym;
1095 e->symtree = parent_st; /* Point to the right thing. */
1097 if (sym->attr.flavor == FL_PROCEDURE
1098 || sym->attr.intrinsic
1099 || sym->attr.external)
1105 e->expr_type = EXPR_VARIABLE;
1107 if (sym->as != NULL)
1109 e->rank = sym->as->rank;
1110 e->ref = gfc_get_ref ();
1111 e->ref->type = REF_ARRAY;
1112 e->ref->u.ar.type = AR_FULL;
1113 e->ref->u.ar.as = sym->as;
1116 /* Expressions are assigned a default ts.type of BT_PROCEDURE in
1117 primary.c (match_actual_arg). If above code determines that it
1118 is a variable instead, it needs to be resolved as it was not
1119 done at the beginning of this function. */
1120 if (gfc_resolve_expr (e) != SUCCESS)
1124 /* Check argument list functions %VAL, %LOC and %REF. There is
1125 nothing to do for %REF. */
1126 if (arg->name && arg->name[0] == '%')
1128 if (strncmp ("%VAL", arg->name, 4) == 0)
1130 if (e->ts.type == BT_CHARACTER || e->ts.type == BT_DERIVED)
1132 gfc_error ("By-value argument at %L is not of numeric "
1139 gfc_error ("By-value argument at %L cannot be an array or "
1140 "an array section", &e->where);
1144 /* Intrinsics are still PROC_UNKNOWN here. However,
1145 since same file external procedures are not resolvable
1146 in gfortran, it is a good deal easier to leave them to
1148 if (ptype != PROC_UNKNOWN
1149 && ptype != PROC_DUMMY
1150 && ptype != PROC_EXTERNAL
1151 && ptype != PROC_MODULE)
1153 gfc_error ("By-value argument at %L is not allowed "
1154 "in this context", &e->where);
1159 /* Statement functions have already been excluded above. */
1160 else if (strncmp ("%LOC", arg->name, 4) == 0
1161 && e->ts.type == BT_PROCEDURE)
1163 if (e->symtree->n.sym->attr.proc == PROC_INTERNAL)
1165 gfc_error ("Passing internal procedure at %L by location "
1166 "not allowed", &e->where);
1177 /* Do the checks of the actual argument list that are specific to elemental
1178 procedures. If called with c == NULL, we have a function, otherwise if
1179 expr == NULL, we have a subroutine. */
1182 resolve_elemental_actual (gfc_expr *expr, gfc_code *c)
1184 gfc_actual_arglist *arg0;
1185 gfc_actual_arglist *arg;
1186 gfc_symbol *esym = NULL;
1187 gfc_intrinsic_sym *isym = NULL;
1189 gfc_intrinsic_arg *iformal = NULL;
1190 gfc_formal_arglist *eformal = NULL;
1191 bool formal_optional = false;
1192 bool set_by_optional = false;
1196 /* Is this an elemental procedure? */
1197 if (expr && expr->value.function.actual != NULL)
1199 if (expr->value.function.esym != NULL
1200 && expr->value.function.esym->attr.elemental)
1202 arg0 = expr->value.function.actual;
1203 esym = expr->value.function.esym;
1205 else if (expr->value.function.isym != NULL
1206 && expr->value.function.isym->elemental)
1208 arg0 = expr->value.function.actual;
1209 isym = expr->value.function.isym;
1214 else if (c && c->ext.actual != NULL && c->symtree->n.sym->attr.elemental)
1216 arg0 = c->ext.actual;
1217 esym = c->symtree->n.sym;
1222 /* The rank of an elemental is the rank of its array argument(s). */
1223 for (arg = arg0; arg; arg = arg->next)
1225 if (arg->expr != NULL && arg->expr->rank > 0)
1227 rank = arg->expr->rank;
1228 if (arg->expr->expr_type == EXPR_VARIABLE
1229 && arg->expr->symtree->n.sym->attr.optional)
1230 set_by_optional = true;
1232 /* Function specific; set the result rank and shape. */
1236 if (!expr->shape && arg->expr->shape)
1238 expr->shape = gfc_get_shape (rank);
1239 for (i = 0; i < rank; i++)
1240 mpz_init_set (expr->shape[i], arg->expr->shape[i]);
1247 /* If it is an array, it shall not be supplied as an actual argument
1248 to an elemental procedure unless an array of the same rank is supplied
1249 as an actual argument corresponding to a nonoptional dummy argument of
1250 that elemental procedure(12.4.1.5). */
1251 formal_optional = false;
1253 iformal = isym->formal;
1255 eformal = esym->formal;
1257 for (arg = arg0; arg; arg = arg->next)
1261 if (eformal->sym && eformal->sym->attr.optional)
1262 formal_optional = true;
1263 eformal = eformal->next;
1265 else if (isym && iformal)
1267 if (iformal->optional)
1268 formal_optional = true;
1269 iformal = iformal->next;
1272 formal_optional = true;
1274 if (pedantic && arg->expr != NULL
1275 && arg->expr->expr_type == EXPR_VARIABLE
1276 && arg->expr->symtree->n.sym->attr.optional
1279 && (set_by_optional || arg->expr->rank != rank)
1280 && !(isym && isym->id == GFC_ISYM_CONVERSION))
1282 gfc_warning ("'%s' at %L is an array and OPTIONAL; IF IT IS "
1283 "MISSING, it cannot be the actual argument of an "
1284 "ELEMENTAL procedure unless there is a non-optional "
1285 "argument with the same rank (12.4.1.5)",
1286 arg->expr->symtree->n.sym->name, &arg->expr->where);
1291 for (arg = arg0; arg; arg = arg->next)
1293 if (arg->expr == NULL || arg->expr->rank == 0)
1296 /* Being elemental, the last upper bound of an assumed size array
1297 argument must be present. */
1298 if (resolve_assumed_size_actual (arg->expr))
1301 /* Elemental procedure's array actual arguments must conform. */
1304 if (gfc_check_conformance ("elemental procedure", arg->expr, e)
1312 /* INTENT(OUT) is only allowed for subroutines; if any actual argument
1313 is an array, the intent inout/out variable needs to be also an array. */
1314 if (rank > 0 && esym && expr == NULL)
1315 for (eformal = esym->formal, arg = arg0; arg && eformal;
1316 arg = arg->next, eformal = eformal->next)
1317 if ((eformal->sym->attr.intent == INTENT_OUT
1318 || eformal->sym->attr.intent == INTENT_INOUT)
1319 && arg->expr && arg->expr->rank == 0)
1321 gfc_error ("Actual argument at %L for INTENT(%s) dummy '%s' of "
1322 "ELEMENTAL subroutine '%s' is a scalar, but another "
1323 "actual argument is an array", &arg->expr->where,
1324 (eformal->sym->attr.intent == INTENT_OUT) ? "OUT"
1325 : "INOUT", eformal->sym->name, esym->name);
1332 /* Go through each actual argument in ACTUAL and see if it can be
1333 implemented as an inlined, non-copying intrinsic. FNSYM is the
1334 function being called, or NULL if not known. */
1337 find_noncopying_intrinsics (gfc_symbol *fnsym, gfc_actual_arglist *actual)
1339 gfc_actual_arglist *ap;
1342 for (ap = actual; ap; ap = ap->next)
1344 && (expr = gfc_get_noncopying_intrinsic_argument (ap->expr))
1345 && !gfc_check_fncall_dependency (expr, INTENT_IN, fnsym, actual))
1346 ap->expr->inline_noncopying_intrinsic = 1;
1350 /* This function does the checking of references to global procedures
1351 as defined in sections 18.1 and 14.1, respectively, of the Fortran
1352 77 and 95 standards. It checks for a gsymbol for the name, making
1353 one if it does not already exist. If it already exists, then the
1354 reference being resolved must correspond to the type of gsymbol.
1355 Otherwise, the new symbol is equipped with the attributes of the
1356 reference. The corresponding code that is called in creating
1357 global entities is parse.c. */
1360 resolve_global_procedure (gfc_symbol *sym, locus *where, int sub)
1365 type = sub ? GSYM_SUBROUTINE : GSYM_FUNCTION;
1367 gsym = gfc_get_gsymbol (sym->name);
1369 if ((gsym->type != GSYM_UNKNOWN && gsym->type != type))
1370 gfc_global_used (gsym, where);
1372 if (gsym->type == GSYM_UNKNOWN)
1375 gsym->where = *where;
1382 /************* Function resolution *************/
1384 /* Resolve a function call known to be generic.
1385 Section 14.1.2.4.1. */
1388 resolve_generic_f0 (gfc_expr *expr, gfc_symbol *sym)
1392 if (sym->attr.generic)
1394 s = gfc_search_interface (sym->generic, 0, &expr->value.function.actual);
1397 expr->value.function.name = s->name;
1398 expr->value.function.esym = s;
1400 if (s->ts.type != BT_UNKNOWN)
1402 else if (s->result != NULL && s->result->ts.type != BT_UNKNOWN)
1403 expr->ts = s->result->ts;
1406 expr->rank = s->as->rank;
1407 else if (s->result != NULL && s->result->as != NULL)
1408 expr->rank = s->result->as->rank;
1413 /* TODO: Need to search for elemental references in generic
1417 if (sym->attr.intrinsic)
1418 return gfc_intrinsic_func_interface (expr, 0);
1425 resolve_generic_f (gfc_expr *expr)
1430 sym = expr->symtree->n.sym;
1434 m = resolve_generic_f0 (expr, sym);
1437 else if (m == MATCH_ERROR)
1441 if (sym->ns->parent == NULL)
1443 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
1447 if (!generic_sym (sym))
1451 /* Last ditch attempt. See if the reference is to an intrinsic
1452 that possesses a matching interface. 14.1.2.4 */
1453 if (sym && !gfc_intrinsic_name (sym->name, 0))
1455 gfc_error ("There is no specific function for the generic '%s' at %L",
1456 expr->symtree->n.sym->name, &expr->where);
1460 m = gfc_intrinsic_func_interface (expr, 0);
1464 gfc_error ("Generic function '%s' at %L is not consistent with a "
1465 "specific intrinsic interface", expr->symtree->n.sym->name,
1472 /* Resolve a function call known to be specific. */
1475 resolve_specific_f0 (gfc_symbol *sym, gfc_expr *expr)
1479 if (sym->attr.external || sym->attr.if_source == IFSRC_IFBODY)
1481 if (sym->attr.dummy)
1483 sym->attr.proc = PROC_DUMMY;
1487 sym->attr.proc = PROC_EXTERNAL;
1491 if (sym->attr.proc == PROC_MODULE
1492 || sym->attr.proc == PROC_ST_FUNCTION
1493 || sym->attr.proc == PROC_INTERNAL)
1496 if (sym->attr.intrinsic)
1498 m = gfc_intrinsic_func_interface (expr, 1);
1502 gfc_error ("Function '%s' at %L is INTRINSIC but is not compatible "
1503 "with an intrinsic", sym->name, &expr->where);
1511 gfc_procedure_use (sym, &expr->value.function.actual, &expr->where);
1514 expr->value.function.name = sym->name;
1515 expr->value.function.esym = sym;
1516 if (sym->as != NULL)
1517 expr->rank = sym->as->rank;
1524 resolve_specific_f (gfc_expr *expr)
1529 sym = expr->symtree->n.sym;
1533 m = resolve_specific_f0 (sym, expr);
1536 if (m == MATCH_ERROR)
1539 if (sym->ns->parent == NULL)
1542 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
1548 gfc_error ("Unable to resolve the specific function '%s' at %L",
1549 expr->symtree->n.sym->name, &expr->where);
1555 /* Resolve a procedure call not known to be generic nor specific. */
1558 resolve_unknown_f (gfc_expr *expr)
1563 sym = expr->symtree->n.sym;
1565 if (sym->attr.dummy)
1567 sym->attr.proc = PROC_DUMMY;
1568 expr->value.function.name = sym->name;
1572 /* See if we have an intrinsic function reference. */
1574 if (gfc_intrinsic_name (sym->name, 0))
1576 if (gfc_intrinsic_func_interface (expr, 1) == MATCH_YES)
1581 /* The reference is to an external name. */
1583 sym->attr.proc = PROC_EXTERNAL;
1584 expr->value.function.name = sym->name;
1585 expr->value.function.esym = expr->symtree->n.sym;
1587 if (sym->as != NULL)
1588 expr->rank = sym->as->rank;
1590 /* Type of the expression is either the type of the symbol or the
1591 default type of the symbol. */
1594 gfc_procedure_use (sym, &expr->value.function.actual, &expr->where);
1596 if (sym->ts.type != BT_UNKNOWN)
1600 ts = gfc_get_default_type (sym, sym->ns);
1602 if (ts->type == BT_UNKNOWN)
1604 gfc_error ("Function '%s' at %L has no IMPLICIT type",
1605 sym->name, &expr->where);
1616 /* Return true, if the symbol is an external procedure. */
1618 is_external_proc (gfc_symbol *sym)
1620 if (!sym->attr.dummy && !sym->attr.contained
1621 && !(sym->attr.intrinsic
1622 || gfc_intrinsic_name (sym->name, sym->attr.subroutine))
1623 && sym->attr.proc != PROC_ST_FUNCTION
1624 && !sym->attr.use_assoc
1632 /* Figure out if a function reference is pure or not. Also set the name
1633 of the function for a potential error message. Return nonzero if the
1634 function is PURE, zero if not. */
1637 pure_function (gfc_expr *e, const char **name)
1643 if (e->symtree != NULL
1644 && e->symtree->n.sym != NULL
1645 && e->symtree->n.sym->attr.proc == PROC_ST_FUNCTION)
1648 if (e->value.function.esym)
1650 pure = gfc_pure (e->value.function.esym);
1651 *name = e->value.function.esym->name;
1653 else if (e->value.function.isym)
1655 pure = e->value.function.isym->pure
1656 || e->value.function.isym->elemental;
1657 *name = e->value.function.isym->name;
1661 /* Implicit functions are not pure. */
1663 *name = e->value.function.name;
1671 is_scalar_expr_ptr (gfc_expr *expr)
1673 try retval = SUCCESS;
1678 /* See if we have a gfc_ref, which means we have a substring, array
1679 reference, or a component. */
1680 if (expr->ref != NULL)
1683 while (ref->next != NULL)
1689 if (ref->u.ss.length != NULL
1690 && ref->u.ss.length->length != NULL
1692 && ref->u.ss.start->expr_type == EXPR_CONSTANT
1694 && ref->u.ss.end->expr_type == EXPR_CONSTANT)
1696 start = (int) mpz_get_si (ref->u.ss.start->value.integer);
1697 end = (int) mpz_get_si (ref->u.ss.end->value.integer);
1698 if (end - start + 1 != 1)
1705 if (ref->u.ar.type == AR_ELEMENT)
1707 else if (ref->u.ar.type == AR_FULL)
1709 /* The user can give a full array if the array is of size 1. */
1710 if (ref->u.ar.as != NULL
1711 && ref->u.ar.as->rank == 1
1712 && ref->u.ar.as->type == AS_EXPLICIT
1713 && ref->u.ar.as->lower[0] != NULL
1714 && ref->u.ar.as->lower[0]->expr_type == EXPR_CONSTANT
1715 && ref->u.ar.as->upper[0] != NULL
1716 && ref->u.ar.as->upper[0]->expr_type == EXPR_CONSTANT)
1718 /* If we have a character string, we need to check if
1719 its length is one. */
1720 if (expr->ts.type == BT_CHARACTER)
1722 if (expr->ts.cl == NULL
1723 || expr->ts.cl->length == NULL
1724 || mpz_cmp_si (expr->ts.cl->length->value.integer, 1)
1730 /* We have constant lower and upper bounds. If the
1731 difference between is 1, it can be considered a
1733 start = (int) mpz_get_si
1734 (ref->u.ar.as->lower[0]->value.integer);
1735 end = (int) mpz_get_si
1736 (ref->u.ar.as->upper[0]->value.integer);
1737 if (end - start + 1 != 1)
1752 else if (expr->ts.type == BT_CHARACTER && expr->rank == 0)
1754 /* Character string. Make sure it's of length 1. */
1755 if (expr->ts.cl == NULL
1756 || expr->ts.cl->length == NULL
1757 || mpz_cmp_si (expr->ts.cl->length->value.integer, 1) != 0)
1760 else if (expr->rank != 0)
1767 /* Match one of the iso_c_binding functions (c_associated or c_loc)
1768 and, in the case of c_associated, set the binding label based on
1772 gfc_iso_c_func_interface (gfc_symbol *sym, gfc_actual_arglist *args,
1773 gfc_symbol **new_sym)
1775 char name[GFC_MAX_SYMBOL_LEN + 1];
1776 char binding_label[GFC_MAX_BINDING_LABEL_LEN + 1];
1777 int optional_arg = 0;
1778 try retval = SUCCESS;
1779 gfc_symbol *args_sym;
1780 gfc_typespec *arg_ts;
1781 gfc_ref *parent_ref;
1784 if (args->expr->expr_type == EXPR_CONSTANT
1785 || args->expr->expr_type == EXPR_OP
1786 || args->expr->expr_type == EXPR_NULL)
1788 gfc_error ("Argument to '%s' at %L is not a variable",
1789 sym->name, &(args->expr->where));
1793 args_sym = args->expr->symtree->n.sym;
1795 /* The typespec for the actual arg should be that stored in the expr
1796 and not necessarily that of the expr symbol (args_sym), because
1797 the actual expression could be a part-ref of the expr symbol. */
1798 arg_ts = &(args->expr->ts);
1800 /* Get the parent reference (if any) for the expression. This happens for
1801 cases such as a%b%c. */
1802 parent_ref = args->expr->ref;
1804 if (parent_ref != NULL)
1806 curr_ref = parent_ref->next;
1807 while (curr_ref != NULL && curr_ref->next != NULL)
1809 parent_ref = curr_ref;
1810 curr_ref = curr_ref->next;
1814 /* If curr_ref is non-NULL, we had a part-ref expression. If the curr_ref
1815 is for a REF_COMPONENT, then we need to use it as the parent_ref for
1816 the name, etc. Otherwise, the current parent_ref should be correct. */
1817 if (curr_ref != NULL && curr_ref->type == REF_COMPONENT)
1818 parent_ref = curr_ref;
1820 if (parent_ref == args->expr->ref)
1822 else if (parent_ref != NULL && parent_ref->type != REF_COMPONENT)
1823 gfc_internal_error ("Unexpected expression reference type in "
1824 "gfc_iso_c_func_interface");
1826 if (sym->intmod_sym_id == ISOCBINDING_ASSOCIATED)
1828 /* If the user gave two args then they are providing something for
1829 the optional arg (the second cptr). Therefore, set the name and
1830 binding label to the c_associated for two cptrs. Otherwise,
1831 set c_associated to expect one cptr. */
1835 sprintf (name, "%s_2", sym->name);
1836 sprintf (binding_label, "%s_2", sym->binding_label);
1842 sprintf (name, "%s_1", sym->name);
1843 sprintf (binding_label, "%s_1", sym->binding_label);
1847 /* Get a new symbol for the version of c_associated that
1849 *new_sym = get_iso_c_sym (sym, name, binding_label, optional_arg);
1851 else if (sym->intmod_sym_id == ISOCBINDING_LOC
1852 || sym->intmod_sym_id == ISOCBINDING_FUNLOC)
1854 sprintf (name, "%s", sym->name);
1855 sprintf (binding_label, "%s", sym->binding_label);
1857 /* Error check the call. */
1858 if (args->next != NULL)
1860 gfc_error_now ("More actual than formal arguments in '%s' "
1861 "call at %L", name, &(args->expr->where));
1864 else if (sym->intmod_sym_id == ISOCBINDING_LOC)
1866 /* Make sure we have either the target or pointer attribute. */
1867 if (!(args_sym->attr.target)
1868 && !(args_sym->attr.pointer)
1869 && (parent_ref == NULL ||
1870 !parent_ref->u.c.component->pointer))
1872 gfc_error_now ("Parameter '%s' to '%s' at %L must be either "
1873 "a TARGET or an associated pointer",
1875 sym->name, &(args->expr->where));
1879 /* See if we have interoperable type and type param. */
1880 if (verify_c_interop (arg_ts,
1881 (parent_ref ? parent_ref->u.c.component->name
1883 &(args->expr->where)) == SUCCESS
1884 || gfc_check_any_c_kind (arg_ts) == SUCCESS)
1886 if (args_sym->attr.target == 1)
1888 /* Case 1a, section 15.1.2.5, J3/04-007: variable that
1889 has the target attribute and is interoperable. */
1890 /* Case 1b, section 15.1.2.5, J3/04-007: allocated
1891 allocatable variable that has the TARGET attribute and
1892 is not an array of zero size. */
1893 if (args_sym->attr.allocatable == 1)
1895 if (args_sym->attr.dimension != 0
1896 && (args_sym->as && args_sym->as->rank == 0))
1898 gfc_error_now ("Allocatable variable '%s' used as a "
1899 "parameter to '%s' at %L must not be "
1900 "an array of zero size",
1901 args_sym->name, sym->name,
1902 &(args->expr->where));
1908 /* A non-allocatable target variable with C
1909 interoperable type and type parameters must be
1911 if (args_sym && args_sym->attr.dimension)
1913 if (args_sym->as->type == AS_ASSUMED_SHAPE)
1915 gfc_error ("Assumed-shape array '%s' at %L "
1916 "cannot be an argument to the "
1917 "procedure '%s' because "
1918 "it is not C interoperable",
1920 &(args->expr->where), sym->name);
1923 else if (args_sym->as->type == AS_DEFERRED)
1925 gfc_error ("Deferred-shape array '%s' at %L "
1926 "cannot be an argument to the "
1927 "procedure '%s' because "
1928 "it is not C interoperable",
1930 &(args->expr->where), sym->name);
1935 /* Make sure it's not a character string. Arrays of
1936 any type should be ok if the variable is of a C
1937 interoperable type. */
1938 if (arg_ts->type == BT_CHARACTER)
1939 if (arg_ts->cl != NULL
1940 && (arg_ts->cl->length == NULL
1941 || arg_ts->cl->length->expr_type
1944 (arg_ts->cl->length->value.integer, 1)
1946 && is_scalar_expr_ptr (args->expr) != SUCCESS)
1948 gfc_error_now ("CHARACTER argument '%s' to '%s' "
1949 "at %L must have a length of 1",
1950 args_sym->name, sym->name,
1951 &(args->expr->where));
1956 else if ((args_sym->attr.pointer == 1 ||
1958 && parent_ref->u.c.component->pointer))
1959 && is_scalar_expr_ptr (args->expr) != SUCCESS)
1961 /* Case 1c, section 15.1.2.5, J3/04-007: an associated
1963 gfc_error_now ("Argument '%s' to '%s' at %L must be an "
1964 "associated scalar POINTER", args_sym->name,
1965 sym->name, &(args->expr->where));
1971 /* The parameter is not required to be C interoperable. If it
1972 is not C interoperable, it must be a nonpolymorphic scalar
1973 with no length type parameters. It still must have either
1974 the pointer or target attribute, and it can be
1975 allocatable (but must be allocated when c_loc is called). */
1976 if (args->expr->rank != 0
1977 && is_scalar_expr_ptr (args->expr) != SUCCESS)
1979 gfc_error_now ("Parameter '%s' to '%s' at %L must be a "
1980 "scalar", args_sym->name, sym->name,
1981 &(args->expr->where));
1984 else if (arg_ts->type == BT_CHARACTER
1985 && is_scalar_expr_ptr (args->expr) != SUCCESS)
1987 gfc_error_now ("CHARACTER argument '%s' to '%s' at "
1988 "%L must have a length of 1",
1989 args_sym->name, sym->name,
1990 &(args->expr->where));
1995 else if (sym->intmod_sym_id == ISOCBINDING_FUNLOC)
1997 if (args_sym->attr.flavor != FL_PROCEDURE)
1999 /* TODO: Update this error message to allow for procedure
2000 pointers once they are implemented. */
2001 gfc_error_now ("Parameter '%s' to '%s' at %L must be a "
2003 args_sym->name, sym->name,
2004 &(args->expr->where));
2007 else if (args_sym->attr.is_bind_c != 1)
2009 gfc_error_now ("Parameter '%s' to '%s' at %L must be "
2011 args_sym->name, sym->name,
2012 &(args->expr->where));
2017 /* for c_loc/c_funloc, the new symbol is the same as the old one */
2022 gfc_internal_error ("gfc_iso_c_func_interface(): Unhandled "
2023 "iso_c_binding function: '%s'!\n", sym->name);
2030 /* Resolve a function call, which means resolving the arguments, then figuring
2031 out which entity the name refers to. */
2032 /* TODO: Check procedure arguments so that an INTENT(IN) isn't passed
2033 to INTENT(OUT) or INTENT(INOUT). */
2036 resolve_function (gfc_expr *expr)
2038 gfc_actual_arglist *arg;
2043 procedure_type p = PROC_INTRINSIC;
2047 sym = expr->symtree->n.sym;
2049 if (sym && sym->attr.flavor == FL_VARIABLE)
2051 gfc_error ("'%s' at %L is not a function", sym->name, &expr->where);
2055 if (sym && sym->attr.abstract)
2057 gfc_error ("ABSTRACT INTERFACE '%s' must not be referenced at %L",
2058 sym->name, &expr->where);
2062 /* If the procedure is external, check for usage. */
2063 if (sym && is_external_proc (sym))
2064 resolve_global_procedure (sym, &expr->where, 0);
2066 /* Switch off assumed size checking and do this again for certain kinds
2067 of procedure, once the procedure itself is resolved. */
2068 need_full_assumed_size++;
2070 if (expr->symtree && expr->symtree->n.sym)
2071 p = expr->symtree->n.sym->attr.proc;
2073 if (resolve_actual_arglist (expr->value.function.actual, p) == FAILURE)
2076 /* Need to setup the call to the correct c_associated, depending on
2077 the number of cptrs to user gives to compare. */
2078 if (sym && sym->attr.is_iso_c == 1)
2080 if (gfc_iso_c_func_interface (sym, expr->value.function.actual, &sym)
2084 /* Get the symtree for the new symbol (resolved func).
2085 the old one will be freed later, when it's no longer used. */
2086 gfc_find_sym_tree (sym->name, sym->ns, 1, &(expr->symtree));
2089 /* Resume assumed_size checking. */
2090 need_full_assumed_size--;
2092 if (sym && sym->ts.type == BT_CHARACTER
2094 && sym->ts.cl->length == NULL
2096 && expr->value.function.esym == NULL
2097 && !sym->attr.contained)
2099 /* Internal procedures are taken care of in resolve_contained_fntype. */
2100 gfc_error ("Function '%s' is declared CHARACTER(*) and cannot "
2101 "be used at %L since it is not a dummy argument",
2102 sym->name, &expr->where);
2106 /* See if function is already resolved. */
2108 if (expr->value.function.name != NULL)
2110 if (expr->ts.type == BT_UNKNOWN)
2116 /* Apply the rules of section 14.1.2. */
2118 switch (procedure_kind (sym))
2121 t = resolve_generic_f (expr);
2124 case PTYPE_SPECIFIC:
2125 t = resolve_specific_f (expr);
2129 t = resolve_unknown_f (expr);
2133 gfc_internal_error ("resolve_function(): bad function type");
2137 /* If the expression is still a function (it might have simplified),
2138 then we check to see if we are calling an elemental function. */
2140 if (expr->expr_type != EXPR_FUNCTION)
2143 temp = need_full_assumed_size;
2144 need_full_assumed_size = 0;
2146 if (resolve_elemental_actual (expr, NULL) == FAILURE)
2149 if (omp_workshare_flag
2150 && expr->value.function.esym
2151 && ! gfc_elemental (expr->value.function.esym))
2153 gfc_error ("User defined non-ELEMENTAL function '%s' at %L not allowed "
2154 "in WORKSHARE construct", expr->value.function.esym->name,
2159 #define GENERIC_ID expr->value.function.isym->id
2160 else if (expr->value.function.actual != NULL
2161 && expr->value.function.isym != NULL
2162 && GENERIC_ID != GFC_ISYM_LBOUND
2163 && GENERIC_ID != GFC_ISYM_LEN
2164 && GENERIC_ID != GFC_ISYM_LOC
2165 && GENERIC_ID != GFC_ISYM_PRESENT)
2167 /* Array intrinsics must also have the last upper bound of an
2168 assumed size array argument. UBOUND and SIZE have to be
2169 excluded from the check if the second argument is anything
2172 inquiry = GENERIC_ID == GFC_ISYM_UBOUND
2173 || GENERIC_ID == GFC_ISYM_SIZE;
2175 for (arg = expr->value.function.actual; arg; arg = arg->next)
2177 if (inquiry && arg->next != NULL && arg->next->expr)
2179 if (arg->next->expr->expr_type != EXPR_CONSTANT)
2182 if ((int)mpz_get_si (arg->next->expr->value.integer)
2187 if (arg->expr != NULL
2188 && arg->expr->rank > 0
2189 && resolve_assumed_size_actual (arg->expr))
2195 need_full_assumed_size = temp;
2198 if (!pure_function (expr, &name) && name)
2202 gfc_error ("reference to non-PURE function '%s' at %L inside a "
2203 "FORALL %s", name, &expr->where,
2204 forall_flag == 2 ? "mask" : "block");
2207 else if (gfc_pure (NULL))
2209 gfc_error ("Function reference to '%s' at %L is to a non-PURE "
2210 "procedure within a PURE procedure", name, &expr->where);
2215 /* Functions without the RECURSIVE attribution are not allowed to
2216 * call themselves. */
2217 if (expr->value.function.esym && !expr->value.function.esym->attr.recursive)
2219 gfc_symbol *esym, *proc;
2220 esym = expr->value.function.esym;
2221 proc = gfc_current_ns->proc_name;
2224 gfc_error ("Function '%s' at %L cannot call itself, as it is not "
2225 "RECURSIVE", name, &expr->where);
2229 if (esym->attr.entry && esym->ns->entries && proc->ns->entries
2230 && esym->ns->entries->sym == proc->ns->entries->sym)
2232 gfc_error ("Call to ENTRY '%s' at %L is recursive, but function "
2233 "'%s' is not declared as RECURSIVE",
2234 esym->name, &expr->where, esym->ns->entries->sym->name);
2239 /* Character lengths of use associated functions may contains references to
2240 symbols not referenced from the current program unit otherwise. Make sure
2241 those symbols are marked as referenced. */
2243 if (expr->ts.type == BT_CHARACTER && expr->value.function.esym
2244 && expr->value.function.esym->attr.use_assoc)
2246 gfc_expr_set_symbols_referenced (expr->ts.cl->length);
2250 find_noncopying_intrinsics (expr->value.function.esym,
2251 expr->value.function.actual);
2253 /* Make sure that the expression has a typespec that works. */
2254 if (expr->ts.type == BT_UNKNOWN)
2256 if (expr->symtree->n.sym->result
2257 && expr->symtree->n.sym->result->ts.type != BT_UNKNOWN)
2258 expr->ts = expr->symtree->n.sym->result->ts;
2265 /************* Subroutine resolution *************/
2268 pure_subroutine (gfc_code *c, gfc_symbol *sym)
2274 gfc_error ("Subroutine call to '%s' in FORALL block at %L is not PURE",
2275 sym->name, &c->loc);
2276 else if (gfc_pure (NULL))
2277 gfc_error ("Subroutine call to '%s' at %L is not PURE", sym->name,
2283 resolve_generic_s0 (gfc_code *c, gfc_symbol *sym)
2287 if (sym->attr.generic)
2289 s = gfc_search_interface (sym->generic, 1, &c->ext.actual);
2292 c->resolved_sym = s;
2293 pure_subroutine (c, s);
2297 /* TODO: Need to search for elemental references in generic interface. */
2300 if (sym->attr.intrinsic)
2301 return gfc_intrinsic_sub_interface (c, 0);
2308 resolve_generic_s (gfc_code *c)
2313 sym = c->symtree->n.sym;
2317 m = resolve_generic_s0 (c, sym);
2320 else if (m == MATCH_ERROR)
2324 if (sym->ns->parent == NULL)
2326 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
2330 if (!generic_sym (sym))
2334 /* Last ditch attempt. See if the reference is to an intrinsic
2335 that possesses a matching interface. 14.1.2.4 */
2336 sym = c->symtree->n.sym;
2338 if (!gfc_intrinsic_name (sym->name, 1))
2340 gfc_error ("There is no specific subroutine for the generic '%s' at %L",
2341 sym->name, &c->loc);
2345 m = gfc_intrinsic_sub_interface (c, 0);
2349 gfc_error ("Generic subroutine '%s' at %L is not consistent with an "
2350 "intrinsic subroutine interface", sym->name, &c->loc);
2356 /* Set the name and binding label of the subroutine symbol in the call
2357 expression represented by 'c' to include the type and kind of the
2358 second parameter. This function is for resolving the appropriate
2359 version of c_f_pointer() and c_f_procpointer(). For example, a
2360 call to c_f_pointer() for a default integer pointer could have a
2361 name of c_f_pointer_i4. If no second arg exists, which is an error
2362 for these two functions, it defaults to the generic symbol's name
2363 and binding label. */
2366 set_name_and_label (gfc_code *c, gfc_symbol *sym,
2367 char *name, char *binding_label)
2369 gfc_expr *arg = NULL;
2373 /* The second arg of c_f_pointer and c_f_procpointer determines
2374 the type and kind for the procedure name. */
2375 arg = c->ext.actual->next->expr;
2379 /* Set up the name to have the given symbol's name,
2380 plus the type and kind. */
2381 /* a derived type is marked with the type letter 'u' */
2382 if (arg->ts.type == BT_DERIVED)
2385 kind = 0; /* set the kind as 0 for now */
2389 type = gfc_type_letter (arg->ts.type);
2390 kind = arg->ts.kind;
2393 if (arg->ts.type == BT_CHARACTER)
2394 /* Kind info for character strings not needed. */
2397 sprintf (name, "%s_%c%d", sym->name, type, kind);
2398 /* Set up the binding label as the given symbol's label plus
2399 the type and kind. */
2400 sprintf (binding_label, "%s_%c%d", sym->binding_label, type, kind);
2404 /* If the second arg is missing, set the name and label as
2405 was, cause it should at least be found, and the missing
2406 arg error will be caught by compare_parameters(). */
2407 sprintf (name, "%s", sym->name);
2408 sprintf (binding_label, "%s", sym->binding_label);
2415 /* Resolve a generic version of the iso_c_binding procedure given
2416 (sym) to the specific one based on the type and kind of the
2417 argument(s). Currently, this function resolves c_f_pointer() and
2418 c_f_procpointer based on the type and kind of the second argument
2419 (FPTR). Other iso_c_binding procedures aren't specially handled.
2420 Upon successfully exiting, c->resolved_sym will hold the resolved
2421 symbol. Returns MATCH_ERROR if an error occurred; MATCH_YES
2425 gfc_iso_c_sub_interface (gfc_code *c, gfc_symbol *sym)
2427 gfc_symbol *new_sym;
2428 /* this is fine, since we know the names won't use the max */
2429 char name[GFC_MAX_SYMBOL_LEN + 1];
2430 char binding_label[GFC_MAX_BINDING_LABEL_LEN + 1];
2431 /* default to success; will override if find error */
2432 match m = MATCH_YES;
2434 /* Make sure the actual arguments are in the necessary order (based on the
2435 formal args) before resolving. */
2436 gfc_procedure_use (sym, &c->ext.actual, &(c->loc));
2438 if ((sym->intmod_sym_id == ISOCBINDING_F_POINTER) ||
2439 (sym->intmod_sym_id == ISOCBINDING_F_PROCPOINTER))
2441 set_name_and_label (c, sym, name, binding_label);
2443 if (sym->intmod_sym_id == ISOCBINDING_F_POINTER)
2445 if (c->ext.actual != NULL && c->ext.actual->next != NULL)
2447 /* Make sure we got a third arg if the second arg has non-zero
2448 rank. We must also check that the type and rank are
2449 correct since we short-circuit this check in
2450 gfc_procedure_use() (called above to sort actual args). */
2451 if (c->ext.actual->next->expr->rank != 0)
2453 if(c->ext.actual->next->next == NULL
2454 || c->ext.actual->next->next->expr == NULL)
2457 gfc_error ("Missing SHAPE parameter for call to %s "
2458 "at %L", sym->name, &(c->loc));
2460 else if (c->ext.actual->next->next->expr->ts.type
2462 || c->ext.actual->next->next->expr->rank != 1)
2465 gfc_error ("SHAPE parameter for call to %s at %L must "
2466 "be a rank 1 INTEGER array", sym->name,
2473 if (m != MATCH_ERROR)
2475 /* the 1 means to add the optional arg to formal list */
2476 new_sym = get_iso_c_sym (sym, name, binding_label, 1);
2478 /* for error reporting, say it's declared where the original was */
2479 new_sym->declared_at = sym->declared_at;
2482 else if (sym->intmod_sym_id == ISOCBINDING_ASSOCIATED)
2484 /* TODO: Figure out if this is even reachable; this part of the
2485 conditional may not be necessary. */
2487 if (c->ext.actual->next == NULL)
2489 /* The user did not give two args, so resolve to the version
2490 of c_associated expecting one arg. */
2492 /* get rid of the second arg */
2493 /* TODO!! Should free up the memory here! */
2494 sym->formal->next = NULL;
2502 sprintf (name, "%s_%d", sym->name, num_args);
2503 sprintf (binding_label, "%s_%d", sym->binding_label, num_args);
2504 sym->name = gfc_get_string (name);
2505 strcpy (sym->binding_label, binding_label);
2509 /* no differences for c_loc or c_funloc */
2513 /* set the resolved symbol */
2514 if (m != MATCH_ERROR)
2515 c->resolved_sym = new_sym;
2517 c->resolved_sym = sym;
2523 /* Resolve a subroutine call known to be specific. */
2526 resolve_specific_s0 (gfc_code *c, gfc_symbol *sym)
2530 if(sym->attr.is_iso_c)
2532 m = gfc_iso_c_sub_interface (c,sym);
2536 if (sym->attr.external || sym->attr.if_source == IFSRC_IFBODY)
2538 if (sym->attr.dummy)
2540 sym->attr.proc = PROC_DUMMY;
2544 sym->attr.proc = PROC_EXTERNAL;
2548 if (sym->attr.proc == PROC_MODULE || sym->attr.proc == PROC_INTERNAL)
2551 if (sym->attr.intrinsic)
2553 m = gfc_intrinsic_sub_interface (c, 1);
2557 gfc_error ("Subroutine '%s' at %L is INTRINSIC but is not compatible "
2558 "with an intrinsic", sym->name, &c->loc);
2566 gfc_procedure_use (sym, &c->ext.actual, &c->loc);
2568 c->resolved_sym = sym;
2569 pure_subroutine (c, sym);
2576 resolve_specific_s (gfc_code *c)
2581 sym = c->symtree->n.sym;
2585 m = resolve_specific_s0 (c, sym);
2588 if (m == MATCH_ERROR)
2591 if (sym->ns->parent == NULL)
2594 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
2600 sym = c->symtree->n.sym;
2601 gfc_error ("Unable to resolve the specific subroutine '%s' at %L",
2602 sym->name, &c->loc);
2608 /* Resolve a subroutine call not known to be generic nor specific. */
2611 resolve_unknown_s (gfc_code *c)
2615 sym = c->symtree->n.sym;
2617 if (sym->attr.dummy)
2619 sym->attr.proc = PROC_DUMMY;
2623 /* See if we have an intrinsic function reference. */
2625 if (gfc_intrinsic_name (sym->name, 1))
2627 if (gfc_intrinsic_sub_interface (c, 1) == MATCH_YES)
2632 /* The reference is to an external name. */
2635 gfc_procedure_use (sym, &c->ext.actual, &c->loc);
2637 c->resolved_sym = sym;
2639 pure_subroutine (c, sym);
2645 /* Resolve a subroutine call. Although it was tempting to use the same code
2646 for functions, subroutines and functions are stored differently and this
2647 makes things awkward. */
2650 resolve_call (gfc_code *c)
2653 procedure_type ptype = PROC_INTRINSIC;
2655 if (c->symtree && c->symtree->n.sym
2656 && c->symtree->n.sym->ts.type != BT_UNKNOWN)
2658 gfc_error ("'%s' at %L has a type, which is not consistent with "
2659 "the CALL at %L", c->symtree->n.sym->name,
2660 &c->symtree->n.sym->declared_at, &c->loc);
2664 /* If external, check for usage. */
2665 if (c->symtree && is_external_proc (c->symtree->n.sym))
2666 resolve_global_procedure (c->symtree->n.sym, &c->loc, 1);
2668 /* Subroutines without the RECURSIVE attribution are not allowed to
2669 * call themselves. */
2670 if (c->symtree && c->symtree->n.sym && !c->symtree->n.sym->attr.recursive)
2672 gfc_symbol *csym, *proc;
2673 csym = c->symtree->n.sym;
2674 proc = gfc_current_ns->proc_name;
2677 gfc_error ("SUBROUTINE '%s' at %L cannot call itself, as it is not "
2678 "RECURSIVE", csym->name, &c->loc);
2682 if (csym->attr.entry && csym->ns->entries && proc->ns->entries
2683 && csym->ns->entries->sym == proc->ns->entries->sym)
2685 gfc_error ("Call to ENTRY '%s' at %L is recursive, but subroutine "
2686 "'%s' is not declared as RECURSIVE",
2687 csym->name, &c->loc, csym->ns->entries->sym->name);
2692 /* Switch off assumed size checking and do this again for certain kinds
2693 of procedure, once the procedure itself is resolved. */
2694 need_full_assumed_size++;
2696 if (c->symtree && c->symtree->n.sym)
2697 ptype = c->symtree->n.sym->attr.proc;
2699 if (resolve_actual_arglist (c->ext.actual, ptype) == FAILURE)
2702 /* Resume assumed_size checking. */
2703 need_full_assumed_size--;
2706 if (c->resolved_sym == NULL)
2707 switch (procedure_kind (c->symtree->n.sym))
2710 t = resolve_generic_s (c);
2713 case PTYPE_SPECIFIC:
2714 t = resolve_specific_s (c);
2718 t = resolve_unknown_s (c);
2722 gfc_internal_error ("resolve_subroutine(): bad function type");
2725 /* Some checks of elemental subroutine actual arguments. */
2726 if (resolve_elemental_actual (NULL, c) == FAILURE)
2730 find_noncopying_intrinsics (c->resolved_sym, c->ext.actual);
2735 /* Compare the shapes of two arrays that have non-NULL shapes. If both
2736 op1->shape and op2->shape are non-NULL return SUCCESS if their shapes
2737 match. If both op1->shape and op2->shape are non-NULL return FAILURE
2738 if their shapes do not match. If either op1->shape or op2->shape is
2739 NULL, return SUCCESS. */
2742 compare_shapes (gfc_expr *op1, gfc_expr *op2)
2749 if (op1->shape != NULL && op2->shape != NULL)
2751 for (i = 0; i < op1->rank; i++)
2753 if (mpz_cmp (op1->shape[i], op2->shape[i]) != 0)
2755 gfc_error ("Shapes for operands at %L and %L are not conformable",
2756 &op1->where, &op2->where);
2767 /* Resolve an operator expression node. This can involve replacing the
2768 operation with a user defined function call. */
2771 resolve_operator (gfc_expr *e)
2773 gfc_expr *op1, *op2;
2775 bool dual_locus_error;
2778 /* Resolve all subnodes-- give them types. */
2780 switch (e->value.op.operator)
2783 if (gfc_resolve_expr (e->value.op.op2) == FAILURE)
2786 /* Fall through... */
2789 case INTRINSIC_UPLUS:
2790 case INTRINSIC_UMINUS:
2791 case INTRINSIC_PARENTHESES:
2792 if (gfc_resolve_expr (e->value.op.op1) == FAILURE)
2797 /* Typecheck the new node. */
2799 op1 = e->value.op.op1;
2800 op2 = e->value.op.op2;
2801 dual_locus_error = false;
2803 if ((op1 && op1->expr_type == EXPR_NULL)
2804 || (op2 && op2->expr_type == EXPR_NULL))
2806 sprintf (msg, _("Invalid context for NULL() pointer at %%L"));
2810 switch (e->value.op.operator)
2812 case INTRINSIC_UPLUS:
2813 case INTRINSIC_UMINUS:
2814 if (op1->ts.type == BT_INTEGER
2815 || op1->ts.type == BT_REAL
2816 || op1->ts.type == BT_COMPLEX)
2822 sprintf (msg, _("Operand of unary numeric operator '%s' at %%L is %s"),
2823 gfc_op2string (e->value.op.operator), gfc_typename (&e->ts));
2826 case INTRINSIC_PLUS:
2827 case INTRINSIC_MINUS:
2828 case INTRINSIC_TIMES:
2829 case INTRINSIC_DIVIDE:
2830 case INTRINSIC_POWER:
2831 if (gfc_numeric_ts (&op1->ts) && gfc_numeric_ts (&op2->ts))
2833 gfc_type_convert_binary (e);
2838 _("Operands of binary numeric operator '%s' at %%L are %s/%s"),
2839 gfc_op2string (e->value.op.operator), gfc_typename (&op1->ts),
2840 gfc_typename (&op2->ts));
2843 case INTRINSIC_CONCAT:
2844 if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER)
2846 e->ts.type = BT_CHARACTER;
2847 e->ts.kind = op1->ts.kind;
2852 _("Operands of string concatenation operator at %%L are %s/%s"),
2853 gfc_typename (&op1->ts), gfc_typename (&op2->ts));
2859 case INTRINSIC_NEQV:
2860 if (op1->ts.type == BT_LOGICAL && op2->ts.type == BT_LOGICAL)
2862 e->ts.type = BT_LOGICAL;
2863 e->ts.kind = gfc_kind_max (op1, op2);
2864 if (op1->ts.kind < e->ts.kind)
2865 gfc_convert_type (op1, &e->ts, 2);
2866 else if (op2->ts.kind < e->ts.kind)
2867 gfc_convert_type (op2, &e->ts, 2);
2871 sprintf (msg, _("Operands of logical operator '%s' at %%L are %s/%s"),
2872 gfc_op2string (e->value.op.operator), gfc_typename (&op1->ts),
2873 gfc_typename (&op2->ts));
2878 if (op1->ts.type == BT_LOGICAL)
2880 e->ts.type = BT_LOGICAL;
2881 e->ts.kind = op1->ts.kind;
2885 sprintf (msg, _("Operand of .not. operator at %%L is %s"),
2886 gfc_typename (&op1->ts));
2890 case INTRINSIC_GT_OS:
2892 case INTRINSIC_GE_OS:
2894 case INTRINSIC_LT_OS:
2896 case INTRINSIC_LE_OS:
2897 if (op1->ts.type == BT_COMPLEX || op2->ts.type == BT_COMPLEX)
2899 strcpy (msg, _("COMPLEX quantities cannot be compared at %L"));
2903 /* Fall through... */
2906 case INTRINSIC_EQ_OS:
2908 case INTRINSIC_NE_OS:
2909 if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER)
2911 e->ts.type = BT_LOGICAL;
2912 e->ts.kind = gfc_default_logical_kind;
2916 if (gfc_numeric_ts (&op1->ts) && gfc_numeric_ts (&op2->ts))
2918 gfc_type_convert_binary (e);
2920 e->ts.type = BT_LOGICAL;
2921 e->ts.kind = gfc_default_logical_kind;
2925 if (op1->ts.type == BT_LOGICAL && op2->ts.type == BT_LOGICAL)
2927 _("Logicals at %%L must be compared with %s instead of %s"),
2928 (e->value.op.operator == INTRINSIC_EQ
2929 || e->value.op.operator == INTRINSIC_EQ_OS)
2930 ? ".eqv." : ".neqv.", gfc_op2string (e->value.op.operator));
2933 _("Operands of comparison operator '%s' at %%L are %s/%s"),
2934 gfc_op2string (e->value.op.operator), gfc_typename (&op1->ts),
2935 gfc_typename (&op2->ts));
2939 case INTRINSIC_USER:
2940 if (e->value.op.uop->operator == NULL)
2941 sprintf (msg, _("Unknown operator '%s' at %%L"), e->value.op.uop->name);
2942 else if (op2 == NULL)
2943 sprintf (msg, _("Operand of user operator '%s' at %%L is %s"),
2944 e->value.op.uop->name, gfc_typename (&op1->ts));
2946 sprintf (msg, _("Operands of user operator '%s' at %%L are %s/%s"),
2947 e->value.op.uop->name, gfc_typename (&op1->ts),
2948 gfc_typename (&op2->ts));
2952 case INTRINSIC_PARENTHESES:
2954 if (e->ts.type == BT_CHARACTER)
2955 e->ts.cl = op1->ts.cl;
2959 gfc_internal_error ("resolve_operator(): Bad intrinsic");
2962 /* Deal with arrayness of an operand through an operator. */
2966 switch (e->value.op.operator)
2968 case INTRINSIC_PLUS:
2969 case INTRINSIC_MINUS:
2970 case INTRINSIC_TIMES:
2971 case INTRINSIC_DIVIDE:
2972 case INTRINSIC_POWER:
2973 case INTRINSIC_CONCAT:
2977 case INTRINSIC_NEQV:
2979 case INTRINSIC_EQ_OS:
2981 case INTRINSIC_NE_OS:
2983 case INTRINSIC_GT_OS:
2985 case INTRINSIC_GE_OS:
2987 case INTRINSIC_LT_OS:
2989 case INTRINSIC_LE_OS:
2991 if (op1->rank == 0 && op2->rank == 0)
2994 if (op1->rank == 0 && op2->rank != 0)
2996 e->rank = op2->rank;
2998 if (e->shape == NULL)
2999 e->shape = gfc_copy_shape (op2->shape, op2->rank);
3002 if (op1->rank != 0 && op2->rank == 0)
3004 e->rank = op1->rank;
3006 if (e->shape == NULL)
3007 e->shape = gfc_copy_shape (op1->shape, op1->rank);
3010 if (op1->rank != 0 && op2->rank != 0)
3012 if (op1->rank == op2->rank)
3014 e->rank = op1->rank;
3015 if (e->shape == NULL)
3017 t = compare_shapes(op1, op2);
3021 e->shape = gfc_copy_shape (op1->shape, op1->rank);
3026 /* Allow higher level expressions to work. */
3029 /* Try user-defined operators, and otherwise throw an error. */
3030 dual_locus_error = true;
3032 _("Inconsistent ranks for operator at %%L and %%L"));
3039 case INTRINSIC_PARENTHESES:
3041 case INTRINSIC_UPLUS:
3042 case INTRINSIC_UMINUS:
3043 /* Simply copy arrayness attribute */
3044 e->rank = op1->rank;
3046 if (e->shape == NULL)
3047 e->shape = gfc_copy_shape (op1->shape, op1->rank);
3055 /* Attempt to simplify the expression. */
3058 t = gfc_simplify_expr (e, 0);
3059 /* Some calls do not succeed in simplification and return FAILURE
3060 even though there is no error; eg. variable references to
3061 PARAMETER arrays. */
3062 if (!gfc_is_constant_expr (e))
3069 if (gfc_extend_expr (e) == SUCCESS)
3072 if (dual_locus_error)
3073 gfc_error (msg, &op1->where, &op2->where);
3075 gfc_error (msg, &e->where);
3081 /************** Array resolution subroutines **************/
3084 { CMP_LT, CMP_EQ, CMP_GT, CMP_UNKNOWN }
3087 /* Compare two integer expressions. */
3090 compare_bound (gfc_expr *a, gfc_expr *b)
3094 if (a == NULL || a->expr_type != EXPR_CONSTANT
3095 || b == NULL || b->expr_type != EXPR_CONSTANT)
3098 if (a->ts.type != BT_INTEGER || b->ts.type != BT_INTEGER)
3099 gfc_internal_error ("compare_bound(): Bad expression");
3101 i = mpz_cmp (a->value.integer, b->value.integer);
3111 /* Compare an integer expression with an integer. */
3114 compare_bound_int (gfc_expr *a, int b)
3118 if (a == NULL || a->expr_type != EXPR_CONSTANT)
3121 if (a->ts.type != BT_INTEGER)
3122 gfc_internal_error ("compare_bound_int(): Bad expression");
3124 i = mpz_cmp_si (a->value.integer, b);
3134 /* Compare an integer expression with a mpz_t. */
3137 compare_bound_mpz_t (gfc_expr *a, mpz_t b)
3141 if (a == NULL || a->expr_type != EXPR_CONSTANT)
3144 if (a->ts.type != BT_INTEGER)
3145 gfc_internal_error ("compare_bound_int(): Bad expression");
3147 i = mpz_cmp (a->value.integer, b);
3157 /* Compute the last value of a sequence given by a triplet.
3158 Return 0 if it wasn't able to compute the last value, or if the
3159 sequence if empty, and 1 otherwise. */
3162 compute_last_value_for_triplet (gfc_expr *start, gfc_expr *end,
3163 gfc_expr *stride, mpz_t last)
3167 if (start == NULL || start->expr_type != EXPR_CONSTANT
3168 || end == NULL || end->expr_type != EXPR_CONSTANT
3169 || (stride != NULL && stride->expr_type != EXPR_CONSTANT))
3172 if (start->ts.type != BT_INTEGER || end->ts.type != BT_INTEGER
3173 || (stride != NULL && stride->ts.type != BT_INTEGER))
3176 if (stride == NULL || compare_bound_int(stride, 1) == CMP_EQ)
3178 if (compare_bound (start, end) == CMP_GT)
3180 mpz_set (last, end->value.integer);
3184 if (compare_bound_int (stride, 0) == CMP_GT)
3186 /* Stride is positive */
3187 if (mpz_cmp (start->value.integer, end->value.integer) > 0)
3192 /* Stride is negative */
3193 if (mpz_cmp (start->value.integer, end->value.integer) < 0)
3198 mpz_sub (rem, end->value.integer, start->value.integer);
3199 mpz_tdiv_r (rem, rem, stride->value.integer);
3200 mpz_sub (last, end->value.integer, rem);
3207 /* Compare a single dimension of an array reference to the array
3211 check_dimension (int i, gfc_array_ref *ar, gfc_array_spec *as)
3215 /* Given start, end and stride values, calculate the minimum and
3216 maximum referenced indexes. */
3218 switch (ar->dimen_type[i])
3224 if (compare_bound (ar->start[i], as->lower[i]) == CMP_LT)
3226 gfc_warning ("Array reference at %L is out of bounds "
3227 "(%ld < %ld) in dimension %d", &ar->c_where[i],
3228 mpz_get_si (ar->start[i]->value.integer),
3229 mpz_get_si (as->lower[i]->value.integer), i+1);
3232 if (compare_bound (ar->start[i], as->upper[i]) == CMP_GT)
3234 gfc_warning ("Array reference at %L is out of bounds "
3235 "(%ld > %ld) in dimension %d", &ar->c_where[i],
3236 mpz_get_si (ar->start[i]->value.integer),
3237 mpz_get_si (as->upper[i]->value.integer), i+1);
3245 #define AR_START (ar->start[i] ? ar->start[i] : as->lower[i])
3246 #define AR_END (ar->end[i] ? ar->end[i] : as->upper[i])
3248 comparison comp_start_end = compare_bound (AR_START, AR_END);
3250 /* Check for zero stride, which is not allowed. */
3251 if (compare_bound_int (ar->stride[i], 0) == CMP_EQ)
3253 gfc_error ("Illegal stride of zero at %L", &ar->c_where[i]);
3257 /* if start == len || (stride > 0 && start < len)
3258 || (stride < 0 && start > len),
3259 then the array section contains at least one element. In this
3260 case, there is an out-of-bounds access if
3261 (start < lower || start > upper). */
3262 if (compare_bound (AR_START, AR_END) == CMP_EQ
3263 || ((compare_bound_int (ar->stride[i], 0) == CMP_GT
3264 || ar->stride[i] == NULL) && comp_start_end == CMP_LT)
3265 || (compare_bound_int (ar->stride[i], 0) == CMP_LT
3266 && comp_start_end == CMP_GT))
3268 if (compare_bound (AR_START, as->lower[i]) == CMP_LT)
3270 gfc_warning ("Lower array reference at %L is out of bounds "
3271 "(%ld < %ld) in dimension %d", &ar->c_where[i],
3272 mpz_get_si (AR_START->value.integer),
3273 mpz_get_si (as->lower[i]->value.integer), i+1);
3276 if (compare_bound (AR_START, as->upper[i]) == CMP_GT)
3278 gfc_warning ("Lower array reference at %L is out of bounds "
3279 "(%ld > %ld) in dimension %d", &ar->c_where[i],
3280 mpz_get_si (AR_START->value.integer),
3281 mpz_get_si (as->upper[i]->value.integer), i+1);
3286 /* If we can compute the highest index of the array section,
3287 then it also has to be between lower and upper. */
3288 mpz_init (last_value);
3289 if (compute_last_value_for_triplet (AR_START, AR_END, ar->stride[i],
3292 if (compare_bound_mpz_t (as->lower[i], last_value) == CMP_GT)
3294 gfc_warning ("Upper array reference at %L is out of bounds "
3295 "(%ld < %ld) in dimension %d", &ar->c_where[i],
3296 mpz_get_si (last_value),
3297 mpz_get_si (as->lower[i]->value.integer), i+1);
3298 mpz_clear (last_value);
3301 if (compare_bound_mpz_t (as->upper[i], last_value) == CMP_LT)
3303 gfc_warning ("Upper array reference at %L is out of bounds "
3304 "(%ld > %ld) in dimension %d", &ar->c_where[i],
3305 mpz_get_si (last_value),
3306 mpz_get_si (as->upper[i]->value.integer), i+1);
3307 mpz_clear (last_value);
3311 mpz_clear (last_value);
3319 gfc_internal_error ("check_dimension(): Bad array reference");
3326 /* Compare an array reference with an array specification. */
3329 compare_spec_to_ref (gfc_array_ref *ar)
3336 /* TODO: Full array sections are only allowed as actual parameters. */
3337 if (as->type == AS_ASSUMED_SIZE
3338 && (/*ar->type == AR_FULL
3339 ||*/ (ar->type == AR_SECTION
3340 && ar->dimen_type[i] == DIMEN_RANGE && ar->end[i] == NULL)))
3342 gfc_error ("Rightmost upper bound of assumed size array section "
3343 "not specified at %L", &ar->where);
3347 if (ar->type == AR_FULL)
3350 if (as->rank != ar->dimen)
3352 gfc_error ("Rank mismatch in array reference at %L (%d/%d)",
3353 &ar->where, ar->dimen, as->rank);
3357 for (i = 0; i < as->rank; i++)
3358 if (check_dimension (i, ar, as) == FAILURE)
3365 /* Resolve one part of an array index. */
3368 gfc_resolve_index (gfc_expr *index, int check_scalar)
3375 if (gfc_resolve_expr (index) == FAILURE)
3378 if (check_scalar && index->rank != 0)
3380 gfc_error ("Array index at %L must be scalar", &index->where);
3384 if (index->ts.type != BT_INTEGER && index->ts.type != BT_REAL)
3386 gfc_error ("Array index at %L must be of INTEGER type",
3391 if (index->ts.type == BT_REAL)
3392 if (gfc_notify_std (GFC_STD_LEGACY, "Extension: REAL array index at %L",
3393 &index->where) == FAILURE)
3396 if (index->ts.kind != gfc_index_integer_kind
3397 || index->ts.type != BT_INTEGER)
3400 ts.type = BT_INTEGER;
3401 ts.kind = gfc_index_integer_kind;
3403 gfc_convert_type_warn (index, &ts, 2, 0);
3409 /* Resolve a dim argument to an intrinsic function. */
3412 gfc_resolve_dim_arg (gfc_expr *dim)
3417 if (gfc_resolve_expr (dim) == FAILURE)
3422 gfc_error ("Argument dim at %L must be scalar", &dim->where);
3426 if (dim->ts.type != BT_INTEGER)
3428 gfc_error ("Argument dim at %L must be of INTEGER type", &dim->where);
3431 if (dim->ts.kind != gfc_index_integer_kind)
3435 ts.type = BT_INTEGER;
3436 ts.kind = gfc_index_integer_kind;
3438 gfc_convert_type_warn (dim, &ts, 2, 0);
3444 /* Given an expression that contains array references, update those array
3445 references to point to the right array specifications. While this is
3446 filled in during matching, this information is difficult to save and load
3447 in a module, so we take care of it here.
3449 The idea here is that the original array reference comes from the
3450 base symbol. We traverse the list of reference structures, setting
3451 the stored reference to references. Component references can
3452 provide an additional array specification. */
3455 find_array_spec (gfc_expr *e)
3459 gfc_symbol *derived;
3462 as = e->symtree->n.sym->as;
3465 for (ref = e->ref; ref; ref = ref->next)
3470 gfc_internal_error ("find_array_spec(): Missing spec");
3477 if (derived == NULL)
3478 derived = e->symtree->n.sym->ts.derived;
3480 c = derived->components;
3482 for (; c; c = c->next)
3483 if (c == ref->u.c.component)
3485 /* Track the sequence of component references. */
3486 if (c->ts.type == BT_DERIVED)
3487 derived = c->ts.derived;
3492 gfc_internal_error ("find_array_spec(): Component not found");
3497 gfc_internal_error ("find_array_spec(): unused as(1)");
3508 gfc_internal_error ("find_array_spec(): unused as(2)");
3512 /* Resolve an array reference. */
3515 resolve_array_ref (gfc_array_ref *ar)
3517 int i, check_scalar;
3520 for (i = 0; i < ar->dimen; i++)
3522 check_scalar = ar->dimen_type[i] == DIMEN_RANGE;
3524 if (gfc_resolve_index (ar->start[i], check_scalar) == FAILURE)
3526 if (gfc_resolve_index (ar->end[i], check_scalar) == FAILURE)
3528 if (gfc_resolve_index (ar->stride[i], check_scalar) == FAILURE)
3533 if (ar->dimen_type[i] == DIMEN_UNKNOWN)
3537 ar->dimen_type[i] = DIMEN_ELEMENT;
3541 ar->dimen_type[i] = DIMEN_VECTOR;
3542 if (e->expr_type == EXPR_VARIABLE
3543 && e->symtree->n.sym->ts.type == BT_DERIVED)
3544 ar->start[i] = gfc_get_parentheses (e);
3548 gfc_error ("Array index at %L is an array of rank %d",
3549 &ar->c_where[i], e->rank);
3554 /* If the reference type is unknown, figure out what kind it is. */
3556 if (ar->type == AR_UNKNOWN)
3558 ar->type = AR_ELEMENT;
3559 for (i = 0; i < ar->dimen; i++)
3560 if (ar->dimen_type[i] == DIMEN_RANGE
3561 || ar->dimen_type[i] == DIMEN_VECTOR)
3563 ar->type = AR_SECTION;
3568 if (!ar->as->cray_pointee && compare_spec_to_ref (ar) == FAILURE)
3576 resolve_substring (gfc_ref *ref)
3578 if (ref->u.ss.start != NULL)
3580 if (gfc_resolve_expr (ref->u.ss.start) == FAILURE)
3583 if (ref->u.ss.start->ts.type != BT_INTEGER)
3585 gfc_error ("Substring start index at %L must be of type INTEGER",
3586 &ref->u.ss.start->where);
3590 if (ref->u.ss.start->rank != 0)
3592 gfc_error ("Substring start index at %L must be scalar",
3593 &ref->u.ss.start->where);
3597 if (compare_bound_int (ref->u.ss.start, 1) == CMP_LT
3598 && (compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_EQ
3599 || compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_GT))
3601 gfc_error ("Substring start index at %L is less than one",
3602 &ref->u.ss.start->where);
3607 if (ref->u.ss.end != NULL)
3609 if (gfc_resolve_expr (ref->u.ss.end) == FAILURE)
3612 if (ref->u.ss.end->ts.type != BT_INTEGER)
3614 gfc_error ("Substring end index at %L must be of type INTEGER",
3615 &ref->u.ss.end->where);
3619 if (ref->u.ss.end->rank != 0)
3621 gfc_error ("Substring end index at %L must be scalar",
3622 &ref->u.ss.end->where);
3626 if (ref->u.ss.length != NULL
3627 && compare_bound (ref->u.ss.end, ref->u.ss.length->length) == CMP_GT
3628 && (compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_EQ
3629 || compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_GT))
3631 gfc_error ("Substring end index at %L exceeds the string length",
3632 &ref->u.ss.start->where);
3641 /* This function supplies missing substring charlens. */
3644 gfc_resolve_substring_charlen (gfc_expr *e)
3647 gfc_expr *start, *end;
3649 for (char_ref = e->ref; char_ref; char_ref = char_ref->next)
3650 if (char_ref->type == REF_SUBSTRING)
3656 gcc_assert (char_ref->next == NULL);
3660 if (e->ts.cl->length)
3661 gfc_free_expr (e->ts.cl->length);
3662 else if (e->expr_type == EXPR_VARIABLE
3663 && e->symtree->n.sym->attr.dummy)
3667 e->ts.type = BT_CHARACTER;
3668 e->ts.kind = gfc_default_character_kind;
3672 e->ts.cl = gfc_get_charlen ();
3673 e->ts.cl->next = gfc_current_ns->cl_list;
3674 gfc_current_ns->cl_list = e->ts.cl;
3677 if (char_ref->u.ss.start)
3678 start = gfc_copy_expr (char_ref->u.ss.start);
3680 start = gfc_int_expr (1);
3682 if (char_ref->u.ss.end)
3683 end = gfc_copy_expr (char_ref->u.ss.end);
3684 else if (e->expr_type == EXPR_VARIABLE)
3685 end = gfc_copy_expr (e->symtree->n.sym->ts.cl->length);
3692 /* Length = (end - start +1). */
3693 e->ts.cl->length = gfc_subtract (end, start);
3694 e->ts.cl->length = gfc_add (e->ts.cl->length, gfc_int_expr (1));
3696 e->ts.cl->length->ts.type = BT_INTEGER;
3697 e->ts.cl->length->ts.kind = gfc_charlen_int_kind;;
3699 /* Make sure that the length is simplified. */
3700 gfc_simplify_expr (e->ts.cl->length, 1);
3701 gfc_resolve_expr (e->ts.cl->length);
3705 /* Resolve subtype references. */
3708 resolve_ref (gfc_expr *expr)
3710 int current_part_dimension, n_components, seen_part_dimension;
3713 for (ref = expr->ref; ref; ref = ref->next)
3714 if (ref->type == REF_ARRAY && ref->u.ar.as == NULL)
3716 find_array_spec (expr);
3720 for (ref = expr->ref; ref; ref = ref->next)
3724 if (resolve_array_ref (&ref->u.ar) == FAILURE)
3732 resolve_substring (ref);
3736 /* Check constraints on part references. */
3738 current_part_dimension = 0;
3739 seen_part_dimension = 0;
3742 for (ref = expr->ref; ref; ref = ref->next)
3747 switch (ref->u.ar.type)
3751 current_part_dimension = 1;
3755 current_part_dimension = 0;
3759 gfc_internal_error ("resolve_ref(): Bad array reference");
3765 if (current_part_dimension || seen_part_dimension)
3767 if (ref->u.c.component->pointer)
3769 gfc_error ("Component to the right of a part reference "
3770 "with nonzero rank must not have the POINTER "
3771 "attribute at %L", &expr->where);
3774 else if (ref->u.c.component->allocatable)
3776 gfc_error ("Component to the right of a part reference "
3777 "with nonzero rank must not have the ALLOCATABLE "
3778 "attribute at %L", &expr->where);
3790 if (((ref->type == REF_COMPONENT && n_components > 1)
3791 || ref->next == NULL)
3792 && current_part_dimension
3793 && seen_part_dimension)
3795 gfc_error ("Two or more part references with nonzero rank must "
3796 "not be specified at %L", &expr->where);
3800 if (ref->type == REF_COMPONENT)
3802 if (current_part_dimension)
3803 seen_part_dimension = 1;
3805 /* reset to make sure */
3806 current_part_dimension = 0;
3814 /* Given an expression, determine its shape. This is easier than it sounds.
3815 Leaves the shape array NULL if it is not possible to determine the shape. */
3818 expression_shape (gfc_expr *e)
3820 mpz_t array[GFC_MAX_DIMENSIONS];
3823 if (e->rank == 0 || e->shape != NULL)
3826 for (i = 0; i < e->rank; i++)
3827 if (gfc_array_dimen_size (e, i, &array[i]) == FAILURE)
3830 e->shape = gfc_get_shape (e->rank);
3832 memcpy (e->shape, array, e->rank * sizeof (mpz_t));
3837 for (i--; i >= 0; i--)
3838 mpz_clear (array[i]);
3842 /* Given a variable expression node, compute the rank of the expression by
3843 examining the base symbol and any reference structures it may have. */
3846 expression_rank (gfc_expr *e)
3853 if (e->expr_type == EXPR_ARRAY)
3855 /* Constructors can have a rank different from one via RESHAPE(). */
3857 if (e->symtree == NULL)
3863 e->rank = (e->symtree->n.sym->as == NULL)
3864 ? 0 : e->symtree->n.sym->as->rank;
3870 for (ref = e->ref; ref; ref = ref->next)
3872 if (ref->type != REF_ARRAY)
3875 if (ref->u.ar.type == AR_FULL)
3877 rank = ref->u.ar.as->rank;
3881 if (ref->u.ar.type == AR_SECTION)
3883 /* Figure out the rank of the section. */
3885 gfc_internal_error ("expression_rank(): Two array specs");
3887 for (i = 0; i < ref->u.ar.dimen; i++)
3888 if (ref->u.ar.dimen_type[i] == DIMEN_RANGE
3889 || ref->u.ar.dimen_type[i] == DIMEN_VECTOR)
3899 expression_shape (e);
3903 /* Resolve a variable expression. */
3906 resolve_variable (gfc_expr *e)
3913 if (e->symtree == NULL)
3916 if (e->ref && resolve_ref (e) == FAILURE)
3919 sym = e->symtree->n.sym;
3920 if (sym->attr.flavor == FL_PROCEDURE && !sym->attr.function)
3922 e->ts.type = BT_PROCEDURE;
3926 if (sym->ts.type != BT_UNKNOWN)
3927 gfc_variable_attr (e, &e->ts);
3930 /* Must be a simple variable reference. */
3931 if (gfc_set_default_type (sym, 1, sym->ns) == FAILURE)
3936 if (check_assumed_size_reference (sym, e))
3939 /* Deal with forward references to entries during resolve_code, to
3940 satisfy, at least partially, 12.5.2.5. */
3941 if (gfc_current_ns->entries
3942 && current_entry_id == sym->entry_id
3945 && cs_base->current->op != EXEC_ENTRY)
3947 gfc_entry_list *entry;
3948 gfc_formal_arglist *formal;
3952 /* If the symbol is a dummy... */
3953 if (sym->attr.dummy)
3955 entry = gfc_current_ns->entries;
3958 /* ...test if the symbol is a parameter of previous entries. */
3959 for (; entry && entry->id <= current_entry_id; entry = entry->next)
3960 for (formal = entry->sym->formal; formal; formal = formal->next)
3962 if (formal->sym && sym->name == formal->sym->name)
3966 /* If it has not been seen as a dummy, this is an error. */
3969 if (specification_expr)
3970 gfc_error ("Variable '%s',used in a specification expression, "
3971 "is referenced at %L before the ENTRY statement "
3972 "in which it is a parameter",
3973 sym->name, &cs_base->current->loc);
3975 gfc_error ("Variable '%s' is used at %L before the ENTRY "
3976 "statement in which it is a parameter",
3977 sym->name, &cs_base->current->loc);
3982 /* Now do the same check on the specification expressions. */
3983 specification_expr = 1;
3984 if (sym->ts.type == BT_CHARACTER
3985 && gfc_resolve_expr (sym->ts.cl->length) == FAILURE)
3989 for (n = 0; n < sym->as->rank; n++)
3991 specification_expr = 1;
3992 if (gfc_resolve_expr (sym->as->lower[n]) == FAILURE)
3994 specification_expr = 1;
3995 if (gfc_resolve_expr (sym->as->upper[n]) == FAILURE)
3998 specification_expr = 0;
4001 /* Update the symbol's entry level. */
4002 sym->entry_id = current_entry_id + 1;
4009 /* Checks to see that the correct symbol has been host associated.
4010 The only situation where this arises is that in which a twice
4011 contained function is parsed after the host association is made.
4012 Therefore, on detecting this, the line is rematched, having got
4013 rid of the existing references and actual_arg_list. */
4015 check_host_association (gfc_expr *e)
4017 gfc_symbol *sym, *old_sym;
4021 bool retval = e->expr_type == EXPR_FUNCTION;
4023 if (e->symtree == NULL || e->symtree->n.sym == NULL)
4026 old_sym = e->symtree->n.sym;
4028 if (old_sym->attr.use_assoc)
4031 if (gfc_current_ns->parent
4032 && gfc_current_ns->parent->parent
4033 && old_sym->ns != gfc_current_ns)
4035 gfc_find_symbol (old_sym->name, gfc_current_ns->parent, 1, &sym);
4036 if (sym && old_sym != sym && sym->attr.flavor == FL_PROCEDURE)
4038 temp_locus = gfc_current_locus;
4039 gfc_current_locus = e->where;
4041 gfc_buffer_error (1);
4043 gfc_free_ref_list (e->ref);
4048 gfc_free_actual_arglist (e->value.function.actual);
4049 e->value.function.actual = NULL;
4052 if (e->shape != NULL)
4054 for (n = 0; n < e->rank; n++)
4055 mpz_clear (e->shape[n]);
4057 gfc_free (e->shape);
4060 gfc_match_rvalue (&expr);
4062 gfc_buffer_error (0);
4064 gcc_assert (expr && sym == expr->symtree->n.sym);
4070 gfc_current_locus = temp_locus;
4073 /* This might have changed! */
4074 return e->expr_type == EXPR_FUNCTION;
4079 gfc_resolve_character_operator (gfc_expr *e)
4081 gfc_expr *op1 = e->value.op.op1;
4082 gfc_expr *op2 = e->value.op.op2;
4083 gfc_expr *e1 = NULL;
4084 gfc_expr *e2 = NULL;
4086 gcc_assert (e->value.op.operator == INTRINSIC_CONCAT);
4088 if (op1->ts.cl && op1->ts.cl->length)
4089 e1 = gfc_copy_expr (op1->ts.cl->length);
4090 else if (op1->expr_type == EXPR_CONSTANT)
4091 e1 = gfc_int_expr (op1->value.character.length);
4093 if (op2->ts.cl && op2->ts.cl->length)
4094 e2 = gfc_copy_expr (op2->ts.cl->length);
4095 else if (op2->expr_type == EXPR_CONSTANT)
4096 e2 = gfc_int_expr (op2->value.character.length);
4098 e->ts.cl = gfc_get_charlen ();
4099 e->ts.cl->next = gfc_current_ns->cl_list;
4100 gfc_current_ns->cl_list = e->ts.cl;
4105 e->ts.cl->length = gfc_add (e1, e2);
4106 e->ts.cl->length->ts.type = BT_INTEGER;
4107 e->ts.cl->length->ts.kind = gfc_charlen_int_kind;;
4108 gfc_simplify_expr (e->ts.cl->length, 0);
4109 gfc_resolve_expr (e->ts.cl->length);
4115 /* Ensure that an character expression has a charlen and, if possible, a
4116 length expression. */
4119 fixup_charlen (gfc_expr *e)
4121 /* The cases fall through so that changes in expression type and the need
4122 for multiple fixes are picked up. In all circumstances, a charlen should
4123 be available for the middle end to hang a backend_decl on. */
4124 switch (e->expr_type)
4127 gfc_resolve_character_operator (e);
4130 if (e->expr_type == EXPR_ARRAY)
4131 gfc_resolve_character_array_constructor (e);
4133 case EXPR_SUBSTRING:
4134 if (!e->ts.cl && e->ref)
4135 gfc_resolve_substring_charlen (e);
4140 e->ts.cl = gfc_get_charlen ();
4141 e->ts.cl->next = gfc_current_ns->cl_list;
4142 gfc_current_ns->cl_list = e->ts.cl;
4150 /* Resolve an expression. That is, make sure that types of operands agree
4151 with their operators, intrinsic operators are converted to function calls
4152 for overloaded types and unresolved function references are resolved. */
4155 gfc_resolve_expr (gfc_expr *e)
4162 switch (e->expr_type)
4165 t = resolve_operator (e);
4171 if (check_host_association (e))
4172 t = resolve_function (e);
4175 t = resolve_variable (e);
4177 expression_rank (e);
4180 if (e->ts.type == BT_CHARACTER && e->ts.cl == NULL && e->ref
4181 && e->ref->type != REF_SUBSTRING)
4182 gfc_resolve_substring_charlen (e);
4186 case EXPR_SUBSTRING:
4187 t = resolve_ref (e);
4197 if (resolve_ref (e) == FAILURE)
4200 t = gfc_resolve_array_constructor (e);
4201 /* Also try to expand a constructor. */
4204 expression_rank (e);
4205 gfc_expand_constructor (e);
4208 /* This provides the opportunity for the length of constructors with
4209 character valued function elements to propagate the string length
4210 to the expression. */
4211 if (e->ts.type == BT_CHARACTER)
4212 gfc_resolve_character_array_constructor (e);
4216 case EXPR_STRUCTURE:
4217 t = resolve_ref (e);
4221 t = resolve_structure_cons (e);
4225 t = gfc_simplify_expr (e, 0);
4229 gfc_internal_error ("gfc_resolve_expr(): Bad expression type");
4232 if (e->ts.type == BT_CHARACTER && t == SUCCESS && !e->ts.cl)
4239 /* Resolve an expression from an iterator. They must be scalar and have
4240 INTEGER or (optionally) REAL type. */
4243 gfc_resolve_iterator_expr (gfc_expr *expr, bool real_ok,
4244 const char *name_msgid)
4246 if (gfc_resolve_expr (expr) == FAILURE)
4249 if (expr->rank != 0)
4251 gfc_error ("%s at %L must be a scalar", _(name_msgid), &expr->where);
4255 if (expr->ts.type != BT_INTEGER)
4257 if (expr->ts.type == BT_REAL)
4260 return gfc_notify_std (GFC_STD_F95_DEL,
4261 "Deleted feature: %s at %L must be integer",
4262 _(name_msgid), &expr->where);
4265 gfc_error ("%s at %L must be INTEGER", _(name_msgid),
4272 gfc_error ("%s at %L must be INTEGER", _(name_msgid), &expr->where);
4280 /* Resolve the expressions in an iterator structure. If REAL_OK is
4281 false allow only INTEGER type iterators, otherwise allow REAL types. */
4284 gfc_resolve_iterator (gfc_iterator *iter, bool real_ok)
4286 if (gfc_resolve_iterator_expr (iter->var, real_ok, "Loop variable")
4290 if (gfc_pure (NULL) && gfc_impure_variable (iter->var->symtree->n.sym))
4292 gfc_error ("Cannot assign to loop variable in PURE procedure at %L",
4297 if (gfc_resolve_iterator_expr (iter->start, real_ok,
4298 "Start expression in DO loop") == FAILURE)
4301 if (gfc_resolve_iterator_expr (iter->end, real_ok,
4302 "End expression in DO loop") == FAILURE)
4305 if (gfc_resolve_iterator_expr (iter->step, real_ok,
4306 "Step expression in DO loop") == FAILURE)
4309 if (iter->step->expr_type == EXPR_CONSTANT)
4311 if ((iter->step->ts.type == BT_INTEGER
4312 && mpz_cmp_ui (iter->step->value.integer, 0) == 0)
4313 || (iter->step->ts.type == BT_REAL
4314 && mpfr_sgn (iter->step->value.real) == 0))
4316 gfc_error ("Step expression in DO loop at %L cannot be zero",
4317 &iter->step->where);
4322 /* Convert start, end, and step to the same type as var. */
4323 if (iter->start->ts.kind != iter->var->ts.kind
4324 || iter->start->ts.type != iter->var->ts.type)
4325 gfc_convert_type (iter->start, &iter->var->ts, 2);
4327 if (iter->end->ts.kind != iter->var->ts.kind
4328 || iter->end->ts.type != iter->var->ts.type)
4329 gfc_convert_type (iter->end, &iter->var->ts, 2);
4331 if (iter->step->ts.kind != iter->var->ts.kind
4332 || iter->step->ts.type != iter->var->ts.type)
4333 gfc_convert_type (iter->step, &iter->var->ts, 2);
4339 /* Check whether the FORALL index appears in the expression or not.
4340 Returns SUCCESS if SYM is found in EXPR. */
4343 find_forall_index (gfc_expr *expr, gfc_symbol *symbol)
4347 gfc_actual_arglist *args;
4353 switch (expr->expr_type)
4356 gcc_assert (expr->symtree->n.sym);
4358 /* A scalar assignment */
4361 if (expr->symtree->n.sym == symbol)
4367 /* the expr is array ref, substring or struct component. */
4374 /* Check if the symbol appears in the array subscript. */
4376 for (i = 0; i < GFC_MAX_DIMENSIONS; i++)
4379 if (find_forall_index (ar.start[i], symbol) == SUCCESS)
4383 if (find_forall_index (ar.end[i], symbol) == SUCCESS)
4387 if (find_forall_index (ar.stride[i], symbol) == SUCCESS)
4393 if (expr->symtree->n.sym == symbol)
4396 /* Check if the symbol appears in the substring section. */
4397 if (find_forall_index (tmp->u.ss.start, symbol) == SUCCESS)
4399 if (find_forall_index (tmp->u.ss.end, symbol) == SUCCESS)
4407 gfc_error("expression reference type error at %L", &expr->where);
4413 /* If the expression is a function call, then check if the symbol
4414 appears in the actual arglist of the function. */
4416 for (args = expr->value.function.actual; args; args = args->next)
4418 if (find_forall_index(args->expr,symbol) == SUCCESS)
4423 /* It seems not to happen. */
4424 case EXPR_SUBSTRING:
4428 gcc_assert (expr->ref->type == REF_SUBSTRING);
4429 if (find_forall_index (tmp->u.ss.start, symbol) == SUCCESS)
4431 if (find_forall_index (tmp->u.ss.end, symbol) == SUCCESS)
4436 /* It seems not to happen. */
4437 case EXPR_STRUCTURE:
4439 gfc_error ("Unsupported statement while finding forall index in "
4444 /* Find the FORALL index in the first operand. */
4445 if (expr->value.op.op1)
4447 if (find_forall_index (expr->value.op.op1, symbol) == SUCCESS)
4451 /* Find the FORALL index in the second operand. */
4452 if (expr->value.op.op2)
4454 if (find_forall_index (expr->value.op.op2, symbol) == SUCCESS)
4467 /* Resolve a list of FORALL iterators. The FORALL index-name is constrained
4468 to be a scalar INTEGER variable. The subscripts and stride are scalar
4469 INTEGERs, and if stride is a constant it must be nonzero.
4470 Furthermore "A subscript or stride in a forall-triplet-spec shall
4471 not contain a reference to any index-name in the
4472 forall-triplet-spec-list in which it appears." (7.5.4.1) */
4475 resolve_forall_iterators (gfc_forall_iterator *it)
4477 gfc_forall_iterator *iter, *iter2;
4479 for (iter = it; iter; iter = iter->next)
4481 if (gfc_resolve_expr (iter->var) == SUCCESS
4482 && (iter->var->ts.type != BT_INTEGER || iter->var->rank != 0))
4483 gfc_error ("FORALL index-name at %L must be a scalar INTEGER",
4486 if (gfc_resolve_expr (iter->start) == SUCCESS
4487 && (iter->start->ts.type != BT_INTEGER || iter->start->rank != 0))
4488 gfc_error ("FORALL start expression at %L must be a scalar INTEGER",
4489 &iter->start->where);
4490 if (iter->var->ts.kind != iter->start->ts.kind)
4491 gfc_convert_type (iter->start, &iter->var->ts, 2);
4493 if (gfc_resolve_expr (iter->end) == SUCCESS
4494 && (iter->end->ts.type != BT_INTEGER || iter->end->rank != 0))
4495 gfc_error ("FORALL end expression at %L must be a scalar INTEGER",
4497 if (iter->var->ts.kind != iter->end->ts.kind)
4498 gfc_convert_type (iter->end, &iter->var->ts, 2);
4500 if (gfc_resolve_expr (iter->stride) == SUCCESS)
4502 if (iter->stride->ts.type != BT_INTEGER || iter->stride->rank != 0)
4503 gfc_error ("FORALL stride expression at %L must be a scalar %s",
4504 &iter->stride->where, "INTEGER");
4506 if (iter->stride->expr_type == EXPR_CONSTANT
4507 && mpz_cmp_ui(iter->stride->value.integer, 0) == 0)
4508 gfc_error ("FORALL stride expression at %L cannot be zero",
4509 &iter->stride->where);
4511 if (iter->var->ts.kind != iter->stride->ts.kind)
4512 gfc_convert_type (iter->stride, &iter->var->ts, 2);
4515 for (iter = it; iter; iter = iter->next)
4516 for (iter2 = iter; iter2; iter2 = iter2->next)
4518 if (find_forall_index (iter2->start,
4519 iter->var->symtree->n.sym) == SUCCESS
4520 || find_forall_index (iter2->end,
4521 iter->var->symtree->n.sym) == SUCCESS
4522 || find_forall_index (iter2->stride,
4523 iter->var->symtree->n.sym) == SUCCESS)
4524 gfc_error ("FORALL index '%s' may not appear in triplet "
4525 "specification at %L", iter->var->symtree->name,
4526 &iter2->start->where);
4531 /* Given a pointer to a symbol that is a derived type, see if it's
4532 inaccessible, i.e. if it's defined in another module and the components are
4533 PRIVATE. The search is recursive if necessary. Returns zero if no
4534 inaccessible components are found, nonzero otherwise. */
4537 derived_inaccessible (gfc_symbol *sym)
4541 if (sym->attr.use_assoc && sym->attr.private_comp)
4544 for (c = sym->components; c; c = c->next)
4546 if (c->ts.type == BT_DERIVED && derived_inaccessible (c->ts.derived))
4554 /* Resolve the argument of a deallocate expression. The expression must be
4555 a pointer or a full array. */
4558 resolve_deallocate_expr (gfc_expr *e)
4560 symbol_attribute attr;
4561 int allocatable, pointer, check_intent_in;
4564 /* Check INTENT(IN), unless the object is a sub-component of a pointer. */
4565 check_intent_in = 1;
4567 if (gfc_resolve_expr (e) == FAILURE)
4570 if (e->expr_type != EXPR_VARIABLE)
4573 allocatable = e->symtree->n.sym->attr.allocatable;
4574 pointer = e->symtree->n.sym->attr.pointer;
4575 for (ref = e->ref; ref; ref = ref->next)
4578 check_intent_in = 0;
4583 if (ref->u.ar.type != AR_FULL)
4588 allocatable = (ref->u.c.component->as != NULL
4589 && ref->u.c.component->as->type == AS_DEFERRED);
4590 pointer = ref->u.c.component->pointer;
4599 attr = gfc_expr_attr (e);
4601 if (allocatable == 0 && attr.pointer == 0)
4604 gfc_error ("Expression in DEALLOCATE statement at %L must be "
4605 "ALLOCATABLE or a POINTER", &e->where);
4609 && e->symtree->n.sym->attr.intent == INTENT_IN)
4611 gfc_error ("Cannot deallocate INTENT(IN) variable '%s' at %L",
4612 e->symtree->n.sym->name, &e->where);
4620 /* Returns true if the expression e contains a reference the symbol sym. */
4622 find_sym_in_expr (gfc_symbol *sym, gfc_expr *e)
4624 gfc_actual_arglist *arg;
4632 switch (e->expr_type)
4635 for (arg = e->value.function.actual; arg; arg = arg->next)
4636 rv = rv || find_sym_in_expr (sym, arg->expr);
4639 /* If the variable is not the same as the dependent, 'sym', and
4640 it is not marked as being declared and it is in the same
4641 namespace as 'sym', add it to the local declarations. */
4643 if (sym == e->symtree->n.sym)
4648 rv = rv || find_sym_in_expr (sym, e->value.op.op1);
4649 rv = rv || find_sym_in_expr (sym, e->value.op.op2);
4658 for (ref = e->ref; ref; ref = ref->next)
4663 for (i = 0; i < ref->u.ar.dimen; i++)
4665 rv = rv || find_sym_in_expr (sym, ref->u.ar.start[i]);
4666 rv = rv || find_sym_in_expr (sym, ref->u.ar.end[i]);
4667 rv = rv || find_sym_in_expr (sym, ref->u.ar.stride[i]);
4672 rv = rv || find_sym_in_expr (sym, ref->u.ss.start);
4673 rv = rv || find_sym_in_expr (sym, ref->u.ss.end);
4677 if (ref->u.c.component->ts.type == BT_CHARACTER
4678 && ref->u.c.component->ts.cl->length->expr_type
4681 || find_sym_in_expr (sym,
4682 ref->u.c.component->ts.cl->length);
4684 if (ref->u.c.component->as)
4685 for (i = 0; i < ref->u.c.component->as->rank; i++)
4688 || find_sym_in_expr (sym,
4689 ref->u.c.component->as->lower[i]);
4691 || find_sym_in_expr (sym,
4692 ref->u.c.component->as->upper[i]);
4702 /* Given the expression node e for an allocatable/pointer of derived type to be
4703 allocated, get the expression node to be initialized afterwards (needed for
4704 derived types with default initializers, and derived types with allocatable
4705 components that need nullification.) */
4708 expr_to_initialize (gfc_expr *e)
4714 result = gfc_copy_expr (e);
4716 /* Change the last array reference from AR_ELEMENT to AR_FULL. */
4717 for (ref = result->ref; ref; ref = ref->next)
4718 if (ref->type == REF_ARRAY && ref->next == NULL)
4720 ref->u.ar.type = AR_FULL;
4722 for (i = 0; i < ref->u.ar.dimen; i++)
4723 ref->u.ar.start[i] = ref->u.ar.end[i] = ref->u.ar.stride[i] = NULL;
4725 result->rank = ref->u.ar.dimen;
4733 /* Resolve the expression in an ALLOCATE statement, doing the additional
4734 checks to see whether the expression is OK or not. The expression must
4735 have a trailing array reference that gives the size of the array. */
4738 resolve_allocate_expr (gfc_expr *e, gfc_code *code)
4740 int i, pointer, allocatable, dimension, check_intent_in;
4741 symbol_attribute attr;
4742 gfc_ref *ref, *ref2;
4749 /* Check INTENT(IN), unless the object is a sub-component of a pointer. */
4750 check_intent_in = 1;
4752 if (gfc_resolve_expr (e) == FAILURE)
4755 if (code->expr && code->expr->expr_type == EXPR_VARIABLE)
4756 sym = code->expr->symtree->n.sym;
4760 /* Make sure the expression is allocatable or a pointer. If it is
4761 pointer, the next-to-last reference must be a pointer. */
4765 if (e->expr_type != EXPR_VARIABLE)
4768 attr = gfc_expr_attr (e);
4769 pointer = attr.pointer;
4770 dimension = attr.dimension;
4774 allocatable = e->symtree->n.sym->attr.allocatable;
4775 pointer = e->symtree->n.sym->attr.pointer;
4776 dimension = e->symtree->n.sym->attr.dimension;
4778 if (sym == e->symtree->n.sym && sym->ts.type != BT_DERIVED)
4780 gfc_error ("The STAT variable '%s' in an ALLOCATE statement must "
4781 "not be allocated in the same statement at %L",
4782 sym->name, &e->where);
4786 for (ref = e->ref; ref; ref2 = ref, ref = ref->next)
4789 check_intent_in = 0;
4794 if (ref->next != NULL)
4799 allocatable = (ref->u.c.component->as != NULL
4800 && ref->u.c.component->as->type == AS_DEFERRED);
4802 pointer = ref->u.c.component->pointer;
4803 dimension = ref->u.c.component->dimension;
4814 if (allocatable == 0 && pointer == 0)
4816 gfc_error ("Expression in ALLOCATE statement at %L must be "
4817 "ALLOCATABLE or a POINTER", &e->where);
4822 && e->symtree->n.sym->attr.intent == INTENT_IN)
4824 gfc_error ("Cannot allocate INTENT(IN) variable '%s' at %L",
4825 e->symtree->n.sym->name, &e->where);
4829 /* Add default initializer for those derived types that need them. */
4830 if (e->ts.type == BT_DERIVED && (init_e = gfc_default_initializer (&e->ts)))
4832 init_st = gfc_get_code ();
4833 init_st->loc = code->loc;
4834 init_st->op = EXEC_INIT_ASSIGN;
4835 init_st->expr = expr_to_initialize (e);
4836 init_st->expr2 = init_e;
4837 init_st->next = code->next;
4838 code->next = init_st;
4841 if (pointer && dimension == 0)
4844 /* Make sure the next-to-last reference node is an array specification. */
4846 if (ref2 == NULL || ref2->type != REF_ARRAY || ref2->u.ar.type == AR_FULL)
4848 gfc_error ("Array specification required in ALLOCATE statement "
4849 "at %L", &e->where);
4853 /* Make sure that the array section reference makes sense in the
4854 context of an ALLOCATE specification. */
4858 for (i = 0; i < ar->dimen; i++)
4860 if (ref2->u.ar.type == AR_ELEMENT)
4863 switch (ar->dimen_type[i])
4869 if (ar->start[i] != NULL
4870 && ar->end[i] != NULL
4871 && ar->stride[i] == NULL)
4874 /* Fall Through... */
4878 gfc_error ("Bad array specification in ALLOCATE statement at %L",
4885 for (a = code->ext.alloc_list; a; a = a->next)
4887 sym = a->expr->symtree->n.sym;
4889 /* TODO - check derived type components. */
4890 if (sym->ts.type == BT_DERIVED)
4893 if ((ar->start[i] != NULL && find_sym_in_expr (sym, ar->start[i]))
4894 || (ar->end[i] != NULL && find_sym_in_expr (sym, ar->end[i])))
4896 gfc_error ("'%s' must not appear an the array specification at "
4897 "%L in the same ALLOCATE statement where it is "
4898 "itself allocated", sym->name, &ar->where);
4908 /************ SELECT CASE resolution subroutines ************/
4910 /* Callback function for our mergesort variant. Determines interval
4911 overlaps for CASEs. Return <0 if op1 < op2, 0 for overlap, >0 for
4912 op1 > op2. Assumes we're not dealing with the default case.
4913 We have op1 = (:L), (K:L) or (K:) and op2 = (:N), (M:N) or (M:).
4914 There are nine situations to check. */
4917 compare_cases (const gfc_case *op1, const gfc_case *op2)
4921 if (op1->low == NULL) /* op1 = (:L) */
4923 /* op2 = (:N), so overlap. */
4925 /* op2 = (M:) or (M:N), L < M */
4926 if (op2->low != NULL
4927 && gfc_compare_expr (op1->high, op2->low) < 0)
4930 else if (op1->high == NULL) /* op1 = (K:) */
4932 /* op2 = (M:), so overlap. */
4934 /* op2 = (:N) or (M:N), K > N */
4935 if (op2->high != NULL
4936 && gfc_compare_expr (op1->low, op2->high) > 0)
4939 else /* op1 = (K:L) */
4941 if (op2->low == NULL) /* op2 = (:N), K > N */
4942 retval = (gfc_compare_expr (op1->low, op2->high) > 0) ? 1 : 0;
4943 else if (op2->high == NULL) /* op2 = (M:), L < M */
4944 retval = (gfc_compare_expr (op1->high, op2->low) < 0) ? -1 : 0;
4945 else /* op2 = (M:N) */
4949 if (gfc_compare_expr (op1->high, op2->low) < 0)
4952 else if (gfc_compare_expr (op1->low, op2->high) > 0)
4961 /* Merge-sort a double linked case list, detecting overlap in the
4962 process. LIST is the head of the double linked case list before it
4963 is sorted. Returns the head of the sorted list if we don't see any
4964 overlap, or NULL otherwise. */
4967 check_case_overlap (gfc_case *list)
4969 gfc_case *p, *q, *e, *tail;
4970 int insize, nmerges, psize, qsize, cmp, overlap_seen;
4972 /* If the passed list was empty, return immediately. */
4979 /* Loop unconditionally. The only exit from this loop is a return
4980 statement, when we've finished sorting the case list. */
4987 /* Count the number of merges we do in this pass. */
4990 /* Loop while there exists a merge to be done. */
4995 /* Count this merge. */
4998 /* Cut the list in two pieces by stepping INSIZE places
4999 forward in the list, starting from P. */
5002 for (i = 0; i < insize; i++)
5011 /* Now we have two lists. Merge them! */
5012 while (psize > 0 || (qsize > 0 && q != NULL))
5014 /* See from which the next case to merge comes from. */
5017 /* P is empty so the next case must come from Q. */
5022 else if (qsize == 0 || q == NULL)
5031 cmp = compare_cases (p, q);
5034 /* The whole case range for P is less than the
5042 /* The whole case range for Q is greater than
5043 the case range for P. */
5050 /* The cases overlap, or they are the same
5051 element in the list. Either way, we must
5052 issue an error and get the next case from P. */
5053 /* FIXME: Sort P and Q by line number. */
5054 gfc_error ("CASE label at %L overlaps with CASE "
5055 "label at %L", &p->where, &q->where);
5063 /* Add the next element to the merged list. */
5072 /* P has now stepped INSIZE places along, and so has Q. So
5073 they're the same. */
5078 /* If we have done only one merge or none at all, we've
5079 finished sorting the cases. */
5088 /* Otherwise repeat, merging lists twice the size. */
5094 /* Check to see if an expression is suitable for use in a CASE statement.
5095 Makes sure that all case expressions are scalar constants of the same
5096 type. Return FAILURE if anything is wrong. */
5099 validate_case_label_expr (gfc_expr *e, gfc_expr *case_expr)
5101 if (e == NULL) return SUCCESS;
5103 if (e->ts.type != case_expr->ts.type)
5105 gfc_error ("Expression in CASE statement at %L must be of type %s",
5106 &e->where, gfc_basic_typename (case_expr->ts.type));
5110 /* C805 (R808) For a given case-construct, each case-value shall be of
5111 the same type as case-expr. For character type, length differences
5112 are allowed, but the kind type parameters shall be the same. */
5114 if (case_expr->ts.type == BT_CHARACTER && e->ts.kind != case_expr->ts.kind)
5116 gfc_error("Expression in CASE statement at %L must be kind %d",
5117 &e->where, case_expr->ts.kind);
5121 /* Convert the case value kind to that of case expression kind, if needed.
5122 FIXME: Should a warning be issued? */
5123 if (e->ts.kind != case_expr->ts.kind)
5124 gfc_convert_type_warn (e, &case_expr->ts, 2, 0);
5128 gfc_error ("Expression in CASE statement at %L must be scalar",
5137 /* Given a completely parsed select statement, we:
5139 - Validate all expressions and code within the SELECT.
5140 - Make sure that the selection expression is not of the wrong type.
5141 - Make sure that no case ranges overlap.
5142 - Eliminate unreachable cases and unreachable code resulting from
5143 removing case labels.
5145 The standard does allow unreachable cases, e.g. CASE (5:3). But
5146 they are a hassle for code generation, and to prevent that, we just
5147 cut them out here. This is not necessary for overlapping cases
5148 because they are illegal and we never even try to generate code.
5150 We have the additional caveat that a SELECT construct could have
5151 been a computed GOTO in the source code. Fortunately we can fairly
5152 easily work around that here: The case_expr for a "real" SELECT CASE
5153 is in code->expr1, but for a computed GOTO it is in code->expr2. All
5154 we have to do is make sure that the case_expr is a scalar integer
5158 resolve_select (gfc_code *code)
5161 gfc_expr *case_expr;
5162 gfc_case *cp, *default_case, *tail, *head;
5163 int seen_unreachable;
5169 if (code->expr == NULL)
5171 /* This was actually a computed GOTO statement. */
5172 case_expr = code->expr2;
5173 if (case_expr->ts.type != BT_INTEGER|| case_expr->rank != 0)
5174 gfc_error ("Selection expression in computed GOTO statement "
5175 "at %L must be a scalar integer expression",
5178 /* Further checking is not necessary because this SELECT was built
5179 by the compiler, so it should always be OK. Just move the
5180 case_expr from expr2 to expr so that we can handle computed
5181 GOTOs as normal SELECTs from here on. */
5182 code->expr = code->expr2;
5187 case_expr = code->expr;
5189 type = case_expr->ts.type;
5190 if (type != BT_LOGICAL && type != BT_INTEGER && type != BT_CHARACTER)
5192 gfc_error ("Argument of SELECT statement at %L cannot be %s",
5193 &case_expr->where, gfc_typename (&case_expr->ts));
5195 /* Punt. Going on here just produce more garbage error messages. */
5199 if (case_expr->rank != 0)
5201 gfc_error ("Argument of SELECT statement at %L must be a scalar "
5202 "expression", &case_expr->where);
5208 /* PR 19168 has a long discussion concerning a mismatch of the kinds
5209 of the SELECT CASE expression and its CASE values. Walk the lists
5210 of case values, and if we find a mismatch, promote case_expr to
5211 the appropriate kind. */
5213 if (type == BT_LOGICAL || type == BT_INTEGER)
5215 for (body = code->block; body; body = body->block)
5217 /* Walk the case label list. */
5218 for (cp = body->ext.case_list; cp; cp = cp->next)
5220 /* Intercept the DEFAULT case. It does not have a kind. */
5221 if (cp->low == NULL && cp->high == NULL)
5224 /* Unreachable case ranges are discarded, so ignore. */
5225 if (cp->low != NULL && cp->high != NULL
5226 && cp->low != cp->high
5227 && gfc_compare_expr (cp->low, cp->high) > 0)
5230 /* FIXME: Should a warning be issued? */
5232 && case_expr->ts.kind != gfc_kind_max(case_expr, cp->low))
5233 gfc_convert_type_warn (case_expr, &cp->low->ts, 2, 0);
5235 if (cp->high != NULL
5236 && case_expr->ts.kind != gfc_kind_max(case_expr, cp->high))
5237 gfc_convert_type_warn (case_expr, &cp->high->ts, 2, 0);
5242 /* Assume there is no DEFAULT case. */
5243 default_case = NULL;
5248 for (body = code->block; body; body = body->block)
5250 /* Assume the CASE list is OK, and all CASE labels can be matched. */
5252 seen_unreachable = 0;
5254 /* Walk the case label list, making sure that all case labels
5256 for (cp = body->ext.case_list; cp; cp = cp->next)
5258 /* Count the number of cases in the whole construct. */
5261 /* Intercept the DEFAULT case. */
5262 if (cp->low == NULL && cp->high == NULL)
5264 if (default_case != NULL)
5266 gfc_error ("The DEFAULT CASE at %L cannot be followed "
5267 "by a second DEFAULT CASE at %L",
5268 &default_case->where, &cp->where);
5279 /* Deal with single value cases and case ranges. Errors are
5280 issued from the validation function. */
5281 if(validate_case_label_expr (cp->low, case_expr) != SUCCESS
5282 || validate_case_label_expr (cp->high, case_expr) != SUCCESS)
5288 if (type == BT_LOGICAL
5289 && ((cp->low == NULL || cp->high == NULL)
5290 || cp->low != cp->high))
5292 gfc_error ("Logical range in CASE statement at %L is not "
5293 "allowed", &cp->low->where);
5298 if (type == BT_LOGICAL && cp->low->expr_type == EXPR_CONSTANT)
5301 value = cp->low->value.logical == 0 ? 2 : 1;
5302 if (value & seen_logical)
5304 gfc_error ("constant logical value in CASE statement "
5305 "is repeated at %L",
5310 seen_logical |= value;
5313 if (cp->low != NULL && cp->high != NULL
5314 && cp->low != cp->high
5315 && gfc_compare_expr (cp->low, cp->high) > 0)
5317 if (gfc_option.warn_surprising)
5318 gfc_warning ("Range specification at %L can never "
5319 "be matched", &cp->where);
5321 cp->unreachable = 1;
5322 seen_unreachable = 1;
5326 /* If the case range can be matched, it can also overlap with
5327 other cases. To make sure it does not, we put it in a
5328 double linked list here. We sort that with a merge sort
5329 later on to detect any overlapping cases. */
5333 head->right = head->left = NULL;
5338 tail->right->left = tail;
5345 /* It there was a failure in the previous case label, give up
5346 for this case label list. Continue with the next block. */
5350 /* See if any case labels that are unreachable have been seen.
5351 If so, we eliminate them. This is a bit of a kludge because
5352 the case lists for a single case statement (label) is a
5353 single forward linked lists. */
5354 if (seen_unreachable)
5356 /* Advance until the first case in the list is reachable. */
5357 while (body->ext.case_list != NULL
5358 && body->ext.case_list->unreachable)
5360 gfc_case *n = body->ext.case_list;
5361 body->ext.case_list = body->ext.case_list->next;
5363 gfc_free_case_list (n);
5366 /* Strip all other unreachable cases. */
5367 if (body->ext.case_list)
5369 for (cp = body->ext.case_list; cp->next; cp = cp->next)
5371 if (cp->next->unreachable)
5373 gfc_case *n = cp->next;
5374 cp->next = cp->next->next;
5376 gfc_free_case_list (n);
5383 /* See if there were overlapping cases. If the check returns NULL,
5384 there was overlap. In that case we don't do anything. If head
5385 is non-NULL, we prepend the DEFAULT case. The sorted list can
5386 then used during code generation for SELECT CASE constructs with
5387 a case expression of a CHARACTER type. */
5390 head = check_case_overlap (head);
5392 /* Prepend the default_case if it is there. */
5393 if (head != NULL && default_case)
5395 default_case->left = NULL;
5396 default_case->right = head;
5397 head->left = default_case;
5401 /* Eliminate dead blocks that may be the result if we've seen
5402 unreachable case labels for a block. */
5403 for (body = code; body && body->block; body = body->block)
5405 if (body->block->ext.case_list == NULL)
5407 /* Cut the unreachable block from the code chain. */
5408 gfc_code *c = body->block;
5409 body->block = c->block;
5411 /* Kill the dead block, but not the blocks below it. */
5413 gfc_free_statements (c);
5417 /* More than two cases is legal but insane for logical selects.
5418 Issue a warning for it. */
5419 if (gfc_option.warn_surprising && type == BT_LOGICAL
5421 gfc_warning ("Logical SELECT CASE block at %L has more that two cases",
5426 /* Resolve a transfer statement. This is making sure that:
5427 -- a derived type being transferred has only non-pointer components
5428 -- a derived type being transferred doesn't have private components, unless
5429 it's being transferred from the module where the type was defined
5430 -- we're not trying to transfer a whole assumed size array. */
5433 resolve_transfer (gfc_code *code)
5442 if (exp->expr_type != EXPR_VARIABLE && exp->expr_type != EXPR_FUNCTION)
5445 sym = exp->symtree->n.sym;
5448 /* Go to actual component transferred. */
5449 for (ref = code->expr->ref; ref; ref = ref->next)
5450 if (ref->type == REF_COMPONENT)
5451 ts = &ref->u.c.component->ts;
5453 if (ts->type == BT_DERIVED)
5455 /* Check that transferred derived type doesn't contain POINTER
5457 if (ts->derived->attr.pointer_comp)
5459 gfc_error ("Data transfer element at %L cannot have "
5460 "POINTER components", &code->loc);
5464 if (ts->derived->attr.alloc_comp)
5466 gfc_error ("Data transfer element at %L cannot have "
5467 "ALLOCATABLE components", &code->loc);
5471 if (derived_inaccessible (ts->derived))
5473 gfc_error ("Data transfer element at %L cannot have "
5474 "PRIVATE components",&code->loc);
5479 if (sym->as != NULL && sym->as->type == AS_ASSUMED_SIZE
5480 && exp->ref->type == REF_ARRAY && exp->ref->u.ar.type == AR_FULL)
5482 gfc_error ("Data transfer element at %L cannot be a full reference to "
5483 "an assumed-size array", &code->loc);
5489 /*********** Toplevel code resolution subroutines ***********/
5491 /* Find the set of labels that are reachable from this block. We also
5492 record the last statement in each block so that we don't have to do
5493 a linear search to find the END DO statements of the blocks. */
5496 reachable_labels (gfc_code *block)
5503 cs_base->reachable_labels = bitmap_obstack_alloc (&labels_obstack);
5505 /* Collect labels in this block. */
5506 for (c = block; c; c = c->next)
5509 bitmap_set_bit (cs_base->reachable_labels, c->here->value);
5511 if (!c->next && cs_base->prev)
5512 cs_base->prev->tail = c;
5515 /* Merge with labels from parent block. */
5518 gcc_assert (cs_base->prev->reachable_labels);
5519 bitmap_ior_into (cs_base->reachable_labels,
5520 cs_base->prev->reachable_labels);
5524 /* Given a branch to a label and a namespace, if the branch is conforming.
5525 The code node describes where the branch is located. */
5528 resolve_branch (gfc_st_label *label, gfc_code *code)
5535 /* Step one: is this a valid branching target? */
5537 if (label->defined == ST_LABEL_UNKNOWN)
5539 gfc_error ("Label %d referenced at %L is never defined", label->value,
5544 if (label->defined != ST_LABEL_TARGET)
5546 gfc_error ("Statement at %L is not a valid branch target statement "
5547 "for the branch statement at %L", &label->where, &code->loc);
5551 /* Step two: make sure this branch is not a branch to itself ;-) */
5553 if (code->here == label)
5555 gfc_warning ("Branch at %L causes an infinite loop", &code->loc);
5559 /* Step three: See if the label is in the same block as the
5560 branching statement. The hard work has been done by setting up
5561 the bitmap reachable_labels. */
5563 if (!bitmap_bit_p (cs_base->reachable_labels, label->value))
5565 /* The label is not in an enclosing block, so illegal. This was
5566 allowed in Fortran 66, so we allow it as extension. No
5567 further checks are necessary in this case. */
5568 gfc_notify_std (GFC_STD_LEGACY, "Label at %L is not in the same block "
5569 "as the GOTO statement at %L", &label->where,
5574 /* Step four: Make sure that the branching target is legal if
5575 the statement is an END {SELECT,IF}. */
5577 for (stack = cs_base; stack; stack = stack->prev)
5578 if (stack->current->next && stack->current->next->here == label)
5581 if (stack && stack->current->next->op == EXEC_NOP)
5583 gfc_notify_std (GFC_STD_F95_DEL, "Deleted feature: GOTO at %L jumps to "
5584 "END of construct at %L", &code->loc,
5585 &stack->current->next->loc);
5586 return; /* We know this is not an END DO. */
5589 /* Step five: Make sure that we're not jumping to the end of a DO
5590 loop from within the loop. */
5592 for (stack = cs_base; stack; stack = stack->prev)
5593 if ((stack->current->op == EXEC_DO
5594 || stack->current->op == EXEC_DO_WHILE)
5595 && stack->tail->here == label && stack->tail->op == EXEC_NOP)
5597 gfc_notify_std (GFC_STD_F95_DEL, "Deleted feature: GOTO at %L jumps "
5598 "to END of construct at %L", &code->loc,
5606 /* Check whether EXPR1 has the same shape as EXPR2. */
5609 resolve_where_shape (gfc_expr *expr1, gfc_expr *expr2)
5611 mpz_t shape[GFC_MAX_DIMENSIONS];
5612 mpz_t shape2[GFC_MAX_DIMENSIONS];
5613 try result = FAILURE;
5616 /* Compare the rank. */
5617 if (expr1->rank != expr2->rank)
5620 /* Compare the size of each dimension. */
5621 for (i=0; i<expr1->rank; i++)
5623 if (gfc_array_dimen_size (expr1, i, &shape[i]) == FAILURE)
5626 if (gfc_array_dimen_size (expr2, i, &shape2[i]) == FAILURE)
5629 if (mpz_cmp (shape[i], shape2[i]))
5633 /* When either of the two expression is an assumed size array, we
5634 ignore the comparison of dimension sizes. */
5639 for (i--; i >= 0; i--)
5641 mpz_clear (shape[i]);
5642 mpz_clear (shape2[i]);
5648 /* Check whether a WHERE assignment target or a WHERE mask expression
5649 has the same shape as the outmost WHERE mask expression. */
5652 resolve_where (gfc_code *code, gfc_expr *mask)
5658 cblock = code->block;
5660 /* Store the first WHERE mask-expr of the WHERE statement or construct.
5661 In case of nested WHERE, only the outmost one is stored. */
5662 if (mask == NULL) /* outmost WHERE */
5664 else /* inner WHERE */
5671 /* Check if the mask-expr has a consistent shape with the
5672 outmost WHERE mask-expr. */
5673 if (resolve_where_shape (cblock->expr, e) == FAILURE)
5674 gfc_error ("WHERE mask at %L has inconsistent shape",
5675 &cblock->expr->where);
5678 /* the assignment statement of a WHERE statement, or the first
5679 statement in where-body-construct of a WHERE construct */
5680 cnext = cblock->next;
5685 /* WHERE assignment statement */
5688 /* Check shape consistent for WHERE assignment target. */
5689 if (e && resolve_where_shape (cnext->expr, e) == FAILURE)
5690 gfc_error ("WHERE assignment target at %L has "
5691 "inconsistent shape", &cnext->expr->where);
5695 case EXEC_ASSIGN_CALL:
5696 resolve_call (cnext);
5699 /* WHERE or WHERE construct is part of a where-body-construct */
5701 resolve_where (cnext, e);
5705 gfc_error ("Unsupported statement inside WHERE at %L",
5708 /* the next statement within the same where-body-construct */
5709 cnext = cnext->next;
5711 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
5712 cblock = cblock->block;
5717 /* Resolve assignment in FORALL construct.
5718 NVAR is the number of FORALL index variables, and VAR_EXPR records the
5719 FORALL index variables. */
5722 gfc_resolve_assign_in_forall (gfc_code *code, int nvar, gfc_expr **var_expr)
5726 for (n = 0; n < nvar; n++)
5728 gfc_symbol *forall_index;
5730 forall_index = var_expr[n]->symtree->n.sym;
5732 /* Check whether the assignment target is one of the FORALL index
5734 if ((code->expr->expr_type == EXPR_VARIABLE)
5735 && (code->expr->symtree->n.sym == forall_index))
5736 gfc_error ("Assignment to a FORALL index variable at %L",
5737 &code->expr->where);
5740 /* If one of the FORALL index variables doesn't appear in the
5741 assignment target, then there will be a many-to-one
5743 if (find_forall_index (code->expr, forall_index) == FAILURE)
5744 gfc_error ("The FORALL with index '%s' cause more than one "
5745 "assignment to this object at %L",
5746 var_expr[n]->symtree->name, &code->expr->where);
5752 /* Resolve WHERE statement in FORALL construct. */
5755 gfc_resolve_where_code_in_forall (gfc_code *code, int nvar,
5756 gfc_expr **var_expr)
5761 cblock = code->block;
5764 /* the assignment statement of a WHERE statement, or the first
5765 statement in where-body-construct of a WHERE construct */
5766 cnext = cblock->next;
5771 /* WHERE assignment statement */
5773 gfc_resolve_assign_in_forall (cnext, nvar, var_expr);
5776 /* WHERE operator assignment statement */
5777 case EXEC_ASSIGN_CALL:
5778 resolve_call (cnext);
5781 /* WHERE or WHERE construct is part of a where-body-construct */
5783 gfc_resolve_where_code_in_forall (cnext, nvar, var_expr);
5787 gfc_error ("Unsupported statement inside WHERE at %L",
5790 /* the next statement within the same where-body-construct */
5791 cnext = cnext->next;
5793 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
5794 cblock = cblock->block;
5799 /* Traverse the FORALL body to check whether the following errors exist:
5800 1. For assignment, check if a many-to-one assignment happens.
5801 2. For WHERE statement, check the WHERE body to see if there is any
5802 many-to-one assignment. */
5805 gfc_resolve_forall_body (gfc_code *code, int nvar, gfc_expr **var_expr)
5809 c = code->block->next;
5815 case EXEC_POINTER_ASSIGN:
5816 gfc_resolve_assign_in_forall (c, nvar, var_expr);
5819 case EXEC_ASSIGN_CALL:
5823 /* Because the gfc_resolve_blocks() will handle the nested FORALL,
5824 there is no need to handle it here. */
5828 gfc_resolve_where_code_in_forall(c, nvar, var_expr);
5833 /* The next statement in the FORALL body. */
5839 /* Given a FORALL construct, first resolve the FORALL iterator, then call
5840 gfc_resolve_forall_body to resolve the FORALL body. */
5843 gfc_resolve_forall (gfc_code *code, gfc_namespace *ns, int forall_save)
5845 static gfc_expr **var_expr;
5846 static int total_var = 0;
5847 static int nvar = 0;
5848 gfc_forall_iterator *fa;
5852 /* Start to resolve a FORALL construct */
5853 if (forall_save == 0)
5855 /* Count the total number of FORALL index in the nested FORALL
5856 construct in order to allocate the VAR_EXPR with proper size. */
5858 while ((next != NULL) && (next->op == EXEC_FORALL))
5860 for (fa = next->ext.forall_iterator; fa; fa = fa->next)
5862 next = next->block->next;
5865 /* Allocate VAR_EXPR with NUMBER_OF_FORALL_INDEX elements. */
5866 var_expr = (gfc_expr **) gfc_getmem (total_var * sizeof (gfc_expr *));
5869 /* The information about FORALL iterator, including FORALL index start, end
5870 and stride. The FORALL index can not appear in start, end or stride. */
5871 for (fa = code->ext.forall_iterator; fa; fa = fa->next)
5873 /* Check if any outer FORALL index name is the same as the current
5875 for (i = 0; i < nvar; i++)
5877 if (fa->var->symtree->n.sym == var_expr[i]->symtree->n.sym)
5879 gfc_error ("An outer FORALL construct already has an index "
5880 "with this name %L", &fa->var->where);
5884 /* Record the current FORALL index. */
5885 var_expr[nvar] = gfc_copy_expr (fa->var);
5890 /* Resolve the FORALL body. */
5891 gfc_resolve_forall_body (code, nvar, var_expr);
5893 /* May call gfc_resolve_forall to resolve the inner FORALL loop. */
5894 gfc_resolve_blocks (code->block, ns);
5896 /* Free VAR_EXPR after the whole FORALL construct resolved. */
5897 for (i = 0; i < total_var; i++)
5898 gfc_free_expr (var_expr[i]);
5900 /* Reset the counters. */
5906 /* Resolve lists of blocks found in IF, SELECT CASE, WHERE, FORALL ,GOTO and
5909 static void resolve_code (gfc_code *, gfc_namespace *);
5912 gfc_resolve_blocks (gfc_code *b, gfc_namespace *ns)
5916 for (; b; b = b->block)
5918 t = gfc_resolve_expr (b->expr);
5919 if (gfc_resolve_expr (b->expr2) == FAILURE)
5925 if (t == SUCCESS && b->expr != NULL
5926 && (b->expr->ts.type != BT_LOGICAL || b->expr->rank != 0))
5927 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
5934 && (b->expr->ts.type != BT_LOGICAL || b->expr->rank == 0))
5935 gfc_error ("WHERE/ELSEWHERE clause at %L requires a LOGICAL array",
5940 resolve_branch (b->label, b);
5952 case EXEC_OMP_ATOMIC:
5953 case EXEC_OMP_CRITICAL:
5955 case EXEC_OMP_MASTER:
5956 case EXEC_OMP_ORDERED:
5957 case EXEC_OMP_PARALLEL:
5958 case EXEC_OMP_PARALLEL_DO:
5959 case EXEC_OMP_PARALLEL_SECTIONS:
5960 case EXEC_OMP_PARALLEL_WORKSHARE:
5961 case EXEC_OMP_SECTIONS:
5962 case EXEC_OMP_SINGLE:
5963 case EXEC_OMP_WORKSHARE:
5967 gfc_internal_error ("resolve_block(): Bad block type");
5970 resolve_code (b->next, ns);
5975 /* Given a block of code, recursively resolve everything pointed to by this
5979 resolve_code (gfc_code *code, gfc_namespace *ns)
5981 int omp_workshare_save;
5987 frame.prev = cs_base;
5991 reachable_labels (code);
5993 for (; code; code = code->next)
5995 frame.current = code;
5996 forall_save = forall_flag;
5998 if (code->op == EXEC_FORALL)
6001 gfc_resolve_forall (code, ns, forall_save);
6004 else if (code->block)
6006 omp_workshare_save = -1;
6009 case EXEC_OMP_PARALLEL_WORKSHARE:
6010 omp_workshare_save = omp_workshare_flag;
6011 omp_workshare_flag = 1;
6012 gfc_resolve_omp_parallel_blocks (code, ns);
6014 case EXEC_OMP_PARALLEL:
6015 case EXEC_OMP_PARALLEL_DO:
6016 case EXEC_OMP_PARALLEL_SECTIONS:
6017 omp_workshare_save = omp_workshare_flag;
6018 omp_workshare_flag = 0;
6019 gfc_resolve_omp_parallel_blocks (code, ns);
6022 gfc_resolve_omp_do_blocks (code, ns);
6024 case EXEC_OMP_WORKSHARE:
6025 omp_workshare_save = omp_workshare_flag;
6026 omp_workshare_flag = 1;
6029 gfc_resolve_blocks (code->block, ns);
6033 if (omp_workshare_save != -1)
6034 omp_workshare_flag = omp_workshare_save;
6037 t = gfc_resolve_expr (code->expr);
6038 forall_flag = forall_save;
6040 if (gfc_resolve_expr (code->expr2) == FAILURE)
6055 /* Keep track of which entry we are up to. */
6056 current_entry_id = code->ext.entry->id;
6060 resolve_where (code, NULL);
6064 if (code->expr != NULL)
6066 if (code->expr->ts.type != BT_INTEGER)
6067 gfc_error ("ASSIGNED GOTO statement at %L requires an "
6068 "INTEGER variable", &code->expr->where);
6069 else if (code->expr->symtree->n.sym->attr.assign != 1)
6070 gfc_error ("Variable '%s' has not been assigned a target "
6071 "label at %L", code->expr->symtree->n.sym->name,
6072 &code->expr->where);
6075 resolve_branch (code->label, code);
6079 if (code->expr != NULL
6080 && (code->expr->ts.type != BT_INTEGER || code->expr->rank))
6081 gfc_error ("Alternate RETURN statement at %L requires a SCALAR-"
6082 "INTEGER return specifier", &code->expr->where);
6085 case EXEC_INIT_ASSIGN:
6092 if (gfc_extend_assign (code, ns) == SUCCESS)
6094 gfc_expr *lhs = code->ext.actual->expr;
6095 gfc_expr *rhs = code->ext.actual->next->expr;
6097 if (gfc_pure (NULL) && !gfc_pure (code->symtree->n.sym))
6099 gfc_error ("Subroutine '%s' called instead of assignment at "
6100 "%L must be PURE", code->symtree->n.sym->name,
6105 /* Make a temporary rhs when there is a default initializer
6106 and rhs is the same symbol as the lhs. */
6107 if (rhs->expr_type == EXPR_VARIABLE
6108 && rhs->symtree->n.sym->ts.type == BT_DERIVED
6109 && has_default_initializer (rhs->symtree->n.sym->ts.derived)
6110 && (lhs->symtree->n.sym == rhs->symtree->n.sym))
6111 code->ext.actual->next->expr = gfc_get_parentheses (rhs);
6116 if (code->expr->ts.type == BT_CHARACTER
6117 && gfc_option.warn_character_truncation)
6119 int llen = 0, rlen = 0;
6121 if (code->expr->ts.cl != NULL
6122 && code->expr->ts.cl->length != NULL
6123 && code->expr->ts.cl->length->expr_type == EXPR_CONSTANT)
6124 llen = mpz_get_si (code->expr->ts.cl->length->value.integer);
6126 if (code->expr2->expr_type == EXPR_CONSTANT)
6127 rlen = code->expr2->value.character.length;
6129 else if (code->expr2->ts.cl != NULL
6130 && code->expr2->ts.cl->length != NULL
6131 && code->expr2->ts.cl->length->expr_type
6133 rlen = mpz_get_si (code->expr2->ts.cl->length->value.integer);
6135 if (rlen && llen && rlen > llen)
6136 gfc_warning_now ("CHARACTER expression will be truncated "
6137 "in assignment (%d/%d) at %L",
6138 llen, rlen, &code->loc);
6141 if (gfc_pure (NULL))
6143 if (gfc_impure_variable (code->expr->symtree->n.sym))
6145 gfc_error ("Cannot assign to variable '%s' in PURE "
6147 code->expr->symtree->n.sym->name,
6148 &code->expr->where);
6152 if (code->expr->ts.type == BT_DERIVED
6153 && code->expr->expr_type == EXPR_VARIABLE
6154 && code->expr->ts.derived->attr.pointer_comp
6155 && gfc_impure_variable (code->expr2->symtree->n.sym))
6157 gfc_error ("The impure variable at %L is assigned to "
6158 "a derived type variable with a POINTER "
6159 "component in a PURE procedure (12.6)",
6160 &code->expr2->where);
6165 gfc_check_assign (code->expr, code->expr2, 1);
6168 case EXEC_LABEL_ASSIGN:
6169 if (code->label->defined == ST_LABEL_UNKNOWN)
6170 gfc_error ("Label %d referenced at %L is never defined",
6171 code->label->value, &code->label->where);
6173 && (code->expr->expr_type != EXPR_VARIABLE
6174 || code->expr->symtree->n.sym->ts.type != BT_INTEGER
6175 || code->expr->symtree->n.sym->ts.kind
6176 != gfc_default_integer_kind
6177 || code->expr->symtree->n.sym->as != NULL))
6178 gfc_error ("ASSIGN statement at %L requires a scalar "
6179 "default INTEGER variable", &code->expr->where);
6182 case EXEC_POINTER_ASSIGN:
6186 gfc_check_pointer_assign (code->expr, code->expr2);
6189 case EXEC_ARITHMETIC_IF:
6191 && code->expr->ts.type != BT_INTEGER
6192 && code->expr->ts.type != BT_REAL)
6193 gfc_error ("Arithmetic IF statement at %L requires a numeric "
6194 "expression", &code->expr->where);
6196 resolve_branch (code->label, code);
6197 resolve_branch (code->label2, code);
6198 resolve_branch (code->label3, code);
6202 if (t == SUCCESS && code->expr != NULL
6203 && (code->expr->ts.type != BT_LOGICAL
6204 || code->expr->rank != 0))
6205 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
6206 &code->expr->where);
6211 resolve_call (code);
6215 /* Select is complicated. Also, a SELECT construct could be
6216 a transformed computed GOTO. */
6217 resolve_select (code);
6221 if (code->ext.iterator != NULL)
6223 gfc_iterator *iter = code->ext.iterator;
6224 if (gfc_resolve_iterator (iter, true) != FAILURE)
6225 gfc_resolve_do_iterator (code, iter->var->symtree->n.sym);
6230 if (code->expr == NULL)
6231 gfc_internal_error ("resolve_code(): No expression on DO WHILE");
6233 && (code->expr->rank != 0
6234 || code->expr->ts.type != BT_LOGICAL))
6235 gfc_error ("Exit condition of DO WHILE loop at %L must be "
6236 "a scalar LOGICAL expression", &code->expr->where);
6240 if (t == SUCCESS && code->expr != NULL
6241 && code->expr->ts.type != BT_INTEGER)
6242 gfc_error ("STAT tag in ALLOCATE statement at %L must be "
6243 "of type INTEGER", &code->expr->where);
6245 for (a = code->ext.alloc_list; a; a = a->next)
6246 resolve_allocate_expr (a->expr, code);
6250 case EXEC_DEALLOCATE:
6251 if (t == SUCCESS && code->expr != NULL
6252 && code->expr->ts.type != BT_INTEGER)
6254 ("STAT tag in DEALLOCATE statement at %L must be of type "
6255 "INTEGER", &code->expr->where);
6257 for (a = code->ext.alloc_list; a; a = a->next)
6258 resolve_deallocate_expr (a->expr);
6263 if (gfc_resolve_open (code->ext.open) == FAILURE)
6266 resolve_branch (code->ext.open->err, code);
6270 if (gfc_resolve_close (code->ext.close) == FAILURE)
6273 resolve_branch (code->ext.close->err, code);
6276 case EXEC_BACKSPACE:
6280 if (gfc_resolve_filepos (code->ext.filepos) == FAILURE)
6283 resolve_branch (code->ext.filepos->err, code);
6287 if (gfc_resolve_inquire (code->ext.inquire) == FAILURE)
6290 resolve_branch (code->ext.inquire->err, code);
6294 gcc_assert (code->ext.inquire != NULL);
6295 if (gfc_resolve_inquire (code->ext.inquire) == FAILURE)
6298 resolve_branch (code->ext.inquire->err, code);
6303 if (gfc_resolve_dt (code->ext.dt) == FAILURE)
6306 resolve_branch (code->ext.dt->err, code);
6307 resolve_branch (code->ext.dt->end, code);
6308 resolve_branch (code->ext.dt->eor, code);
6312 resolve_transfer (code);
6316 resolve_forall_iterators (code->ext.forall_iterator);
6318 if (code->expr != NULL && code->expr->ts.type != BT_LOGICAL)
6319 gfc_error ("FORALL mask clause at %L requires a LOGICAL "
6320 "expression", &code->expr->where);
6323 case EXEC_OMP_ATOMIC:
6324 case EXEC_OMP_BARRIER:
6325 case EXEC_OMP_CRITICAL:
6326 case EXEC_OMP_FLUSH:
6328 case EXEC_OMP_MASTER:
6329 case EXEC_OMP_ORDERED:
6330 case EXEC_OMP_SECTIONS:
6331 case EXEC_OMP_SINGLE:
6332 case EXEC_OMP_WORKSHARE:
6333 gfc_resolve_omp_directive (code, ns);
6336 case EXEC_OMP_PARALLEL:
6337 case EXEC_OMP_PARALLEL_DO:
6338 case EXEC_OMP_PARALLEL_SECTIONS:
6339 case EXEC_OMP_PARALLEL_WORKSHARE:
6340 omp_workshare_save = omp_workshare_flag;
6341 omp_workshare_flag = 0;
6342 gfc_resolve_omp_directive (code, ns);
6343 omp_workshare_flag = omp_workshare_save;
6347 gfc_internal_error ("resolve_code(): Bad statement code");
6351 cs_base = frame.prev;
6355 /* Resolve initial values and make sure they are compatible with
6359 resolve_values (gfc_symbol *sym)
6361 if (sym->value == NULL)
6364 if (gfc_resolve_expr (sym->value) == FAILURE)
6367 gfc_check_assign_symbol (sym, sym->value);
6371 /* Verify the binding labels for common blocks that are BIND(C). The label
6372 for a BIND(C) common block must be identical in all scoping units in which
6373 the common block is declared. Further, the binding label can not collide
6374 with any other global entity in the program. */
6377 resolve_bind_c_comms (gfc_symtree *comm_block_tree)
6379 if (comm_block_tree->n.common->is_bind_c == 1)
6381 gfc_gsymbol *binding_label_gsym;
6382 gfc_gsymbol *comm_name_gsym;
6384 /* See if a global symbol exists by the common block's name. It may
6385 be NULL if the common block is use-associated. */
6386 comm_name_gsym = gfc_find_gsymbol (gfc_gsym_root,
6387 comm_block_tree->n.common->name);
6388 if (comm_name_gsym != NULL && comm_name_gsym->type != GSYM_COMMON)
6389 gfc_error ("Binding label '%s' for common block '%s' at %L collides "
6390 "with the global entity '%s' at %L",
6391 comm_block_tree->n.common->binding_label,
6392 comm_block_tree->n.common->name,
6393 &(comm_block_tree->n.common->where),
6394 comm_name_gsym->name, &(comm_name_gsym->where));
6395 else if (comm_name_gsym != NULL
6396 && strcmp (comm_name_gsym->name,
6397 comm_block_tree->n.common->name) == 0)
6399 /* TODO: Need to make sure the fields of gfc_gsymbol are initialized
6401 if (comm_name_gsym->binding_label == NULL)
6402 /* No binding label for common block stored yet; save this one. */
6403 comm_name_gsym->binding_label =
6404 comm_block_tree->n.common->binding_label;
6406 if (strcmp (comm_name_gsym->binding_label,
6407 comm_block_tree->n.common->binding_label) != 0)
6409 /* Common block names match but binding labels do not. */
6410 gfc_error ("Binding label '%s' for common block '%s' at %L "
6411 "does not match the binding label '%s' for common "
6413 comm_block_tree->n.common->binding_label,
6414 comm_block_tree->n.common->name,
6415 &(comm_block_tree->n.common->where),
6416 comm_name_gsym->binding_label,
6417 comm_name_gsym->name,
6418 &(comm_name_gsym->where));
6423 /* There is no binding label (NAME="") so we have nothing further to
6424 check and nothing to add as a global symbol for the label. */
6425 if (comm_block_tree->n.common->binding_label[0] == '\0' )
6428 binding_label_gsym =
6429 gfc_find_gsymbol (gfc_gsym_root,
6430 comm_block_tree->n.common->binding_label);
6431 if (binding_label_gsym == NULL)
6433 /* Need to make a global symbol for the binding label to prevent
6434 it from colliding with another. */
6435 binding_label_gsym =
6436 gfc_get_gsymbol (comm_block_tree->n.common->binding_label);
6437 binding_label_gsym->sym_name = comm_block_tree->n.common->name;
6438 binding_label_gsym->type = GSYM_COMMON;
6442 /* If comm_name_gsym is NULL, the name common block is use
6443 associated and the name could be colliding. */
6444 if (binding_label_gsym->type != GSYM_COMMON)
6445 gfc_error ("Binding label '%s' for common block '%s' at %L "
6446 "collides with the global entity '%s' at %L",
6447 comm_block_tree->n.common->binding_label,
6448 comm_block_tree->n.common->name,
6449 &(comm_block_tree->n.common->where),
6450 binding_label_gsym->name,
6451 &(binding_label_gsym->where));
6452 else if (comm_name_gsym != NULL
6453 && (strcmp (binding_label_gsym->name,
6454 comm_name_gsym->binding_label) != 0)
6455 && (strcmp (binding_label_gsym->sym_name,
6456 comm_name_gsym->name) != 0))
6457 gfc_error ("Binding label '%s' for common block '%s' at %L "
6458 "collides with global entity '%s' at %L",
6459 binding_label_gsym->name, binding_label_gsym->sym_name,
6460 &(comm_block_tree->n.common->where),
6461 comm_name_gsym->name, &(comm_name_gsym->where));
6469 /* Verify any BIND(C) derived types in the namespace so we can report errors
6470 for them once, rather than for each variable declared of that type. */
6473 resolve_bind_c_derived_types (gfc_symbol *derived_sym)
6475 if (derived_sym != NULL && derived_sym->attr.flavor == FL_DERIVED
6476 && derived_sym->attr.is_bind_c == 1)
6477 verify_bind_c_derived_type (derived_sym);
6483 /* Verify that any binding labels used in a given namespace do not collide
6484 with the names or binding labels of any global symbols. */
6487 gfc_verify_binding_labels (gfc_symbol *sym)
6491 if (sym != NULL && sym->attr.is_bind_c && sym->attr.is_iso_c == 0
6492 && sym->attr.flavor != FL_DERIVED && sym->binding_label[0] != '\0')
6494 gfc_gsymbol *bind_c_sym;
6496 bind_c_sym = gfc_find_gsymbol (gfc_gsym_root, sym->binding_label);
6497 if (bind_c_sym != NULL
6498 && strcmp (bind_c_sym->name, sym->binding_label) == 0)
6500 if (sym->attr.if_source == IFSRC_DECL
6501 && (bind_c_sym->type != GSYM_SUBROUTINE
6502 && bind_c_sym->type != GSYM_FUNCTION)
6503 && ((sym->attr.contained == 1
6504 && strcmp (bind_c_sym->sym_name, sym->name) != 0)
6505 || (sym->attr.use_assoc == 1
6506 && (strcmp (bind_c_sym->mod_name, sym->module) != 0))))
6508 /* Make sure global procedures don't collide with anything. */
6509 gfc_error ("Binding label '%s' at %L collides with the global "
6510 "entity '%s' at %L", sym->binding_label,
6511 &(sym->declared_at), bind_c_sym->name,
6512 &(bind_c_sym->where));
6515 else if (sym->attr.contained == 0
6516 && (sym->attr.if_source == IFSRC_IFBODY
6517 && sym->attr.flavor == FL_PROCEDURE)
6518 && (bind_c_sym->sym_name != NULL
6519 && strcmp (bind_c_sym->sym_name, sym->name) != 0))
6521 /* Make sure procedures in interface bodies don't collide. */
6522 gfc_error ("Binding label '%s' in interface body at %L collides "
6523 "with the global entity '%s' at %L",
6525 &(sym->declared_at), bind_c_sym->name,
6526 &(bind_c_sym->where));
6529 else if (sym->attr.contained == 0
6530 && (sym->attr.if_source == IFSRC_UNKNOWN))
6531 if ((sym->attr.use_assoc
6532 && (strcmp (bind_c_sym->mod_name, sym->module) != 0))
6533 || sym->attr.use_assoc == 0)
6535 gfc_error ("Binding label '%s' at %L collides with global "
6536 "entity '%s' at %L", sym->binding_label,
6537 &(sym->declared_at), bind_c_sym->name,
6538 &(bind_c_sym->where));
6543 /* Clear the binding label to prevent checking multiple times. */
6544 sym->binding_label[0] = '\0';
6546 else if (bind_c_sym == NULL)
6548 bind_c_sym = gfc_get_gsymbol (sym->binding_label);
6549 bind_c_sym->where = sym->declared_at;
6550 bind_c_sym->sym_name = sym->name;
6552 if (sym->attr.use_assoc == 1)
6553 bind_c_sym->mod_name = sym->module;
6555 if (sym->ns->proc_name != NULL)
6556 bind_c_sym->mod_name = sym->ns->proc_name->name;
6558 if (sym->attr.contained == 0)
6560 if (sym->attr.subroutine)
6561 bind_c_sym->type = GSYM_SUBROUTINE;
6562 else if (sym->attr.function)
6563 bind_c_sym->type = GSYM_FUNCTION;
6571 /* Resolve an index expression. */
6574 resolve_index_expr (gfc_expr *e)
6576 if (gfc_resolve_expr (e) == FAILURE)
6579 if (gfc_simplify_expr (e, 0) == FAILURE)
6582 if (gfc_specification_expr (e) == FAILURE)
6588 /* Resolve a charlen structure. */
6591 resolve_charlen (gfc_charlen *cl)
6600 specification_expr = 1;
6602 if (resolve_index_expr (cl->length) == FAILURE)
6604 specification_expr = 0;
6608 /* "If the character length parameter value evaluates to a negative
6609 value, the length of character entities declared is zero." */
6610 if (cl->length && !gfc_extract_int (cl->length, &i) && i < 0)
6612 gfc_warning_now ("CHARACTER variable has zero length at %L",
6613 &cl->length->where);
6614 gfc_replace_expr (cl->length, gfc_int_expr (0));
6621 /* Test for non-constant shape arrays. */
6624 is_non_constant_shape_array (gfc_symbol *sym)
6630 not_constant = false;
6631 if (sym->as != NULL)
6633 /* Unfortunately, !gfc_is_compile_time_shape hits a legal case that
6634 has not been simplified; parameter array references. Do the
6635 simplification now. */
6636 for (i = 0; i < sym->as->rank; i++)
6638 e = sym->as->lower[i];
6639 if (e && (resolve_index_expr (e) == FAILURE
6640 || !gfc_is_constant_expr (e)))
6641 not_constant = true;
6643 e = sym->as->upper[i];
6644 if (e && (resolve_index_expr (e) == FAILURE
6645 || !gfc_is_constant_expr (e)))
6646 not_constant = true;
6649 return not_constant;
6652 /* Given a symbol and an initialization expression, add code to initialize
6653 the symbol to the function entry. */
6655 build_init_assign (gfc_symbol *sym, gfc_expr *init)
6659 gfc_namespace *ns = sym->ns;
6661 /* Search for the function namespace if this is a contained
6662 function without an explicit result. */
6663 if (sym->attr.function && sym == sym->result
6664 && sym->name != sym->ns->proc_name->name)
6667 for (;ns; ns = ns->sibling)
6668 if (strcmp (ns->proc_name->name, sym->name) == 0)
6674 gfc_free_expr (init);
6678 /* Build an l-value expression for the result. */
6679 lval = gfc_lval_expr_from_sym (sym);
6681 /* Add the code at scope entry. */
6682 init_st = gfc_get_code ();
6683 init_st->next = ns->code;
6686 /* Assign the default initializer to the l-value. */
6687 init_st->loc = sym->declared_at;
6688 init_st->op = EXEC_INIT_ASSIGN;
6689 init_st->expr = lval;
6690 init_st->expr2 = init;
6693 /* Assign the default initializer to a derived type variable or result. */
6696 apply_default_init (gfc_symbol *sym)
6698 gfc_expr *init = NULL;
6700 if (sym->attr.flavor != FL_VARIABLE && !sym->attr.function)
6703 if (sym->ts.type == BT_DERIVED && sym->ts.derived)
6704 init = gfc_default_initializer (&sym->ts);
6709 build_init_assign (sym, init);
6712 /* Build an initializer for a local integer, real, complex, logical, or
6713 character variable, based on the command line flags finit-local-zero,
6714 finit-integer=, finit-real=, finit-logical=, and finit-runtime. Returns
6715 null if the symbol should not have a default initialization. */
6717 build_default_init_expr (gfc_symbol *sym)
6720 gfc_expr *init_expr;
6724 /* These symbols should never have a default initialization. */
6725 if ((sym->attr.dimension && !gfc_is_compile_time_shape (sym->as))
6726 || sym->attr.external
6728 || sym->attr.pointer
6729 || sym->attr.in_equivalence
6730 || sym->attr.in_common
6733 || sym->attr.cray_pointee
6734 || sym->attr.cray_pointer)
6737 /* Now we'll try to build an initializer expression. */
6738 init_expr = gfc_get_expr ();
6739 init_expr->expr_type = EXPR_CONSTANT;
6740 init_expr->ts.type = sym->ts.type;
6741 init_expr->ts.kind = sym->ts.kind;
6742 init_expr->where = sym->declared_at;
6744 /* We will only initialize integers, reals, complex, logicals, and
6745 characters, and only if the corresponding command-line flags
6746 were set. Otherwise, we free init_expr and return null. */
6747 switch (sym->ts.type)
6750 if (gfc_option.flag_init_integer != GFC_INIT_INTEGER_OFF)
6751 mpz_init_set_si (init_expr->value.integer,
6752 gfc_option.flag_init_integer_value);
6755 gfc_free_expr (init_expr);
6761 mpfr_init (init_expr->value.real);
6762 switch (gfc_option.flag_init_real)
6764 case GFC_INIT_REAL_NAN:
6765 mpfr_set_nan (init_expr->value.real);
6768 case GFC_INIT_REAL_INF:
6769 mpfr_set_inf (init_expr->value.real, 1);
6772 case GFC_INIT_REAL_NEG_INF:
6773 mpfr_set_inf (init_expr->value.real, -1);
6776 case GFC_INIT_REAL_ZERO:
6777 mpfr_set_ui (init_expr->value.real, 0.0, GFC_RND_MODE);
6781 gfc_free_expr (init_expr);
6788 mpfr_init (init_expr->value.complex.r);
6789 mpfr_init (init_expr->value.complex.i);
6790 switch (gfc_option.flag_init_real)
6792 case GFC_INIT_REAL_NAN:
6793 mpfr_set_nan (init_expr->value.complex.r);
6794 mpfr_set_nan (init_expr->value.complex.i);
6797 case GFC_INIT_REAL_INF:
6798 mpfr_set_inf (init_expr->value.complex.r, 1);
6799 mpfr_set_inf (init_expr->value.complex.i, 1);
6802 case GFC_INIT_REAL_NEG_INF:
6803 mpfr_set_inf (init_expr->value.complex.r, -1);
6804 mpfr_set_inf (init_expr->value.complex.i, -1);
6807 case GFC_INIT_REAL_ZERO:
6808 mpfr_set_ui (init_expr->value.complex.r, 0.0, GFC_RND_MODE);
6809 mpfr_set_ui (init_expr->value.complex.i, 0.0, GFC_RND_MODE);
6813 gfc_free_expr (init_expr);
6820 if (gfc_option.flag_init_logical == GFC_INIT_LOGICAL_FALSE)
6821 init_expr->value.logical = 0;
6822 else if (gfc_option.flag_init_logical == GFC_INIT_LOGICAL_TRUE)
6823 init_expr->value.logical = 1;
6826 gfc_free_expr (init_expr);
6832 /* For characters, the length must be constant in order to
6833 create a default initializer. */
6834 if (gfc_option.flag_init_character == GFC_INIT_CHARACTER_ON
6835 && sym->ts.cl->length
6836 && sym->ts.cl->length->expr_type == EXPR_CONSTANT)
6838 char_len = mpz_get_si (sym->ts.cl->length->value.integer);
6839 init_expr->value.character.length = char_len;
6840 init_expr->value.character.string = gfc_getmem (char_len+1);
6841 ch = init_expr->value.character.string;
6842 for (i = 0; i < char_len; i++)
6843 *(ch++) = gfc_option.flag_init_character_value;
6847 gfc_free_expr (init_expr);
6853 gfc_free_expr (init_expr);
6859 /* Add an initialization expression to a local variable. */
6861 apply_default_init_local (gfc_symbol *sym)
6863 gfc_expr *init = NULL;
6865 /* The symbol should be a variable or a function return value. */
6866 if ((sym->attr.flavor != FL_VARIABLE && !sym->attr.function)
6867 || (sym->attr.function && sym->result != sym))
6870 /* Try to build the initializer expression. If we can't initialize
6871 this symbol, then init will be NULL. */
6872 init = build_default_init_expr (sym);
6876 /* For saved variables, we don't want to add an initializer at
6877 function entry, so we just add a static initializer. */
6878 if (sym->attr.save || sym->ns->save_all)
6880 /* Don't clobber an existing initializer! */
6881 gcc_assert (sym->value == NULL);
6886 build_init_assign (sym, init);
6889 /* Resolution of common features of flavors variable and procedure. */
6892 resolve_fl_var_and_proc (gfc_symbol *sym, int mp_flag)
6894 /* Constraints on deferred shape variable. */
6895 if (sym->as == NULL || sym->as->type != AS_DEFERRED)
6897 if (sym->attr.allocatable)
6899 if (sym->attr.dimension)
6900 gfc_error ("Allocatable array '%s' at %L must have "
6901 "a deferred shape", sym->name, &sym->declared_at);
6903 gfc_error ("Scalar object '%s' at %L may not be ALLOCATABLE",
6904 sym->name, &sym->declared_at);
6908 if (sym->attr.pointer && sym->attr.dimension)
6910 gfc_error ("Array pointer '%s' at %L must have a deferred shape",
6911 sym->name, &sym->declared_at);
6918 if (!mp_flag && !sym->attr.allocatable
6919 && !sym->attr.pointer && !sym->attr.dummy)
6921 gfc_error ("Array '%s' at %L cannot have a deferred shape",
6922 sym->name, &sym->declared_at);
6930 /* Additional checks for symbols with flavor variable and derived
6931 type. To be called from resolve_fl_variable. */
6934 resolve_fl_variable_derived (gfc_symbol *sym, int no_init_flag)
6936 gcc_assert (sym->ts.type == BT_DERIVED);
6938 /* Check to see if a derived type is blocked from being host
6939 associated by the presence of another class I symbol in the same
6940 namespace. 14.6.1.3 of the standard and the discussion on
6941 comp.lang.fortran. */
6942 if (sym->ns != sym->ts.derived->ns
6943 && sym->ns->proc_name->attr.if_source != IFSRC_IFBODY)
6946 gfc_find_symbol (sym->ts.derived->name, sym->ns, 0, &s);
6947 if (s && (s->attr.flavor != FL_DERIVED
6948 || !gfc_compare_derived_types (s, sym->ts.derived)))
6950 gfc_error ("The type '%s' cannot be host associated at %L "
6951 "because it is blocked by an incompatible object "
6952 "of the same name declared at %L",
6953 sym->ts.derived->name, &sym->declared_at,
6959 /* 4th constraint in section 11.3: "If an object of a type for which
6960 component-initialization is specified (R429) appears in the
6961 specification-part of a module and does not have the ALLOCATABLE
6962 or POINTER attribute, the object shall have the SAVE attribute."
6964 The check for initializers is performed with
6965 has_default_initializer because gfc_default_initializer generates
6966 a hidden default for allocatable components. */
6967 if (!(sym->value || no_init_flag) && sym->ns->proc_name
6968 && sym->ns->proc_name->attr.flavor == FL_MODULE
6969 && !sym->ns->save_all && !sym->attr.save
6970 && !sym->attr.pointer && !sym->attr.allocatable
6971 && has_default_initializer (sym->ts.derived))
6973 gfc_error("Object '%s' at %L must have the SAVE attribute for "
6974 "default initialization of a component",
6975 sym->name, &sym->declared_at);
6979 /* Assign default initializer. */
6980 if (!(sym->value || sym->attr.pointer || sym->attr.allocatable)
6981 && (!no_init_flag || sym->attr.intent == INTENT_OUT))
6983 sym->value = gfc_default_initializer (&sym->ts);
6990 /* Resolve symbols with flavor variable. */
6993 resolve_fl_variable (gfc_symbol *sym, int mp_flag)
6995 int no_init_flag, automatic_flag;
6997 const char *auto_save_msg;
6999 auto_save_msg = "Automatic object '%s' at %L cannot have the "
7002 if (resolve_fl_var_and_proc (sym, mp_flag) == FAILURE)
7005 /* Set this flag to check that variables are parameters of all entries.
7006 This check is effected by the call to gfc_resolve_expr through
7007 is_non_constant_shape_array. */
7008 specification_expr = 1;
7010 if (sym->ns->proc_name
7011 && (sym->ns->proc_name->attr.flavor == FL_MODULE
7012 || sym->ns->proc_name->attr.is_main_program)
7013 && !sym->attr.use_assoc
7014 && !sym->attr.allocatable
7015 && !sym->attr.pointer
7016 && is_non_constant_shape_array (sym))
7018 /* The shape of a main program or module array needs to be
7020 gfc_error ("The module or main program array '%s' at %L must "
7021 "have constant shape", sym->name, &sym->declared_at);
7022 specification_expr = 0;
7026 if (sym->ts.type == BT_CHARACTER)
7028 /* Make sure that character string variables with assumed length are
7030 e = sym->ts.cl->length;
7031 if (e == NULL && !sym->attr.dummy && !sym->attr.result)
7033 gfc_error ("Entity with assumed character length at %L must be a "
7034 "dummy argument or a PARAMETER", &sym->declared_at);
7038 if (e && sym->attr.save && !gfc_is_constant_expr (e))
7040 gfc_error (auto_save_msg, sym->name, &sym->declared_at);
7044 if (!gfc_is_constant_expr (e)
7045 && !(e->expr_type == EXPR_VARIABLE
7046 && e->symtree->n.sym->attr.flavor == FL_PARAMETER)
7047 && sym->ns->proc_name
7048 && (sym->ns->proc_name->attr.flavor == FL_MODULE
7049 || sym->ns->proc_name->attr.is_main_program)
7050 && !sym->attr.use_assoc)
7052 gfc_error ("'%s' at %L must have constant character length "
7053 "in this context", sym->name, &sym->declared_at);
7058 if (sym->value == NULL && sym->attr.referenced)
7059 apply_default_init_local (sym); /* Try to apply a default initialization. */
7061 /* Determine if the symbol may not have an initializer. */
7062 no_init_flag = automatic_flag = 0;
7063 if (sym->attr.allocatable || sym->attr.external || sym->attr.dummy
7064 || sym->attr.intrinsic || sym->attr.result)
7066 else if (sym->attr.dimension && !sym->attr.pointer
7067 && is_non_constant_shape_array (sym))
7069 no_init_flag = automatic_flag = 1;
7071 /* Also, they must not have the SAVE attribute.
7072 SAVE_IMPLICIT is checked below. */
7073 if (sym->attr.save == SAVE_EXPLICIT)
7075 gfc_error (auto_save_msg, sym->name, &sym->declared_at);
7080 /* Reject illegal initializers. */
7081 if (!sym->mark && sym->value)
7083 if (sym->attr.allocatable)
7084 gfc_error ("Allocatable '%s' at %L cannot have an initializer",
7085 sym->name, &sym->declared_at);
7086 else if (sym->attr.external)
7087 gfc_error ("External '%s' at %L cannot have an initializer",
7088 sym->name, &sym->declared_at);
7089 else if (sym->attr.dummy
7090 && !(sym->ts.type == BT_DERIVED && sym->attr.intent == INTENT_OUT))
7091 gfc_error ("Dummy '%s' at %L cannot have an initializer",
7092 sym->name, &sym->declared_at);
7093 else if (sym->attr.intrinsic)
7094 gfc_error ("Intrinsic '%s' at %L cannot have an initializer",
7095 sym->name, &sym->declared_at);
7096 else if (sym->attr.result)
7097 gfc_error ("Function result '%s' at %L cannot have an initializer",
7098 sym->name, &sym->declared_at);
7099 else if (automatic_flag)
7100 gfc_error ("Automatic array '%s' at %L cannot have an initializer",
7101 sym->name, &sym->declared_at);
7108 if (sym->ts.type == BT_DERIVED)
7109 return resolve_fl_variable_derived (sym, no_init_flag);
7115 /* Resolve a procedure. */
7118 resolve_fl_procedure (gfc_symbol *sym, int mp_flag)
7120 gfc_formal_arglist *arg;
7122 if (sym->attr.ambiguous_interfaces && !sym->attr.referenced)
7123 gfc_warning ("Although not referenced, '%s' at %L has ambiguous "
7124 "interfaces", sym->name, &sym->declared_at);
7126 if (sym->attr.function
7127 && resolve_fl_var_and_proc (sym, mp_flag) == FAILURE)
7130 if (sym->ts.type == BT_CHARACTER)
7132 gfc_charlen *cl = sym->ts.cl;
7134 if (cl && cl->length && gfc_is_constant_expr (cl->length)
7135 && resolve_charlen (cl) == FAILURE)
7138 if (!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT)
7140 if (sym->attr.proc == PROC_ST_FUNCTION)
7142 gfc_error ("Character-valued statement function '%s' at %L must "
7143 "have constant length", sym->name, &sym->declared_at);
7147 if (sym->attr.external && sym->formal == NULL
7148 && cl && cl->length && cl->length->expr_type != EXPR_CONSTANT)
7150 gfc_error ("Automatic character length function '%s' at %L must "
7151 "have an explicit interface", sym->name,
7158 /* Ensure that derived type for are not of a private type. Internal
7159 module procedures are excluded by 2.2.3.3 - ie. they are not
7160 externally accessible and can access all the objects accessible in
7162 if (!(sym->ns->parent
7163 && sym->ns->parent->proc_name->attr.flavor == FL_MODULE)
7164 && gfc_check_access(sym->attr.access, sym->ns->default_access))
7166 gfc_interface *iface;
7168 for (arg = sym->formal; arg; arg = arg->next)
7171 && arg->sym->ts.type == BT_DERIVED
7172 && !arg->sym->ts.derived->attr.use_assoc
7173 && !gfc_check_access (arg->sym->ts.derived->attr.access,
7174 arg->sym->ts.derived->ns->default_access)
7175 && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: '%s' is of a "
7176 "PRIVATE type and cannot be a dummy argument"
7177 " of '%s', which is PUBLIC at %L",
7178 arg->sym->name, sym->name, &sym->declared_at)
7181 /* Stop this message from recurring. */
7182 arg->sym->ts.derived->attr.access = ACCESS_PUBLIC;
7187 /* PUBLIC interfaces may expose PRIVATE procedures that take types
7188 PRIVATE to the containing module. */
7189 for (iface = sym->generic; iface; iface = iface->next)
7191 for (arg = iface->sym->formal; arg; arg = arg->next)
7194 && arg->sym->ts.type == BT_DERIVED
7195 && !arg->sym->ts.derived->attr.use_assoc
7196 && !gfc_check_access (arg->sym->ts.derived->attr.access,
7197 arg->sym->ts.derived->ns->default_access)
7198 && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Procedure "
7199 "'%s' in PUBLIC interface '%s' at %L "
7200 "takes dummy arguments of '%s' which is "
7201 "PRIVATE", iface->sym->name, sym->name,
7202 &iface->sym->declared_at,
7203 gfc_typename (&arg->sym->ts)) == FAILURE)
7205 /* Stop this message from recurring. */
7206 arg->sym->ts.derived->attr.access = ACCESS_PUBLIC;
7212 /* PUBLIC interfaces may expose PRIVATE procedures that take types
7213 PRIVATE to the containing module. */
7214 for (iface = sym->generic; iface; iface = iface->next)
7216 for (arg = iface->sym->formal; arg; arg = arg->next)
7219 && arg->sym->ts.type == BT_DERIVED
7220 && !arg->sym->ts.derived->attr.use_assoc
7221 && !gfc_check_access (arg->sym->ts.derived->attr.access,
7222 arg->sym->ts.derived->ns->default_access)
7223 && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Procedure "
7224 "'%s' in PUBLIC interface '%s' at %L "
7225 "takes dummy arguments of '%s' which is "
7226 "PRIVATE", iface->sym->name, sym->name,
7227 &iface->sym->declared_at,
7228 gfc_typename (&arg->sym->ts)) == FAILURE)
7230 /* Stop this message from recurring. */
7231 arg->sym->ts.derived->attr.access = ACCESS_PUBLIC;
7238 if (sym->attr.function && sym->value && sym->attr.proc != PROC_ST_FUNCTION)
7240 gfc_error ("Function '%s' at %L cannot have an initializer",
7241 sym->name, &sym->declared_at);
7245 /* An external symbol may not have an initializer because it is taken to be
7247 if (sym->attr.external && sym->value)
7249 gfc_error ("External object '%s' at %L may not have an initializer",
7250 sym->name, &sym->declared_at);
7254 /* An elemental function is required to return a scalar 12.7.1 */
7255 if (sym->attr.elemental && sym->attr.function && sym->as)
7257 gfc_error ("ELEMENTAL function '%s' at %L must have a scalar "
7258 "result", sym->name, &sym->declared_at);
7259 /* Reset so that the error only occurs once. */
7260 sym->attr.elemental = 0;
7264 /* 5.1.1.5 of the Standard: A function name declared with an asterisk
7265 char-len-param shall not be array-valued, pointer-valued, recursive
7266 or pure. ....snip... A character value of * may only be used in the
7267 following ways: (i) Dummy arg of procedure - dummy associates with
7268 actual length; (ii) To declare a named constant; or (iii) External
7269 function - but length must be declared in calling scoping unit. */
7270 if (sym->attr.function
7271 && sym->ts.type == BT_CHARACTER
7272 && sym->ts.cl && sym->ts.cl->length == NULL)
7274 if ((sym->as && sym->as->rank) || (sym->attr.pointer)
7275 || (sym->attr.recursive) || (sym->attr.pure))
7277 if (sym->as && sym->as->rank)
7278 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
7279 "array-valued", sym->name, &sym->declared_at);
7281 if (sym->attr.pointer)
7282 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
7283 "pointer-valued", sym->name, &sym->declared_at);
7286 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
7287 "pure", sym->name, &sym->declared_at);
7289 if (sym->attr.recursive)
7290 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
7291 "recursive", sym->name, &sym->declared_at);
7296 /* Appendix B.2 of the standard. Contained functions give an
7297 error anyway. Fixed-form is likely to be F77/legacy. */
7298 if (!sym->attr.contained && gfc_current_form != FORM_FIXED)
7299 gfc_notify_std (GFC_STD_F95_OBS, "CHARACTER(*) function "
7300 "'%s' at %L is obsolescent in fortran 95",
7301 sym->name, &sym->declared_at);
7304 if (sym->attr.is_bind_c && sym->attr.is_c_interop != 1)
7306 gfc_formal_arglist *curr_arg;
7307 int has_non_interop_arg = 0;
7309 if (verify_bind_c_sym (sym, &(sym->ts), sym->attr.in_common,
7310 sym->common_block) == FAILURE)
7312 /* Clear these to prevent looking at them again if there was an
7314 sym->attr.is_bind_c = 0;
7315 sym->attr.is_c_interop = 0;
7316 sym->ts.is_c_interop = 0;
7320 /* So far, no errors have been found. */
7321 sym->attr.is_c_interop = 1;
7322 sym->ts.is_c_interop = 1;
7325 curr_arg = sym->formal;
7326 while (curr_arg != NULL)
7328 /* Skip implicitly typed dummy args here. */
7329 if (curr_arg->sym->attr.implicit_type == 0)
7330 if (verify_c_interop_param (curr_arg->sym) == FAILURE)
7331 /* If something is found to fail, record the fact so we
7332 can mark the symbol for the procedure as not being
7333 BIND(C) to try and prevent multiple errors being
7335 has_non_interop_arg = 1;
7337 curr_arg = curr_arg->next;
7340 /* See if any of the arguments were not interoperable and if so, clear
7341 the procedure symbol to prevent duplicate error messages. */
7342 if (has_non_interop_arg != 0)
7344 sym->attr.is_c_interop = 0;
7345 sym->ts.is_c_interop = 0;
7346 sym->attr.is_bind_c = 0;
7354 /* Resolve the components of a derived type. */
7357 resolve_fl_derived (gfc_symbol *sym)
7360 gfc_dt_list * dt_list;
7363 for (c = sym->components; c != NULL; c = c->next)
7365 if (c->ts.type == BT_CHARACTER)
7367 if (c->ts.cl->length == NULL
7368 || (resolve_charlen (c->ts.cl) == FAILURE)
7369 || !gfc_is_constant_expr (c->ts.cl->length))
7371 gfc_error ("Character length of component '%s' needs to "
7372 "be a constant specification expression at %L",
7374 c->ts.cl->length ? &c->ts.cl->length->where : &c->loc);
7379 if (c->ts.type == BT_DERIVED
7380 && sym->component_access != ACCESS_PRIVATE
7381 && gfc_check_access (sym->attr.access, sym->ns->default_access)
7382 && !c->ts.derived->attr.use_assoc
7383 && !gfc_check_access (c->ts.derived->attr.access,
7384 c->ts.derived->ns->default_access))
7386 gfc_error ("The component '%s' is a PRIVATE type and cannot be "
7387 "a component of '%s', which is PUBLIC at %L",
7388 c->name, sym->name, &sym->declared_at);
7392 if (sym->attr.sequence)
7394 if (c->ts.type == BT_DERIVED && c->ts.derived->attr.sequence == 0)
7396 gfc_error ("Component %s of SEQUENCE type declared at %L does "
7397 "not have the SEQUENCE attribute",
7398 c->ts.derived->name, &sym->declared_at);
7403 if (c->ts.type == BT_DERIVED && c->pointer
7404 && c->ts.derived->components == NULL)
7406 gfc_error ("The pointer component '%s' of '%s' at %L is a type "
7407 "that has not been declared", c->name, sym->name,
7412 if (c->pointer || c->allocatable || c->as == NULL)
7415 for (i = 0; i < c->as->rank; i++)
7417 if (c->as->lower[i] == NULL
7418 || !gfc_is_constant_expr (c->as->lower[i])
7419 || (resolve_index_expr (c->as->lower[i]) == FAILURE)
7420 || c->as->upper[i] == NULL
7421 || (resolve_index_expr (c->as->upper[i]) == FAILURE)
7422 || !gfc_is_constant_expr (c->as->upper[i]))
7424 gfc_error ("Component '%s' of '%s' at %L must have "
7425 "constant array bounds",
7426 c->name, sym->name, &c->loc);
7432 /* Add derived type to the derived type list. */
7433 for (dt_list = gfc_derived_types; dt_list; dt_list = dt_list->next)
7434 if (sym == dt_list->derived)
7437 if (dt_list == NULL)
7439 dt_list = gfc_get_dt_list ();
7440 dt_list->next = gfc_derived_types;
7441 dt_list->derived = sym;
7442 gfc_derived_types = dt_list;
7450 resolve_fl_namelist (gfc_symbol *sym)
7455 /* Reject PRIVATE objects in a PUBLIC namelist. */
7456 if (gfc_check_access(sym->attr.access, sym->ns->default_access))
7458 for (nl = sym->namelist; nl; nl = nl->next)
7460 if (!nl->sym->attr.use_assoc
7461 && !(sym->ns->parent == nl->sym->ns)
7462 && !(sym->ns->parent
7463 && sym->ns->parent->parent == nl->sym->ns)
7464 && !gfc_check_access(nl->sym->attr.access,
7465 nl->sym->ns->default_access))
7467 gfc_error ("NAMELIST object '%s' was declared PRIVATE and "
7468 "cannot be member of PUBLIC namelist '%s' at %L",
7469 nl->sym->name, sym->name, &sym->declared_at);
7473 /* Types with private components that came here by USE-association. */
7474 if (nl->sym->ts.type == BT_DERIVED
7475 && derived_inaccessible (nl->sym->ts.derived))
7477 gfc_error ("NAMELIST object '%s' has use-associated PRIVATE "
7478 "components and cannot be member of namelist '%s' at %L",
7479 nl->sym->name, sym->name, &sym->declared_at);
7483 /* Types with private components that are defined in the same module. */
7484 if (nl->sym->ts.type == BT_DERIVED
7485 && !(sym->ns->parent == nl->sym->ts.derived->ns)
7486 && !gfc_check_access (nl->sym->ts.derived->attr.private_comp
7487 ? ACCESS_PRIVATE : ACCESS_UNKNOWN,
7488 nl->sym->ns->default_access))
7490 gfc_error ("NAMELIST object '%s' has PRIVATE components and "
7491 "cannot be a member of PUBLIC namelist '%s' at %L",
7492 nl->sym->name, sym->name, &sym->declared_at);
7498 for (nl = sym->namelist; nl; nl = nl->next)
7500 /* Reject namelist arrays of assumed shape. */
7501 if (nl->sym->as && nl->sym->as->type == AS_ASSUMED_SHAPE
7502 && gfc_notify_std (GFC_STD_F2003, "NAMELIST array object '%s' "
7503 "must not have assumed shape in namelist "
7504 "'%s' at %L", nl->sym->name, sym->name,
7505 &sym->declared_at) == FAILURE)
7508 /* Reject namelist arrays that are not constant shape. */
7509 if (is_non_constant_shape_array (nl->sym))
7511 gfc_error ("NAMELIST array object '%s' must have constant "
7512 "shape in namelist '%s' at %L", nl->sym->name,
7513 sym->name, &sym->declared_at);
7517 /* Namelist objects cannot have allocatable or pointer components. */
7518 if (nl->sym->ts.type != BT_DERIVED)
7521 if (nl->sym->ts.derived->attr.alloc_comp)
7523 gfc_error ("NAMELIST object '%s' in namelist '%s' at %L cannot "
7524 "have ALLOCATABLE components",
7525 nl->sym->name, sym->name, &sym->declared_at);
7529 if (nl->sym->ts.derived->attr.pointer_comp)
7531 gfc_error ("NAMELIST object '%s' in namelist '%s' at %L cannot "
7532 "have POINTER components",
7533 nl->sym->name, sym->name, &sym->declared_at);
7539 /* 14.1.2 A module or internal procedure represent local entities
7540 of the same type as a namelist member and so are not allowed. */
7541 for (nl = sym->namelist; nl; nl = nl->next)
7543 if (nl->sym->ts.kind != 0 && nl->sym->attr.flavor == FL_VARIABLE)
7546 if (nl->sym->attr.function && nl->sym == nl->sym->result)
7547 if ((nl->sym == sym->ns->proc_name)
7549 (sym->ns->parent && nl->sym == sym->ns->parent->proc_name))
7553 if (nl->sym && nl->sym->name)
7554 gfc_find_symbol (nl->sym->name, sym->ns, 1, &nlsym);
7555 if (nlsym && nlsym->attr.flavor == FL_PROCEDURE)
7557 gfc_error ("PROCEDURE attribute conflicts with NAMELIST "
7558 "attribute in '%s' at %L", nlsym->name,
7569 resolve_fl_parameter (gfc_symbol *sym)
7571 /* A parameter array's shape needs to be constant. */
7573 && (sym->as->type == AS_DEFERRED
7574 || is_non_constant_shape_array (sym)))
7576 gfc_error ("Parameter array '%s' at %L cannot be automatic "
7577 "or of deferred shape", sym->name, &sym->declared_at);
7581 /* Make sure a parameter that has been implicitly typed still
7582 matches the implicit type, since PARAMETER statements can precede
7583 IMPLICIT statements. */
7584 if (sym->attr.implicit_type
7585 && !gfc_compare_types (&sym->ts, gfc_get_default_type (sym, sym->ns)))
7587 gfc_error ("Implicitly typed PARAMETER '%s' at %L doesn't match a "
7588 "later IMPLICIT type", sym->name, &sym->declared_at);
7592 /* Make sure the types of derived parameters are consistent. This
7593 type checking is deferred until resolution because the type may
7594 refer to a derived type from the host. */
7595 if (sym->ts.type == BT_DERIVED
7596 && !gfc_compare_types (&sym->ts, &sym->value->ts))
7598 gfc_error ("Incompatible derived type in PARAMETER at %L",
7599 &sym->value->where);
7606 /* Do anything necessary to resolve a symbol. Right now, we just
7607 assume that an otherwise unknown symbol is a variable. This sort
7608 of thing commonly happens for symbols in module. */
7611 resolve_symbol (gfc_symbol *sym)
7613 int check_constant, mp_flag;
7614 gfc_symtree *symtree;
7615 gfc_symtree *this_symtree;
7619 if (sym->attr.flavor == FL_UNKNOWN)
7622 /* If we find that a flavorless symbol is an interface in one of the
7623 parent namespaces, find its symtree in this namespace, free the
7624 symbol and set the symtree to point to the interface symbol. */
7625 for (ns = gfc_current_ns->parent; ns; ns = ns->parent)
7627 symtree = gfc_find_symtree (ns->sym_root, sym->name);
7628 if (symtree && symtree->n.sym->generic)
7630 this_symtree = gfc_find_symtree (gfc_current_ns->sym_root,
7634 gfc_free_symbol (sym);
7635 symtree->n.sym->refs++;
7636 this_symtree->n.sym = symtree->n.sym;
7641 /* Otherwise give it a flavor according to such attributes as
7643 if (sym->attr.external == 0 && sym->attr.intrinsic == 0)
7644 sym->attr.flavor = FL_VARIABLE;
7647 sym->attr.flavor = FL_PROCEDURE;
7648 if (sym->attr.dimension)
7649 sym->attr.function = 1;
7653 if (sym->attr.procedure && sym->interface
7654 && sym->attr.if_source != IFSRC_DECL)
7656 /* Get the attributes from the interface (now resolved). */
7657 if (sym->interface->attr.if_source || sym->interface->attr.intrinsic)
7659 sym->ts = sym->interface->ts;
7660 sym->attr.function = sym->interface->attr.function;
7661 sym->attr.subroutine = sym->interface->attr.subroutine;
7662 copy_formal_args (sym, sym->interface);
7664 else if (sym->interface->name[0] != '\0')
7666 gfc_error ("Interface '%s' of procedure '%s' at %L must be explicit",
7667 sym->interface->name, sym->name, &sym->declared_at);
7672 if (sym->attr.flavor == FL_DERIVED && resolve_fl_derived (sym) == FAILURE)
7675 /* Symbols that are module procedures with results (functions) have
7676 the types and array specification copied for type checking in
7677 procedures that call them, as well as for saving to a module
7678 file. These symbols can't stand the scrutiny that their results
7680 mp_flag = (sym->result != NULL && sym->result != sym);
7683 /* Make sure that the intrinsic is consistent with its internal
7684 representation. This needs to be done before assigning a default
7685 type to avoid spurious warnings. */
7686 if (sym->attr.flavor != FL_MODULE && sym->attr.intrinsic)
7688 if (gfc_intrinsic_name (sym->name, 0))
7690 if (sym->ts.type != BT_UNKNOWN && gfc_option.warn_surprising)
7691 gfc_warning ("Type specified for intrinsic function '%s' at %L is ignored",
7692 sym->name, &sym->declared_at);
7694 else if (gfc_intrinsic_name (sym->name, 1))
7696 if (sym->ts.type != BT_UNKNOWN)
7698 gfc_error ("Intrinsic subroutine '%s' at %L shall not have a type specifier",
7699 sym->name, &sym->declared_at);
7705 gfc_error ("Intrinsic '%s' at %L does not exist", sym->name, &sym->declared_at);
7710 /* Assign default type to symbols that need one and don't have one. */
7711 if (sym->ts.type == BT_UNKNOWN)
7713 if (sym->attr.flavor == FL_VARIABLE || sym->attr.flavor == FL_PARAMETER)
7714 gfc_set_default_type (sym, 1, NULL);
7716 if (sym->attr.flavor == FL_PROCEDURE && sym->attr.function)
7718 /* The specific case of an external procedure should emit an error
7719 in the case that there is no implicit type. */
7721 gfc_set_default_type (sym, sym->attr.external, NULL);
7724 /* Result may be in another namespace. */
7725 resolve_symbol (sym->result);
7727 sym->ts = sym->result->ts;
7728 sym->as = gfc_copy_array_spec (sym->result->as);
7729 sym->attr.dimension = sym->result->attr.dimension;
7730 sym->attr.pointer = sym->result->attr.pointer;
7731 sym->attr.allocatable = sym->result->attr.allocatable;
7736 /* Assumed size arrays and assumed shape arrays must be dummy
7740 && (sym->as->type == AS_ASSUMED_SIZE
7741 || sym->as->type == AS_ASSUMED_SHAPE)
7742 && sym->attr.dummy == 0)
7744 if (sym->as->type == AS_ASSUMED_SIZE)
7745 gfc_error ("Assumed size array at %L must be a dummy argument",
7748 gfc_error ("Assumed shape array at %L must be a dummy argument",
7753 /* Make sure symbols with known intent or optional are really dummy
7754 variable. Because of ENTRY statement, this has to be deferred
7755 until resolution time. */
7757 if (!sym->attr.dummy
7758 && (sym->attr.optional || sym->attr.intent != INTENT_UNKNOWN))
7760 gfc_error ("Symbol at %L is not a DUMMY variable", &sym->declared_at);
7764 if (sym->attr.value && !sym->attr.dummy)
7766 gfc_error ("'%s' at %L cannot have the VALUE attribute because "
7767 "it is not a dummy argument", sym->name, &sym->declared_at);
7771 if (sym->attr.value && sym->ts.type == BT_CHARACTER)
7773 gfc_charlen *cl = sym->ts.cl;
7774 if (!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT)
7776 gfc_error ("Character dummy variable '%s' at %L with VALUE "
7777 "attribute must have constant length",
7778 sym->name, &sym->declared_at);
7782 if (sym->ts.is_c_interop
7783 && mpz_cmp_si (cl->length->value.integer, 1) != 0)
7785 gfc_error ("C interoperable character dummy variable '%s' at %L "
7786 "with VALUE attribute must have length one",
7787 sym->name, &sym->declared_at);
7792 /* If the symbol is marked as bind(c), verify it's type and kind. Do not
7793 do this for something that was implicitly typed because that is handled
7794 in gfc_set_default_type. Handle dummy arguments and procedure
7795 definitions separately. Also, anything that is use associated is not
7796 handled here but instead is handled in the module it is declared in.
7797 Finally, derived type definitions are allowed to be BIND(C) since that
7798 only implies that they're interoperable, and they are checked fully for
7799 interoperability when a variable is declared of that type. */
7800 if (sym->attr.is_bind_c && sym->attr.implicit_type == 0 &&
7801 sym->attr.use_assoc == 0 && sym->attr.dummy == 0 &&
7802 sym->attr.flavor != FL_PROCEDURE && sym->attr.flavor != FL_DERIVED)
7806 /* First, make sure the variable is declared at the
7807 module-level scope (J3/04-007, Section 15.3). */
7808 if (sym->ns->proc_name->attr.flavor != FL_MODULE &&
7809 sym->attr.in_common == 0)
7811 gfc_error ("Variable '%s' at %L cannot be BIND(C) because it "
7812 "is neither a COMMON block nor declared at the "
7813 "module level scope", sym->name, &(sym->declared_at));
7816 else if (sym->common_head != NULL)
7818 t = verify_com_block_vars_c_interop (sym->common_head);
7822 /* If type() declaration, we need to verify that the components
7823 of the given type are all C interoperable, etc. */
7824 if (sym->ts.type == BT_DERIVED &&
7825 sym->ts.derived->attr.is_c_interop != 1)
7827 /* Make sure the user marked the derived type as BIND(C). If
7828 not, call the verify routine. This could print an error
7829 for the derived type more than once if multiple variables
7830 of that type are declared. */
7831 if (sym->ts.derived->attr.is_bind_c != 1)
7832 verify_bind_c_derived_type (sym->ts.derived);
7836 /* Verify the variable itself as C interoperable if it
7837 is BIND(C). It is not possible for this to succeed if
7838 the verify_bind_c_derived_type failed, so don't have to handle
7839 any error returned by verify_bind_c_derived_type. */
7840 t = verify_bind_c_sym (sym, &(sym->ts), sym->attr.in_common,
7846 /* clear the is_bind_c flag to prevent reporting errors more than
7847 once if something failed. */
7848 sym->attr.is_bind_c = 0;
7853 /* If a derived type symbol has reached this point, without its
7854 type being declared, we have an error. Notice that most
7855 conditions that produce undefined derived types have already
7856 been dealt with. However, the likes of:
7857 implicit type(t) (t) ..... call foo (t) will get us here if
7858 the type is not declared in the scope of the implicit
7859 statement. Change the type to BT_UNKNOWN, both because it is so
7860 and to prevent an ICE. */
7861 if (sym->ts.type == BT_DERIVED && sym->ts.derived->components == NULL
7862 && !sym->ts.derived->attr.zero_comp)
7864 gfc_error ("The derived type '%s' at %L is of type '%s', "
7865 "which has not been defined", sym->name,
7866 &sym->declared_at, sym->ts.derived->name);
7867 sym->ts.type = BT_UNKNOWN;
7871 /* Unless the derived-type declaration is use associated, Fortran 95
7872 does not allow public entries of private derived types.
7873 See 4.4.1 (F95) and 4.5.1.1 (F2003); and related interpretation
7875 if (sym->ts.type == BT_DERIVED
7876 && gfc_check_access (sym->attr.access, sym->ns->default_access)
7877 && !gfc_check_access (sym->ts.derived->attr.access,
7878 sym->ts.derived->ns->default_access)
7879 && !sym->ts.derived->attr.use_assoc
7880 && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: PUBLIC %s '%s' at %L "
7881 "of PRIVATE derived type '%s'",
7882 (sym->attr.flavor == FL_PARAMETER) ? "parameter"
7883 : "variable", sym->name, &sym->declared_at,
7884 sym->ts.derived->name) == FAILURE)
7887 /* An assumed-size array with INTENT(OUT) shall not be of a type for which
7888 default initialization is defined (5.1.2.4.4). */
7889 if (sym->ts.type == BT_DERIVED
7891 && sym->attr.intent == INTENT_OUT
7893 && sym->as->type == AS_ASSUMED_SIZE)
7895 for (c = sym->ts.derived->components; c; c = c->next)
7899 gfc_error ("The INTENT(OUT) dummy argument '%s' at %L is "
7900 "ASSUMED SIZE and so cannot have a default initializer",
7901 sym->name, &sym->declared_at);
7907 switch (sym->attr.flavor)
7910 if (resolve_fl_variable (sym, mp_flag) == FAILURE)
7915 if (resolve_fl_procedure (sym, mp_flag) == FAILURE)
7920 if (resolve_fl_namelist (sym) == FAILURE)
7925 if (resolve_fl_parameter (sym) == FAILURE)
7933 /* Resolve array specifier. Check as well some constraints
7934 on COMMON blocks. */
7936 check_constant = sym->attr.in_common && !sym->attr.pointer;
7938 /* Set the formal_arg_flag so that check_conflict will not throw
7939 an error for host associated variables in the specification
7940 expression for an array_valued function. */
7941 if (sym->attr.function && sym->as)
7942 formal_arg_flag = 1;
7944 gfc_resolve_array_spec (sym->as, check_constant);
7946 formal_arg_flag = 0;
7948 /* Resolve formal namespaces. */
7949 if (sym->formal_ns && sym->formal_ns != gfc_current_ns)
7950 gfc_resolve (sym->formal_ns);
7952 /* Check threadprivate restrictions. */
7953 if (sym->attr.threadprivate && !sym->attr.save && !sym->ns->save_all
7954 && (!sym->attr.in_common
7955 && sym->module == NULL
7956 && (sym->ns->proc_name == NULL
7957 || sym->ns->proc_name->attr.flavor != FL_MODULE)))
7958 gfc_error ("Threadprivate at %L isn't SAVEd", &sym->declared_at);
7960 /* If we have come this far we can apply default-initializers, as
7961 described in 14.7.5, to those variables that have not already
7962 been assigned one. */
7963 if (sym->ts.type == BT_DERIVED
7964 && sym->attr.referenced
7965 && sym->ns == gfc_current_ns
7967 && !sym->attr.allocatable
7968 && !sym->attr.alloc_comp)
7970 symbol_attribute *a = &sym->attr;
7972 if ((!a->save && !a->dummy && !a->pointer
7973 && !a->in_common && !a->use_assoc
7974 && !(a->function && sym != sym->result))
7975 || (a->dummy && a->intent == INTENT_OUT))
7976 apply_default_init (sym);
7981 /************* Resolve DATA statements *************/
7985 gfc_data_value *vnode;
7991 /* Advance the values structure to point to the next value in the data list. */
7994 next_data_value (void)
7996 while (values.left == 0)
7998 if (values.vnode->next == NULL)
8001 values.vnode = values.vnode->next;
8002 values.left = values.vnode->repeat;
8010 check_data_variable (gfc_data_variable *var, locus *where)
8016 ar_type mark = AR_UNKNOWN;
8018 mpz_t section_index[GFC_MAX_DIMENSIONS];
8022 if (gfc_resolve_expr (var->expr) == FAILURE)
8026 mpz_init_set_si (offset, 0);
8029 if (e->expr_type != EXPR_VARIABLE)
8030 gfc_internal_error ("check_data_variable(): Bad expression");
8032 if (e->symtree->n.sym->ns->is_block_data
8033 && !e->symtree->n.sym->attr.in_common)
8035 gfc_error ("BLOCK DATA element '%s' at %L must be in COMMON",
8036 e->symtree->n.sym->name, &e->symtree->n.sym->declared_at);
8041 mpz_init_set_ui (size, 1);
8048 /* Find the array section reference. */
8049 for (ref = e->ref; ref; ref = ref->next)
8051 if (ref->type != REF_ARRAY)
8053 if (ref->u.ar.type == AR_ELEMENT)
8059 /* Set marks according to the reference pattern. */
8060 switch (ref->u.ar.type)
8068 /* Get the start position of array section. */
8069 gfc_get_section_index (ar, section_index, &offset);
8077 if (gfc_array_size (e, &size) == FAILURE)
8079 gfc_error ("Nonconstant array section at %L in DATA statement",
8088 while (mpz_cmp_ui (size, 0) > 0)
8090 if (next_data_value () == FAILURE)
8092 gfc_error ("DATA statement at %L has more variables than values",
8098 t = gfc_check_assign (var->expr, values.vnode->expr, 0);
8102 /* If we have more than one element left in the repeat count,
8103 and we have more than one element left in the target variable,
8104 then create a range assignment. */
8105 /* ??? Only done for full arrays for now, since array sections
8107 if (mark == AR_FULL && ref && ref->next == NULL
8108 && values.left > 1 && mpz_cmp_ui (size, 1) > 0)
8112 if (mpz_cmp_ui (size, values.left) >= 0)
8114 mpz_init_set_ui (range, values.left);
8115 mpz_sub_ui (size, size, values.left);
8120 mpz_init_set (range, size);
8121 values.left -= mpz_get_ui (size);
8122 mpz_set_ui (size, 0);
8125 gfc_assign_data_value_range (var->expr, values.vnode->expr,
8128 mpz_add (offset, offset, range);
8132 /* Assign initial value to symbol. */
8136 mpz_sub_ui (size, size, 1);
8138 t = gfc_assign_data_value (var->expr, values.vnode->expr, offset);
8142 if (mark == AR_FULL)
8143 mpz_add_ui (offset, offset, 1);
8145 /* Modify the array section indexes and recalculate the offset
8146 for next element. */
8147 else if (mark == AR_SECTION)
8148 gfc_advance_section (section_index, ar, &offset);
8152 if (mark == AR_SECTION)
8154 for (i = 0; i < ar->dimen; i++)
8155 mpz_clear (section_index[i]);
8165 static try traverse_data_var (gfc_data_variable *, locus *);
8167 /* Iterate over a list of elements in a DATA statement. */
8170 traverse_data_list (gfc_data_variable *var, locus *where)
8173 iterator_stack frame;
8174 gfc_expr *e, *start, *end, *step;
8175 try retval = SUCCESS;
8177 mpz_init (frame.value);
8179 start = gfc_copy_expr (var->iter.start);
8180 end = gfc_copy_expr (var->iter.end);
8181 step = gfc_copy_expr (var->iter.step);
8183 if (gfc_simplify_expr (start, 1) == FAILURE
8184 || start->expr_type != EXPR_CONSTANT)
8186 gfc_error ("iterator start at %L does not simplify", &start->where);
8190 if (gfc_simplify_expr (end, 1) == FAILURE
8191 || end->expr_type != EXPR_CONSTANT)
8193 gfc_error ("iterator end at %L does not simplify", &end->where);
8197 if (gfc_simplify_expr (step, 1) == FAILURE
8198 || step->expr_type != EXPR_CONSTANT)
8200 gfc_error ("iterator step at %L does not simplify", &step->where);
8205 mpz_init_set (trip, end->value.integer);
8206 mpz_sub (trip, trip, start->value.integer);
8207 mpz_add (trip, trip, step->value.integer);
8209 mpz_div (trip, trip, step->value.integer);
8211 mpz_set (frame.value, start->value.integer);
8213 frame.prev = iter_stack;
8214 frame.variable = var->iter.var->symtree;
8215 iter_stack = &frame;
8217 while (mpz_cmp_ui (trip, 0) > 0)
8219 if (traverse_data_var (var->list, where) == FAILURE)
8226 e = gfc_copy_expr (var->expr);
8227 if (gfc_simplify_expr (e, 1) == FAILURE)
8235 mpz_add (frame.value, frame.value, step->value.integer);
8237 mpz_sub_ui (trip, trip, 1);
8242 mpz_clear (frame.value);
8244 gfc_free_expr (start);
8245 gfc_free_expr (end);
8246 gfc_free_expr (step);
8248 iter_stack = frame.prev;
8253 /* Type resolve variables in the variable list of a DATA statement. */
8256 traverse_data_var (gfc_data_variable *var, locus *where)
8260 for (; var; var = var->next)
8262 if (var->expr == NULL)
8263 t = traverse_data_list (var, where);
8265 t = check_data_variable (var, where);
8275 /* Resolve the expressions and iterators associated with a data statement.
8276 This is separate from the assignment checking because data lists should
8277 only be resolved once. */
8280 resolve_data_variables (gfc_data_variable *d)
8282 for (; d; d = d->next)
8284 if (d->list == NULL)
8286 if (gfc_resolve_expr (d->expr) == FAILURE)
8291 if (gfc_resolve_iterator (&d->iter, false) == FAILURE)
8294 if (resolve_data_variables (d->list) == FAILURE)
8303 /* Resolve a single DATA statement. We implement this by storing a pointer to
8304 the value list into static variables, and then recursively traversing the
8305 variables list, expanding iterators and such. */
8308 resolve_data (gfc_data * d)
8310 if (resolve_data_variables (d->var) == FAILURE)
8313 values.vnode = d->value;
8314 values.left = (d->value == NULL) ? 0 : d->value->repeat;
8316 if (traverse_data_var (d->var, &d->where) == FAILURE)
8319 /* At this point, we better not have any values left. */
8321 if (next_data_value () == SUCCESS)
8322 gfc_error ("DATA statement at %L has more values than variables",
8327 /* 12.6 Constraint: In a pure subprogram any variable which is in common or
8328 accessed by host or use association, is a dummy argument to a pure function,
8329 is a dummy argument with INTENT (IN) to a pure subroutine, or an object that
8330 is storage associated with any such variable, shall not be used in the
8331 following contexts: (clients of this function). */
8333 /* Determines if a variable is not 'pure', ie not assignable within a pure
8334 procedure. Returns zero if assignment is OK, nonzero if there is a
8337 gfc_impure_variable (gfc_symbol *sym)
8341 if (sym->attr.use_assoc || sym->attr.in_common)
8344 if (sym->ns != gfc_current_ns)
8345 return !sym->attr.function;
8347 proc = sym->ns->proc_name;
8348 if (sym->attr.dummy && gfc_pure (proc)
8349 && ((proc->attr.subroutine && sym->attr.intent == INTENT_IN)
8351 proc->attr.function))
8354 /* TODO: Sort out what can be storage associated, if anything, and include
8355 it here. In principle equivalences should be scanned but it does not
8356 seem to be possible to storage associate an impure variable this way. */
8361 /* Test whether a symbol is pure or not. For a NULL pointer, checks the
8362 symbol of the current procedure. */
8365 gfc_pure (gfc_symbol *sym)
8367 symbol_attribute attr;
8370 sym = gfc_current_ns->proc_name;
8376 return attr.flavor == FL_PROCEDURE && (attr.pure || attr.elemental);
8380 /* Test whether the current procedure is elemental or not. */
8383 gfc_elemental (gfc_symbol *sym)
8385 symbol_attribute attr;
8388 sym = gfc_current_ns->proc_name;
8393 return attr.flavor == FL_PROCEDURE && attr.elemental;
8397 /* Warn about unused labels. */
8400 warn_unused_fortran_label (gfc_st_label *label)
8405 warn_unused_fortran_label (label->left);
8407 if (label->defined == ST_LABEL_UNKNOWN)
8410 switch (label->referenced)
8412 case ST_LABEL_UNKNOWN:
8413 gfc_warning ("Label %d at %L defined but not used", label->value,
8417 case ST_LABEL_BAD_TARGET:
8418 gfc_warning ("Label %d at %L defined but cannot be used",
8419 label->value, &label->where);
8426 warn_unused_fortran_label (label->right);
8430 /* Returns the sequence type of a symbol or sequence. */
8433 sequence_type (gfc_typespec ts)
8442 if (ts.derived->components == NULL)
8443 return SEQ_NONDEFAULT;
8445 result = sequence_type (ts.derived->components->ts);
8446 for (c = ts.derived->components->next; c; c = c->next)
8447 if (sequence_type (c->ts) != result)
8453 if (ts.kind != gfc_default_character_kind)
8454 return SEQ_NONDEFAULT;
8456 return SEQ_CHARACTER;
8459 if (ts.kind != gfc_default_integer_kind)
8460 return SEQ_NONDEFAULT;
8465 if (!(ts.kind == gfc_default_real_kind
8466 || ts.kind == gfc_default_double_kind))
8467 return SEQ_NONDEFAULT;
8472 if (ts.kind != gfc_default_complex_kind)
8473 return SEQ_NONDEFAULT;
8478 if (ts.kind != gfc_default_logical_kind)
8479 return SEQ_NONDEFAULT;
8484 return SEQ_NONDEFAULT;
8489 /* Resolve derived type EQUIVALENCE object. */
8492 resolve_equivalence_derived (gfc_symbol *derived, gfc_symbol *sym, gfc_expr *e)
8495 gfc_component *c = derived->components;
8500 /* Shall not be an object of nonsequence derived type. */
8501 if (!derived->attr.sequence)
8503 gfc_error ("Derived type variable '%s' at %L must have SEQUENCE "
8504 "attribute to be an EQUIVALENCE object", sym->name,
8509 /* Shall not have allocatable components. */
8510 if (derived->attr.alloc_comp)
8512 gfc_error ("Derived type variable '%s' at %L cannot have ALLOCATABLE "
8513 "components to be an EQUIVALENCE object",sym->name,
8518 for (; c ; c = c->next)
8522 && (resolve_equivalence_derived (c->ts.derived, sym, e) == FAILURE))
8525 /* Shall not be an object of sequence derived type containing a pointer
8526 in the structure. */
8529 gfc_error ("Derived type variable '%s' at %L with pointer "
8530 "component(s) cannot be an EQUIVALENCE object",
8531 sym->name, &e->where);
8539 /* Resolve equivalence object.
8540 An EQUIVALENCE object shall not be a dummy argument, a pointer, a target,
8541 an allocatable array, an object of nonsequence derived type, an object of
8542 sequence derived type containing a pointer at any level of component
8543 selection, an automatic object, a function name, an entry name, a result
8544 name, a named constant, a structure component, or a subobject of any of
8545 the preceding objects. A substring shall not have length zero. A
8546 derived type shall not have components with default initialization nor
8547 shall two objects of an equivalence group be initialized.
8548 Either all or none of the objects shall have an protected attribute.
8549 The simple constraints are done in symbol.c(check_conflict) and the rest
8550 are implemented here. */
8553 resolve_equivalence (gfc_equiv *eq)
8556 gfc_symbol *derived;
8557 gfc_symbol *first_sym;
8560 locus *last_where = NULL;
8561 seq_type eq_type, last_eq_type;
8562 gfc_typespec *last_ts;
8563 int object, cnt_protected;
8564 const char *value_name;
8568 last_ts = &eq->expr->symtree->n.sym->ts;
8570 first_sym = eq->expr->symtree->n.sym;
8574 for (object = 1; eq; eq = eq->eq, object++)
8578 e->ts = e->symtree->n.sym->ts;
8579 /* match_varspec might not know yet if it is seeing
8580 array reference or substring reference, as it doesn't
8582 if (e->ref && e->ref->type == REF_ARRAY)
8584 gfc_ref *ref = e->ref;
8585 sym = e->symtree->n.sym;
8587 if (sym->attr.dimension)
8589 ref->u.ar.as = sym->as;
8593 /* For substrings, convert REF_ARRAY into REF_SUBSTRING. */
8594 if (e->ts.type == BT_CHARACTER
8596 && ref->type == REF_ARRAY
8597 && ref->u.ar.dimen == 1
8598 && ref->u.ar.dimen_type[0] == DIMEN_RANGE
8599 && ref->u.ar.stride[0] == NULL)
8601 gfc_expr *start = ref->u.ar.start[0];
8602 gfc_expr *end = ref->u.ar.end[0];
8605 /* Optimize away the (:) reference. */
8606 if (start == NULL && end == NULL)
8611 e->ref->next = ref->next;
8616 ref->type = REF_SUBSTRING;
8618 start = gfc_int_expr (1);
8619 ref->u.ss.start = start;
8620 if (end == NULL && e->ts.cl)
8621 end = gfc_copy_expr (e->ts.cl->length);
8622 ref->u.ss.end = end;
8623 ref->u.ss.length = e->ts.cl;
8630 /* Any further ref is an error. */
8633 gcc_assert (ref->type == REF_ARRAY);
8634 gfc_error ("Syntax error in EQUIVALENCE statement at %L",
8640 if (gfc_resolve_expr (e) == FAILURE)
8643 sym = e->symtree->n.sym;
8645 if (sym->attr.protected)
8647 if (cnt_protected > 0 && cnt_protected != object)
8649 gfc_error ("Either all or none of the objects in the "
8650 "EQUIVALENCE set at %L shall have the "
8651 "PROTECTED attribute",
8656 /* Shall not equivalence common block variables in a PURE procedure. */
8657 if (sym->ns->proc_name
8658 && sym->ns->proc_name->attr.pure
8659 && sym->attr.in_common)
8661 gfc_error ("Common block member '%s' at %L cannot be an EQUIVALENCE "
8662 "object in the pure procedure '%s'",
8663 sym->name, &e->where, sym->ns->proc_name->name);
8667 /* Shall not be a named constant. */
8668 if (e->expr_type == EXPR_CONSTANT)
8670 gfc_error ("Named constant '%s' at %L cannot be an EQUIVALENCE "
8671 "object", sym->name, &e->where);
8675 derived = e->ts.derived;
8676 if (derived && resolve_equivalence_derived (derived, sym, e) == FAILURE)
8679 /* Check that the types correspond correctly:
8681 A numeric sequence structure may be equivalenced to another sequence
8682 structure, an object of default integer type, default real type, double
8683 precision real type, default logical type such that components of the
8684 structure ultimately only become associated to objects of the same
8685 kind. A character sequence structure may be equivalenced to an object
8686 of default character kind or another character sequence structure.
8687 Other objects may be equivalenced only to objects of the same type and
8690 /* Identical types are unconditionally OK. */
8691 if (object == 1 || gfc_compare_types (last_ts, &sym->ts))
8692 goto identical_types;
8694 last_eq_type = sequence_type (*last_ts);
8695 eq_type = sequence_type (sym->ts);
8697 /* Since the pair of objects is not of the same type, mixed or
8698 non-default sequences can be rejected. */
8700 msg = "Sequence %s with mixed components in EQUIVALENCE "
8701 "statement at %L with different type objects";
8703 && last_eq_type == SEQ_MIXED
8704 && gfc_notify_std (GFC_STD_GNU, msg, first_sym->name, last_where)
8706 || (eq_type == SEQ_MIXED
8707 && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
8708 &e->where) == FAILURE))
8711 msg = "Non-default type object or sequence %s in EQUIVALENCE "
8712 "statement at %L with objects of different type";
8714 && last_eq_type == SEQ_NONDEFAULT
8715 && gfc_notify_std (GFC_STD_GNU, msg, first_sym->name,
8716 last_where) == FAILURE)
8717 || (eq_type == SEQ_NONDEFAULT
8718 && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
8719 &e->where) == FAILURE))
8722 msg ="Non-CHARACTER object '%s' in default CHARACTER "
8723 "EQUIVALENCE statement at %L";
8724 if (last_eq_type == SEQ_CHARACTER
8725 && eq_type != SEQ_CHARACTER
8726 && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
8727 &e->where) == FAILURE)
8730 msg ="Non-NUMERIC object '%s' in default NUMERIC "
8731 "EQUIVALENCE statement at %L";
8732 if (last_eq_type == SEQ_NUMERIC
8733 && eq_type != SEQ_NUMERIC
8734 && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
8735 &e->where) == FAILURE)
8740 last_where = &e->where;
8745 /* Shall not be an automatic array. */
8746 if (e->ref->type == REF_ARRAY
8747 && gfc_resolve_array_spec (e->ref->u.ar.as, 1) == FAILURE)
8749 gfc_error ("Array '%s' at %L with non-constant bounds cannot be "
8750 "an EQUIVALENCE object", sym->name, &e->where);
8757 /* Shall not be a structure component. */
8758 if (r->type == REF_COMPONENT)
8760 gfc_error ("Structure component '%s' at %L cannot be an "
8761 "EQUIVALENCE object",
8762 r->u.c.component->name, &e->where);
8766 /* A substring shall not have length zero. */
8767 if (r->type == REF_SUBSTRING)
8769 if (compare_bound (r->u.ss.start, r->u.ss.end) == CMP_GT)
8771 gfc_error ("Substring at %L has length zero",
8772 &r->u.ss.start->where);
8782 /* Resolve function and ENTRY types, issue diagnostics if needed. */
8785 resolve_fntype (gfc_namespace *ns)
8790 if (ns->proc_name == NULL || !ns->proc_name->attr.function)
8793 /* If there are any entries, ns->proc_name is the entry master
8794 synthetic symbol and ns->entries->sym actual FUNCTION symbol. */
8796 sym = ns->entries->sym;
8798 sym = ns->proc_name;
8799 if (sym->result == sym
8800 && sym->ts.type == BT_UNKNOWN
8801 && gfc_set_default_type (sym, 0, NULL) == FAILURE
8802 && !sym->attr.untyped)
8804 gfc_error ("Function '%s' at %L has no IMPLICIT type",
8805 sym->name, &sym->declared_at);
8806 sym->attr.untyped = 1;
8809 if (sym->ts.type == BT_DERIVED && !sym->ts.derived->attr.use_assoc
8810 && !gfc_check_access (sym->ts.derived->attr.access,
8811 sym->ts.derived->ns->default_access)
8812 && gfc_check_access (sym->attr.access, sym->ns->default_access))
8814 gfc_error ("PUBLIC function '%s' at %L cannot be of PRIVATE type '%s'",
8815 sym->name, &sym->declared_at, sym->ts.derived->name);
8819 for (el = ns->entries->next; el; el = el->next)
8821 if (el->sym->result == el->sym
8822 && el->sym->ts.type == BT_UNKNOWN
8823 && gfc_set_default_type (el->sym, 0, NULL) == FAILURE
8824 && !el->sym->attr.untyped)
8826 gfc_error ("ENTRY '%s' at %L has no IMPLICIT type",
8827 el->sym->name, &el->sym->declared_at);
8828 el->sym->attr.untyped = 1;
8833 /* 12.3.2.1.1 Defined operators. */
8836 gfc_resolve_uops (gfc_symtree *symtree)
8840 gfc_formal_arglist *formal;
8842 if (symtree == NULL)
8845 gfc_resolve_uops (symtree->left);
8846 gfc_resolve_uops (symtree->right);
8848 for (itr = symtree->n.uop->operator; itr; itr = itr->next)
8851 if (!sym->attr.function)
8852 gfc_error ("User operator procedure '%s' at %L must be a FUNCTION",
8853 sym->name, &sym->declared_at);
8855 if (sym->ts.type == BT_CHARACTER
8856 && !(sym->ts.cl && sym->ts.cl->length)
8857 && !(sym->result && sym->result->ts.cl
8858 && sym->result->ts.cl->length))
8859 gfc_error ("User operator procedure '%s' at %L cannot be assumed "
8860 "character length", sym->name, &sym->declared_at);
8862 formal = sym->formal;
8863 if (!formal || !formal->sym)
8865 gfc_error ("User operator procedure '%s' at %L must have at least "
8866 "one argument", sym->name, &sym->declared_at);
8870 if (formal->sym->attr.intent != INTENT_IN)
8871 gfc_error ("First argument of operator interface at %L must be "
8872 "INTENT(IN)", &sym->declared_at);
8874 if (formal->sym->attr.optional)
8875 gfc_error ("First argument of operator interface at %L cannot be "
8876 "optional", &sym->declared_at);
8878 formal = formal->next;
8879 if (!formal || !formal->sym)
8882 if (formal->sym->attr.intent != INTENT_IN)
8883 gfc_error ("Second argument of operator interface at %L must be "
8884 "INTENT(IN)", &sym->declared_at);
8886 if (formal->sym->attr.optional)
8887 gfc_error ("Second argument of operator interface at %L cannot be "
8888 "optional", &sym->declared_at);
8891 gfc_error ("Operator interface at %L must have, at most, two "
8892 "arguments", &sym->declared_at);
8897 /* Examine all of the expressions associated with a program unit,
8898 assign types to all intermediate expressions, make sure that all
8899 assignments are to compatible types and figure out which names
8900 refer to which functions or subroutines. It doesn't check code
8901 block, which is handled by resolve_code. */
8904 resolve_types (gfc_namespace *ns)
8911 gfc_current_ns = ns;
8913 resolve_entries (ns);
8915 resolve_common_blocks (ns->common_root);
8917 resolve_contained_functions (ns);
8919 gfc_traverse_ns (ns, resolve_bind_c_derived_types);
8921 for (cl = ns->cl_list; cl; cl = cl->next)
8922 resolve_charlen (cl);
8924 gfc_traverse_ns (ns, resolve_symbol);
8926 resolve_fntype (ns);
8928 for (n = ns->contained; n; n = n->sibling)
8930 if (gfc_pure (ns->proc_name) && !gfc_pure (n->proc_name))
8931 gfc_error ("Contained procedure '%s' at %L of a PURE procedure must "
8932 "also be PURE", n->proc_name->name,
8933 &n->proc_name->declared_at);
8939 gfc_check_interfaces (ns);
8941 gfc_traverse_ns (ns, resolve_values);
8947 for (d = ns->data; d; d = d->next)
8951 gfc_traverse_ns (ns, gfc_formalize_init_value);
8953 gfc_traverse_ns (ns, gfc_verify_binding_labels);
8955 if (ns->common_root != NULL)
8956 gfc_traverse_symtree (ns->common_root, resolve_bind_c_comms);
8958 for (eq = ns->equiv; eq; eq = eq->next)
8959 resolve_equivalence (eq);
8961 /* Warn about unused labels. */
8962 if (warn_unused_label)
8963 warn_unused_fortran_label (ns->st_labels);
8965 gfc_resolve_uops (ns->uop_root);
8969 /* Call resolve_code recursively. */
8972 resolve_codes (gfc_namespace *ns)
8976 for (n = ns->contained; n; n = n->sibling)
8979 gfc_current_ns = ns;
8981 /* Set to an out of range value. */
8982 current_entry_id = -1;
8984 bitmap_obstack_initialize (&labels_obstack);
8985 resolve_code (ns->code, ns);
8986 bitmap_obstack_release (&labels_obstack);
8990 /* This function is called after a complete program unit has been compiled.
8991 Its purpose is to examine all of the expressions associated with a program
8992 unit, assign types to all intermediate expressions, make sure that all
8993 assignments are to compatible types and figure out which names refer to
8994 which functions or subroutines. */
8997 gfc_resolve (gfc_namespace *ns)
8999 gfc_namespace *old_ns;
9001 old_ns = gfc_current_ns;
9006 gfc_current_ns = old_ns;