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->ts.type != BT_PROCEDURE)
976 if (gfc_resolve_expr (e) != SUCCESS)
981 /* See if the expression node should really be a variable reference. */
983 sym = e->symtree->n.sym;
985 if (sym->attr.flavor == FL_PROCEDURE
986 || sym->attr.intrinsic
987 || sym->attr.external)
991 /* If a procedure is not already determined to be something else
992 check if it is intrinsic. */
993 if (!sym->attr.intrinsic
994 && !(sym->attr.external || sym->attr.use_assoc
995 || sym->attr.if_source == IFSRC_IFBODY)
996 && gfc_intrinsic_name (sym->name, sym->attr.subroutine))
997 sym->attr.intrinsic = 1;
999 if (sym->attr.proc == PROC_ST_FUNCTION)
1001 gfc_error ("Statement function '%s' at %L is not allowed as an "
1002 "actual argument", sym->name, &e->where);
1005 actual_ok = gfc_intrinsic_actual_ok (sym->name,
1006 sym->attr.subroutine);
1007 if (sym->attr.intrinsic && actual_ok == 0)
1009 gfc_error ("Intrinsic '%s' at %L is not allowed as an "
1010 "actual argument", sym->name, &e->where);
1013 if (sym->attr.contained && !sym->attr.use_assoc
1014 && sym->ns->proc_name->attr.flavor != FL_MODULE)
1016 gfc_error ("Internal procedure '%s' is not allowed as an "
1017 "actual argument at %L", sym->name, &e->where);
1020 if (sym->attr.elemental && !sym->attr.intrinsic)
1022 gfc_error ("ELEMENTAL non-INTRINSIC procedure '%s' is not "
1023 "allowed as an actual argument at %L", sym->name,
1027 /* Check if a generic interface has a specific procedure
1028 with the same name before emitting an error. */
1029 if (sym->attr.generic)
1032 for (p = sym->generic; p; p = p->next)
1033 if (strcmp (sym->name, p->sym->name) == 0)
1035 e->symtree = gfc_find_symtree
1036 (p->sym->ns->sym_root, sym->name);
1041 if (p == NULL || e->symtree == NULL)
1042 gfc_error ("GENERIC non-INTRINSIC procedure '%s' is not "
1043 "allowed as an actual argument at %L", sym->name,
1047 /* If the symbol is the function that names the current (or
1048 parent) scope, then we really have a variable reference. */
1050 if (sym->attr.function && sym->result == sym
1051 && (sym->ns->proc_name == sym
1052 || (sym->ns->parent != NULL
1053 && sym->ns->parent->proc_name == sym)))
1056 /* If all else fails, see if we have a specific intrinsic. */
1057 if (sym->attr.function
1058 && sym->ts.type == BT_UNKNOWN && sym->attr.intrinsic)
1060 gfc_intrinsic_sym *isym;
1061 isym = gfc_find_function (sym->name);
1062 if (isym == NULL || !isym->specific)
1064 gfc_error ("Unable to find a specific INTRINSIC procedure "
1065 "for the reference '%s' at %L", sym->name,
1073 /* See if the name is a module procedure in a parent unit. */
1075 if (was_declared (sym) || sym->ns->parent == NULL)
1078 if (gfc_find_sym_tree (sym->name, sym->ns->parent, 1, &parent_st))
1080 gfc_error ("Symbol '%s' at %L is ambiguous", sym->name, &e->where);
1084 if (parent_st == NULL)
1087 sym = parent_st->n.sym;
1088 e->symtree = parent_st; /* Point to the right thing. */
1090 if (sym->attr.flavor == FL_PROCEDURE
1091 || sym->attr.intrinsic
1092 || sym->attr.external)
1098 e->expr_type = EXPR_VARIABLE;
1100 if (sym->as != NULL)
1102 e->rank = sym->as->rank;
1103 e->ref = gfc_get_ref ();
1104 e->ref->type = REF_ARRAY;
1105 e->ref->u.ar.type = AR_FULL;
1106 e->ref->u.ar.as = sym->as;
1109 /* Expressions are assigned a default ts.type of BT_PROCEDURE in
1110 primary.c (match_actual_arg). If above code determines that it
1111 is a variable instead, it needs to be resolved as it was not
1112 done at the beginning of this function. */
1113 if (gfc_resolve_expr (e) != SUCCESS)
1117 /* Check argument list functions %VAL, %LOC and %REF. There is
1118 nothing to do for %REF. */
1119 if (arg->name && arg->name[0] == '%')
1121 if (strncmp ("%VAL", arg->name, 4) == 0)
1123 if (e->ts.type == BT_CHARACTER || e->ts.type == BT_DERIVED)
1125 gfc_error ("By-value argument at %L is not of numeric "
1132 gfc_error ("By-value argument at %L cannot be an array or "
1133 "an array section", &e->where);
1137 /* Intrinsics are still PROC_UNKNOWN here. However,
1138 since same file external procedures are not resolvable
1139 in gfortran, it is a good deal easier to leave them to
1141 if (ptype != PROC_UNKNOWN
1142 && ptype != PROC_DUMMY
1143 && ptype != PROC_EXTERNAL
1144 && ptype != PROC_MODULE)
1146 gfc_error ("By-value argument at %L is not allowed "
1147 "in this context", &e->where);
1152 /* Statement functions have already been excluded above. */
1153 else if (strncmp ("%LOC", arg->name, 4) == 0
1154 && e->ts.type == BT_PROCEDURE)
1156 if (e->symtree->n.sym->attr.proc == PROC_INTERNAL)
1158 gfc_error ("Passing internal procedure at %L by location "
1159 "not allowed", &e->where);
1170 /* Do the checks of the actual argument list that are specific to elemental
1171 procedures. If called with c == NULL, we have a function, otherwise if
1172 expr == NULL, we have a subroutine. */
1175 resolve_elemental_actual (gfc_expr *expr, gfc_code *c)
1177 gfc_actual_arglist *arg0;
1178 gfc_actual_arglist *arg;
1179 gfc_symbol *esym = NULL;
1180 gfc_intrinsic_sym *isym = NULL;
1182 gfc_intrinsic_arg *iformal = NULL;
1183 gfc_formal_arglist *eformal = NULL;
1184 bool formal_optional = false;
1185 bool set_by_optional = false;
1189 /* Is this an elemental procedure? */
1190 if (expr && expr->value.function.actual != NULL)
1192 if (expr->value.function.esym != NULL
1193 && expr->value.function.esym->attr.elemental)
1195 arg0 = expr->value.function.actual;
1196 esym = expr->value.function.esym;
1198 else if (expr->value.function.isym != NULL
1199 && expr->value.function.isym->elemental)
1201 arg0 = expr->value.function.actual;
1202 isym = expr->value.function.isym;
1207 else if (c && c->ext.actual != NULL && c->symtree->n.sym->attr.elemental)
1209 arg0 = c->ext.actual;
1210 esym = c->symtree->n.sym;
1215 /* The rank of an elemental is the rank of its array argument(s). */
1216 for (arg = arg0; arg; arg = arg->next)
1218 if (arg->expr != NULL && arg->expr->rank > 0)
1220 rank = arg->expr->rank;
1221 if (arg->expr->expr_type == EXPR_VARIABLE
1222 && arg->expr->symtree->n.sym->attr.optional)
1223 set_by_optional = true;
1225 /* Function specific; set the result rank and shape. */
1229 if (!expr->shape && arg->expr->shape)
1231 expr->shape = gfc_get_shape (rank);
1232 for (i = 0; i < rank; i++)
1233 mpz_init_set (expr->shape[i], arg->expr->shape[i]);
1240 /* If it is an array, it shall not be supplied as an actual argument
1241 to an elemental procedure unless an array of the same rank is supplied
1242 as an actual argument corresponding to a nonoptional dummy argument of
1243 that elemental procedure(12.4.1.5). */
1244 formal_optional = false;
1246 iformal = isym->formal;
1248 eformal = esym->formal;
1250 for (arg = arg0; arg; arg = arg->next)
1254 if (eformal->sym && eformal->sym->attr.optional)
1255 formal_optional = true;
1256 eformal = eformal->next;
1258 else if (isym && iformal)
1260 if (iformal->optional)
1261 formal_optional = true;
1262 iformal = iformal->next;
1265 formal_optional = true;
1267 if (pedantic && arg->expr != NULL
1268 && arg->expr->expr_type == EXPR_VARIABLE
1269 && arg->expr->symtree->n.sym->attr.optional
1272 && (set_by_optional || arg->expr->rank != rank)
1273 && !(isym && isym->id == GFC_ISYM_CONVERSION))
1275 gfc_warning ("'%s' at %L is an array and OPTIONAL; IF IT IS "
1276 "MISSING, it cannot be the actual argument of an "
1277 "ELEMENTAL procedure unless there is a non-optional "
1278 "argument with the same rank (12.4.1.5)",
1279 arg->expr->symtree->n.sym->name, &arg->expr->where);
1284 for (arg = arg0; arg; arg = arg->next)
1286 if (arg->expr == NULL || arg->expr->rank == 0)
1289 /* Being elemental, the last upper bound of an assumed size array
1290 argument must be present. */
1291 if (resolve_assumed_size_actual (arg->expr))
1294 /* Elemental procedure's array actual arguments must conform. */
1297 if (gfc_check_conformance ("elemental procedure", arg->expr, e)
1305 /* INTENT(OUT) is only allowed for subroutines; if any actual argument
1306 is an array, the intent inout/out variable needs to be also an array. */
1307 if (rank > 0 && esym && expr == NULL)
1308 for (eformal = esym->formal, arg = arg0; arg && eformal;
1309 arg = arg->next, eformal = eformal->next)
1310 if ((eformal->sym->attr.intent == INTENT_OUT
1311 || eformal->sym->attr.intent == INTENT_INOUT)
1312 && arg->expr && arg->expr->rank == 0)
1314 gfc_error ("Actual argument at %L for INTENT(%s) dummy '%s' of "
1315 "ELEMENTAL subroutine '%s' is a scalar, but another "
1316 "actual argument is an array", &arg->expr->where,
1317 (eformal->sym->attr.intent == INTENT_OUT) ? "OUT"
1318 : "INOUT", eformal->sym->name, esym->name);
1325 /* Go through each actual argument in ACTUAL and see if it can be
1326 implemented as an inlined, non-copying intrinsic. FNSYM is the
1327 function being called, or NULL if not known. */
1330 find_noncopying_intrinsics (gfc_symbol *fnsym, gfc_actual_arglist *actual)
1332 gfc_actual_arglist *ap;
1335 for (ap = actual; ap; ap = ap->next)
1337 && (expr = gfc_get_noncopying_intrinsic_argument (ap->expr))
1338 && !gfc_check_fncall_dependency (expr, INTENT_IN, fnsym, actual))
1339 ap->expr->inline_noncopying_intrinsic = 1;
1343 /* This function does the checking of references to global procedures
1344 as defined in sections 18.1 and 14.1, respectively, of the Fortran
1345 77 and 95 standards. It checks for a gsymbol for the name, making
1346 one if it does not already exist. If it already exists, then the
1347 reference being resolved must correspond to the type of gsymbol.
1348 Otherwise, the new symbol is equipped with the attributes of the
1349 reference. The corresponding code that is called in creating
1350 global entities is parse.c. */
1353 resolve_global_procedure (gfc_symbol *sym, locus *where, int sub)
1358 type = sub ? GSYM_SUBROUTINE : GSYM_FUNCTION;
1360 gsym = gfc_get_gsymbol (sym->name);
1362 if ((gsym->type != GSYM_UNKNOWN && gsym->type != type))
1363 gfc_global_used (gsym, where);
1365 if (gsym->type == GSYM_UNKNOWN)
1368 gsym->where = *where;
1375 /************* Function resolution *************/
1377 /* Resolve a function call known to be generic.
1378 Section 14.1.2.4.1. */
1381 resolve_generic_f0 (gfc_expr *expr, gfc_symbol *sym)
1385 if (sym->attr.generic)
1387 s = gfc_search_interface (sym->generic, 0, &expr->value.function.actual);
1390 expr->value.function.name = s->name;
1391 expr->value.function.esym = s;
1393 if (s->ts.type != BT_UNKNOWN)
1395 else if (s->result != NULL && s->result->ts.type != BT_UNKNOWN)
1396 expr->ts = s->result->ts;
1399 expr->rank = s->as->rank;
1400 else if (s->result != NULL && s->result->as != NULL)
1401 expr->rank = s->result->as->rank;
1406 /* TODO: Need to search for elemental references in generic
1410 if (sym->attr.intrinsic)
1411 return gfc_intrinsic_func_interface (expr, 0);
1418 resolve_generic_f (gfc_expr *expr)
1423 sym = expr->symtree->n.sym;
1427 m = resolve_generic_f0 (expr, sym);
1430 else if (m == MATCH_ERROR)
1434 if (sym->ns->parent == NULL)
1436 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
1440 if (!generic_sym (sym))
1444 /* Last ditch attempt. See if the reference is to an intrinsic
1445 that possesses a matching interface. 14.1.2.4 */
1446 if (sym && !gfc_intrinsic_name (sym->name, 0))
1448 gfc_error ("There is no specific function for the generic '%s' at %L",
1449 expr->symtree->n.sym->name, &expr->where);
1453 m = gfc_intrinsic_func_interface (expr, 0);
1457 gfc_error ("Generic function '%s' at %L is not consistent with a "
1458 "specific intrinsic interface", expr->symtree->n.sym->name,
1465 /* Resolve a function call known to be specific. */
1468 resolve_specific_f0 (gfc_symbol *sym, gfc_expr *expr)
1472 if (sym->attr.external || sym->attr.if_source == IFSRC_IFBODY)
1474 if (sym->attr.dummy)
1476 sym->attr.proc = PROC_DUMMY;
1480 sym->attr.proc = PROC_EXTERNAL;
1484 if (sym->attr.proc == PROC_MODULE
1485 || sym->attr.proc == PROC_ST_FUNCTION
1486 || sym->attr.proc == PROC_INTERNAL)
1489 if (sym->attr.intrinsic)
1491 m = gfc_intrinsic_func_interface (expr, 1);
1495 gfc_error ("Function '%s' at %L is INTRINSIC but is not compatible "
1496 "with an intrinsic", sym->name, &expr->where);
1504 gfc_procedure_use (sym, &expr->value.function.actual, &expr->where);
1507 expr->value.function.name = sym->name;
1508 expr->value.function.esym = sym;
1509 if (sym->as != NULL)
1510 expr->rank = sym->as->rank;
1517 resolve_specific_f (gfc_expr *expr)
1522 sym = expr->symtree->n.sym;
1526 m = resolve_specific_f0 (sym, expr);
1529 if (m == MATCH_ERROR)
1532 if (sym->ns->parent == NULL)
1535 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
1541 gfc_error ("Unable to resolve the specific function '%s' at %L",
1542 expr->symtree->n.sym->name, &expr->where);
1548 /* Resolve a procedure call not known to be generic nor specific. */
1551 resolve_unknown_f (gfc_expr *expr)
1556 sym = expr->symtree->n.sym;
1558 if (sym->attr.dummy)
1560 sym->attr.proc = PROC_DUMMY;
1561 expr->value.function.name = sym->name;
1565 /* See if we have an intrinsic function reference. */
1567 if (gfc_intrinsic_name (sym->name, 0))
1569 if (gfc_intrinsic_func_interface (expr, 1) == MATCH_YES)
1574 /* The reference is to an external name. */
1576 sym->attr.proc = PROC_EXTERNAL;
1577 expr->value.function.name = sym->name;
1578 expr->value.function.esym = expr->symtree->n.sym;
1580 if (sym->as != NULL)
1581 expr->rank = sym->as->rank;
1583 /* Type of the expression is either the type of the symbol or the
1584 default type of the symbol. */
1587 gfc_procedure_use (sym, &expr->value.function.actual, &expr->where);
1589 if (sym->ts.type != BT_UNKNOWN)
1593 ts = gfc_get_default_type (sym, sym->ns);
1595 if (ts->type == BT_UNKNOWN)
1597 gfc_error ("Function '%s' at %L has no IMPLICIT type",
1598 sym->name, &expr->where);
1609 /* Return true, if the symbol is an external procedure. */
1611 is_external_proc (gfc_symbol *sym)
1613 if (!sym->attr.dummy && !sym->attr.contained
1614 && !(sym->attr.intrinsic
1615 || gfc_intrinsic_name (sym->name, sym->attr.subroutine))
1616 && sym->attr.proc != PROC_ST_FUNCTION
1617 && !sym->attr.use_assoc
1625 /* Figure out if a function reference is pure or not. Also set the name
1626 of the function for a potential error message. Return nonzero if the
1627 function is PURE, zero if not. */
1630 pure_function (gfc_expr *e, const char **name)
1636 if (e->symtree != NULL
1637 && e->symtree->n.sym != NULL
1638 && e->symtree->n.sym->attr.proc == PROC_ST_FUNCTION)
1641 if (e->value.function.esym)
1643 pure = gfc_pure (e->value.function.esym);
1644 *name = e->value.function.esym->name;
1646 else if (e->value.function.isym)
1648 pure = e->value.function.isym->pure
1649 || e->value.function.isym->elemental;
1650 *name = e->value.function.isym->name;
1654 /* Implicit functions are not pure. */
1656 *name = e->value.function.name;
1664 is_scalar_expr_ptr (gfc_expr *expr)
1666 try retval = SUCCESS;
1671 /* See if we have a gfc_ref, which means we have a substring, array
1672 reference, or a component. */
1673 if (expr->ref != NULL)
1676 while (ref->next != NULL)
1682 if (ref->u.ss.length != NULL
1683 && ref->u.ss.length->length != NULL
1685 && ref->u.ss.start->expr_type == EXPR_CONSTANT
1687 && ref->u.ss.end->expr_type == EXPR_CONSTANT)
1689 start = (int) mpz_get_si (ref->u.ss.start->value.integer);
1690 end = (int) mpz_get_si (ref->u.ss.end->value.integer);
1691 if (end - start + 1 != 1)
1698 if (ref->u.ar.type == AR_ELEMENT)
1700 else if (ref->u.ar.type == AR_FULL)
1702 /* The user can give a full array if the array is of size 1. */
1703 if (ref->u.ar.as != NULL
1704 && ref->u.ar.as->rank == 1
1705 && ref->u.ar.as->type == AS_EXPLICIT
1706 && ref->u.ar.as->lower[0] != NULL
1707 && ref->u.ar.as->lower[0]->expr_type == EXPR_CONSTANT
1708 && ref->u.ar.as->upper[0] != NULL
1709 && ref->u.ar.as->upper[0]->expr_type == EXPR_CONSTANT)
1711 /* If we have a character string, we need to check if
1712 its length is one. */
1713 if (expr->ts.type == BT_CHARACTER)
1715 if (expr->ts.cl == NULL
1716 || expr->ts.cl->length == NULL
1717 || mpz_cmp_si (expr->ts.cl->length->value.integer, 1)
1723 /* We have constant lower and upper bounds. If the
1724 difference between is 1, it can be considered a
1726 start = (int) mpz_get_si
1727 (ref->u.ar.as->lower[0]->value.integer);
1728 end = (int) mpz_get_si
1729 (ref->u.ar.as->upper[0]->value.integer);
1730 if (end - start + 1 != 1)
1745 else if (expr->ts.type == BT_CHARACTER && expr->rank == 0)
1747 /* Character string. Make sure it's of length 1. */
1748 if (expr->ts.cl == NULL
1749 || expr->ts.cl->length == NULL
1750 || mpz_cmp_si (expr->ts.cl->length->value.integer, 1) != 0)
1753 else if (expr->rank != 0)
1760 /* Match one of the iso_c_binding functions (c_associated or c_loc)
1761 and, in the case of c_associated, set the binding label based on
1765 gfc_iso_c_func_interface (gfc_symbol *sym, gfc_actual_arglist *args,
1766 gfc_symbol **new_sym)
1768 char name[GFC_MAX_SYMBOL_LEN + 1];
1769 char binding_label[GFC_MAX_BINDING_LABEL_LEN + 1];
1770 int optional_arg = 0;
1771 try retval = SUCCESS;
1772 gfc_symbol *args_sym;
1773 gfc_typespec *arg_ts;
1774 gfc_ref *parent_ref;
1777 if (args->expr->expr_type == EXPR_CONSTANT
1778 || args->expr->expr_type == EXPR_OP
1779 || args->expr->expr_type == EXPR_NULL)
1781 gfc_error ("Argument to '%s' at %L is not a variable",
1782 sym->name, &(args->expr->where));
1786 args_sym = args->expr->symtree->n.sym;
1788 /* The typespec for the actual arg should be that stored in the expr
1789 and not necessarily that of the expr symbol (args_sym), because
1790 the actual expression could be a part-ref of the expr symbol. */
1791 arg_ts = &(args->expr->ts);
1793 /* Get the parent reference (if any) for the expression. This happens for
1794 cases such as a%b%c. */
1795 parent_ref = args->expr->ref;
1797 if (parent_ref != NULL)
1799 curr_ref = parent_ref->next;
1800 while (curr_ref != NULL && curr_ref->next != NULL)
1802 parent_ref = curr_ref;
1803 curr_ref = curr_ref->next;
1807 /* If curr_ref is non-NULL, we had a part-ref expression. If the curr_ref
1808 is for a REF_COMPONENT, then we need to use it as the parent_ref for
1809 the name, etc. Otherwise, the current parent_ref should be correct. */
1810 if (curr_ref != NULL && curr_ref->type == REF_COMPONENT)
1811 parent_ref = curr_ref;
1813 if (parent_ref == args->expr->ref)
1815 else if (parent_ref != NULL && parent_ref->type != REF_COMPONENT)
1816 gfc_internal_error ("Unexpected expression reference type in "
1817 "gfc_iso_c_func_interface");
1819 if (sym->intmod_sym_id == ISOCBINDING_ASSOCIATED)
1821 /* If the user gave two args then they are providing something for
1822 the optional arg (the second cptr). Therefore, set the name and
1823 binding label to the c_associated for two cptrs. Otherwise,
1824 set c_associated to expect one cptr. */
1828 sprintf (name, "%s_2", sym->name);
1829 sprintf (binding_label, "%s_2", sym->binding_label);
1835 sprintf (name, "%s_1", sym->name);
1836 sprintf (binding_label, "%s_1", sym->binding_label);
1840 /* Get a new symbol for the version of c_associated that
1842 *new_sym = get_iso_c_sym (sym, name, binding_label, optional_arg);
1844 else if (sym->intmod_sym_id == ISOCBINDING_LOC
1845 || sym->intmod_sym_id == ISOCBINDING_FUNLOC)
1847 sprintf (name, "%s", sym->name);
1848 sprintf (binding_label, "%s", sym->binding_label);
1850 /* Error check the call. */
1851 if (args->next != NULL)
1853 gfc_error_now ("More actual than formal arguments in '%s' "
1854 "call at %L", name, &(args->expr->where));
1857 else if (sym->intmod_sym_id == ISOCBINDING_LOC)
1859 /* Make sure we have either the target or pointer attribute. */
1860 if (!(args_sym->attr.target)
1861 && !(args_sym->attr.pointer)
1862 && (parent_ref == NULL ||
1863 !parent_ref->u.c.component->pointer))
1865 gfc_error_now ("Parameter '%s' to '%s' at %L must be either "
1866 "a TARGET or an associated pointer",
1868 sym->name, &(args->expr->where));
1872 /* See if we have interoperable type and type param. */
1873 if (verify_c_interop (arg_ts,
1874 (parent_ref ? parent_ref->u.c.component->name
1876 &(args->expr->where)) == SUCCESS
1877 || gfc_check_any_c_kind (arg_ts) == SUCCESS)
1879 if (args_sym->attr.target == 1)
1881 /* Case 1a, section 15.1.2.5, J3/04-007: variable that
1882 has the target attribute and is interoperable. */
1883 /* Case 1b, section 15.1.2.5, J3/04-007: allocated
1884 allocatable variable that has the TARGET attribute and
1885 is not an array of zero size. */
1886 if (args_sym->attr.allocatable == 1)
1888 if (args_sym->attr.dimension != 0
1889 && (args_sym->as && args_sym->as->rank == 0))
1891 gfc_error_now ("Allocatable variable '%s' used as a "
1892 "parameter to '%s' at %L must not be "
1893 "an array of zero size",
1894 args_sym->name, sym->name,
1895 &(args->expr->where));
1901 /* A non-allocatable target variable with C
1902 interoperable type and type parameters must be
1904 if (args_sym && args_sym->attr.dimension)
1906 if (args_sym->as->type == AS_ASSUMED_SHAPE)
1908 gfc_error ("Assumed-shape array '%s' at %L "
1909 "cannot be an argument to the "
1910 "procedure '%s' because "
1911 "it is not C interoperable",
1913 &(args->expr->where), sym->name);
1916 else if (args_sym->as->type == AS_DEFERRED)
1918 gfc_error ("Deferred-shape array '%s' at %L "
1919 "cannot be an argument to the "
1920 "procedure '%s' because "
1921 "it is not C interoperable",
1923 &(args->expr->where), sym->name);
1928 /* Make sure it's not a character string. Arrays of
1929 any type should be ok if the variable is of a C
1930 interoperable type. */
1931 if (arg_ts->type == BT_CHARACTER)
1932 if (arg_ts->cl != NULL
1933 && (arg_ts->cl->length == NULL
1934 || arg_ts->cl->length->expr_type
1937 (arg_ts->cl->length->value.integer, 1)
1939 && is_scalar_expr_ptr (args->expr) != SUCCESS)
1941 gfc_error_now ("CHARACTER argument '%s' to '%s' "
1942 "at %L must have a length of 1",
1943 args_sym->name, sym->name,
1944 &(args->expr->where));
1949 else if ((args_sym->attr.pointer == 1 ||
1951 && parent_ref->u.c.component->pointer))
1952 && is_scalar_expr_ptr (args->expr) != SUCCESS)
1954 /* Case 1c, section 15.1.2.5, J3/04-007: an associated
1956 gfc_error_now ("Argument '%s' to '%s' at %L must be an "
1957 "associated scalar POINTER", args_sym->name,
1958 sym->name, &(args->expr->where));
1964 /* The parameter is not required to be C interoperable. If it
1965 is not C interoperable, it must be a nonpolymorphic scalar
1966 with no length type parameters. It still must have either
1967 the pointer or target attribute, and it can be
1968 allocatable (but must be allocated when c_loc is called). */
1969 if (args->expr->rank != 0
1970 && is_scalar_expr_ptr (args->expr) != SUCCESS)
1972 gfc_error_now ("Parameter '%s' to '%s' at %L must be a "
1973 "scalar", args_sym->name, sym->name,
1974 &(args->expr->where));
1977 else if (arg_ts->type == BT_CHARACTER
1978 && is_scalar_expr_ptr (args->expr) != SUCCESS)
1980 gfc_error_now ("CHARACTER argument '%s' to '%s' at "
1981 "%L must have a length of 1",
1982 args_sym->name, sym->name,
1983 &(args->expr->where));
1988 else if (sym->intmod_sym_id == ISOCBINDING_FUNLOC)
1990 if (args_sym->attr.flavor != FL_PROCEDURE)
1992 /* TODO: Update this error message to allow for procedure
1993 pointers once they are implemented. */
1994 gfc_error_now ("Parameter '%s' to '%s' at %L must be a "
1996 args_sym->name, sym->name,
1997 &(args->expr->where));
2000 else if (args_sym->attr.is_bind_c != 1)
2002 gfc_error_now ("Parameter '%s' to '%s' at %L must be "
2004 args_sym->name, sym->name,
2005 &(args->expr->where));
2010 /* for c_loc/c_funloc, the new symbol is the same as the old one */
2015 gfc_internal_error ("gfc_iso_c_func_interface(): Unhandled "
2016 "iso_c_binding function: '%s'!\n", sym->name);
2023 /* Resolve a function call, which means resolving the arguments, then figuring
2024 out which entity the name refers to. */
2025 /* TODO: Check procedure arguments so that an INTENT(IN) isn't passed
2026 to INTENT(OUT) or INTENT(INOUT). */
2029 resolve_function (gfc_expr *expr)
2031 gfc_actual_arglist *arg;
2036 procedure_type p = PROC_INTRINSIC;
2040 sym = expr->symtree->n.sym;
2042 if (sym && sym->attr.flavor == FL_VARIABLE)
2044 gfc_error ("'%s' at %L is not a function", sym->name, &expr->where);
2048 if (sym && sym->attr.abstract)
2050 gfc_error ("ABSTRACT INTERFACE '%s' must not be referenced at %L",
2051 sym->name, &expr->where);
2055 /* If the procedure is external, check for usage. */
2056 if (sym && is_external_proc (sym))
2057 resolve_global_procedure (sym, &expr->where, 0);
2059 /* Switch off assumed size checking and do this again for certain kinds
2060 of procedure, once the procedure itself is resolved. */
2061 need_full_assumed_size++;
2063 if (expr->symtree && expr->symtree->n.sym)
2064 p = expr->symtree->n.sym->attr.proc;
2066 if (resolve_actual_arglist (expr->value.function.actual, p) == FAILURE)
2069 /* Need to setup the call to the correct c_associated, depending on
2070 the number of cptrs to user gives to compare. */
2071 if (sym && sym->attr.is_iso_c == 1)
2073 if (gfc_iso_c_func_interface (sym, expr->value.function.actual, &sym)
2077 /* Get the symtree for the new symbol (resolved func).
2078 the old one will be freed later, when it's no longer used. */
2079 gfc_find_sym_tree (sym->name, sym->ns, 1, &(expr->symtree));
2082 /* Resume assumed_size checking. */
2083 need_full_assumed_size--;
2085 if (sym && sym->ts.type == BT_CHARACTER
2087 && sym->ts.cl->length == NULL
2089 && expr->value.function.esym == NULL
2090 && !sym->attr.contained)
2092 /* Internal procedures are taken care of in resolve_contained_fntype. */
2093 gfc_error ("Function '%s' is declared CHARACTER(*) and cannot "
2094 "be used at %L since it is not a dummy argument",
2095 sym->name, &expr->where);
2099 /* See if function is already resolved. */
2101 if (expr->value.function.name != NULL)
2103 if (expr->ts.type == BT_UNKNOWN)
2109 /* Apply the rules of section 14.1.2. */
2111 switch (procedure_kind (sym))
2114 t = resolve_generic_f (expr);
2117 case PTYPE_SPECIFIC:
2118 t = resolve_specific_f (expr);
2122 t = resolve_unknown_f (expr);
2126 gfc_internal_error ("resolve_function(): bad function type");
2130 /* If the expression is still a function (it might have simplified),
2131 then we check to see if we are calling an elemental function. */
2133 if (expr->expr_type != EXPR_FUNCTION)
2136 temp = need_full_assumed_size;
2137 need_full_assumed_size = 0;
2139 if (resolve_elemental_actual (expr, NULL) == FAILURE)
2142 if (omp_workshare_flag
2143 && expr->value.function.esym
2144 && ! gfc_elemental (expr->value.function.esym))
2146 gfc_error ("User defined non-ELEMENTAL function '%s' at %L not allowed "
2147 "in WORKSHARE construct", expr->value.function.esym->name,
2152 #define GENERIC_ID expr->value.function.isym->id
2153 else if (expr->value.function.actual != NULL
2154 && expr->value.function.isym != NULL
2155 && GENERIC_ID != GFC_ISYM_LBOUND
2156 && GENERIC_ID != GFC_ISYM_LEN
2157 && GENERIC_ID != GFC_ISYM_LOC
2158 && GENERIC_ID != GFC_ISYM_PRESENT)
2160 /* Array intrinsics must also have the last upper bound of an
2161 assumed size array argument. UBOUND and SIZE have to be
2162 excluded from the check if the second argument is anything
2165 inquiry = GENERIC_ID == GFC_ISYM_UBOUND
2166 || GENERIC_ID == GFC_ISYM_SIZE;
2168 for (arg = expr->value.function.actual; arg; arg = arg->next)
2170 if (inquiry && arg->next != NULL && arg->next->expr)
2172 if (arg->next->expr->expr_type != EXPR_CONSTANT)
2175 if ((int)mpz_get_si (arg->next->expr->value.integer)
2180 if (arg->expr != NULL
2181 && arg->expr->rank > 0
2182 && resolve_assumed_size_actual (arg->expr))
2188 need_full_assumed_size = temp;
2191 if (!pure_function (expr, &name) && name)
2195 gfc_error ("reference to non-PURE function '%s' at %L inside a "
2196 "FORALL %s", name, &expr->where,
2197 forall_flag == 2 ? "mask" : "block");
2200 else if (gfc_pure (NULL))
2202 gfc_error ("Function reference to '%s' at %L is to a non-PURE "
2203 "procedure within a PURE procedure", name, &expr->where);
2208 /* Functions without the RECURSIVE attribution are not allowed to
2209 * call themselves. */
2210 if (expr->value.function.esym && !expr->value.function.esym->attr.recursive)
2212 gfc_symbol *esym, *proc;
2213 esym = expr->value.function.esym;
2214 proc = gfc_current_ns->proc_name;
2217 gfc_error ("Function '%s' at %L cannot call itself, as it is not "
2218 "RECURSIVE", name, &expr->where);
2222 if (esym->attr.entry && esym->ns->entries && proc->ns->entries
2223 && esym->ns->entries->sym == proc->ns->entries->sym)
2225 gfc_error ("Call to ENTRY '%s' at %L is recursive, but function "
2226 "'%s' is not declared as RECURSIVE",
2227 esym->name, &expr->where, esym->ns->entries->sym->name);
2232 /* Character lengths of use associated functions may contains references to
2233 symbols not referenced from the current program unit otherwise. Make sure
2234 those symbols are marked as referenced. */
2236 if (expr->ts.type == BT_CHARACTER && expr->value.function.esym
2237 && expr->value.function.esym->attr.use_assoc)
2239 gfc_expr_set_symbols_referenced (expr->ts.cl->length);
2243 find_noncopying_intrinsics (expr->value.function.esym,
2244 expr->value.function.actual);
2246 /* Make sure that the expression has a typespec that works. */
2247 if (expr->ts.type == BT_UNKNOWN)
2249 if (expr->symtree->n.sym->result
2250 && expr->symtree->n.sym->result->ts.type != BT_UNKNOWN)
2251 expr->ts = expr->symtree->n.sym->result->ts;
2258 /************* Subroutine resolution *************/
2261 pure_subroutine (gfc_code *c, gfc_symbol *sym)
2267 gfc_error ("Subroutine call to '%s' in FORALL block at %L is not PURE",
2268 sym->name, &c->loc);
2269 else if (gfc_pure (NULL))
2270 gfc_error ("Subroutine call to '%s' at %L is not PURE", sym->name,
2276 resolve_generic_s0 (gfc_code *c, gfc_symbol *sym)
2280 if (sym->attr.generic)
2282 s = gfc_search_interface (sym->generic, 1, &c->ext.actual);
2285 c->resolved_sym = s;
2286 pure_subroutine (c, s);
2290 /* TODO: Need to search for elemental references in generic interface. */
2293 if (sym->attr.intrinsic)
2294 return gfc_intrinsic_sub_interface (c, 0);
2301 resolve_generic_s (gfc_code *c)
2306 sym = c->symtree->n.sym;
2310 m = resolve_generic_s0 (c, sym);
2313 else if (m == MATCH_ERROR)
2317 if (sym->ns->parent == NULL)
2319 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
2323 if (!generic_sym (sym))
2327 /* Last ditch attempt. See if the reference is to an intrinsic
2328 that possesses a matching interface. 14.1.2.4 */
2329 sym = c->symtree->n.sym;
2331 if (!gfc_intrinsic_name (sym->name, 1))
2333 gfc_error ("There is no specific subroutine for the generic '%s' at %L",
2334 sym->name, &c->loc);
2338 m = gfc_intrinsic_sub_interface (c, 0);
2342 gfc_error ("Generic subroutine '%s' at %L is not consistent with an "
2343 "intrinsic subroutine interface", sym->name, &c->loc);
2349 /* Set the name and binding label of the subroutine symbol in the call
2350 expression represented by 'c' to include the type and kind of the
2351 second parameter. This function is for resolving the appropriate
2352 version of c_f_pointer() and c_f_procpointer(). For example, a
2353 call to c_f_pointer() for a default integer pointer could have a
2354 name of c_f_pointer_i4. If no second arg exists, which is an error
2355 for these two functions, it defaults to the generic symbol's name
2356 and binding label. */
2359 set_name_and_label (gfc_code *c, gfc_symbol *sym,
2360 char *name, char *binding_label)
2362 gfc_expr *arg = NULL;
2366 /* The second arg of c_f_pointer and c_f_procpointer determines
2367 the type and kind for the procedure name. */
2368 arg = c->ext.actual->next->expr;
2372 /* Set up the name to have the given symbol's name,
2373 plus the type and kind. */
2374 /* a derived type is marked with the type letter 'u' */
2375 if (arg->ts.type == BT_DERIVED)
2378 kind = 0; /* set the kind as 0 for now */
2382 type = gfc_type_letter (arg->ts.type);
2383 kind = arg->ts.kind;
2386 if (arg->ts.type == BT_CHARACTER)
2387 /* Kind info for character strings not needed. */
2390 sprintf (name, "%s_%c%d", sym->name, type, kind);
2391 /* Set up the binding label as the given symbol's label plus
2392 the type and kind. */
2393 sprintf (binding_label, "%s_%c%d", sym->binding_label, type, kind);
2397 /* If the second arg is missing, set the name and label as
2398 was, cause it should at least be found, and the missing
2399 arg error will be caught by compare_parameters(). */
2400 sprintf (name, "%s", sym->name);
2401 sprintf (binding_label, "%s", sym->binding_label);
2408 /* Resolve a generic version of the iso_c_binding procedure given
2409 (sym) to the specific one based on the type and kind of the
2410 argument(s). Currently, this function resolves c_f_pointer() and
2411 c_f_procpointer based on the type and kind of the second argument
2412 (FPTR). Other iso_c_binding procedures aren't specially handled.
2413 Upon successfully exiting, c->resolved_sym will hold the resolved
2414 symbol. Returns MATCH_ERROR if an error occurred; MATCH_YES
2418 gfc_iso_c_sub_interface (gfc_code *c, gfc_symbol *sym)
2420 gfc_symbol *new_sym;
2421 /* this is fine, since we know the names won't use the max */
2422 char name[GFC_MAX_SYMBOL_LEN + 1];
2423 char binding_label[GFC_MAX_BINDING_LABEL_LEN + 1];
2424 /* default to success; will override if find error */
2425 match m = MATCH_YES;
2427 /* Make sure the actual arguments are in the necessary order (based on the
2428 formal args) before resolving. */
2429 gfc_procedure_use (sym, &c->ext.actual, &(c->loc));
2431 if ((sym->intmod_sym_id == ISOCBINDING_F_POINTER) ||
2432 (sym->intmod_sym_id == ISOCBINDING_F_PROCPOINTER))
2434 set_name_and_label (c, sym, name, binding_label);
2436 if (sym->intmod_sym_id == ISOCBINDING_F_POINTER)
2438 if (c->ext.actual != NULL && c->ext.actual->next != NULL)
2440 /* Make sure we got a third arg if the second arg has non-zero
2441 rank. We must also check that the type and rank are
2442 correct since we short-circuit this check in
2443 gfc_procedure_use() (called above to sort actual args). */
2444 if (c->ext.actual->next->expr->rank != 0)
2446 if(c->ext.actual->next->next == NULL
2447 || c->ext.actual->next->next->expr == NULL)
2450 gfc_error ("Missing SHAPE parameter for call to %s "
2451 "at %L", sym->name, &(c->loc));
2453 else if (c->ext.actual->next->next->expr->ts.type
2455 || c->ext.actual->next->next->expr->rank != 1)
2458 gfc_error ("SHAPE parameter for call to %s at %L must "
2459 "be a rank 1 INTEGER array", sym->name,
2466 if (m != MATCH_ERROR)
2468 /* the 1 means to add the optional arg to formal list */
2469 new_sym = get_iso_c_sym (sym, name, binding_label, 1);
2471 /* for error reporting, say it's declared where the original was */
2472 new_sym->declared_at = sym->declared_at;
2475 else if (sym->intmod_sym_id == ISOCBINDING_ASSOCIATED)
2477 /* TODO: Figure out if this is even reachable; this part of the
2478 conditional may not be necessary. */
2480 if (c->ext.actual->next == NULL)
2482 /* The user did not give two args, so resolve to the version
2483 of c_associated expecting one arg. */
2485 /* get rid of the second arg */
2486 /* TODO!! Should free up the memory here! */
2487 sym->formal->next = NULL;
2495 sprintf (name, "%s_%d", sym->name, num_args);
2496 sprintf (binding_label, "%s_%d", sym->binding_label, num_args);
2497 sym->name = gfc_get_string (name);
2498 strcpy (sym->binding_label, binding_label);
2502 /* no differences for c_loc or c_funloc */
2506 /* set the resolved symbol */
2507 if (m != MATCH_ERROR)
2508 c->resolved_sym = new_sym;
2510 c->resolved_sym = sym;
2516 /* Resolve a subroutine call known to be specific. */
2519 resolve_specific_s0 (gfc_code *c, gfc_symbol *sym)
2523 if(sym->attr.is_iso_c)
2525 m = gfc_iso_c_sub_interface (c,sym);
2529 if (sym->attr.external || sym->attr.if_source == IFSRC_IFBODY)
2531 if (sym->attr.dummy)
2533 sym->attr.proc = PROC_DUMMY;
2537 sym->attr.proc = PROC_EXTERNAL;
2541 if (sym->attr.proc == PROC_MODULE || sym->attr.proc == PROC_INTERNAL)
2544 if (sym->attr.intrinsic)
2546 m = gfc_intrinsic_sub_interface (c, 1);
2550 gfc_error ("Subroutine '%s' at %L is INTRINSIC but is not compatible "
2551 "with an intrinsic", sym->name, &c->loc);
2559 gfc_procedure_use (sym, &c->ext.actual, &c->loc);
2561 c->resolved_sym = sym;
2562 pure_subroutine (c, sym);
2569 resolve_specific_s (gfc_code *c)
2574 sym = c->symtree->n.sym;
2578 m = resolve_specific_s0 (c, sym);
2581 if (m == MATCH_ERROR)
2584 if (sym->ns->parent == NULL)
2587 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
2593 sym = c->symtree->n.sym;
2594 gfc_error ("Unable to resolve the specific subroutine '%s' at %L",
2595 sym->name, &c->loc);
2601 /* Resolve a subroutine call not known to be generic nor specific. */
2604 resolve_unknown_s (gfc_code *c)
2608 sym = c->symtree->n.sym;
2610 if (sym->attr.dummy)
2612 sym->attr.proc = PROC_DUMMY;
2616 /* See if we have an intrinsic function reference. */
2618 if (gfc_intrinsic_name (sym->name, 1))
2620 if (gfc_intrinsic_sub_interface (c, 1) == MATCH_YES)
2625 /* The reference is to an external name. */
2628 gfc_procedure_use (sym, &c->ext.actual, &c->loc);
2630 c->resolved_sym = sym;
2632 pure_subroutine (c, sym);
2638 /* Resolve a subroutine call. Although it was tempting to use the same code
2639 for functions, subroutines and functions are stored differently and this
2640 makes things awkward. */
2643 resolve_call (gfc_code *c)
2646 procedure_type ptype = PROC_INTRINSIC;
2648 if (c->symtree && c->symtree->n.sym
2649 && c->symtree->n.sym->ts.type != BT_UNKNOWN)
2651 gfc_error ("'%s' at %L has a type, which is not consistent with "
2652 "the CALL at %L", c->symtree->n.sym->name,
2653 &c->symtree->n.sym->declared_at, &c->loc);
2657 /* If external, check for usage. */
2658 if (c->symtree && is_external_proc (c->symtree->n.sym))
2659 resolve_global_procedure (c->symtree->n.sym, &c->loc, 1);
2661 /* Subroutines without the RECURSIVE attribution are not allowed to
2662 * call themselves. */
2663 if (c->symtree && c->symtree->n.sym && !c->symtree->n.sym->attr.recursive)
2665 gfc_symbol *csym, *proc;
2666 csym = c->symtree->n.sym;
2667 proc = gfc_current_ns->proc_name;
2670 gfc_error ("SUBROUTINE '%s' at %L cannot call itself, as it is not "
2671 "RECURSIVE", csym->name, &c->loc);
2675 if (csym->attr.entry && csym->ns->entries && proc->ns->entries
2676 && csym->ns->entries->sym == proc->ns->entries->sym)
2678 gfc_error ("Call to ENTRY '%s' at %L is recursive, but subroutine "
2679 "'%s' is not declared as RECURSIVE",
2680 csym->name, &c->loc, csym->ns->entries->sym->name);
2685 /* Switch off assumed size checking and do this again for certain kinds
2686 of procedure, once the procedure itself is resolved. */
2687 need_full_assumed_size++;
2689 if (c->symtree && c->symtree->n.sym)
2690 ptype = c->symtree->n.sym->attr.proc;
2692 if (resolve_actual_arglist (c->ext.actual, ptype) == FAILURE)
2695 /* Resume assumed_size checking. */
2696 need_full_assumed_size--;
2699 if (c->resolved_sym == NULL)
2700 switch (procedure_kind (c->symtree->n.sym))
2703 t = resolve_generic_s (c);
2706 case PTYPE_SPECIFIC:
2707 t = resolve_specific_s (c);
2711 t = resolve_unknown_s (c);
2715 gfc_internal_error ("resolve_subroutine(): bad function type");
2718 /* Some checks of elemental subroutine actual arguments. */
2719 if (resolve_elemental_actual (NULL, c) == FAILURE)
2723 find_noncopying_intrinsics (c->resolved_sym, c->ext.actual);
2728 /* Compare the shapes of two arrays that have non-NULL shapes. If both
2729 op1->shape and op2->shape are non-NULL return SUCCESS if their shapes
2730 match. If both op1->shape and op2->shape are non-NULL return FAILURE
2731 if their shapes do not match. If either op1->shape or op2->shape is
2732 NULL, return SUCCESS. */
2735 compare_shapes (gfc_expr *op1, gfc_expr *op2)
2742 if (op1->shape != NULL && op2->shape != NULL)
2744 for (i = 0; i < op1->rank; i++)
2746 if (mpz_cmp (op1->shape[i], op2->shape[i]) != 0)
2748 gfc_error ("Shapes for operands at %L and %L are not conformable",
2749 &op1->where, &op2->where);
2760 /* Resolve an operator expression node. This can involve replacing the
2761 operation with a user defined function call. */
2764 resolve_operator (gfc_expr *e)
2766 gfc_expr *op1, *op2;
2768 bool dual_locus_error;
2771 /* Resolve all subnodes-- give them types. */
2773 switch (e->value.op.operator)
2776 if (gfc_resolve_expr (e->value.op.op2) == FAILURE)
2779 /* Fall through... */
2782 case INTRINSIC_UPLUS:
2783 case INTRINSIC_UMINUS:
2784 case INTRINSIC_PARENTHESES:
2785 if (gfc_resolve_expr (e->value.op.op1) == FAILURE)
2790 /* Typecheck the new node. */
2792 op1 = e->value.op.op1;
2793 op2 = e->value.op.op2;
2794 dual_locus_error = false;
2796 if ((op1 && op1->expr_type == EXPR_NULL)
2797 || (op2 && op2->expr_type == EXPR_NULL))
2799 sprintf (msg, _("Invalid context for NULL() pointer at %%L"));
2803 switch (e->value.op.operator)
2805 case INTRINSIC_UPLUS:
2806 case INTRINSIC_UMINUS:
2807 if (op1->ts.type == BT_INTEGER
2808 || op1->ts.type == BT_REAL
2809 || op1->ts.type == BT_COMPLEX)
2815 sprintf (msg, _("Operand of unary numeric operator '%s' at %%L is %s"),
2816 gfc_op2string (e->value.op.operator), gfc_typename (&e->ts));
2819 case INTRINSIC_PLUS:
2820 case INTRINSIC_MINUS:
2821 case INTRINSIC_TIMES:
2822 case INTRINSIC_DIVIDE:
2823 case INTRINSIC_POWER:
2824 if (gfc_numeric_ts (&op1->ts) && gfc_numeric_ts (&op2->ts))
2826 gfc_type_convert_binary (e);
2831 _("Operands of binary numeric operator '%s' at %%L are %s/%s"),
2832 gfc_op2string (e->value.op.operator), gfc_typename (&op1->ts),
2833 gfc_typename (&op2->ts));
2836 case INTRINSIC_CONCAT:
2837 if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER)
2839 e->ts.type = BT_CHARACTER;
2840 e->ts.kind = op1->ts.kind;
2845 _("Operands of string concatenation operator at %%L are %s/%s"),
2846 gfc_typename (&op1->ts), gfc_typename (&op2->ts));
2852 case INTRINSIC_NEQV:
2853 if (op1->ts.type == BT_LOGICAL && op2->ts.type == BT_LOGICAL)
2855 e->ts.type = BT_LOGICAL;
2856 e->ts.kind = gfc_kind_max (op1, op2);
2857 if (op1->ts.kind < e->ts.kind)
2858 gfc_convert_type (op1, &e->ts, 2);
2859 else if (op2->ts.kind < e->ts.kind)
2860 gfc_convert_type (op2, &e->ts, 2);
2864 sprintf (msg, _("Operands of logical operator '%s' at %%L are %s/%s"),
2865 gfc_op2string (e->value.op.operator), gfc_typename (&op1->ts),
2866 gfc_typename (&op2->ts));
2871 if (op1->ts.type == BT_LOGICAL)
2873 e->ts.type = BT_LOGICAL;
2874 e->ts.kind = op1->ts.kind;
2878 sprintf (msg, _("Operand of .not. operator at %%L is %s"),
2879 gfc_typename (&op1->ts));
2883 case INTRINSIC_GT_OS:
2885 case INTRINSIC_GE_OS:
2887 case INTRINSIC_LT_OS:
2889 case INTRINSIC_LE_OS:
2890 if (op1->ts.type == BT_COMPLEX || op2->ts.type == BT_COMPLEX)
2892 strcpy (msg, _("COMPLEX quantities cannot be compared at %L"));
2896 /* Fall through... */
2899 case INTRINSIC_EQ_OS:
2901 case INTRINSIC_NE_OS:
2902 if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER)
2904 e->ts.type = BT_LOGICAL;
2905 e->ts.kind = gfc_default_logical_kind;
2909 if (gfc_numeric_ts (&op1->ts) && gfc_numeric_ts (&op2->ts))
2911 gfc_type_convert_binary (e);
2913 e->ts.type = BT_LOGICAL;
2914 e->ts.kind = gfc_default_logical_kind;
2918 if (op1->ts.type == BT_LOGICAL && op2->ts.type == BT_LOGICAL)
2920 _("Logicals at %%L must be compared with %s instead of %s"),
2921 (e->value.op.operator == INTRINSIC_EQ
2922 || e->value.op.operator == INTRINSIC_EQ_OS)
2923 ? ".eqv." : ".neqv.", gfc_op2string (e->value.op.operator));
2926 _("Operands of comparison operator '%s' at %%L are %s/%s"),
2927 gfc_op2string (e->value.op.operator), gfc_typename (&op1->ts),
2928 gfc_typename (&op2->ts));
2932 case INTRINSIC_USER:
2933 if (e->value.op.uop->operator == NULL)
2934 sprintf (msg, _("Unknown operator '%s' at %%L"), e->value.op.uop->name);
2935 else if (op2 == NULL)
2936 sprintf (msg, _("Operand of user operator '%s' at %%L is %s"),
2937 e->value.op.uop->name, gfc_typename (&op1->ts));
2939 sprintf (msg, _("Operands of user operator '%s' at %%L are %s/%s"),
2940 e->value.op.uop->name, gfc_typename (&op1->ts),
2941 gfc_typename (&op2->ts));
2945 case INTRINSIC_PARENTHESES:
2947 if (e->ts.type == BT_CHARACTER)
2948 e->ts.cl = op1->ts.cl;
2952 gfc_internal_error ("resolve_operator(): Bad intrinsic");
2955 /* Deal with arrayness of an operand through an operator. */
2959 switch (e->value.op.operator)
2961 case INTRINSIC_PLUS:
2962 case INTRINSIC_MINUS:
2963 case INTRINSIC_TIMES:
2964 case INTRINSIC_DIVIDE:
2965 case INTRINSIC_POWER:
2966 case INTRINSIC_CONCAT:
2970 case INTRINSIC_NEQV:
2972 case INTRINSIC_EQ_OS:
2974 case INTRINSIC_NE_OS:
2976 case INTRINSIC_GT_OS:
2978 case INTRINSIC_GE_OS:
2980 case INTRINSIC_LT_OS:
2982 case INTRINSIC_LE_OS:
2984 if (op1->rank == 0 && op2->rank == 0)
2987 if (op1->rank == 0 && op2->rank != 0)
2989 e->rank = op2->rank;
2991 if (e->shape == NULL)
2992 e->shape = gfc_copy_shape (op2->shape, op2->rank);
2995 if (op1->rank != 0 && op2->rank == 0)
2997 e->rank = op1->rank;
2999 if (e->shape == NULL)
3000 e->shape = gfc_copy_shape (op1->shape, op1->rank);
3003 if (op1->rank != 0 && op2->rank != 0)
3005 if (op1->rank == op2->rank)
3007 e->rank = op1->rank;
3008 if (e->shape == NULL)
3010 t = compare_shapes(op1, op2);
3014 e->shape = gfc_copy_shape (op1->shape, op1->rank);
3019 /* Allow higher level expressions to work. */
3022 /* Try user-defined operators, and otherwise throw an error. */
3023 dual_locus_error = true;
3025 _("Inconsistent ranks for operator at %%L and %%L"));
3032 case INTRINSIC_PARENTHESES:
3034 case INTRINSIC_UPLUS:
3035 case INTRINSIC_UMINUS:
3036 /* Simply copy arrayness attribute */
3037 e->rank = op1->rank;
3039 if (e->shape == NULL)
3040 e->shape = gfc_copy_shape (op1->shape, op1->rank);
3048 /* Attempt to simplify the expression. */
3051 t = gfc_simplify_expr (e, 0);
3052 /* Some calls do not succeed in simplification and return FAILURE
3053 even though there is no error; eg. variable references to
3054 PARAMETER arrays. */
3055 if (!gfc_is_constant_expr (e))
3062 if (gfc_extend_expr (e) == SUCCESS)
3065 if (dual_locus_error)
3066 gfc_error (msg, &op1->where, &op2->where);
3068 gfc_error (msg, &e->where);
3074 /************** Array resolution subroutines **************/
3077 { CMP_LT, CMP_EQ, CMP_GT, CMP_UNKNOWN }
3080 /* Compare two integer expressions. */
3083 compare_bound (gfc_expr *a, gfc_expr *b)
3087 if (a == NULL || a->expr_type != EXPR_CONSTANT
3088 || b == NULL || b->expr_type != EXPR_CONSTANT)
3091 if (a->ts.type != BT_INTEGER || b->ts.type != BT_INTEGER)
3092 gfc_internal_error ("compare_bound(): Bad expression");
3094 i = mpz_cmp (a->value.integer, b->value.integer);
3104 /* Compare an integer expression with an integer. */
3107 compare_bound_int (gfc_expr *a, int b)
3111 if (a == NULL || a->expr_type != EXPR_CONSTANT)
3114 if (a->ts.type != BT_INTEGER)
3115 gfc_internal_error ("compare_bound_int(): Bad expression");
3117 i = mpz_cmp_si (a->value.integer, b);
3127 /* Compare an integer expression with a mpz_t. */
3130 compare_bound_mpz_t (gfc_expr *a, mpz_t b)
3134 if (a == NULL || a->expr_type != EXPR_CONSTANT)
3137 if (a->ts.type != BT_INTEGER)
3138 gfc_internal_error ("compare_bound_int(): Bad expression");
3140 i = mpz_cmp (a->value.integer, b);
3150 /* Compute the last value of a sequence given by a triplet.
3151 Return 0 if it wasn't able to compute the last value, or if the
3152 sequence if empty, and 1 otherwise. */
3155 compute_last_value_for_triplet (gfc_expr *start, gfc_expr *end,
3156 gfc_expr *stride, mpz_t last)
3160 if (start == NULL || start->expr_type != EXPR_CONSTANT
3161 || end == NULL || end->expr_type != EXPR_CONSTANT
3162 || (stride != NULL && stride->expr_type != EXPR_CONSTANT))
3165 if (start->ts.type != BT_INTEGER || end->ts.type != BT_INTEGER
3166 || (stride != NULL && stride->ts.type != BT_INTEGER))
3169 if (stride == NULL || compare_bound_int(stride, 1) == CMP_EQ)
3171 if (compare_bound (start, end) == CMP_GT)
3173 mpz_set (last, end->value.integer);
3177 if (compare_bound_int (stride, 0) == CMP_GT)
3179 /* Stride is positive */
3180 if (mpz_cmp (start->value.integer, end->value.integer) > 0)
3185 /* Stride is negative */
3186 if (mpz_cmp (start->value.integer, end->value.integer) < 0)
3191 mpz_sub (rem, end->value.integer, start->value.integer);
3192 mpz_tdiv_r (rem, rem, stride->value.integer);
3193 mpz_sub (last, end->value.integer, rem);
3200 /* Compare a single dimension of an array reference to the array
3204 check_dimension (int i, gfc_array_ref *ar, gfc_array_spec *as)
3208 /* Given start, end and stride values, calculate the minimum and
3209 maximum referenced indexes. */
3217 if (compare_bound (ar->start[i], as->lower[i]) == CMP_LT)
3219 if (compare_bound (ar->start[i], as->upper[i]) == CMP_GT)
3226 #define AR_START (ar->start[i] ? ar->start[i] : as->lower[i])
3227 #define AR_END (ar->end[i] ? ar->end[i] : as->upper[i])
3229 comparison comp_start_end = compare_bound (AR_START, AR_END);
3231 /* Check for zero stride, which is not allowed. */
3232 if (compare_bound_int (ar->stride[i], 0) == CMP_EQ)
3234 gfc_error ("Illegal stride of zero at %L", &ar->c_where[i]);
3238 /* if start == len || (stride > 0 && start < len)
3239 || (stride < 0 && start > len),
3240 then the array section contains at least one element. In this
3241 case, there is an out-of-bounds access if
3242 (start < lower || start > upper). */
3243 if (compare_bound (AR_START, AR_END) == CMP_EQ
3244 || ((compare_bound_int (ar->stride[i], 0) == CMP_GT
3245 || ar->stride[i] == NULL) && comp_start_end == CMP_LT)
3246 || (compare_bound_int (ar->stride[i], 0) == CMP_LT
3247 && comp_start_end == CMP_GT))
3249 if (compare_bound (AR_START, as->lower[i]) == CMP_LT
3250 || compare_bound (AR_START, as->upper[i]) == CMP_GT)
3254 /* If we can compute the highest index of the array section,
3255 then it also has to be between lower and upper. */
3256 mpz_init (last_value);
3257 if (compute_last_value_for_triplet (AR_START, AR_END, ar->stride[i],
3260 if (compare_bound_mpz_t (as->lower[i], last_value) == CMP_GT
3261 || compare_bound_mpz_t (as->upper[i], last_value) == CMP_LT)
3263 mpz_clear (last_value);
3267 mpz_clear (last_value);
3275 gfc_internal_error ("check_dimension(): Bad array reference");
3281 gfc_warning ("Array reference at %L is out of bounds", &ar->c_where[i]);
3286 /* Compare an array reference with an array specification. */
3289 compare_spec_to_ref (gfc_array_ref *ar)
3296 /* TODO: Full array sections are only allowed as actual parameters. */
3297 if (as->type == AS_ASSUMED_SIZE
3298 && (/*ar->type == AR_FULL
3299 ||*/ (ar->type == AR_SECTION
3300 && ar->dimen_type[i] == DIMEN_RANGE && ar->end[i] == NULL)))
3302 gfc_error ("Rightmost upper bound of assumed size array section "
3303 "not specified at %L", &ar->where);
3307 if (ar->type == AR_FULL)
3310 if (as->rank != ar->dimen)
3312 gfc_error ("Rank mismatch in array reference at %L (%d/%d)",
3313 &ar->where, ar->dimen, as->rank);
3317 for (i = 0; i < as->rank; i++)
3318 if (check_dimension (i, ar, as) == FAILURE)
3325 /* Resolve one part of an array index. */
3328 gfc_resolve_index (gfc_expr *index, int check_scalar)
3335 if (gfc_resolve_expr (index) == FAILURE)
3338 if (check_scalar && index->rank != 0)
3340 gfc_error ("Array index at %L must be scalar", &index->where);
3344 if (index->ts.type != BT_INTEGER && index->ts.type != BT_REAL)
3346 gfc_error ("Array index at %L must be of INTEGER type",
3351 if (index->ts.type == BT_REAL)
3352 if (gfc_notify_std (GFC_STD_LEGACY, "Extension: REAL array index at %L",
3353 &index->where) == FAILURE)
3356 if (index->ts.kind != gfc_index_integer_kind
3357 || index->ts.type != BT_INTEGER)
3360 ts.type = BT_INTEGER;
3361 ts.kind = gfc_index_integer_kind;
3363 gfc_convert_type_warn (index, &ts, 2, 0);
3369 /* Resolve a dim argument to an intrinsic function. */
3372 gfc_resolve_dim_arg (gfc_expr *dim)
3377 if (gfc_resolve_expr (dim) == FAILURE)
3382 gfc_error ("Argument dim at %L must be scalar", &dim->where);
3386 if (dim->ts.type != BT_INTEGER)
3388 gfc_error ("Argument dim at %L must be of INTEGER type", &dim->where);
3391 if (dim->ts.kind != gfc_index_integer_kind)
3395 ts.type = BT_INTEGER;
3396 ts.kind = gfc_index_integer_kind;
3398 gfc_convert_type_warn (dim, &ts, 2, 0);
3404 /* Given an expression that contains array references, update those array
3405 references to point to the right array specifications. While this is
3406 filled in during matching, this information is difficult to save and load
3407 in a module, so we take care of it here.
3409 The idea here is that the original array reference comes from the
3410 base symbol. We traverse the list of reference structures, setting
3411 the stored reference to references. Component references can
3412 provide an additional array specification. */
3415 find_array_spec (gfc_expr *e)
3419 gfc_symbol *derived;
3422 as = e->symtree->n.sym->as;
3425 for (ref = e->ref; ref; ref = ref->next)
3430 gfc_internal_error ("find_array_spec(): Missing spec");
3437 if (derived == NULL)
3438 derived = e->symtree->n.sym->ts.derived;
3440 c = derived->components;
3442 for (; c; c = c->next)
3443 if (c == ref->u.c.component)
3445 /* Track the sequence of component references. */
3446 if (c->ts.type == BT_DERIVED)
3447 derived = c->ts.derived;
3452 gfc_internal_error ("find_array_spec(): Component not found");
3457 gfc_internal_error ("find_array_spec(): unused as(1)");
3468 gfc_internal_error ("find_array_spec(): unused as(2)");
3472 /* Resolve an array reference. */
3475 resolve_array_ref (gfc_array_ref *ar)
3477 int i, check_scalar;
3480 for (i = 0; i < ar->dimen; i++)
3482 check_scalar = ar->dimen_type[i] == DIMEN_RANGE;
3484 if (gfc_resolve_index (ar->start[i], check_scalar) == FAILURE)
3486 if (gfc_resolve_index (ar->end[i], check_scalar) == FAILURE)
3488 if (gfc_resolve_index (ar->stride[i], check_scalar) == FAILURE)
3493 if (ar->dimen_type[i] == DIMEN_UNKNOWN)
3497 ar->dimen_type[i] = DIMEN_ELEMENT;
3501 ar->dimen_type[i] = DIMEN_VECTOR;
3502 if (e->expr_type == EXPR_VARIABLE
3503 && e->symtree->n.sym->ts.type == BT_DERIVED)
3504 ar->start[i] = gfc_get_parentheses (e);
3508 gfc_error ("Array index at %L is an array of rank %d",
3509 &ar->c_where[i], e->rank);
3514 /* If the reference type is unknown, figure out what kind it is. */
3516 if (ar->type == AR_UNKNOWN)
3518 ar->type = AR_ELEMENT;
3519 for (i = 0; i < ar->dimen; i++)
3520 if (ar->dimen_type[i] == DIMEN_RANGE
3521 || ar->dimen_type[i] == DIMEN_VECTOR)
3523 ar->type = AR_SECTION;
3528 if (!ar->as->cray_pointee && compare_spec_to_ref (ar) == FAILURE)
3536 resolve_substring (gfc_ref *ref)
3538 if (ref->u.ss.start != NULL)
3540 if (gfc_resolve_expr (ref->u.ss.start) == FAILURE)
3543 if (ref->u.ss.start->ts.type != BT_INTEGER)
3545 gfc_error ("Substring start index at %L must be of type INTEGER",
3546 &ref->u.ss.start->where);
3550 if (ref->u.ss.start->rank != 0)
3552 gfc_error ("Substring start index at %L must be scalar",
3553 &ref->u.ss.start->where);
3557 if (compare_bound_int (ref->u.ss.start, 1) == CMP_LT
3558 && (compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_EQ
3559 || compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_GT))
3561 gfc_error ("Substring start index at %L is less than one",
3562 &ref->u.ss.start->where);
3567 if (ref->u.ss.end != NULL)
3569 if (gfc_resolve_expr (ref->u.ss.end) == FAILURE)
3572 if (ref->u.ss.end->ts.type != BT_INTEGER)
3574 gfc_error ("Substring end index at %L must be of type INTEGER",
3575 &ref->u.ss.end->where);
3579 if (ref->u.ss.end->rank != 0)
3581 gfc_error ("Substring end index at %L must be scalar",
3582 &ref->u.ss.end->where);
3586 if (ref->u.ss.length != NULL
3587 && compare_bound (ref->u.ss.end, ref->u.ss.length->length) == CMP_GT
3588 && (compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_EQ
3589 || compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_GT))
3591 gfc_error ("Substring end index at %L exceeds the string length",
3592 &ref->u.ss.start->where);
3601 /* This function supplies missing substring charlens. */
3604 gfc_resolve_substring_charlen (gfc_expr *e)
3607 gfc_expr *start, *end;
3609 for (char_ref = e->ref; char_ref; char_ref = char_ref->next)
3610 if (char_ref->type == REF_SUBSTRING)
3616 gcc_assert (char_ref->next == NULL);
3620 if (e->ts.cl->length)
3621 gfc_free_expr (e->ts.cl->length);
3622 else if (e->expr_type == EXPR_VARIABLE
3623 && e->symtree->n.sym->attr.dummy)
3627 e->ts.type = BT_CHARACTER;
3628 e->ts.kind = gfc_default_character_kind;
3632 e->ts.cl = gfc_get_charlen ();
3633 e->ts.cl->next = gfc_current_ns->cl_list;
3634 gfc_current_ns->cl_list = e->ts.cl;
3637 if (char_ref->u.ss.start)
3638 start = gfc_copy_expr (char_ref->u.ss.start);
3640 start = gfc_int_expr (1);
3642 if (char_ref->u.ss.end)
3643 end = gfc_copy_expr (char_ref->u.ss.end);
3644 else if (e->expr_type == EXPR_VARIABLE)
3645 end = gfc_copy_expr (e->symtree->n.sym->ts.cl->length);
3652 /* Length = (end - start +1). */
3653 e->ts.cl->length = gfc_subtract (end, start);
3654 e->ts.cl->length = gfc_add (e->ts.cl->length, gfc_int_expr (1));
3656 e->ts.cl->length->ts.type = BT_INTEGER;
3657 e->ts.cl->length->ts.kind = gfc_charlen_int_kind;;
3659 /* Make sure that the length is simplified. */
3660 gfc_simplify_expr (e->ts.cl->length, 1);
3661 gfc_resolve_expr (e->ts.cl->length);
3665 /* Resolve subtype references. */
3668 resolve_ref (gfc_expr *expr)
3670 int current_part_dimension, n_components, seen_part_dimension;
3673 for (ref = expr->ref; ref; ref = ref->next)
3674 if (ref->type == REF_ARRAY && ref->u.ar.as == NULL)
3676 find_array_spec (expr);
3680 for (ref = expr->ref; ref; ref = ref->next)
3684 if (resolve_array_ref (&ref->u.ar) == FAILURE)
3692 resolve_substring (ref);
3696 /* Check constraints on part references. */
3698 current_part_dimension = 0;
3699 seen_part_dimension = 0;
3702 for (ref = expr->ref; ref; ref = ref->next)
3707 switch (ref->u.ar.type)
3711 current_part_dimension = 1;
3715 current_part_dimension = 0;
3719 gfc_internal_error ("resolve_ref(): Bad array reference");
3725 if (current_part_dimension || seen_part_dimension)
3727 if (ref->u.c.component->pointer)
3729 gfc_error ("Component to the right of a part reference "
3730 "with nonzero rank must not have the POINTER "
3731 "attribute at %L", &expr->where);
3734 else if (ref->u.c.component->allocatable)
3736 gfc_error ("Component to the right of a part reference "
3737 "with nonzero rank must not have the ALLOCATABLE "
3738 "attribute at %L", &expr->where);
3750 if (((ref->type == REF_COMPONENT && n_components > 1)
3751 || ref->next == NULL)
3752 && current_part_dimension
3753 && seen_part_dimension)
3755 gfc_error ("Two or more part references with nonzero rank must "
3756 "not be specified at %L", &expr->where);
3760 if (ref->type == REF_COMPONENT)
3762 if (current_part_dimension)
3763 seen_part_dimension = 1;
3765 /* reset to make sure */
3766 current_part_dimension = 0;
3774 /* Given an expression, determine its shape. This is easier than it sounds.
3775 Leaves the shape array NULL if it is not possible to determine the shape. */
3778 expression_shape (gfc_expr *e)
3780 mpz_t array[GFC_MAX_DIMENSIONS];
3783 if (e->rank == 0 || e->shape != NULL)
3786 for (i = 0; i < e->rank; i++)
3787 if (gfc_array_dimen_size (e, i, &array[i]) == FAILURE)
3790 e->shape = gfc_get_shape (e->rank);
3792 memcpy (e->shape, array, e->rank * sizeof (mpz_t));
3797 for (i--; i >= 0; i--)
3798 mpz_clear (array[i]);
3802 /* Given a variable expression node, compute the rank of the expression by
3803 examining the base symbol and any reference structures it may have. */
3806 expression_rank (gfc_expr *e)
3813 if (e->expr_type == EXPR_ARRAY)
3815 /* Constructors can have a rank different from one via RESHAPE(). */
3817 if (e->symtree == NULL)
3823 e->rank = (e->symtree->n.sym->as == NULL)
3824 ? 0 : e->symtree->n.sym->as->rank;
3830 for (ref = e->ref; ref; ref = ref->next)
3832 if (ref->type != REF_ARRAY)
3835 if (ref->u.ar.type == AR_FULL)
3837 rank = ref->u.ar.as->rank;
3841 if (ref->u.ar.type == AR_SECTION)
3843 /* Figure out the rank of the section. */
3845 gfc_internal_error ("expression_rank(): Two array specs");
3847 for (i = 0; i < ref->u.ar.dimen; i++)
3848 if (ref->u.ar.dimen_type[i] == DIMEN_RANGE
3849 || ref->u.ar.dimen_type[i] == DIMEN_VECTOR)
3859 expression_shape (e);
3863 /* Resolve a variable expression. */
3866 resolve_variable (gfc_expr *e)
3873 if (e->symtree == NULL)
3876 if (e->ref && resolve_ref (e) == FAILURE)
3879 sym = e->symtree->n.sym;
3880 if (sym->attr.flavor == FL_PROCEDURE && !sym->attr.function)
3882 e->ts.type = BT_PROCEDURE;
3886 if (sym->ts.type != BT_UNKNOWN)
3887 gfc_variable_attr (e, &e->ts);
3890 /* Must be a simple variable reference. */
3891 if (gfc_set_default_type (sym, 1, sym->ns) == FAILURE)
3896 if (check_assumed_size_reference (sym, e))
3899 /* Deal with forward references to entries during resolve_code, to
3900 satisfy, at least partially, 12.5.2.5. */
3901 if (gfc_current_ns->entries
3902 && current_entry_id == sym->entry_id
3905 && cs_base->current->op != EXEC_ENTRY)
3907 gfc_entry_list *entry;
3908 gfc_formal_arglist *formal;
3912 /* If the symbol is a dummy... */
3913 if (sym->attr.dummy)
3915 entry = gfc_current_ns->entries;
3918 /* ...test if the symbol is a parameter of previous entries. */
3919 for (; entry && entry->id <= current_entry_id; entry = entry->next)
3920 for (formal = entry->sym->formal; formal; formal = formal->next)
3922 if (formal->sym && sym->name == formal->sym->name)
3926 /* If it has not been seen as a dummy, this is an error. */
3929 if (specification_expr)
3930 gfc_error ("Variable '%s',used in a specification expression, "
3931 "is referenced at %L before the ENTRY statement "
3932 "in which it is a parameter",
3933 sym->name, &cs_base->current->loc);
3935 gfc_error ("Variable '%s' is used at %L before the ENTRY "
3936 "statement in which it is a parameter",
3937 sym->name, &cs_base->current->loc);
3942 /* Now do the same check on the specification expressions. */
3943 specification_expr = 1;
3944 if (sym->ts.type == BT_CHARACTER
3945 && gfc_resolve_expr (sym->ts.cl->length) == FAILURE)
3949 for (n = 0; n < sym->as->rank; n++)
3951 specification_expr = 1;
3952 if (gfc_resolve_expr (sym->as->lower[n]) == FAILURE)
3954 specification_expr = 1;
3955 if (gfc_resolve_expr (sym->as->upper[n]) == FAILURE)
3958 specification_expr = 0;
3961 /* Update the symbol's entry level. */
3962 sym->entry_id = current_entry_id + 1;
3969 /* Checks to see that the correct symbol has been host associated.
3970 The only situation where this arises is that in which a twice
3971 contained function is parsed after the host association is made.
3972 Therefore, on detecting this, the line is rematched, having got
3973 rid of the existing references and actual_arg_list. */
3975 check_host_association (gfc_expr *e)
3977 gfc_symbol *sym, *old_sym;
3981 bool retval = e->expr_type == EXPR_FUNCTION;
3983 if (e->symtree == NULL || e->symtree->n.sym == NULL)
3986 old_sym = e->symtree->n.sym;
3988 if (old_sym->attr.use_assoc)
3991 if (gfc_current_ns->parent
3992 && gfc_current_ns->parent->parent
3993 && old_sym->ns != gfc_current_ns)
3995 gfc_find_symbol (old_sym->name, gfc_current_ns->parent, 1, &sym);
3996 if (sym && old_sym != sym && sym->attr.flavor == FL_PROCEDURE)
3998 temp_locus = gfc_current_locus;
3999 gfc_current_locus = e->where;
4001 gfc_buffer_error (1);
4003 gfc_free_ref_list (e->ref);
4008 gfc_free_actual_arglist (e->value.function.actual);
4009 e->value.function.actual = NULL;
4012 if (e->shape != NULL)
4014 for (n = 0; n < e->rank; n++)
4015 mpz_clear (e->shape[n]);
4017 gfc_free (e->shape);
4020 gfc_match_rvalue (&expr);
4022 gfc_buffer_error (0);
4024 gcc_assert (expr && sym == expr->symtree->n.sym);
4030 gfc_current_locus = temp_locus;
4033 /* This might have changed! */
4034 return e->expr_type == EXPR_FUNCTION;
4039 gfc_resolve_character_operator (gfc_expr *e)
4041 gfc_expr *op1 = e->value.op.op1;
4042 gfc_expr *op2 = e->value.op.op2;
4043 gfc_expr *e1 = NULL;
4044 gfc_expr *e2 = NULL;
4046 gcc_assert (e->value.op.operator == INTRINSIC_CONCAT);
4048 if (op1->ts.cl && op1->ts.cl->length)
4049 e1 = gfc_copy_expr (op1->ts.cl->length);
4050 else if (op1->expr_type == EXPR_CONSTANT)
4051 e1 = gfc_int_expr (op1->value.character.length);
4053 if (op2->ts.cl && op2->ts.cl->length)
4054 e2 = gfc_copy_expr (op2->ts.cl->length);
4055 else if (op2->expr_type == EXPR_CONSTANT)
4056 e2 = gfc_int_expr (op2->value.character.length);
4058 e->ts.cl = gfc_get_charlen ();
4059 e->ts.cl->next = gfc_current_ns->cl_list;
4060 gfc_current_ns->cl_list = e->ts.cl;
4065 e->ts.cl->length = gfc_add (e1, e2);
4066 e->ts.cl->length->ts.type = BT_INTEGER;
4067 e->ts.cl->length->ts.kind = gfc_charlen_int_kind;;
4068 gfc_simplify_expr (e->ts.cl->length, 0);
4069 gfc_resolve_expr (e->ts.cl->length);
4075 /* Ensure that an character expression has a charlen and, if possible, a
4076 length expression. */
4079 fixup_charlen (gfc_expr *e)
4081 /* The cases fall through so that changes in expression type and the need
4082 for multiple fixes are picked up. In all circumstances, a charlen should
4083 be available for the middle end to hang a backend_decl on. */
4084 switch (e->expr_type)
4087 gfc_resolve_character_operator (e);
4090 if (e->expr_type == EXPR_ARRAY)
4091 gfc_resolve_character_array_constructor (e);
4093 case EXPR_SUBSTRING:
4094 if (!e->ts.cl && e->ref)
4095 gfc_resolve_substring_charlen (e);
4100 e->ts.cl = gfc_get_charlen ();
4101 e->ts.cl->next = gfc_current_ns->cl_list;
4102 gfc_current_ns->cl_list = e->ts.cl;
4110 /* Resolve an expression. That is, make sure that types of operands agree
4111 with their operators, intrinsic operators are converted to function calls
4112 for overloaded types and unresolved function references are resolved. */
4115 gfc_resolve_expr (gfc_expr *e)
4122 switch (e->expr_type)
4125 t = resolve_operator (e);
4131 if (check_host_association (e))
4132 t = resolve_function (e);
4135 t = resolve_variable (e);
4137 expression_rank (e);
4140 if (e->ts.type == BT_CHARACTER && e->ts.cl == NULL && e->ref
4141 && e->ref->type != REF_SUBSTRING)
4142 gfc_resolve_substring_charlen (e);
4146 case EXPR_SUBSTRING:
4147 t = resolve_ref (e);
4157 if (resolve_ref (e) == FAILURE)
4160 t = gfc_resolve_array_constructor (e);
4161 /* Also try to expand a constructor. */
4164 expression_rank (e);
4165 gfc_expand_constructor (e);
4168 /* This provides the opportunity for the length of constructors with
4169 character valued function elements to propagate the string length
4170 to the expression. */
4171 if (e->ts.type == BT_CHARACTER)
4172 gfc_resolve_character_array_constructor (e);
4176 case EXPR_STRUCTURE:
4177 t = resolve_ref (e);
4181 t = resolve_structure_cons (e);
4185 t = gfc_simplify_expr (e, 0);
4189 gfc_internal_error ("gfc_resolve_expr(): Bad expression type");
4192 if (e->ts.type == BT_CHARACTER && t == SUCCESS && !e->ts.cl)
4199 /* Resolve an expression from an iterator. They must be scalar and have
4200 INTEGER or (optionally) REAL type. */
4203 gfc_resolve_iterator_expr (gfc_expr *expr, bool real_ok,
4204 const char *name_msgid)
4206 if (gfc_resolve_expr (expr) == FAILURE)
4209 if (expr->rank != 0)
4211 gfc_error ("%s at %L must be a scalar", _(name_msgid), &expr->where);
4215 if (expr->ts.type != BT_INTEGER)
4217 if (expr->ts.type == BT_REAL)
4220 return gfc_notify_std (GFC_STD_F95_DEL,
4221 "Deleted feature: %s at %L must be integer",
4222 _(name_msgid), &expr->where);
4225 gfc_error ("%s at %L must be INTEGER", _(name_msgid),
4232 gfc_error ("%s at %L must be INTEGER", _(name_msgid), &expr->where);
4240 /* Resolve the expressions in an iterator structure. If REAL_OK is
4241 false allow only INTEGER type iterators, otherwise allow REAL types. */
4244 gfc_resolve_iterator (gfc_iterator *iter, bool real_ok)
4246 if (gfc_resolve_iterator_expr (iter->var, real_ok, "Loop variable")
4250 if (gfc_pure (NULL) && gfc_impure_variable (iter->var->symtree->n.sym))
4252 gfc_error ("Cannot assign to loop variable in PURE procedure at %L",
4257 if (gfc_resolve_iterator_expr (iter->start, real_ok,
4258 "Start expression in DO loop") == FAILURE)
4261 if (gfc_resolve_iterator_expr (iter->end, real_ok,
4262 "End expression in DO loop") == FAILURE)
4265 if (gfc_resolve_iterator_expr (iter->step, real_ok,
4266 "Step expression in DO loop") == FAILURE)
4269 if (iter->step->expr_type == EXPR_CONSTANT)
4271 if ((iter->step->ts.type == BT_INTEGER
4272 && mpz_cmp_ui (iter->step->value.integer, 0) == 0)
4273 || (iter->step->ts.type == BT_REAL
4274 && mpfr_sgn (iter->step->value.real) == 0))
4276 gfc_error ("Step expression in DO loop at %L cannot be zero",
4277 &iter->step->where);
4282 /* Convert start, end, and step to the same type as var. */
4283 if (iter->start->ts.kind != iter->var->ts.kind
4284 || iter->start->ts.type != iter->var->ts.type)
4285 gfc_convert_type (iter->start, &iter->var->ts, 2);
4287 if (iter->end->ts.kind != iter->var->ts.kind
4288 || iter->end->ts.type != iter->var->ts.type)
4289 gfc_convert_type (iter->end, &iter->var->ts, 2);
4291 if (iter->step->ts.kind != iter->var->ts.kind
4292 || iter->step->ts.type != iter->var->ts.type)
4293 gfc_convert_type (iter->step, &iter->var->ts, 2);
4299 /* Check whether the FORALL index appears in the expression or not.
4300 Returns SUCCESS if SYM is found in EXPR. */
4303 find_forall_index (gfc_expr *expr, gfc_symbol *symbol)
4307 gfc_actual_arglist *args;
4313 switch (expr->expr_type)
4316 gcc_assert (expr->symtree->n.sym);
4318 /* A scalar assignment */
4321 if (expr->symtree->n.sym == symbol)
4327 /* the expr is array ref, substring or struct component. */
4334 /* Check if the symbol appears in the array subscript. */
4336 for (i = 0; i < GFC_MAX_DIMENSIONS; i++)
4339 if (find_forall_index (ar.start[i], symbol) == SUCCESS)
4343 if (find_forall_index (ar.end[i], symbol) == SUCCESS)
4347 if (find_forall_index (ar.stride[i], symbol) == SUCCESS)
4353 if (expr->symtree->n.sym == symbol)
4356 /* Check if the symbol appears in the substring section. */
4357 if (find_forall_index (tmp->u.ss.start, symbol) == SUCCESS)
4359 if (find_forall_index (tmp->u.ss.end, symbol) == SUCCESS)
4367 gfc_error("expression reference type error at %L", &expr->where);
4373 /* If the expression is a function call, then check if the symbol
4374 appears in the actual arglist of the function. */
4376 for (args = expr->value.function.actual; args; args = args->next)
4378 if (find_forall_index(args->expr,symbol) == SUCCESS)
4383 /* It seems not to happen. */
4384 case EXPR_SUBSTRING:
4388 gcc_assert (expr->ref->type == REF_SUBSTRING);
4389 if (find_forall_index (tmp->u.ss.start, symbol) == SUCCESS)
4391 if (find_forall_index (tmp->u.ss.end, symbol) == SUCCESS)
4396 /* It seems not to happen. */
4397 case EXPR_STRUCTURE:
4399 gfc_error ("Unsupported statement while finding forall index in "
4404 /* Find the FORALL index in the first operand. */
4405 if (expr->value.op.op1)
4407 if (find_forall_index (expr->value.op.op1, symbol) == SUCCESS)
4411 /* Find the FORALL index in the second operand. */
4412 if (expr->value.op.op2)
4414 if (find_forall_index (expr->value.op.op2, symbol) == SUCCESS)
4427 /* Resolve a list of FORALL iterators. The FORALL index-name is constrained
4428 to be a scalar INTEGER variable. The subscripts and stride are scalar
4429 INTEGERs, and if stride is a constant it must be nonzero.
4430 Furthermore "A subscript or stride in a forall-triplet-spec shall
4431 not contain a reference to any index-name in the
4432 forall-triplet-spec-list in which it appears." (7.5.4.1) */
4435 resolve_forall_iterators (gfc_forall_iterator *it)
4437 gfc_forall_iterator *iter, *iter2;
4439 for (iter = it; iter; iter = iter->next)
4441 if (gfc_resolve_expr (iter->var) == SUCCESS
4442 && (iter->var->ts.type != BT_INTEGER || iter->var->rank != 0))
4443 gfc_error ("FORALL index-name at %L must be a scalar INTEGER",
4446 if (gfc_resolve_expr (iter->start) == SUCCESS
4447 && (iter->start->ts.type != BT_INTEGER || iter->start->rank != 0))
4448 gfc_error ("FORALL start expression at %L must be a scalar INTEGER",
4449 &iter->start->where);
4450 if (iter->var->ts.kind != iter->start->ts.kind)
4451 gfc_convert_type (iter->start, &iter->var->ts, 2);
4453 if (gfc_resolve_expr (iter->end) == SUCCESS
4454 && (iter->end->ts.type != BT_INTEGER || iter->end->rank != 0))
4455 gfc_error ("FORALL end expression at %L must be a scalar INTEGER",
4457 if (iter->var->ts.kind != iter->end->ts.kind)
4458 gfc_convert_type (iter->end, &iter->var->ts, 2);
4460 if (gfc_resolve_expr (iter->stride) == SUCCESS)
4462 if (iter->stride->ts.type != BT_INTEGER || iter->stride->rank != 0)
4463 gfc_error ("FORALL stride expression at %L must be a scalar %s",
4464 &iter->stride->where, "INTEGER");
4466 if (iter->stride->expr_type == EXPR_CONSTANT
4467 && mpz_cmp_ui(iter->stride->value.integer, 0) == 0)
4468 gfc_error ("FORALL stride expression at %L cannot be zero",
4469 &iter->stride->where);
4471 if (iter->var->ts.kind != iter->stride->ts.kind)
4472 gfc_convert_type (iter->stride, &iter->var->ts, 2);
4475 for (iter = it; iter; iter = iter->next)
4476 for (iter2 = iter; iter2; iter2 = iter2->next)
4478 if (find_forall_index (iter2->start,
4479 iter->var->symtree->n.sym) == SUCCESS
4480 || find_forall_index (iter2->end,
4481 iter->var->symtree->n.sym) == SUCCESS
4482 || find_forall_index (iter2->stride,
4483 iter->var->symtree->n.sym) == SUCCESS)
4484 gfc_error ("FORALL index '%s' may not appear in triplet "
4485 "specification at %L", iter->var->symtree->name,
4486 &iter2->start->where);
4491 /* Given a pointer to a symbol that is a derived type, see if it's
4492 inaccessible, i.e. if it's defined in another module and the components are
4493 PRIVATE. The search is recursive if necessary. Returns zero if no
4494 inaccessible components are found, nonzero otherwise. */
4497 derived_inaccessible (gfc_symbol *sym)
4501 if (sym->attr.use_assoc && sym->attr.private_comp)
4504 for (c = sym->components; c; c = c->next)
4506 if (c->ts.type == BT_DERIVED && derived_inaccessible (c->ts.derived))
4514 /* Resolve the argument of a deallocate expression. The expression must be
4515 a pointer or a full array. */
4518 resolve_deallocate_expr (gfc_expr *e)
4520 symbol_attribute attr;
4521 int allocatable, pointer, check_intent_in;
4524 /* Check INTENT(IN), unless the object is a sub-component of a pointer. */
4525 check_intent_in = 1;
4527 if (gfc_resolve_expr (e) == FAILURE)
4530 if (e->expr_type != EXPR_VARIABLE)
4533 allocatable = e->symtree->n.sym->attr.allocatable;
4534 pointer = e->symtree->n.sym->attr.pointer;
4535 for (ref = e->ref; ref; ref = ref->next)
4538 check_intent_in = 0;
4543 if (ref->u.ar.type != AR_FULL)
4548 allocatable = (ref->u.c.component->as != NULL
4549 && ref->u.c.component->as->type == AS_DEFERRED);
4550 pointer = ref->u.c.component->pointer;
4559 attr = gfc_expr_attr (e);
4561 if (allocatable == 0 && attr.pointer == 0)
4564 gfc_error ("Expression in DEALLOCATE statement at %L must be "
4565 "ALLOCATABLE or a POINTER", &e->where);
4569 && e->symtree->n.sym->attr.intent == INTENT_IN)
4571 gfc_error ("Cannot deallocate INTENT(IN) variable '%s' at %L",
4572 e->symtree->n.sym->name, &e->where);
4580 /* Returns true if the expression e contains a reference the symbol sym. */
4582 find_sym_in_expr (gfc_symbol *sym, gfc_expr *e)
4584 gfc_actual_arglist *arg;
4592 switch (e->expr_type)
4595 for (arg = e->value.function.actual; arg; arg = arg->next)
4596 rv = rv || find_sym_in_expr (sym, arg->expr);
4599 /* If the variable is not the same as the dependent, 'sym', and
4600 it is not marked as being declared and it is in the same
4601 namespace as 'sym', add it to the local declarations. */
4603 if (sym == e->symtree->n.sym)
4608 rv = rv || find_sym_in_expr (sym, e->value.op.op1);
4609 rv = rv || find_sym_in_expr (sym, e->value.op.op2);
4618 for (ref = e->ref; ref; ref = ref->next)
4623 for (i = 0; i < ref->u.ar.dimen; i++)
4625 rv = rv || find_sym_in_expr (sym, ref->u.ar.start[i]);
4626 rv = rv || find_sym_in_expr (sym, ref->u.ar.end[i]);
4627 rv = rv || find_sym_in_expr (sym, ref->u.ar.stride[i]);
4632 rv = rv || find_sym_in_expr (sym, ref->u.ss.start);
4633 rv = rv || find_sym_in_expr (sym, ref->u.ss.end);
4637 if (ref->u.c.component->ts.type == BT_CHARACTER
4638 && ref->u.c.component->ts.cl->length->expr_type
4641 || find_sym_in_expr (sym,
4642 ref->u.c.component->ts.cl->length);
4644 if (ref->u.c.component->as)
4645 for (i = 0; i < ref->u.c.component->as->rank; i++)
4648 || find_sym_in_expr (sym,
4649 ref->u.c.component->as->lower[i]);
4651 || find_sym_in_expr (sym,
4652 ref->u.c.component->as->upper[i]);
4662 /* Given the expression node e for an allocatable/pointer of derived type to be
4663 allocated, get the expression node to be initialized afterwards (needed for
4664 derived types with default initializers, and derived types with allocatable
4665 components that need nullification.) */
4668 expr_to_initialize (gfc_expr *e)
4674 result = gfc_copy_expr (e);
4676 /* Change the last array reference from AR_ELEMENT to AR_FULL. */
4677 for (ref = result->ref; ref; ref = ref->next)
4678 if (ref->type == REF_ARRAY && ref->next == NULL)
4680 ref->u.ar.type = AR_FULL;
4682 for (i = 0; i < ref->u.ar.dimen; i++)
4683 ref->u.ar.start[i] = ref->u.ar.end[i] = ref->u.ar.stride[i] = NULL;
4685 result->rank = ref->u.ar.dimen;
4693 /* Resolve the expression in an ALLOCATE statement, doing the additional
4694 checks to see whether the expression is OK or not. The expression must
4695 have a trailing array reference that gives the size of the array. */
4698 resolve_allocate_expr (gfc_expr *e, gfc_code *code)
4700 int i, pointer, allocatable, dimension, check_intent_in;
4701 symbol_attribute attr;
4702 gfc_ref *ref, *ref2;
4709 /* Check INTENT(IN), unless the object is a sub-component of a pointer. */
4710 check_intent_in = 1;
4712 if (gfc_resolve_expr (e) == FAILURE)
4715 if (code->expr && code->expr->expr_type == EXPR_VARIABLE)
4716 sym = code->expr->symtree->n.sym;
4720 /* Make sure the expression is allocatable or a pointer. If it is
4721 pointer, the next-to-last reference must be a pointer. */
4725 if (e->expr_type != EXPR_VARIABLE)
4728 attr = gfc_expr_attr (e);
4729 pointer = attr.pointer;
4730 dimension = attr.dimension;
4734 allocatable = e->symtree->n.sym->attr.allocatable;
4735 pointer = e->symtree->n.sym->attr.pointer;
4736 dimension = e->symtree->n.sym->attr.dimension;
4738 if (sym == e->symtree->n.sym && sym->ts.type != BT_DERIVED)
4740 gfc_error ("The STAT variable '%s' in an ALLOCATE statement must "
4741 "not be allocated in the same statement at %L",
4742 sym->name, &e->where);
4746 for (ref = e->ref; ref; ref2 = ref, ref = ref->next)
4749 check_intent_in = 0;
4754 if (ref->next != NULL)
4759 allocatable = (ref->u.c.component->as != NULL
4760 && ref->u.c.component->as->type == AS_DEFERRED);
4762 pointer = ref->u.c.component->pointer;
4763 dimension = ref->u.c.component->dimension;
4774 if (allocatable == 0 && pointer == 0)
4776 gfc_error ("Expression in ALLOCATE statement at %L must be "
4777 "ALLOCATABLE or a POINTER", &e->where);
4782 && e->symtree->n.sym->attr.intent == INTENT_IN)
4784 gfc_error ("Cannot allocate INTENT(IN) variable '%s' at %L",
4785 e->symtree->n.sym->name, &e->where);
4789 /* Add default initializer for those derived types that need them. */
4790 if (e->ts.type == BT_DERIVED && (init_e = gfc_default_initializer (&e->ts)))
4792 init_st = gfc_get_code ();
4793 init_st->loc = code->loc;
4794 init_st->op = EXEC_INIT_ASSIGN;
4795 init_st->expr = expr_to_initialize (e);
4796 init_st->expr2 = init_e;
4797 init_st->next = code->next;
4798 code->next = init_st;
4801 if (pointer && dimension == 0)
4804 /* Make sure the next-to-last reference node is an array specification. */
4806 if (ref2 == NULL || ref2->type != REF_ARRAY || ref2->u.ar.type == AR_FULL)
4808 gfc_error ("Array specification required in ALLOCATE statement "
4809 "at %L", &e->where);
4813 /* Make sure that the array section reference makes sense in the
4814 context of an ALLOCATE specification. */
4818 for (i = 0; i < ar->dimen; i++)
4820 if (ref2->u.ar.type == AR_ELEMENT)
4823 switch (ar->dimen_type[i])
4829 if (ar->start[i] != NULL
4830 && ar->end[i] != NULL
4831 && ar->stride[i] == NULL)
4834 /* Fall Through... */
4838 gfc_error ("Bad array specification in ALLOCATE statement at %L",
4845 for (a = code->ext.alloc_list; a; a = a->next)
4847 sym = a->expr->symtree->n.sym;
4849 /* TODO - check derived type components. */
4850 if (sym->ts.type == BT_DERIVED)
4853 if ((ar->start[i] != NULL && find_sym_in_expr (sym, ar->start[i]))
4854 || (ar->end[i] != NULL && find_sym_in_expr (sym, ar->end[i])))
4856 gfc_error ("'%s' must not appear an the array specification at "
4857 "%L in the same ALLOCATE statement where it is "
4858 "itself allocated", sym->name, &ar->where);
4868 /************ SELECT CASE resolution subroutines ************/
4870 /* Callback function for our mergesort variant. Determines interval
4871 overlaps for CASEs. Return <0 if op1 < op2, 0 for overlap, >0 for
4872 op1 > op2. Assumes we're not dealing with the default case.
4873 We have op1 = (:L), (K:L) or (K:) and op2 = (:N), (M:N) or (M:).
4874 There are nine situations to check. */
4877 compare_cases (const gfc_case *op1, const gfc_case *op2)
4881 if (op1->low == NULL) /* op1 = (:L) */
4883 /* op2 = (:N), so overlap. */
4885 /* op2 = (M:) or (M:N), L < M */
4886 if (op2->low != NULL
4887 && gfc_compare_expr (op1->high, op2->low) < 0)
4890 else if (op1->high == NULL) /* op1 = (K:) */
4892 /* op2 = (M:), so overlap. */
4894 /* op2 = (:N) or (M:N), K > N */
4895 if (op2->high != NULL
4896 && gfc_compare_expr (op1->low, op2->high) > 0)
4899 else /* op1 = (K:L) */
4901 if (op2->low == NULL) /* op2 = (:N), K > N */
4902 retval = (gfc_compare_expr (op1->low, op2->high) > 0) ? 1 : 0;
4903 else if (op2->high == NULL) /* op2 = (M:), L < M */
4904 retval = (gfc_compare_expr (op1->high, op2->low) < 0) ? -1 : 0;
4905 else /* op2 = (M:N) */
4909 if (gfc_compare_expr (op1->high, op2->low) < 0)
4912 else if (gfc_compare_expr (op1->low, op2->high) > 0)
4921 /* Merge-sort a double linked case list, detecting overlap in the
4922 process. LIST is the head of the double linked case list before it
4923 is sorted. Returns the head of the sorted list if we don't see any
4924 overlap, or NULL otherwise. */
4927 check_case_overlap (gfc_case *list)
4929 gfc_case *p, *q, *e, *tail;
4930 int insize, nmerges, psize, qsize, cmp, overlap_seen;
4932 /* If the passed list was empty, return immediately. */
4939 /* Loop unconditionally. The only exit from this loop is a return
4940 statement, when we've finished sorting the case list. */
4947 /* Count the number of merges we do in this pass. */
4950 /* Loop while there exists a merge to be done. */
4955 /* Count this merge. */
4958 /* Cut the list in two pieces by stepping INSIZE places
4959 forward in the list, starting from P. */
4962 for (i = 0; i < insize; i++)
4971 /* Now we have two lists. Merge them! */
4972 while (psize > 0 || (qsize > 0 && q != NULL))
4974 /* See from which the next case to merge comes from. */
4977 /* P is empty so the next case must come from Q. */
4982 else if (qsize == 0 || q == NULL)
4991 cmp = compare_cases (p, q);
4994 /* The whole case range for P is less than the
5002 /* The whole case range for Q is greater than
5003 the case range for P. */
5010 /* The cases overlap, or they are the same
5011 element in the list. Either way, we must
5012 issue an error and get the next case from P. */
5013 /* FIXME: Sort P and Q by line number. */
5014 gfc_error ("CASE label at %L overlaps with CASE "
5015 "label at %L", &p->where, &q->where);
5023 /* Add the next element to the merged list. */
5032 /* P has now stepped INSIZE places along, and so has Q. So
5033 they're the same. */
5038 /* If we have done only one merge or none at all, we've
5039 finished sorting the cases. */
5048 /* Otherwise repeat, merging lists twice the size. */
5054 /* Check to see if an expression is suitable for use in a CASE statement.
5055 Makes sure that all case expressions are scalar constants of the same
5056 type. Return FAILURE if anything is wrong. */
5059 validate_case_label_expr (gfc_expr *e, gfc_expr *case_expr)
5061 if (e == NULL) return SUCCESS;
5063 if (e->ts.type != case_expr->ts.type)
5065 gfc_error ("Expression in CASE statement at %L must be of type %s",
5066 &e->where, gfc_basic_typename (case_expr->ts.type));
5070 /* C805 (R808) For a given case-construct, each case-value shall be of
5071 the same type as case-expr. For character type, length differences
5072 are allowed, but the kind type parameters shall be the same. */
5074 if (case_expr->ts.type == BT_CHARACTER && e->ts.kind != case_expr->ts.kind)
5076 gfc_error("Expression in CASE statement at %L must be kind %d",
5077 &e->where, case_expr->ts.kind);
5081 /* Convert the case value kind to that of case expression kind, if needed.
5082 FIXME: Should a warning be issued? */
5083 if (e->ts.kind != case_expr->ts.kind)
5084 gfc_convert_type_warn (e, &case_expr->ts, 2, 0);
5088 gfc_error ("Expression in CASE statement at %L must be scalar",
5097 /* Given a completely parsed select statement, we:
5099 - Validate all expressions and code within the SELECT.
5100 - Make sure that the selection expression is not of the wrong type.
5101 - Make sure that no case ranges overlap.
5102 - Eliminate unreachable cases and unreachable code resulting from
5103 removing case labels.
5105 The standard does allow unreachable cases, e.g. CASE (5:3). But
5106 they are a hassle for code generation, and to prevent that, we just
5107 cut them out here. This is not necessary for overlapping cases
5108 because they are illegal and we never even try to generate code.
5110 We have the additional caveat that a SELECT construct could have
5111 been a computed GOTO in the source code. Fortunately we can fairly
5112 easily work around that here: The case_expr for a "real" SELECT CASE
5113 is in code->expr1, but for a computed GOTO it is in code->expr2. All
5114 we have to do is make sure that the case_expr is a scalar integer
5118 resolve_select (gfc_code *code)
5121 gfc_expr *case_expr;
5122 gfc_case *cp, *default_case, *tail, *head;
5123 int seen_unreachable;
5129 if (code->expr == NULL)
5131 /* This was actually a computed GOTO statement. */
5132 case_expr = code->expr2;
5133 if (case_expr->ts.type != BT_INTEGER|| case_expr->rank != 0)
5134 gfc_error ("Selection expression in computed GOTO statement "
5135 "at %L must be a scalar integer expression",
5138 /* Further checking is not necessary because this SELECT was built
5139 by the compiler, so it should always be OK. Just move the
5140 case_expr from expr2 to expr so that we can handle computed
5141 GOTOs as normal SELECTs from here on. */
5142 code->expr = code->expr2;
5147 case_expr = code->expr;
5149 type = case_expr->ts.type;
5150 if (type != BT_LOGICAL && type != BT_INTEGER && type != BT_CHARACTER)
5152 gfc_error ("Argument of SELECT statement at %L cannot be %s",
5153 &case_expr->where, gfc_typename (&case_expr->ts));
5155 /* Punt. Going on here just produce more garbage error messages. */
5159 if (case_expr->rank != 0)
5161 gfc_error ("Argument of SELECT statement at %L must be a scalar "
5162 "expression", &case_expr->where);
5168 /* PR 19168 has a long discussion concerning a mismatch of the kinds
5169 of the SELECT CASE expression and its CASE values. Walk the lists
5170 of case values, and if we find a mismatch, promote case_expr to
5171 the appropriate kind. */
5173 if (type == BT_LOGICAL || type == BT_INTEGER)
5175 for (body = code->block; body; body = body->block)
5177 /* Walk the case label list. */
5178 for (cp = body->ext.case_list; cp; cp = cp->next)
5180 /* Intercept the DEFAULT case. It does not have a kind. */
5181 if (cp->low == NULL && cp->high == NULL)
5184 /* Unreachable case ranges are discarded, so ignore. */
5185 if (cp->low != NULL && cp->high != NULL
5186 && cp->low != cp->high
5187 && gfc_compare_expr (cp->low, cp->high) > 0)
5190 /* FIXME: Should a warning be issued? */
5192 && case_expr->ts.kind != gfc_kind_max(case_expr, cp->low))
5193 gfc_convert_type_warn (case_expr, &cp->low->ts, 2, 0);
5195 if (cp->high != NULL
5196 && case_expr->ts.kind != gfc_kind_max(case_expr, cp->high))
5197 gfc_convert_type_warn (case_expr, &cp->high->ts, 2, 0);
5202 /* Assume there is no DEFAULT case. */
5203 default_case = NULL;
5208 for (body = code->block; body; body = body->block)
5210 /* Assume the CASE list is OK, and all CASE labels can be matched. */
5212 seen_unreachable = 0;
5214 /* Walk the case label list, making sure that all case labels
5216 for (cp = body->ext.case_list; cp; cp = cp->next)
5218 /* Count the number of cases in the whole construct. */
5221 /* Intercept the DEFAULT case. */
5222 if (cp->low == NULL && cp->high == NULL)
5224 if (default_case != NULL)
5226 gfc_error ("The DEFAULT CASE at %L cannot be followed "
5227 "by a second DEFAULT CASE at %L",
5228 &default_case->where, &cp->where);
5239 /* Deal with single value cases and case ranges. Errors are
5240 issued from the validation function. */
5241 if(validate_case_label_expr (cp->low, case_expr) != SUCCESS
5242 || validate_case_label_expr (cp->high, case_expr) != SUCCESS)
5248 if (type == BT_LOGICAL
5249 && ((cp->low == NULL || cp->high == NULL)
5250 || cp->low != cp->high))
5252 gfc_error ("Logical range in CASE statement at %L is not "
5253 "allowed", &cp->low->where);
5258 if (type == BT_LOGICAL && cp->low->expr_type == EXPR_CONSTANT)
5261 value = cp->low->value.logical == 0 ? 2 : 1;
5262 if (value & seen_logical)
5264 gfc_error ("constant logical value in CASE statement "
5265 "is repeated at %L",
5270 seen_logical |= value;
5273 if (cp->low != NULL && cp->high != NULL
5274 && cp->low != cp->high
5275 && gfc_compare_expr (cp->low, cp->high) > 0)
5277 if (gfc_option.warn_surprising)
5278 gfc_warning ("Range specification at %L can never "
5279 "be matched", &cp->where);
5281 cp->unreachable = 1;
5282 seen_unreachable = 1;
5286 /* If the case range can be matched, it can also overlap with
5287 other cases. To make sure it does not, we put it in a
5288 double linked list here. We sort that with a merge sort
5289 later on to detect any overlapping cases. */
5293 head->right = head->left = NULL;
5298 tail->right->left = tail;
5305 /* It there was a failure in the previous case label, give up
5306 for this case label list. Continue with the next block. */
5310 /* See if any case labels that are unreachable have been seen.
5311 If so, we eliminate them. This is a bit of a kludge because
5312 the case lists for a single case statement (label) is a
5313 single forward linked lists. */
5314 if (seen_unreachable)
5316 /* Advance until the first case in the list is reachable. */
5317 while (body->ext.case_list != NULL
5318 && body->ext.case_list->unreachable)
5320 gfc_case *n = body->ext.case_list;
5321 body->ext.case_list = body->ext.case_list->next;
5323 gfc_free_case_list (n);
5326 /* Strip all other unreachable cases. */
5327 if (body->ext.case_list)
5329 for (cp = body->ext.case_list; cp->next; cp = cp->next)
5331 if (cp->next->unreachable)
5333 gfc_case *n = cp->next;
5334 cp->next = cp->next->next;
5336 gfc_free_case_list (n);
5343 /* See if there were overlapping cases. If the check returns NULL,
5344 there was overlap. In that case we don't do anything. If head
5345 is non-NULL, we prepend the DEFAULT case. The sorted list can
5346 then used during code generation for SELECT CASE constructs with
5347 a case expression of a CHARACTER type. */
5350 head = check_case_overlap (head);
5352 /* Prepend the default_case if it is there. */
5353 if (head != NULL && default_case)
5355 default_case->left = NULL;
5356 default_case->right = head;
5357 head->left = default_case;
5361 /* Eliminate dead blocks that may be the result if we've seen
5362 unreachable case labels for a block. */
5363 for (body = code; body && body->block; body = body->block)
5365 if (body->block->ext.case_list == NULL)
5367 /* Cut the unreachable block from the code chain. */
5368 gfc_code *c = body->block;
5369 body->block = c->block;
5371 /* Kill the dead block, but not the blocks below it. */
5373 gfc_free_statements (c);
5377 /* More than two cases is legal but insane for logical selects.
5378 Issue a warning for it. */
5379 if (gfc_option.warn_surprising && type == BT_LOGICAL
5381 gfc_warning ("Logical SELECT CASE block at %L has more that two cases",
5386 /* Resolve a transfer statement. This is making sure that:
5387 -- a derived type being transferred has only non-pointer components
5388 -- a derived type being transferred doesn't have private components, unless
5389 it's being transferred from the module where the type was defined
5390 -- we're not trying to transfer a whole assumed size array. */
5393 resolve_transfer (gfc_code *code)
5402 if (exp->expr_type != EXPR_VARIABLE && exp->expr_type != EXPR_FUNCTION)
5405 sym = exp->symtree->n.sym;
5408 /* Go to actual component transferred. */
5409 for (ref = code->expr->ref; ref; ref = ref->next)
5410 if (ref->type == REF_COMPONENT)
5411 ts = &ref->u.c.component->ts;
5413 if (ts->type == BT_DERIVED)
5415 /* Check that transferred derived type doesn't contain POINTER
5417 if (ts->derived->attr.pointer_comp)
5419 gfc_error ("Data transfer element at %L cannot have "
5420 "POINTER components", &code->loc);
5424 if (ts->derived->attr.alloc_comp)
5426 gfc_error ("Data transfer element at %L cannot have "
5427 "ALLOCATABLE components", &code->loc);
5431 if (derived_inaccessible (ts->derived))
5433 gfc_error ("Data transfer element at %L cannot have "
5434 "PRIVATE components",&code->loc);
5439 if (sym->as != NULL && sym->as->type == AS_ASSUMED_SIZE
5440 && exp->ref->type == REF_ARRAY && exp->ref->u.ar.type == AR_FULL)
5442 gfc_error ("Data transfer element at %L cannot be a full reference to "
5443 "an assumed-size array", &code->loc);
5449 /*********** Toplevel code resolution subroutines ***********/
5451 /* Find the set of labels that are reachable from this block. We also
5452 record the last statement in each block so that we don't have to do
5453 a linear search to find the END DO statements of the blocks. */
5456 reachable_labels (gfc_code *block)
5463 cs_base->reachable_labels = bitmap_obstack_alloc (&labels_obstack);
5465 /* Collect labels in this block. */
5466 for (c = block; c; c = c->next)
5469 bitmap_set_bit (cs_base->reachable_labels, c->here->value);
5471 if (!c->next && cs_base->prev)
5472 cs_base->prev->tail = c;
5475 /* Merge with labels from parent block. */
5478 gcc_assert (cs_base->prev->reachable_labels);
5479 bitmap_ior_into (cs_base->reachable_labels,
5480 cs_base->prev->reachable_labels);
5484 /* Given a branch to a label and a namespace, if the branch is conforming.
5485 The code node describes where the branch is located. */
5488 resolve_branch (gfc_st_label *label, gfc_code *code)
5495 /* Step one: is this a valid branching target? */
5497 if (label->defined == ST_LABEL_UNKNOWN)
5499 gfc_error ("Label %d referenced at %L is never defined", label->value,
5504 if (label->defined != ST_LABEL_TARGET)
5506 gfc_error ("Statement at %L is not a valid branch target statement "
5507 "for the branch statement at %L", &label->where, &code->loc);
5511 /* Step two: make sure this branch is not a branch to itself ;-) */
5513 if (code->here == label)
5515 gfc_warning ("Branch at %L causes an infinite loop", &code->loc);
5519 /* Step three: See if the label is in the same block as the
5520 branching statement. The hard work has been done by setting up
5521 the bitmap reachable_labels. */
5523 if (!bitmap_bit_p (cs_base->reachable_labels, label->value))
5525 /* The label is not in an enclosing block, so illegal. This was
5526 allowed in Fortran 66, so we allow it as extension. No
5527 further checks are necessary in this case. */
5528 gfc_notify_std (GFC_STD_LEGACY, "Label at %L is not in the same block "
5529 "as the GOTO statement at %L", &label->where,
5534 /* Step four: Make sure that the branching target is legal if
5535 the statement is an END {SELECT,IF}. */
5537 for (stack = cs_base; stack; stack = stack->prev)
5538 if (stack->current->next && stack->current->next->here == label)
5541 if (stack && stack->current->next->op == EXEC_NOP)
5543 gfc_notify_std (GFC_STD_F95_DEL, "Deleted feature: GOTO at %L jumps to "
5544 "END of construct at %L", &code->loc,
5545 &stack->current->next->loc);
5546 return; /* We know this is not an END DO. */
5549 /* Step five: Make sure that we're not jumping to the end of a DO
5550 loop from within the loop. */
5552 for (stack = cs_base; stack; stack = stack->prev)
5553 if ((stack->current->op == EXEC_DO
5554 || stack->current->op == EXEC_DO_WHILE)
5555 && stack->tail->here == label && stack->tail->op == EXEC_NOP)
5557 gfc_notify_std (GFC_STD_F95_DEL, "Deleted feature: GOTO at %L jumps "
5558 "to END of construct at %L", &code->loc,
5566 /* Check whether EXPR1 has the same shape as EXPR2. */
5569 resolve_where_shape (gfc_expr *expr1, gfc_expr *expr2)
5571 mpz_t shape[GFC_MAX_DIMENSIONS];
5572 mpz_t shape2[GFC_MAX_DIMENSIONS];
5573 try result = FAILURE;
5576 /* Compare the rank. */
5577 if (expr1->rank != expr2->rank)
5580 /* Compare the size of each dimension. */
5581 for (i=0; i<expr1->rank; i++)
5583 if (gfc_array_dimen_size (expr1, i, &shape[i]) == FAILURE)
5586 if (gfc_array_dimen_size (expr2, i, &shape2[i]) == FAILURE)
5589 if (mpz_cmp (shape[i], shape2[i]))
5593 /* When either of the two expression is an assumed size array, we
5594 ignore the comparison of dimension sizes. */
5599 for (i--; i >= 0; i--)
5601 mpz_clear (shape[i]);
5602 mpz_clear (shape2[i]);
5608 /* Check whether a WHERE assignment target or a WHERE mask expression
5609 has the same shape as the outmost WHERE mask expression. */
5612 resolve_where (gfc_code *code, gfc_expr *mask)
5618 cblock = code->block;
5620 /* Store the first WHERE mask-expr of the WHERE statement or construct.
5621 In case of nested WHERE, only the outmost one is stored. */
5622 if (mask == NULL) /* outmost WHERE */
5624 else /* inner WHERE */
5631 /* Check if the mask-expr has a consistent shape with the
5632 outmost WHERE mask-expr. */
5633 if (resolve_where_shape (cblock->expr, e) == FAILURE)
5634 gfc_error ("WHERE mask at %L has inconsistent shape",
5635 &cblock->expr->where);
5638 /* the assignment statement of a WHERE statement, or the first
5639 statement in where-body-construct of a WHERE construct */
5640 cnext = cblock->next;
5645 /* WHERE assignment statement */
5648 /* Check shape consistent for WHERE assignment target. */
5649 if (e && resolve_where_shape (cnext->expr, e) == FAILURE)
5650 gfc_error ("WHERE assignment target at %L has "
5651 "inconsistent shape", &cnext->expr->where);
5655 case EXEC_ASSIGN_CALL:
5656 resolve_call (cnext);
5659 /* WHERE or WHERE construct is part of a where-body-construct */
5661 resolve_where (cnext, e);
5665 gfc_error ("Unsupported statement inside WHERE at %L",
5668 /* the next statement within the same where-body-construct */
5669 cnext = cnext->next;
5671 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
5672 cblock = cblock->block;
5677 /* Resolve assignment in FORALL construct.
5678 NVAR is the number of FORALL index variables, and VAR_EXPR records the
5679 FORALL index variables. */
5682 gfc_resolve_assign_in_forall (gfc_code *code, int nvar, gfc_expr **var_expr)
5686 for (n = 0; n < nvar; n++)
5688 gfc_symbol *forall_index;
5690 forall_index = var_expr[n]->symtree->n.sym;
5692 /* Check whether the assignment target is one of the FORALL index
5694 if ((code->expr->expr_type == EXPR_VARIABLE)
5695 && (code->expr->symtree->n.sym == forall_index))
5696 gfc_error ("Assignment to a FORALL index variable at %L",
5697 &code->expr->where);
5700 /* If one of the FORALL index variables doesn't appear in the
5701 assignment target, then there will be a many-to-one
5703 if (find_forall_index (code->expr, forall_index) == FAILURE)
5704 gfc_error ("The FORALL with index '%s' cause more than one "
5705 "assignment to this object at %L",
5706 var_expr[n]->symtree->name, &code->expr->where);
5712 /* Resolve WHERE statement in FORALL construct. */
5715 gfc_resolve_where_code_in_forall (gfc_code *code, int nvar,
5716 gfc_expr **var_expr)
5721 cblock = code->block;
5724 /* the assignment statement of a WHERE statement, or the first
5725 statement in where-body-construct of a WHERE construct */
5726 cnext = cblock->next;
5731 /* WHERE assignment statement */
5733 gfc_resolve_assign_in_forall (cnext, nvar, var_expr);
5736 /* WHERE operator assignment statement */
5737 case EXEC_ASSIGN_CALL:
5738 resolve_call (cnext);
5741 /* WHERE or WHERE construct is part of a where-body-construct */
5743 gfc_resolve_where_code_in_forall (cnext, nvar, var_expr);
5747 gfc_error ("Unsupported statement inside WHERE at %L",
5750 /* the next statement within the same where-body-construct */
5751 cnext = cnext->next;
5753 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
5754 cblock = cblock->block;
5759 /* Traverse the FORALL body to check whether the following errors exist:
5760 1. For assignment, check if a many-to-one assignment happens.
5761 2. For WHERE statement, check the WHERE body to see if there is any
5762 many-to-one assignment. */
5765 gfc_resolve_forall_body (gfc_code *code, int nvar, gfc_expr **var_expr)
5769 c = code->block->next;
5775 case EXEC_POINTER_ASSIGN:
5776 gfc_resolve_assign_in_forall (c, nvar, var_expr);
5779 case EXEC_ASSIGN_CALL:
5783 /* Because the gfc_resolve_blocks() will handle the nested FORALL,
5784 there is no need to handle it here. */
5788 gfc_resolve_where_code_in_forall(c, nvar, var_expr);
5793 /* The next statement in the FORALL body. */
5799 /* Given a FORALL construct, first resolve the FORALL iterator, then call
5800 gfc_resolve_forall_body to resolve the FORALL body. */
5803 gfc_resolve_forall (gfc_code *code, gfc_namespace *ns, int forall_save)
5805 static gfc_expr **var_expr;
5806 static int total_var = 0;
5807 static int nvar = 0;
5808 gfc_forall_iterator *fa;
5812 /* Start to resolve a FORALL construct */
5813 if (forall_save == 0)
5815 /* Count the total number of FORALL index in the nested FORALL
5816 construct in order to allocate the VAR_EXPR with proper size. */
5818 while ((next != NULL) && (next->op == EXEC_FORALL))
5820 for (fa = next->ext.forall_iterator; fa; fa = fa->next)
5822 next = next->block->next;
5825 /* Allocate VAR_EXPR with NUMBER_OF_FORALL_INDEX elements. */
5826 var_expr = (gfc_expr **) gfc_getmem (total_var * sizeof (gfc_expr *));
5829 /* The information about FORALL iterator, including FORALL index start, end
5830 and stride. The FORALL index can not appear in start, end or stride. */
5831 for (fa = code->ext.forall_iterator; fa; fa = fa->next)
5833 /* Check if any outer FORALL index name is the same as the current
5835 for (i = 0; i < nvar; i++)
5837 if (fa->var->symtree->n.sym == var_expr[i]->symtree->n.sym)
5839 gfc_error ("An outer FORALL construct already has an index "
5840 "with this name %L", &fa->var->where);
5844 /* Record the current FORALL index. */
5845 var_expr[nvar] = gfc_copy_expr (fa->var);
5850 /* Resolve the FORALL body. */
5851 gfc_resolve_forall_body (code, nvar, var_expr);
5853 /* May call gfc_resolve_forall to resolve the inner FORALL loop. */
5854 gfc_resolve_blocks (code->block, ns);
5856 /* Free VAR_EXPR after the whole FORALL construct resolved. */
5857 for (i = 0; i < total_var; i++)
5858 gfc_free_expr (var_expr[i]);
5860 /* Reset the counters. */
5866 /* Resolve lists of blocks found in IF, SELECT CASE, WHERE, FORALL ,GOTO and
5869 static void resolve_code (gfc_code *, gfc_namespace *);
5872 gfc_resolve_blocks (gfc_code *b, gfc_namespace *ns)
5876 for (; b; b = b->block)
5878 t = gfc_resolve_expr (b->expr);
5879 if (gfc_resolve_expr (b->expr2) == FAILURE)
5885 if (t == SUCCESS && b->expr != NULL
5886 && (b->expr->ts.type != BT_LOGICAL || b->expr->rank != 0))
5887 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
5894 && (b->expr->ts.type != BT_LOGICAL || b->expr->rank == 0))
5895 gfc_error ("WHERE/ELSEWHERE clause at %L requires a LOGICAL array",
5900 resolve_branch (b->label, b);
5912 case EXEC_OMP_ATOMIC:
5913 case EXEC_OMP_CRITICAL:
5915 case EXEC_OMP_MASTER:
5916 case EXEC_OMP_ORDERED:
5917 case EXEC_OMP_PARALLEL:
5918 case EXEC_OMP_PARALLEL_DO:
5919 case EXEC_OMP_PARALLEL_SECTIONS:
5920 case EXEC_OMP_PARALLEL_WORKSHARE:
5921 case EXEC_OMP_SECTIONS:
5922 case EXEC_OMP_SINGLE:
5923 case EXEC_OMP_WORKSHARE:
5927 gfc_internal_error ("resolve_block(): Bad block type");
5930 resolve_code (b->next, ns);
5935 /* Given a block of code, recursively resolve everything pointed to by this
5939 resolve_code (gfc_code *code, gfc_namespace *ns)
5941 int omp_workshare_save;
5947 frame.prev = cs_base;
5951 reachable_labels (code);
5953 for (; code; code = code->next)
5955 frame.current = code;
5956 forall_save = forall_flag;
5958 if (code->op == EXEC_FORALL)
5961 gfc_resolve_forall (code, ns, forall_save);
5964 else if (code->block)
5966 omp_workshare_save = -1;
5969 case EXEC_OMP_PARALLEL_WORKSHARE:
5970 omp_workshare_save = omp_workshare_flag;
5971 omp_workshare_flag = 1;
5972 gfc_resolve_omp_parallel_blocks (code, ns);
5974 case EXEC_OMP_PARALLEL:
5975 case EXEC_OMP_PARALLEL_DO:
5976 case EXEC_OMP_PARALLEL_SECTIONS:
5977 omp_workshare_save = omp_workshare_flag;
5978 omp_workshare_flag = 0;
5979 gfc_resolve_omp_parallel_blocks (code, ns);
5982 gfc_resolve_omp_do_blocks (code, ns);
5984 case EXEC_OMP_WORKSHARE:
5985 omp_workshare_save = omp_workshare_flag;
5986 omp_workshare_flag = 1;
5989 gfc_resolve_blocks (code->block, ns);
5993 if (omp_workshare_save != -1)
5994 omp_workshare_flag = omp_workshare_save;
5997 t = gfc_resolve_expr (code->expr);
5998 forall_flag = forall_save;
6000 if (gfc_resolve_expr (code->expr2) == FAILURE)
6015 /* Keep track of which entry we are up to. */
6016 current_entry_id = code->ext.entry->id;
6020 resolve_where (code, NULL);
6024 if (code->expr != NULL)
6026 if (code->expr->ts.type != BT_INTEGER)
6027 gfc_error ("ASSIGNED GOTO statement at %L requires an "
6028 "INTEGER variable", &code->expr->where);
6029 else if (code->expr->symtree->n.sym->attr.assign != 1)
6030 gfc_error ("Variable '%s' has not been assigned a target "
6031 "label at %L", code->expr->symtree->n.sym->name,
6032 &code->expr->where);
6035 resolve_branch (code->label, code);
6039 if (code->expr != NULL
6040 && (code->expr->ts.type != BT_INTEGER || code->expr->rank))
6041 gfc_error ("Alternate RETURN statement at %L requires a SCALAR-"
6042 "INTEGER return specifier", &code->expr->where);
6045 case EXEC_INIT_ASSIGN:
6052 if (gfc_extend_assign (code, ns) == SUCCESS)
6054 gfc_expr *lhs = code->ext.actual->expr;
6055 gfc_expr *rhs = code->ext.actual->next->expr;
6057 if (gfc_pure (NULL) && !gfc_pure (code->symtree->n.sym))
6059 gfc_error ("Subroutine '%s' called instead of assignment at "
6060 "%L must be PURE", code->symtree->n.sym->name,
6065 /* Make a temporary rhs when there is a default initializer
6066 and rhs is the same symbol as the lhs. */
6067 if (rhs->expr_type == EXPR_VARIABLE
6068 && rhs->symtree->n.sym->ts.type == BT_DERIVED
6069 && has_default_initializer (rhs->symtree->n.sym->ts.derived)
6070 && (lhs->symtree->n.sym == rhs->symtree->n.sym))
6071 code->ext.actual->next->expr = gfc_get_parentheses (rhs);
6076 if (code->expr->ts.type == BT_CHARACTER
6077 && gfc_option.warn_character_truncation)
6079 int llen = 0, rlen = 0;
6081 if (code->expr->ts.cl != NULL
6082 && code->expr->ts.cl->length != NULL
6083 && code->expr->ts.cl->length->expr_type == EXPR_CONSTANT)
6084 llen = mpz_get_si (code->expr->ts.cl->length->value.integer);
6086 if (code->expr2->expr_type == EXPR_CONSTANT)
6087 rlen = code->expr2->value.character.length;
6089 else if (code->expr2->ts.cl != NULL
6090 && code->expr2->ts.cl->length != NULL
6091 && code->expr2->ts.cl->length->expr_type
6093 rlen = mpz_get_si (code->expr2->ts.cl->length->value.integer);
6095 if (rlen && llen && rlen > llen)
6096 gfc_warning_now ("CHARACTER expression will be truncated "
6097 "in assignment (%d/%d) at %L",
6098 llen, rlen, &code->loc);
6101 if (gfc_pure (NULL))
6103 if (gfc_impure_variable (code->expr->symtree->n.sym))
6105 gfc_error ("Cannot assign to variable '%s' in PURE "
6107 code->expr->symtree->n.sym->name,
6108 &code->expr->where);
6112 if (code->expr->ts.type == BT_DERIVED
6113 && code->expr->expr_type == EXPR_VARIABLE
6114 && code->expr->ts.derived->attr.pointer_comp
6115 && gfc_impure_variable (code->expr2->symtree->n.sym))
6117 gfc_error ("The impure variable at %L is assigned to "
6118 "a derived type variable with a POINTER "
6119 "component in a PURE procedure (12.6)",
6120 &code->expr2->where);
6125 gfc_check_assign (code->expr, code->expr2, 1);
6128 case EXEC_LABEL_ASSIGN:
6129 if (code->label->defined == ST_LABEL_UNKNOWN)
6130 gfc_error ("Label %d referenced at %L is never defined",
6131 code->label->value, &code->label->where);
6133 && (code->expr->expr_type != EXPR_VARIABLE
6134 || code->expr->symtree->n.sym->ts.type != BT_INTEGER
6135 || code->expr->symtree->n.sym->ts.kind
6136 != gfc_default_integer_kind
6137 || code->expr->symtree->n.sym->as != NULL))
6138 gfc_error ("ASSIGN statement at %L requires a scalar "
6139 "default INTEGER variable", &code->expr->where);
6142 case EXEC_POINTER_ASSIGN:
6146 gfc_check_pointer_assign (code->expr, code->expr2);
6149 case EXEC_ARITHMETIC_IF:
6151 && code->expr->ts.type != BT_INTEGER
6152 && code->expr->ts.type != BT_REAL)
6153 gfc_error ("Arithmetic IF statement at %L requires a numeric "
6154 "expression", &code->expr->where);
6156 resolve_branch (code->label, code);
6157 resolve_branch (code->label2, code);
6158 resolve_branch (code->label3, code);
6162 if (t == SUCCESS && code->expr != NULL
6163 && (code->expr->ts.type != BT_LOGICAL
6164 || code->expr->rank != 0))
6165 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
6166 &code->expr->where);
6171 resolve_call (code);
6175 /* Select is complicated. Also, a SELECT construct could be
6176 a transformed computed GOTO. */
6177 resolve_select (code);
6181 if (code->ext.iterator != NULL)
6183 gfc_iterator *iter = code->ext.iterator;
6184 if (gfc_resolve_iterator (iter, true) != FAILURE)
6185 gfc_resolve_do_iterator (code, iter->var->symtree->n.sym);
6190 if (code->expr == NULL)
6191 gfc_internal_error ("resolve_code(): No expression on DO WHILE");
6193 && (code->expr->rank != 0
6194 || code->expr->ts.type != BT_LOGICAL))
6195 gfc_error ("Exit condition of DO WHILE loop at %L must be "
6196 "a scalar LOGICAL expression", &code->expr->where);
6200 if (t == SUCCESS && code->expr != NULL
6201 && code->expr->ts.type != BT_INTEGER)
6202 gfc_error ("STAT tag in ALLOCATE statement at %L must be "
6203 "of type INTEGER", &code->expr->where);
6205 for (a = code->ext.alloc_list; a; a = a->next)
6206 resolve_allocate_expr (a->expr, code);
6210 case EXEC_DEALLOCATE:
6211 if (t == SUCCESS && code->expr != NULL
6212 && code->expr->ts.type != BT_INTEGER)
6214 ("STAT tag in DEALLOCATE statement at %L must be of type "
6215 "INTEGER", &code->expr->where);
6217 for (a = code->ext.alloc_list; a; a = a->next)
6218 resolve_deallocate_expr (a->expr);
6223 if (gfc_resolve_open (code->ext.open) == FAILURE)
6226 resolve_branch (code->ext.open->err, code);
6230 if (gfc_resolve_close (code->ext.close) == FAILURE)
6233 resolve_branch (code->ext.close->err, code);
6236 case EXEC_BACKSPACE:
6240 if (gfc_resolve_filepos (code->ext.filepos) == FAILURE)
6243 resolve_branch (code->ext.filepos->err, code);
6247 if (gfc_resolve_inquire (code->ext.inquire) == FAILURE)
6250 resolve_branch (code->ext.inquire->err, code);
6254 gcc_assert (code->ext.inquire != NULL);
6255 if (gfc_resolve_inquire (code->ext.inquire) == FAILURE)
6258 resolve_branch (code->ext.inquire->err, code);
6263 if (gfc_resolve_dt (code->ext.dt) == FAILURE)
6266 resolve_branch (code->ext.dt->err, code);
6267 resolve_branch (code->ext.dt->end, code);
6268 resolve_branch (code->ext.dt->eor, code);
6272 resolve_transfer (code);
6276 resolve_forall_iterators (code->ext.forall_iterator);
6278 if (code->expr != NULL && code->expr->ts.type != BT_LOGICAL)
6279 gfc_error ("FORALL mask clause at %L requires a LOGICAL "
6280 "expression", &code->expr->where);
6283 case EXEC_OMP_ATOMIC:
6284 case EXEC_OMP_BARRIER:
6285 case EXEC_OMP_CRITICAL:
6286 case EXEC_OMP_FLUSH:
6288 case EXEC_OMP_MASTER:
6289 case EXEC_OMP_ORDERED:
6290 case EXEC_OMP_SECTIONS:
6291 case EXEC_OMP_SINGLE:
6292 case EXEC_OMP_WORKSHARE:
6293 gfc_resolve_omp_directive (code, ns);
6296 case EXEC_OMP_PARALLEL:
6297 case EXEC_OMP_PARALLEL_DO:
6298 case EXEC_OMP_PARALLEL_SECTIONS:
6299 case EXEC_OMP_PARALLEL_WORKSHARE:
6300 omp_workshare_save = omp_workshare_flag;
6301 omp_workshare_flag = 0;
6302 gfc_resolve_omp_directive (code, ns);
6303 omp_workshare_flag = omp_workshare_save;
6307 gfc_internal_error ("resolve_code(): Bad statement code");
6311 cs_base = frame.prev;
6315 /* Resolve initial values and make sure they are compatible with
6319 resolve_values (gfc_symbol *sym)
6321 if (sym->value == NULL)
6324 if (gfc_resolve_expr (sym->value) == FAILURE)
6327 gfc_check_assign_symbol (sym, sym->value);
6331 /* Verify the binding labels for common blocks that are BIND(C). The label
6332 for a BIND(C) common block must be identical in all scoping units in which
6333 the common block is declared. Further, the binding label can not collide
6334 with any other global entity in the program. */
6337 resolve_bind_c_comms (gfc_symtree *comm_block_tree)
6339 if (comm_block_tree->n.common->is_bind_c == 1)
6341 gfc_gsymbol *binding_label_gsym;
6342 gfc_gsymbol *comm_name_gsym;
6344 /* See if a global symbol exists by the common block's name. It may
6345 be NULL if the common block is use-associated. */
6346 comm_name_gsym = gfc_find_gsymbol (gfc_gsym_root,
6347 comm_block_tree->n.common->name);
6348 if (comm_name_gsym != NULL && comm_name_gsym->type != GSYM_COMMON)
6349 gfc_error ("Binding label '%s' for common block '%s' at %L collides "
6350 "with the global entity '%s' at %L",
6351 comm_block_tree->n.common->binding_label,
6352 comm_block_tree->n.common->name,
6353 &(comm_block_tree->n.common->where),
6354 comm_name_gsym->name, &(comm_name_gsym->where));
6355 else if (comm_name_gsym != NULL
6356 && strcmp (comm_name_gsym->name,
6357 comm_block_tree->n.common->name) == 0)
6359 /* TODO: Need to make sure the fields of gfc_gsymbol are initialized
6361 if (comm_name_gsym->binding_label == NULL)
6362 /* No binding label for common block stored yet; save this one. */
6363 comm_name_gsym->binding_label =
6364 comm_block_tree->n.common->binding_label;
6366 if (strcmp (comm_name_gsym->binding_label,
6367 comm_block_tree->n.common->binding_label) != 0)
6369 /* Common block names match but binding labels do not. */
6370 gfc_error ("Binding label '%s' for common block '%s' at %L "
6371 "does not match the binding label '%s' for common "
6373 comm_block_tree->n.common->binding_label,
6374 comm_block_tree->n.common->name,
6375 &(comm_block_tree->n.common->where),
6376 comm_name_gsym->binding_label,
6377 comm_name_gsym->name,
6378 &(comm_name_gsym->where));
6383 /* There is no binding label (NAME="") so we have nothing further to
6384 check and nothing to add as a global symbol for the label. */
6385 if (comm_block_tree->n.common->binding_label[0] == '\0' )
6388 binding_label_gsym =
6389 gfc_find_gsymbol (gfc_gsym_root,
6390 comm_block_tree->n.common->binding_label);
6391 if (binding_label_gsym == NULL)
6393 /* Need to make a global symbol for the binding label to prevent
6394 it from colliding with another. */
6395 binding_label_gsym =
6396 gfc_get_gsymbol (comm_block_tree->n.common->binding_label);
6397 binding_label_gsym->sym_name = comm_block_tree->n.common->name;
6398 binding_label_gsym->type = GSYM_COMMON;
6402 /* If comm_name_gsym is NULL, the name common block is use
6403 associated and the name could be colliding. */
6404 if (binding_label_gsym->type != GSYM_COMMON)
6405 gfc_error ("Binding label '%s' for common block '%s' at %L "
6406 "collides with the global entity '%s' at %L",
6407 comm_block_tree->n.common->binding_label,
6408 comm_block_tree->n.common->name,
6409 &(comm_block_tree->n.common->where),
6410 binding_label_gsym->name,
6411 &(binding_label_gsym->where));
6412 else if (comm_name_gsym != NULL
6413 && (strcmp (binding_label_gsym->name,
6414 comm_name_gsym->binding_label) != 0)
6415 && (strcmp (binding_label_gsym->sym_name,
6416 comm_name_gsym->name) != 0))
6417 gfc_error ("Binding label '%s' for common block '%s' at %L "
6418 "collides with global entity '%s' at %L",
6419 binding_label_gsym->name, binding_label_gsym->sym_name,
6420 &(comm_block_tree->n.common->where),
6421 comm_name_gsym->name, &(comm_name_gsym->where));
6429 /* Verify any BIND(C) derived types in the namespace so we can report errors
6430 for them once, rather than for each variable declared of that type. */
6433 resolve_bind_c_derived_types (gfc_symbol *derived_sym)
6435 if (derived_sym != NULL && derived_sym->attr.flavor == FL_DERIVED
6436 && derived_sym->attr.is_bind_c == 1)
6437 verify_bind_c_derived_type (derived_sym);
6443 /* Verify that any binding labels used in a given namespace do not collide
6444 with the names or binding labels of any global symbols. */
6447 gfc_verify_binding_labels (gfc_symbol *sym)
6451 if (sym != NULL && sym->attr.is_bind_c && sym->attr.is_iso_c == 0
6452 && sym->attr.flavor != FL_DERIVED && sym->binding_label[0] != '\0')
6454 gfc_gsymbol *bind_c_sym;
6456 bind_c_sym = gfc_find_gsymbol (gfc_gsym_root, sym->binding_label);
6457 if (bind_c_sym != NULL
6458 && strcmp (bind_c_sym->name, sym->binding_label) == 0)
6460 if (sym->attr.if_source == IFSRC_DECL
6461 && (bind_c_sym->type != GSYM_SUBROUTINE
6462 && bind_c_sym->type != GSYM_FUNCTION)
6463 && ((sym->attr.contained == 1
6464 && strcmp (bind_c_sym->sym_name, sym->name) != 0)
6465 || (sym->attr.use_assoc == 1
6466 && (strcmp (bind_c_sym->mod_name, sym->module) != 0))))
6468 /* Make sure global procedures don't collide with anything. */
6469 gfc_error ("Binding label '%s' at %L collides with the global "
6470 "entity '%s' at %L", sym->binding_label,
6471 &(sym->declared_at), bind_c_sym->name,
6472 &(bind_c_sym->where));
6475 else if (sym->attr.contained == 0
6476 && (sym->attr.if_source == IFSRC_IFBODY
6477 && sym->attr.flavor == FL_PROCEDURE)
6478 && (bind_c_sym->sym_name != NULL
6479 && strcmp (bind_c_sym->sym_name, sym->name) != 0))
6481 /* Make sure procedures in interface bodies don't collide. */
6482 gfc_error ("Binding label '%s' in interface body at %L collides "
6483 "with the global entity '%s' at %L",
6485 &(sym->declared_at), bind_c_sym->name,
6486 &(bind_c_sym->where));
6489 else if (sym->attr.contained == 0
6490 && (sym->attr.if_source == IFSRC_UNKNOWN))
6491 if ((sym->attr.use_assoc
6492 && (strcmp (bind_c_sym->mod_name, sym->module) != 0))
6493 || sym->attr.use_assoc == 0)
6495 gfc_error ("Binding label '%s' at %L collides with global "
6496 "entity '%s' at %L", sym->binding_label,
6497 &(sym->declared_at), bind_c_sym->name,
6498 &(bind_c_sym->where));
6503 /* Clear the binding label to prevent checking multiple times. */
6504 sym->binding_label[0] = '\0';
6506 else if (bind_c_sym == NULL)
6508 bind_c_sym = gfc_get_gsymbol (sym->binding_label);
6509 bind_c_sym->where = sym->declared_at;
6510 bind_c_sym->sym_name = sym->name;
6512 if (sym->attr.use_assoc == 1)
6513 bind_c_sym->mod_name = sym->module;
6515 if (sym->ns->proc_name != NULL)
6516 bind_c_sym->mod_name = sym->ns->proc_name->name;
6518 if (sym->attr.contained == 0)
6520 if (sym->attr.subroutine)
6521 bind_c_sym->type = GSYM_SUBROUTINE;
6522 else if (sym->attr.function)
6523 bind_c_sym->type = GSYM_FUNCTION;
6531 /* Resolve an index expression. */
6534 resolve_index_expr (gfc_expr *e)
6536 if (gfc_resolve_expr (e) == FAILURE)
6539 if (gfc_simplify_expr (e, 0) == FAILURE)
6542 if (gfc_specification_expr (e) == FAILURE)
6548 /* Resolve a charlen structure. */
6551 resolve_charlen (gfc_charlen *cl)
6560 specification_expr = 1;
6562 if (resolve_index_expr (cl->length) == FAILURE)
6564 specification_expr = 0;
6568 /* "If the character length parameter value evaluates to a negative
6569 value, the length of character entities declared is zero." */
6570 if (cl->length && !gfc_extract_int (cl->length, &i) && i < 0)
6572 gfc_warning_now ("CHARACTER variable has zero length at %L",
6573 &cl->length->where);
6574 gfc_replace_expr (cl->length, gfc_int_expr (0));
6581 /* Test for non-constant shape arrays. */
6584 is_non_constant_shape_array (gfc_symbol *sym)
6590 not_constant = false;
6591 if (sym->as != NULL)
6593 /* Unfortunately, !gfc_is_compile_time_shape hits a legal case that
6594 has not been simplified; parameter array references. Do the
6595 simplification now. */
6596 for (i = 0; i < sym->as->rank; i++)
6598 e = sym->as->lower[i];
6599 if (e && (resolve_index_expr (e) == FAILURE
6600 || !gfc_is_constant_expr (e)))
6601 not_constant = true;
6603 e = sym->as->upper[i];
6604 if (e && (resolve_index_expr (e) == FAILURE
6605 || !gfc_is_constant_expr (e)))
6606 not_constant = true;
6609 return not_constant;
6612 /* Given a symbol and an initialization expression, add code to initialize
6613 the symbol to the function entry. */
6615 build_init_assign (gfc_symbol *sym, gfc_expr *init)
6619 gfc_namespace *ns = sym->ns;
6621 /* Search for the function namespace if this is a contained
6622 function without an explicit result. */
6623 if (sym->attr.function && sym == sym->result
6624 && sym->name != sym->ns->proc_name->name)
6627 for (;ns; ns = ns->sibling)
6628 if (strcmp (ns->proc_name->name, sym->name) == 0)
6634 gfc_free_expr (init);
6638 /* Build an l-value expression for the result. */
6639 lval = gfc_lval_expr_from_sym (sym);
6641 /* Add the code at scope entry. */
6642 init_st = gfc_get_code ();
6643 init_st->next = ns->code;
6646 /* Assign the default initializer to the l-value. */
6647 init_st->loc = sym->declared_at;
6648 init_st->op = EXEC_INIT_ASSIGN;
6649 init_st->expr = lval;
6650 init_st->expr2 = init;
6653 /* Assign the default initializer to a derived type variable or result. */
6656 apply_default_init (gfc_symbol *sym)
6658 gfc_expr *init = NULL;
6660 if (sym->attr.flavor != FL_VARIABLE && !sym->attr.function)
6663 if (sym->ts.type == BT_DERIVED && sym->ts.derived)
6664 init = gfc_default_initializer (&sym->ts);
6669 build_init_assign (sym, init);
6672 /* Build an initializer for a local integer, real, complex, logical, or
6673 character variable, based on the command line flags finit-local-zero,
6674 finit-integer=, finit-real=, finit-logical=, and finit-runtime. Returns
6675 null if the symbol should not have a default initialization. */
6677 build_default_init_expr (gfc_symbol *sym)
6680 gfc_expr *init_expr;
6684 /* These symbols should never have a default initialization. */
6685 if ((sym->attr.dimension && !gfc_is_compile_time_shape (sym->as))
6686 || sym->attr.external
6688 || sym->attr.pointer
6689 || sym->attr.in_equivalence
6690 || sym->attr.in_common
6693 || sym->attr.cray_pointee
6694 || sym->attr.cray_pointer)
6697 /* Now we'll try to build an initializer expression. */
6698 init_expr = gfc_get_expr ();
6699 init_expr->expr_type = EXPR_CONSTANT;
6700 init_expr->ts.type = sym->ts.type;
6701 init_expr->ts.kind = sym->ts.kind;
6702 init_expr->where = sym->declared_at;
6704 /* We will only initialize integers, reals, complex, logicals, and
6705 characters, and only if the corresponding command-line flags
6706 were set. Otherwise, we free init_expr and return null. */
6707 switch (sym->ts.type)
6710 if (gfc_option.flag_init_integer != GFC_INIT_INTEGER_OFF)
6711 mpz_init_set_si (init_expr->value.integer,
6712 gfc_option.flag_init_integer_value);
6715 gfc_free_expr (init_expr);
6721 mpfr_init (init_expr->value.real);
6722 switch (gfc_option.flag_init_real)
6724 case GFC_INIT_REAL_NAN:
6725 mpfr_set_nan (init_expr->value.real);
6728 case GFC_INIT_REAL_INF:
6729 mpfr_set_inf (init_expr->value.real, 1);
6732 case GFC_INIT_REAL_NEG_INF:
6733 mpfr_set_inf (init_expr->value.real, -1);
6736 case GFC_INIT_REAL_ZERO:
6737 mpfr_set_ui (init_expr->value.real, 0.0, GFC_RND_MODE);
6741 gfc_free_expr (init_expr);
6748 mpfr_init (init_expr->value.complex.r);
6749 mpfr_init (init_expr->value.complex.i);
6750 switch (gfc_option.flag_init_real)
6752 case GFC_INIT_REAL_NAN:
6753 mpfr_set_nan (init_expr->value.complex.r);
6754 mpfr_set_nan (init_expr->value.complex.i);
6757 case GFC_INIT_REAL_INF:
6758 mpfr_set_inf (init_expr->value.complex.r, 1);
6759 mpfr_set_inf (init_expr->value.complex.i, 1);
6762 case GFC_INIT_REAL_NEG_INF:
6763 mpfr_set_inf (init_expr->value.complex.r, -1);
6764 mpfr_set_inf (init_expr->value.complex.i, -1);
6767 case GFC_INIT_REAL_ZERO:
6768 mpfr_set_ui (init_expr->value.complex.r, 0.0, GFC_RND_MODE);
6769 mpfr_set_ui (init_expr->value.complex.i, 0.0, GFC_RND_MODE);
6773 gfc_free_expr (init_expr);
6780 if (gfc_option.flag_init_logical == GFC_INIT_LOGICAL_FALSE)
6781 init_expr->value.logical = 0;
6782 else if (gfc_option.flag_init_logical == GFC_INIT_LOGICAL_TRUE)
6783 init_expr->value.logical = 1;
6786 gfc_free_expr (init_expr);
6792 /* For characters, the length must be constant in order to
6793 create a default initializer. */
6794 if (gfc_option.flag_init_character == GFC_INIT_CHARACTER_ON
6795 && sym->ts.cl->length
6796 && sym->ts.cl->length->expr_type == EXPR_CONSTANT)
6798 char_len = mpz_get_si (sym->ts.cl->length->value.integer);
6799 init_expr->value.character.length = char_len;
6800 init_expr->value.character.string = gfc_getmem (char_len+1);
6801 ch = init_expr->value.character.string;
6802 for (i = 0; i < char_len; i++)
6803 *(ch++) = gfc_option.flag_init_character_value;
6807 gfc_free_expr (init_expr);
6813 gfc_free_expr (init_expr);
6819 /* Add an initialization expression to a local variable. */
6821 apply_default_init_local (gfc_symbol *sym)
6823 gfc_expr *init = NULL;
6825 /* The symbol should be a variable or a function return value. */
6826 if ((sym->attr.flavor != FL_VARIABLE && !sym->attr.function)
6827 || (sym->attr.function && sym->result != sym))
6830 /* Try to build the initializer expression. If we can't initialize
6831 this symbol, then init will be NULL. */
6832 init = build_default_init_expr (sym);
6836 /* For saved variables, we don't want to add an initializer at
6837 function entry, so we just add a static initializer. */
6838 if (sym->attr.save || sym->ns->save_all)
6840 /* Don't clobber an existing initializer! */
6841 gcc_assert (sym->value == NULL);
6846 build_init_assign (sym, init);
6849 /* Resolution of common features of flavors variable and procedure. */
6852 resolve_fl_var_and_proc (gfc_symbol *sym, int mp_flag)
6854 /* Constraints on deferred shape variable. */
6855 if (sym->as == NULL || sym->as->type != AS_DEFERRED)
6857 if (sym->attr.allocatable)
6859 if (sym->attr.dimension)
6860 gfc_error ("Allocatable array '%s' at %L must have "
6861 "a deferred shape", sym->name, &sym->declared_at);
6863 gfc_error ("Scalar object '%s' at %L may not be ALLOCATABLE",
6864 sym->name, &sym->declared_at);
6868 if (sym->attr.pointer && sym->attr.dimension)
6870 gfc_error ("Array pointer '%s' at %L must have a deferred shape",
6871 sym->name, &sym->declared_at);
6878 if (!mp_flag && !sym->attr.allocatable
6879 && !sym->attr.pointer && !sym->attr.dummy)
6881 gfc_error ("Array '%s' at %L cannot have a deferred shape",
6882 sym->name, &sym->declared_at);
6890 /* Additional checks for symbols with flavor variable and derived
6891 type. To be called from resolve_fl_variable. */
6894 resolve_fl_variable_derived (gfc_symbol *sym, int flag)
6896 gcc_assert (sym->ts.type == BT_DERIVED);
6898 /* Check to see if a derived type is blocked from being host
6899 associated by the presence of another class I symbol in the same
6900 namespace. 14.6.1.3 of the standard and the discussion on
6901 comp.lang.fortran. */
6902 if (sym->ns != sym->ts.derived->ns
6903 && sym->ns->proc_name->attr.if_source != IFSRC_IFBODY)
6906 gfc_find_symbol (sym->ts.derived->name, sym->ns, 0, &s);
6907 if (s && (s->attr.flavor != FL_DERIVED
6908 || !gfc_compare_derived_types (s, sym->ts.derived)))
6910 gfc_error ("The type '%s' cannot be host associated at %L "
6911 "because it is blocked by an incompatible object "
6912 "of the same name declared at %L",
6913 sym->ts.derived->name, &sym->declared_at,
6919 /* 4th constraint in section 11.3: "If an object of a type for which
6920 component-initialization is specified (R429) appears in the
6921 specification-part of a module and does not have the ALLOCATABLE
6922 or POINTER attribute, the object shall have the SAVE attribute."
6924 The check for initializers is performed with
6925 has_default_initializer because gfc_default_initializer generates
6926 a hidden default for allocatable components. */
6927 if (!(sym->value || flag) && sym->ns->proc_name
6928 && sym->ns->proc_name->attr.flavor == FL_MODULE
6929 && !sym->ns->save_all && !sym->attr.save
6930 && !sym->attr.pointer && !sym->attr.allocatable
6931 && has_default_initializer (sym->ts.derived))
6933 gfc_error("Object '%s' at %L must have the SAVE attribute for "
6934 "default initialization of a component",
6935 sym->name, &sym->declared_at);
6939 /* Assign default initializer. */
6940 if (!(sym->value || sym->attr.pointer || sym->attr.allocatable)
6941 && (!flag || sym->attr.intent == INTENT_OUT))
6943 sym->value = gfc_default_initializer (&sym->ts);
6950 /* Resolve symbols with flavor variable. */
6953 resolve_fl_variable (gfc_symbol *sym, int mp_flag)
6958 const char *auto_save_msg;
6960 auto_save_msg = "automatic object '%s' at %L cannot have the "
6963 if (resolve_fl_var_and_proc (sym, mp_flag) == FAILURE)
6966 /* Set this flag to check that variables are parameters of all entries.
6967 This check is effected by the call to gfc_resolve_expr through
6968 is_non_constant_shape_array. */
6969 specification_expr = 1;
6971 if (!sym->attr.use_assoc
6972 && !sym->attr.allocatable
6973 && !sym->attr.pointer
6974 && is_non_constant_shape_array (sym))
6976 /* The shape of a main program or module array needs to be
6978 if (sym->ns->proc_name
6979 && (sym->ns->proc_name->attr.flavor == FL_MODULE
6980 || sym->ns->proc_name->attr.is_main_program))
6982 gfc_error ("The module or main program array '%s' at %L must "
6983 "have constant shape", sym->name, &sym->declared_at);
6984 specification_expr = 0;
6989 if (sym->ts.type == BT_CHARACTER)
6991 /* Make sure that character string variables with assumed length are
6993 e = sym->ts.cl->length;
6994 if (e == NULL && !sym->attr.dummy && !sym->attr.result)
6996 gfc_error ("Entity with assumed character length at %L must be a "
6997 "dummy argument or a PARAMETER", &sym->declared_at);
7001 if (e && sym->attr.save && !gfc_is_constant_expr (e))
7003 gfc_error (auto_save_msg, sym->name, &sym->declared_at);
7007 if (!gfc_is_constant_expr (e)
7008 && !(e->expr_type == EXPR_VARIABLE
7009 && e->symtree->n.sym->attr.flavor == FL_PARAMETER)
7010 && 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)
7015 gfc_error ("'%s' at %L must have constant character length "
7016 "in this context", sym->name, &sym->declared_at);
7021 if (sym->value == NULL && sym->attr.referenced)
7022 apply_default_init_local (sym); /* Try to apply a default initialization. */
7024 /* Can the symbol have an initializer? */
7026 if (sym->attr.allocatable || sym->attr.external || sym->attr.dummy
7027 || sym->attr.intrinsic || sym->attr.result)
7029 else if (sym->attr.dimension && !sym->attr.pointer)
7031 /* Don't allow initialization of automatic arrays. */
7032 for (i = 0; i < sym->as->rank; i++)
7034 if (sym->as->lower[i] == NULL
7035 || sym->as->lower[i]->expr_type != EXPR_CONSTANT
7036 || sym->as->upper[i] == NULL
7037 || sym->as->upper[i]->expr_type != EXPR_CONSTANT)
7044 /* Also, they must not have the SAVE attribute.
7045 SAVE_IMPLICIT is checked below. */
7046 if (flag && sym->attr.save == SAVE_EXPLICIT)
7048 gfc_error (auto_save_msg, sym->name, &sym->declared_at);
7053 /* Reject illegal initializers. */
7054 if (!sym->mark && sym->value && flag)
7056 if (sym->attr.allocatable)
7057 gfc_error ("Allocatable '%s' at %L cannot have an initializer",
7058 sym->name, &sym->declared_at);
7059 else if (sym->attr.external)
7060 gfc_error ("External '%s' at %L cannot have an initializer",
7061 sym->name, &sym->declared_at);
7062 else if (sym->attr.dummy
7063 && !(sym->ts.type == BT_DERIVED && sym->attr.intent == INTENT_OUT))
7064 gfc_error ("Dummy '%s' at %L cannot have an initializer",
7065 sym->name, &sym->declared_at);
7066 else if (sym->attr.intrinsic)
7067 gfc_error ("Intrinsic '%s' at %L cannot have an initializer",
7068 sym->name, &sym->declared_at);
7069 else if (sym->attr.result)
7070 gfc_error ("Function result '%s' at %L cannot have an initializer",
7071 sym->name, &sym->declared_at);
7073 gfc_error ("Automatic array '%s' at %L cannot have an initializer",
7074 sym->name, &sym->declared_at);
7081 if (sym->ts.type == BT_DERIVED)
7082 return resolve_fl_variable_derived (sym, flag);
7088 /* Resolve a procedure. */
7091 resolve_fl_procedure (gfc_symbol *sym, int mp_flag)
7093 gfc_formal_arglist *arg;
7095 if (sym->attr.ambiguous_interfaces && !sym->attr.referenced)
7096 gfc_warning ("Although not referenced, '%s' at %L has ambiguous "
7097 "interfaces", sym->name, &sym->declared_at);
7099 if (sym->attr.function
7100 && resolve_fl_var_and_proc (sym, mp_flag) == FAILURE)
7103 if (sym->ts.type == BT_CHARACTER)
7105 gfc_charlen *cl = sym->ts.cl;
7107 if (cl && cl->length && gfc_is_constant_expr (cl->length)
7108 && resolve_charlen (cl) == FAILURE)
7111 if (!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT)
7113 if (sym->attr.proc == PROC_ST_FUNCTION)
7115 gfc_error ("Character-valued statement function '%s' at %L must "
7116 "have constant length", sym->name, &sym->declared_at);
7120 if (sym->attr.external && sym->formal == NULL
7121 && cl && cl->length && cl->length->expr_type != EXPR_CONSTANT)
7123 gfc_error ("Automatic character length function '%s' at %L must "
7124 "have an explicit interface", sym->name,
7131 /* Ensure that derived type for are not of a private type. Internal
7132 module procedures are excluded by 2.2.3.3 - ie. they are not
7133 externally accessible and can access all the objects accessible in
7135 if (!(sym->ns->parent
7136 && sym->ns->parent->proc_name->attr.flavor == FL_MODULE)
7137 && gfc_check_access(sym->attr.access, sym->ns->default_access))
7139 gfc_interface *iface;
7141 for (arg = sym->formal; arg; arg = arg->next)
7144 && arg->sym->ts.type == BT_DERIVED
7145 && !arg->sym->ts.derived->attr.use_assoc
7146 && !gfc_check_access (arg->sym->ts.derived->attr.access,
7147 arg->sym->ts.derived->ns->default_access)
7148 && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: '%s' is of a "
7149 "PRIVATE type and cannot be a dummy argument"
7150 " of '%s', which is PUBLIC at %L",
7151 arg->sym->name, sym->name, &sym->declared_at)
7154 /* Stop this message from recurring. */
7155 arg->sym->ts.derived->attr.access = ACCESS_PUBLIC;
7160 /* PUBLIC interfaces may expose PRIVATE procedures that take types
7161 PRIVATE to the containing module. */
7162 for (iface = sym->generic; iface; iface = iface->next)
7164 for (arg = iface->sym->formal; arg; arg = arg->next)
7167 && arg->sym->ts.type == BT_DERIVED
7168 && !arg->sym->ts.derived->attr.use_assoc
7169 && !gfc_check_access (arg->sym->ts.derived->attr.access,
7170 arg->sym->ts.derived->ns->default_access)
7171 && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Procedure "
7172 "'%s' in PUBLIC interface '%s' at %L "
7173 "takes dummy arguments of '%s' which is "
7174 "PRIVATE", iface->sym->name, sym->name,
7175 &iface->sym->declared_at,
7176 gfc_typename (&arg->sym->ts)) == FAILURE)
7178 /* Stop this message from recurring. */
7179 arg->sym->ts.derived->attr.access = ACCESS_PUBLIC;
7185 /* PUBLIC interfaces may expose PRIVATE procedures that take types
7186 PRIVATE to the containing module. */
7187 for (iface = sym->generic; iface; iface = iface->next)
7189 for (arg = iface->sym->formal; arg; arg = arg->next)
7192 && arg->sym->ts.type == BT_DERIVED
7193 && !arg->sym->ts.derived->attr.use_assoc
7194 && !gfc_check_access (arg->sym->ts.derived->attr.access,
7195 arg->sym->ts.derived->ns->default_access)
7196 && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Procedure "
7197 "'%s' in PUBLIC interface '%s' at %L "
7198 "takes dummy arguments of '%s' which is "
7199 "PRIVATE", iface->sym->name, sym->name,
7200 &iface->sym->declared_at,
7201 gfc_typename (&arg->sym->ts)) == FAILURE)
7203 /* Stop this message from recurring. */
7204 arg->sym->ts.derived->attr.access = ACCESS_PUBLIC;
7211 if (sym->attr.function && sym->value && sym->attr.proc != PROC_ST_FUNCTION)
7213 gfc_error ("Function '%s' at %L cannot have an initializer",
7214 sym->name, &sym->declared_at);
7218 /* An external symbol may not have an initializer because it is taken to be
7220 if (sym->attr.external && sym->value)
7222 gfc_error ("External object '%s' at %L may not have an initializer",
7223 sym->name, &sym->declared_at);
7227 /* An elemental function is required to return a scalar 12.7.1 */
7228 if (sym->attr.elemental && sym->attr.function && sym->as)
7230 gfc_error ("ELEMENTAL function '%s' at %L must have a scalar "
7231 "result", sym->name, &sym->declared_at);
7232 /* Reset so that the error only occurs once. */
7233 sym->attr.elemental = 0;
7237 /* 5.1.1.5 of the Standard: A function name declared with an asterisk
7238 char-len-param shall not be array-valued, pointer-valued, recursive
7239 or pure. ....snip... A character value of * may only be used in the
7240 following ways: (i) Dummy arg of procedure - dummy associates with
7241 actual length; (ii) To declare a named constant; or (iii) External
7242 function - but length must be declared in calling scoping unit. */
7243 if (sym->attr.function
7244 && sym->ts.type == BT_CHARACTER
7245 && sym->ts.cl && sym->ts.cl->length == NULL)
7247 if ((sym->as && sym->as->rank) || (sym->attr.pointer)
7248 || (sym->attr.recursive) || (sym->attr.pure))
7250 if (sym->as && sym->as->rank)
7251 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
7252 "array-valued", sym->name, &sym->declared_at);
7254 if (sym->attr.pointer)
7255 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
7256 "pointer-valued", sym->name, &sym->declared_at);
7259 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
7260 "pure", sym->name, &sym->declared_at);
7262 if (sym->attr.recursive)
7263 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
7264 "recursive", sym->name, &sym->declared_at);
7269 /* Appendix B.2 of the standard. Contained functions give an
7270 error anyway. Fixed-form is likely to be F77/legacy. */
7271 if (!sym->attr.contained && gfc_current_form != FORM_FIXED)
7272 gfc_notify_std (GFC_STD_F95_OBS, "CHARACTER(*) function "
7273 "'%s' at %L is obsolescent in fortran 95",
7274 sym->name, &sym->declared_at);
7277 if (sym->attr.is_bind_c && sym->attr.is_c_interop != 1)
7279 gfc_formal_arglist *curr_arg;
7280 int has_non_interop_arg = 0;
7282 if (verify_bind_c_sym (sym, &(sym->ts), sym->attr.in_common,
7283 sym->common_block) == FAILURE)
7285 /* Clear these to prevent looking at them again if there was an
7287 sym->attr.is_bind_c = 0;
7288 sym->attr.is_c_interop = 0;
7289 sym->ts.is_c_interop = 0;
7293 /* So far, no errors have been found. */
7294 sym->attr.is_c_interop = 1;
7295 sym->ts.is_c_interop = 1;
7298 curr_arg = sym->formal;
7299 while (curr_arg != NULL)
7301 /* Skip implicitly typed dummy args here. */
7302 if (curr_arg->sym->attr.implicit_type == 0)
7303 if (verify_c_interop_param (curr_arg->sym) == FAILURE)
7304 /* If something is found to fail, record the fact so we
7305 can mark the symbol for the procedure as not being
7306 BIND(C) to try and prevent multiple errors being
7308 has_non_interop_arg = 1;
7310 curr_arg = curr_arg->next;
7313 /* See if any of the arguments were not interoperable and if so, clear
7314 the procedure symbol to prevent duplicate error messages. */
7315 if (has_non_interop_arg != 0)
7317 sym->attr.is_c_interop = 0;
7318 sym->ts.is_c_interop = 0;
7319 sym->attr.is_bind_c = 0;
7327 /* Resolve the components of a derived type. */
7330 resolve_fl_derived (gfc_symbol *sym)
7333 gfc_dt_list * dt_list;
7336 for (c = sym->components; c != NULL; c = c->next)
7338 if (c->ts.type == BT_CHARACTER)
7340 if (c->ts.cl->length == NULL
7341 || (resolve_charlen (c->ts.cl) == FAILURE)
7342 || !gfc_is_constant_expr (c->ts.cl->length))
7344 gfc_error ("Character length of component '%s' needs to "
7345 "be a constant specification expression at %L",
7347 c->ts.cl->length ? &c->ts.cl->length->where : &c->loc);
7352 if (c->ts.type == BT_DERIVED
7353 && sym->component_access != ACCESS_PRIVATE
7354 && gfc_check_access (sym->attr.access, sym->ns->default_access)
7355 && !c->ts.derived->attr.use_assoc
7356 && !gfc_check_access (c->ts.derived->attr.access,
7357 c->ts.derived->ns->default_access))
7359 gfc_error ("The component '%s' is a PRIVATE type and cannot be "
7360 "a component of '%s', which is PUBLIC at %L",
7361 c->name, sym->name, &sym->declared_at);
7365 if (sym->attr.sequence)
7367 if (c->ts.type == BT_DERIVED && c->ts.derived->attr.sequence == 0)
7369 gfc_error ("Component %s of SEQUENCE type declared at %L does "
7370 "not have the SEQUENCE attribute",
7371 c->ts.derived->name, &sym->declared_at);
7376 if (c->ts.type == BT_DERIVED && c->pointer
7377 && c->ts.derived->components == NULL)
7379 gfc_error ("The pointer component '%s' of '%s' at %L is a type "
7380 "that has not been declared", c->name, sym->name,
7385 if (c->pointer || c->allocatable || c->as == NULL)
7388 for (i = 0; i < c->as->rank; i++)
7390 if (c->as->lower[i] == NULL
7391 || !gfc_is_constant_expr (c->as->lower[i])
7392 || (resolve_index_expr (c->as->lower[i]) == FAILURE)
7393 || c->as->upper[i] == NULL
7394 || (resolve_index_expr (c->as->upper[i]) == FAILURE)
7395 || !gfc_is_constant_expr (c->as->upper[i]))
7397 gfc_error ("Component '%s' of '%s' at %L must have "
7398 "constant array bounds",
7399 c->name, sym->name, &c->loc);
7405 /* Add derived type to the derived type list. */
7406 for (dt_list = gfc_derived_types; dt_list; dt_list = dt_list->next)
7407 if (sym == dt_list->derived)
7410 if (dt_list == NULL)
7412 dt_list = gfc_get_dt_list ();
7413 dt_list->next = gfc_derived_types;
7414 dt_list->derived = sym;
7415 gfc_derived_types = dt_list;
7423 resolve_fl_namelist (gfc_symbol *sym)
7428 /* Reject PRIVATE objects in a PUBLIC namelist. */
7429 if (gfc_check_access(sym->attr.access, sym->ns->default_access))
7431 for (nl = sym->namelist; nl; nl = nl->next)
7433 if (!nl->sym->attr.use_assoc
7434 && !(sym->ns->parent == nl->sym->ns)
7435 && !(sym->ns->parent
7436 && sym->ns->parent->parent == nl->sym->ns)
7437 && !gfc_check_access(nl->sym->attr.access,
7438 nl->sym->ns->default_access))
7440 gfc_error ("NAMELIST object '%s' was declared PRIVATE and "
7441 "cannot be member of PUBLIC namelist '%s' at %L",
7442 nl->sym->name, sym->name, &sym->declared_at);
7446 /* Types with private components that came here by USE-association. */
7447 if (nl->sym->ts.type == BT_DERIVED
7448 && derived_inaccessible (nl->sym->ts.derived))
7450 gfc_error ("NAMELIST object '%s' has use-associated PRIVATE "
7451 "components and cannot be member of namelist '%s' at %L",
7452 nl->sym->name, sym->name, &sym->declared_at);
7456 /* Types with private components that are defined in the same module. */
7457 if (nl->sym->ts.type == BT_DERIVED
7458 && !(sym->ns->parent == nl->sym->ts.derived->ns)
7459 && !gfc_check_access (nl->sym->ts.derived->attr.private_comp
7460 ? ACCESS_PRIVATE : ACCESS_UNKNOWN,
7461 nl->sym->ns->default_access))
7463 gfc_error ("NAMELIST object '%s' has PRIVATE components and "
7464 "cannot be a member of PUBLIC namelist '%s' at %L",
7465 nl->sym->name, sym->name, &sym->declared_at);
7471 for (nl = sym->namelist; nl; nl = nl->next)
7473 /* Reject namelist arrays of assumed shape. */
7474 if (nl->sym->as && nl->sym->as->type == AS_ASSUMED_SHAPE
7475 && gfc_notify_std (GFC_STD_F2003, "NAMELIST array object '%s' "
7476 "must not have assumed shape in namelist "
7477 "'%s' at %L", nl->sym->name, sym->name,
7478 &sym->declared_at) == FAILURE)
7481 /* Reject namelist arrays that are not constant shape. */
7482 if (is_non_constant_shape_array (nl->sym))
7484 gfc_error ("NAMELIST array object '%s' must have constant "
7485 "shape in namelist '%s' at %L", nl->sym->name,
7486 sym->name, &sym->declared_at);
7490 /* Namelist objects cannot have allocatable or pointer components. */
7491 if (nl->sym->ts.type != BT_DERIVED)
7494 if (nl->sym->ts.derived->attr.alloc_comp)
7496 gfc_error ("NAMELIST object '%s' in namelist '%s' at %L cannot "
7497 "have ALLOCATABLE components",
7498 nl->sym->name, sym->name, &sym->declared_at);
7502 if (nl->sym->ts.derived->attr.pointer_comp)
7504 gfc_error ("NAMELIST object '%s' in namelist '%s' at %L cannot "
7505 "have POINTER components",
7506 nl->sym->name, sym->name, &sym->declared_at);
7512 /* 14.1.2 A module or internal procedure represent local entities
7513 of the same type as a namelist member and so are not allowed. */
7514 for (nl = sym->namelist; nl; nl = nl->next)
7516 if (nl->sym->ts.kind != 0 && nl->sym->attr.flavor == FL_VARIABLE)
7519 if (nl->sym->attr.function && nl->sym == nl->sym->result)
7520 if ((nl->sym == sym->ns->proc_name)
7522 (sym->ns->parent && nl->sym == sym->ns->parent->proc_name))
7526 if (nl->sym && nl->sym->name)
7527 gfc_find_symbol (nl->sym->name, sym->ns, 1, &nlsym);
7528 if (nlsym && nlsym->attr.flavor == FL_PROCEDURE)
7530 gfc_error ("PROCEDURE attribute conflicts with NAMELIST "
7531 "attribute in '%s' at %L", nlsym->name,
7542 resolve_fl_parameter (gfc_symbol *sym)
7544 /* A parameter array's shape needs to be constant. */
7546 && (sym->as->type == AS_DEFERRED
7547 || is_non_constant_shape_array (sym)))
7549 gfc_error ("Parameter array '%s' at %L cannot be automatic "
7550 "or of deferred shape", sym->name, &sym->declared_at);
7554 /* Make sure a parameter that has been implicitly typed still
7555 matches the implicit type, since PARAMETER statements can precede
7556 IMPLICIT statements. */
7557 if (sym->attr.implicit_type
7558 && !gfc_compare_types (&sym->ts, gfc_get_default_type (sym, sym->ns)))
7560 gfc_error ("Implicitly typed PARAMETER '%s' at %L doesn't match a "
7561 "later IMPLICIT type", sym->name, &sym->declared_at);
7565 /* Make sure the types of derived parameters are consistent. This
7566 type checking is deferred until resolution because the type may
7567 refer to a derived type from the host. */
7568 if (sym->ts.type == BT_DERIVED
7569 && !gfc_compare_types (&sym->ts, &sym->value->ts))
7571 gfc_error ("Incompatible derived type in PARAMETER at %L",
7572 &sym->value->where);
7579 /* Do anything necessary to resolve a symbol. Right now, we just
7580 assume that an otherwise unknown symbol is a variable. This sort
7581 of thing commonly happens for symbols in module. */
7584 resolve_symbol (gfc_symbol *sym)
7586 int check_constant, mp_flag;
7587 gfc_symtree *symtree;
7588 gfc_symtree *this_symtree;
7592 if (sym->attr.flavor == FL_UNKNOWN)
7595 /* If we find that a flavorless symbol is an interface in one of the
7596 parent namespaces, find its symtree in this namespace, free the
7597 symbol and set the symtree to point to the interface symbol. */
7598 for (ns = gfc_current_ns->parent; ns; ns = ns->parent)
7600 symtree = gfc_find_symtree (ns->sym_root, sym->name);
7601 if (symtree && symtree->n.sym->generic)
7603 this_symtree = gfc_find_symtree (gfc_current_ns->sym_root,
7607 gfc_free_symbol (sym);
7608 symtree->n.sym->refs++;
7609 this_symtree->n.sym = symtree->n.sym;
7614 /* Otherwise give it a flavor according to such attributes as
7616 if (sym->attr.external == 0 && sym->attr.intrinsic == 0)
7617 sym->attr.flavor = FL_VARIABLE;
7620 sym->attr.flavor = FL_PROCEDURE;
7621 if (sym->attr.dimension)
7622 sym->attr.function = 1;
7626 if (sym->attr.procedure && sym->interface
7627 && sym->attr.if_source != IFSRC_DECL)
7629 /* Get the attributes from the interface (now resolved). */
7630 if (sym->interface->attr.if_source || sym->interface->attr.intrinsic)
7632 sym->ts = sym->interface->ts;
7633 sym->attr.function = sym->interface->attr.function;
7634 sym->attr.subroutine = sym->interface->attr.subroutine;
7635 copy_formal_args (sym, sym->interface);
7637 else if (sym->interface->name[0] != '\0')
7639 gfc_error ("Interface '%s' of procedure '%s' at %L must be explicit",
7640 sym->interface->name, sym->name, &sym->declared_at);
7645 if (sym->attr.flavor == FL_DERIVED && resolve_fl_derived (sym) == FAILURE)
7648 /* Symbols that are module procedures with results (functions) have
7649 the types and array specification copied for type checking in
7650 procedures that call them, as well as for saving to a module
7651 file. These symbols can't stand the scrutiny that their results
7653 mp_flag = (sym->result != NULL && sym->result != sym);
7656 /* Make sure that the intrinsic is consistent with its internal
7657 representation. This needs to be done before assigning a default
7658 type to avoid spurious warnings. */
7659 if (sym->attr.flavor != FL_MODULE && sym->attr.intrinsic)
7661 if (gfc_intrinsic_name (sym->name, 0))
7663 if (sym->ts.type != BT_UNKNOWN && gfc_option.warn_surprising)
7664 gfc_warning ("Type specified for intrinsic function '%s' at %L is ignored",
7665 sym->name, &sym->declared_at);
7667 else if (gfc_intrinsic_name (sym->name, 1))
7669 if (sym->ts.type != BT_UNKNOWN)
7671 gfc_error ("Intrinsic subroutine '%s' at %L shall not have a type specifier",
7672 sym->name, &sym->declared_at);
7678 gfc_error ("Intrinsic '%s' at %L does not exist", sym->name, &sym->declared_at);
7683 /* Assign default type to symbols that need one and don't have one. */
7684 if (sym->ts.type == BT_UNKNOWN)
7686 if (sym->attr.flavor == FL_VARIABLE || sym->attr.flavor == FL_PARAMETER)
7687 gfc_set_default_type (sym, 1, NULL);
7689 if (sym->attr.flavor == FL_PROCEDURE && sym->attr.function)
7691 /* The specific case of an external procedure should emit an error
7692 in the case that there is no implicit type. */
7694 gfc_set_default_type (sym, sym->attr.external, NULL);
7697 /* Result may be in another namespace. */
7698 resolve_symbol (sym->result);
7700 sym->ts = sym->result->ts;
7701 sym->as = gfc_copy_array_spec (sym->result->as);
7702 sym->attr.dimension = sym->result->attr.dimension;
7703 sym->attr.pointer = sym->result->attr.pointer;
7704 sym->attr.allocatable = sym->result->attr.allocatable;
7709 /* Assumed size arrays and assumed shape arrays must be dummy
7713 && (sym->as->type == AS_ASSUMED_SIZE
7714 || sym->as->type == AS_ASSUMED_SHAPE)
7715 && sym->attr.dummy == 0)
7717 if (sym->as->type == AS_ASSUMED_SIZE)
7718 gfc_error ("Assumed size array at %L must be a dummy argument",
7721 gfc_error ("Assumed shape array at %L must be a dummy argument",
7726 /* Make sure symbols with known intent or optional are really dummy
7727 variable. Because of ENTRY statement, this has to be deferred
7728 until resolution time. */
7730 if (!sym->attr.dummy
7731 && (sym->attr.optional || sym->attr.intent != INTENT_UNKNOWN))
7733 gfc_error ("Symbol at %L is not a DUMMY variable", &sym->declared_at);
7737 if (sym->attr.value && !sym->attr.dummy)
7739 gfc_error ("'%s' at %L cannot have the VALUE attribute because "
7740 "it is not a dummy argument", sym->name, &sym->declared_at);
7744 if (sym->attr.value && sym->ts.type == BT_CHARACTER)
7746 gfc_charlen *cl = sym->ts.cl;
7747 if (!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT)
7749 gfc_error ("Character dummy variable '%s' at %L with VALUE "
7750 "attribute must have constant length",
7751 sym->name, &sym->declared_at);
7755 if (sym->ts.is_c_interop
7756 && mpz_cmp_si (cl->length->value.integer, 1) != 0)
7758 gfc_error ("C interoperable character dummy variable '%s' at %L "
7759 "with VALUE attribute must have length one",
7760 sym->name, &sym->declared_at);
7765 /* If the symbol is marked as bind(c), verify it's type and kind. Do not
7766 do this for something that was implicitly typed because that is handled
7767 in gfc_set_default_type. Handle dummy arguments and procedure
7768 definitions separately. Also, anything that is use associated is not
7769 handled here but instead is handled in the module it is declared in.
7770 Finally, derived type definitions are allowed to be BIND(C) since that
7771 only implies that they're interoperable, and they are checked fully for
7772 interoperability when a variable is declared of that type. */
7773 if (sym->attr.is_bind_c && sym->attr.implicit_type == 0 &&
7774 sym->attr.use_assoc == 0 && sym->attr.dummy == 0 &&
7775 sym->attr.flavor != FL_PROCEDURE && sym->attr.flavor != FL_DERIVED)
7779 /* First, make sure the variable is declared at the
7780 module-level scope (J3/04-007, Section 15.3). */
7781 if (sym->ns->proc_name->attr.flavor != FL_MODULE &&
7782 sym->attr.in_common == 0)
7784 gfc_error ("Variable '%s' at %L cannot be BIND(C) because it "
7785 "is neither a COMMON block nor declared at the "
7786 "module level scope", sym->name, &(sym->declared_at));
7789 else if (sym->common_head != NULL)
7791 t = verify_com_block_vars_c_interop (sym->common_head);
7795 /* If type() declaration, we need to verify that the components
7796 of the given type are all C interoperable, etc. */
7797 if (sym->ts.type == BT_DERIVED &&
7798 sym->ts.derived->attr.is_c_interop != 1)
7800 /* Make sure the user marked the derived type as BIND(C). If
7801 not, call the verify routine. This could print an error
7802 for the derived type more than once if multiple variables
7803 of that type are declared. */
7804 if (sym->ts.derived->attr.is_bind_c != 1)
7805 verify_bind_c_derived_type (sym->ts.derived);
7809 /* Verify the variable itself as C interoperable if it
7810 is BIND(C). It is not possible for this to succeed if
7811 the verify_bind_c_derived_type failed, so don't have to handle
7812 any error returned by verify_bind_c_derived_type. */
7813 t = verify_bind_c_sym (sym, &(sym->ts), sym->attr.in_common,
7819 /* clear the is_bind_c flag to prevent reporting errors more than
7820 once if something failed. */
7821 sym->attr.is_bind_c = 0;
7826 /* If a derived type symbol has reached this point, without its
7827 type being declared, we have an error. Notice that most
7828 conditions that produce undefined derived types have already
7829 been dealt with. However, the likes of:
7830 implicit type(t) (t) ..... call foo (t) will get us here if
7831 the type is not declared in the scope of the implicit
7832 statement. Change the type to BT_UNKNOWN, both because it is so
7833 and to prevent an ICE. */
7834 if (sym->ts.type == BT_DERIVED && sym->ts.derived->components == NULL
7835 && !sym->ts.derived->attr.zero_comp)
7837 gfc_error ("The derived type '%s' at %L is of type '%s', "
7838 "which has not been defined", sym->name,
7839 &sym->declared_at, sym->ts.derived->name);
7840 sym->ts.type = BT_UNKNOWN;
7844 /* Unless the derived-type declaration is use associated, Fortran 95
7845 does not allow public entries of private derived types.
7846 See 4.4.1 (F95) and 4.5.1.1 (F2003); and related interpretation
7848 if (sym->ts.type == BT_DERIVED
7849 && gfc_check_access (sym->attr.access, sym->ns->default_access)
7850 && !gfc_check_access (sym->ts.derived->attr.access,
7851 sym->ts.derived->ns->default_access)
7852 && !sym->ts.derived->attr.use_assoc
7853 && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: PUBLIC %s '%s' at %L "
7854 "of PRIVATE derived type '%s'",
7855 (sym->attr.flavor == FL_PARAMETER) ? "parameter"
7856 : "variable", sym->name, &sym->declared_at,
7857 sym->ts.derived->name) == FAILURE)
7860 /* An assumed-size array with INTENT(OUT) shall not be of a type for which
7861 default initialization is defined (5.1.2.4.4). */
7862 if (sym->ts.type == BT_DERIVED
7864 && sym->attr.intent == INTENT_OUT
7866 && sym->as->type == AS_ASSUMED_SIZE)
7868 for (c = sym->ts.derived->components; c; c = c->next)
7872 gfc_error ("The INTENT(OUT) dummy argument '%s' at %L is "
7873 "ASSUMED SIZE and so cannot have a default initializer",
7874 sym->name, &sym->declared_at);
7880 switch (sym->attr.flavor)
7883 if (resolve_fl_variable (sym, mp_flag) == FAILURE)
7888 if (resolve_fl_procedure (sym, mp_flag) == FAILURE)
7893 if (resolve_fl_namelist (sym) == FAILURE)
7898 if (resolve_fl_parameter (sym) == FAILURE)
7906 /* Resolve array specifier. Check as well some constraints
7907 on COMMON blocks. */
7909 check_constant = sym->attr.in_common && !sym->attr.pointer;
7911 /* Set the formal_arg_flag so that check_conflict will not throw
7912 an error for host associated variables in the specification
7913 expression for an array_valued function. */
7914 if (sym->attr.function && sym->as)
7915 formal_arg_flag = 1;
7917 gfc_resolve_array_spec (sym->as, check_constant);
7919 formal_arg_flag = 0;
7921 /* Resolve formal namespaces. */
7922 if (sym->formal_ns && sym->formal_ns != gfc_current_ns)
7923 gfc_resolve (sym->formal_ns);
7925 /* Check threadprivate restrictions. */
7926 if (sym->attr.threadprivate && !sym->attr.save && !sym->ns->save_all
7927 && (!sym->attr.in_common
7928 && sym->module == NULL
7929 && (sym->ns->proc_name == NULL
7930 || sym->ns->proc_name->attr.flavor != FL_MODULE)))
7931 gfc_error ("Threadprivate at %L isn't SAVEd", &sym->declared_at);
7933 /* If we have come this far we can apply default-initializers, as
7934 described in 14.7.5, to those variables that have not already
7935 been assigned one. */
7936 if (sym->ts.type == BT_DERIVED
7937 && sym->attr.referenced
7938 && sym->ns == gfc_current_ns
7940 && !sym->attr.allocatable
7941 && !sym->attr.alloc_comp)
7943 symbol_attribute *a = &sym->attr;
7945 if ((!a->save && !a->dummy && !a->pointer
7946 && !a->in_common && !a->use_assoc
7947 && !(a->function && sym != sym->result))
7948 || (a->dummy && a->intent == INTENT_OUT))
7949 apply_default_init (sym);
7954 /************* Resolve DATA statements *************/
7958 gfc_data_value *vnode;
7964 /* Advance the values structure to point to the next value in the data list. */
7967 next_data_value (void)
7969 while (values.left == 0)
7971 if (values.vnode->next == NULL)
7974 values.vnode = values.vnode->next;
7975 values.left = values.vnode->repeat;
7983 check_data_variable (gfc_data_variable *var, locus *where)
7989 ar_type mark = AR_UNKNOWN;
7991 mpz_t section_index[GFC_MAX_DIMENSIONS];
7995 if (gfc_resolve_expr (var->expr) == FAILURE)
7999 mpz_init_set_si (offset, 0);
8002 if (e->expr_type != EXPR_VARIABLE)
8003 gfc_internal_error ("check_data_variable(): Bad expression");
8005 if (e->symtree->n.sym->ns->is_block_data
8006 && !e->symtree->n.sym->attr.in_common)
8008 gfc_error ("BLOCK DATA element '%s' at %L must be in COMMON",
8009 e->symtree->n.sym->name, &e->symtree->n.sym->declared_at);
8014 mpz_init_set_ui (size, 1);
8021 /* Find the array section reference. */
8022 for (ref = e->ref; ref; ref = ref->next)
8024 if (ref->type != REF_ARRAY)
8026 if (ref->u.ar.type == AR_ELEMENT)
8032 /* Set marks according to the reference pattern. */
8033 switch (ref->u.ar.type)
8041 /* Get the start position of array section. */
8042 gfc_get_section_index (ar, section_index, &offset);
8050 if (gfc_array_size (e, &size) == FAILURE)
8052 gfc_error ("Nonconstant array section at %L in DATA statement",
8061 while (mpz_cmp_ui (size, 0) > 0)
8063 if (next_data_value () == FAILURE)
8065 gfc_error ("DATA statement at %L has more variables than values",
8071 t = gfc_check_assign (var->expr, values.vnode->expr, 0);
8075 /* If we have more than one element left in the repeat count,
8076 and we have more than one element left in the target variable,
8077 then create a range assignment. */
8078 /* ??? Only done for full arrays for now, since array sections
8080 if (mark == AR_FULL && ref && ref->next == NULL
8081 && values.left > 1 && mpz_cmp_ui (size, 1) > 0)
8085 if (mpz_cmp_ui (size, values.left) >= 0)
8087 mpz_init_set_ui (range, values.left);
8088 mpz_sub_ui (size, size, values.left);
8093 mpz_init_set (range, size);
8094 values.left -= mpz_get_ui (size);
8095 mpz_set_ui (size, 0);
8098 gfc_assign_data_value_range (var->expr, values.vnode->expr,
8101 mpz_add (offset, offset, range);
8105 /* Assign initial value to symbol. */
8109 mpz_sub_ui (size, size, 1);
8111 t = gfc_assign_data_value (var->expr, values.vnode->expr, offset);
8115 if (mark == AR_FULL)
8116 mpz_add_ui (offset, offset, 1);
8118 /* Modify the array section indexes and recalculate the offset
8119 for next element. */
8120 else if (mark == AR_SECTION)
8121 gfc_advance_section (section_index, ar, &offset);
8125 if (mark == AR_SECTION)
8127 for (i = 0; i < ar->dimen; i++)
8128 mpz_clear (section_index[i]);
8138 static try traverse_data_var (gfc_data_variable *, locus *);
8140 /* Iterate over a list of elements in a DATA statement. */
8143 traverse_data_list (gfc_data_variable *var, locus *where)
8146 iterator_stack frame;
8147 gfc_expr *e, *start, *end, *step;
8148 try retval = SUCCESS;
8150 mpz_init (frame.value);
8152 start = gfc_copy_expr (var->iter.start);
8153 end = gfc_copy_expr (var->iter.end);
8154 step = gfc_copy_expr (var->iter.step);
8156 if (gfc_simplify_expr (start, 1) == FAILURE
8157 || start->expr_type != EXPR_CONSTANT)
8159 gfc_error ("iterator start at %L does not simplify", &start->where);
8163 if (gfc_simplify_expr (end, 1) == FAILURE
8164 || end->expr_type != EXPR_CONSTANT)
8166 gfc_error ("iterator end at %L does not simplify", &end->where);
8170 if (gfc_simplify_expr (step, 1) == FAILURE
8171 || step->expr_type != EXPR_CONSTANT)
8173 gfc_error ("iterator step at %L does not simplify", &step->where);
8178 mpz_init_set (trip, end->value.integer);
8179 mpz_sub (trip, trip, start->value.integer);
8180 mpz_add (trip, trip, step->value.integer);
8182 mpz_div (trip, trip, step->value.integer);
8184 mpz_set (frame.value, start->value.integer);
8186 frame.prev = iter_stack;
8187 frame.variable = var->iter.var->symtree;
8188 iter_stack = &frame;
8190 while (mpz_cmp_ui (trip, 0) > 0)
8192 if (traverse_data_var (var->list, where) == FAILURE)
8199 e = gfc_copy_expr (var->expr);
8200 if (gfc_simplify_expr (e, 1) == FAILURE)
8208 mpz_add (frame.value, frame.value, step->value.integer);
8210 mpz_sub_ui (trip, trip, 1);
8215 mpz_clear (frame.value);
8217 gfc_free_expr (start);
8218 gfc_free_expr (end);
8219 gfc_free_expr (step);
8221 iter_stack = frame.prev;
8226 /* Type resolve variables in the variable list of a DATA statement. */
8229 traverse_data_var (gfc_data_variable *var, locus *where)
8233 for (; var; var = var->next)
8235 if (var->expr == NULL)
8236 t = traverse_data_list (var, where);
8238 t = check_data_variable (var, where);
8248 /* Resolve the expressions and iterators associated with a data statement.
8249 This is separate from the assignment checking because data lists should
8250 only be resolved once. */
8253 resolve_data_variables (gfc_data_variable *d)
8255 for (; d; d = d->next)
8257 if (d->list == NULL)
8259 if (gfc_resolve_expr (d->expr) == FAILURE)
8264 if (gfc_resolve_iterator (&d->iter, false) == FAILURE)
8267 if (resolve_data_variables (d->list) == FAILURE)
8276 /* Resolve a single DATA statement. We implement this by storing a pointer to
8277 the value list into static variables, and then recursively traversing the
8278 variables list, expanding iterators and such. */
8281 resolve_data (gfc_data * d)
8283 if (resolve_data_variables (d->var) == FAILURE)
8286 values.vnode = d->value;
8287 values.left = (d->value == NULL) ? 0 : d->value->repeat;
8289 if (traverse_data_var (d->var, &d->where) == FAILURE)
8292 /* At this point, we better not have any values left. */
8294 if (next_data_value () == SUCCESS)
8295 gfc_error ("DATA statement at %L has more values than variables",
8300 /* 12.6 Constraint: In a pure subprogram any variable which is in common or
8301 accessed by host or use association, is a dummy argument to a pure function,
8302 is a dummy argument with INTENT (IN) to a pure subroutine, or an object that
8303 is storage associated with any such variable, shall not be used in the
8304 following contexts: (clients of this function). */
8306 /* Determines if a variable is not 'pure', ie not assignable within a pure
8307 procedure. Returns zero if assignment is OK, nonzero if there is a
8310 gfc_impure_variable (gfc_symbol *sym)
8314 if (sym->attr.use_assoc || sym->attr.in_common)
8317 if (sym->ns != gfc_current_ns)
8318 return !sym->attr.function;
8320 proc = sym->ns->proc_name;
8321 if (sym->attr.dummy && gfc_pure (proc)
8322 && ((proc->attr.subroutine && sym->attr.intent == INTENT_IN)
8324 proc->attr.function))
8327 /* TODO: Sort out what can be storage associated, if anything, and include
8328 it here. In principle equivalences should be scanned but it does not
8329 seem to be possible to storage associate an impure variable this way. */
8334 /* Test whether a symbol is pure or not. For a NULL pointer, checks the
8335 symbol of the current procedure. */
8338 gfc_pure (gfc_symbol *sym)
8340 symbol_attribute attr;
8343 sym = gfc_current_ns->proc_name;
8349 return attr.flavor == FL_PROCEDURE && (attr.pure || attr.elemental);
8353 /* Test whether the current procedure is elemental or not. */
8356 gfc_elemental (gfc_symbol *sym)
8358 symbol_attribute attr;
8361 sym = gfc_current_ns->proc_name;
8366 return attr.flavor == FL_PROCEDURE && attr.elemental;
8370 /* Warn about unused labels. */
8373 warn_unused_fortran_label (gfc_st_label *label)
8378 warn_unused_fortran_label (label->left);
8380 if (label->defined == ST_LABEL_UNKNOWN)
8383 switch (label->referenced)
8385 case ST_LABEL_UNKNOWN:
8386 gfc_warning ("Label %d at %L defined but not used", label->value,
8390 case ST_LABEL_BAD_TARGET:
8391 gfc_warning ("Label %d at %L defined but cannot be used",
8392 label->value, &label->where);
8399 warn_unused_fortran_label (label->right);
8403 /* Returns the sequence type of a symbol or sequence. */
8406 sequence_type (gfc_typespec ts)
8415 if (ts.derived->components == NULL)
8416 return SEQ_NONDEFAULT;
8418 result = sequence_type (ts.derived->components->ts);
8419 for (c = ts.derived->components->next; c; c = c->next)
8420 if (sequence_type (c->ts) != result)
8426 if (ts.kind != gfc_default_character_kind)
8427 return SEQ_NONDEFAULT;
8429 return SEQ_CHARACTER;
8432 if (ts.kind != gfc_default_integer_kind)
8433 return SEQ_NONDEFAULT;
8438 if (!(ts.kind == gfc_default_real_kind
8439 || ts.kind == gfc_default_double_kind))
8440 return SEQ_NONDEFAULT;
8445 if (ts.kind != gfc_default_complex_kind)
8446 return SEQ_NONDEFAULT;
8451 if (ts.kind != gfc_default_logical_kind)
8452 return SEQ_NONDEFAULT;
8457 return SEQ_NONDEFAULT;
8462 /* Resolve derived type EQUIVALENCE object. */
8465 resolve_equivalence_derived (gfc_symbol *derived, gfc_symbol *sym, gfc_expr *e)
8468 gfc_component *c = derived->components;
8473 /* Shall not be an object of nonsequence derived type. */
8474 if (!derived->attr.sequence)
8476 gfc_error ("Derived type variable '%s' at %L must have SEQUENCE "
8477 "attribute to be an EQUIVALENCE object", sym->name,
8482 /* Shall not have allocatable components. */
8483 if (derived->attr.alloc_comp)
8485 gfc_error ("Derived type variable '%s' at %L cannot have ALLOCATABLE "
8486 "components to be an EQUIVALENCE object",sym->name,
8491 for (; c ; c = c->next)
8495 && (resolve_equivalence_derived (c->ts.derived, sym, e) == FAILURE))
8498 /* Shall not be an object of sequence derived type containing a pointer
8499 in the structure. */
8502 gfc_error ("Derived type variable '%s' at %L with pointer "
8503 "component(s) cannot be an EQUIVALENCE object",
8504 sym->name, &e->where);
8512 /* Resolve equivalence object.
8513 An EQUIVALENCE object shall not be a dummy argument, a pointer, a target,
8514 an allocatable array, an object of nonsequence derived type, an object of
8515 sequence derived type containing a pointer at any level of component
8516 selection, an automatic object, a function name, an entry name, a result
8517 name, a named constant, a structure component, or a subobject of any of
8518 the preceding objects. A substring shall not have length zero. A
8519 derived type shall not have components with default initialization nor
8520 shall two objects of an equivalence group be initialized.
8521 Either all or none of the objects shall have an protected attribute.
8522 The simple constraints are done in symbol.c(check_conflict) and the rest
8523 are implemented here. */
8526 resolve_equivalence (gfc_equiv *eq)
8529 gfc_symbol *derived;
8530 gfc_symbol *first_sym;
8533 locus *last_where = NULL;
8534 seq_type eq_type, last_eq_type;
8535 gfc_typespec *last_ts;
8536 int object, cnt_protected;
8537 const char *value_name;
8541 last_ts = &eq->expr->symtree->n.sym->ts;
8543 first_sym = eq->expr->symtree->n.sym;
8547 for (object = 1; eq; eq = eq->eq, object++)
8551 e->ts = e->symtree->n.sym->ts;
8552 /* match_varspec might not know yet if it is seeing
8553 array reference or substring reference, as it doesn't
8555 if (e->ref && e->ref->type == REF_ARRAY)
8557 gfc_ref *ref = e->ref;
8558 sym = e->symtree->n.sym;
8560 if (sym->attr.dimension)
8562 ref->u.ar.as = sym->as;
8566 /* For substrings, convert REF_ARRAY into REF_SUBSTRING. */
8567 if (e->ts.type == BT_CHARACTER
8569 && ref->type == REF_ARRAY
8570 && ref->u.ar.dimen == 1
8571 && ref->u.ar.dimen_type[0] == DIMEN_RANGE
8572 && ref->u.ar.stride[0] == NULL)
8574 gfc_expr *start = ref->u.ar.start[0];
8575 gfc_expr *end = ref->u.ar.end[0];
8578 /* Optimize away the (:) reference. */
8579 if (start == NULL && end == NULL)
8584 e->ref->next = ref->next;
8589 ref->type = REF_SUBSTRING;
8591 start = gfc_int_expr (1);
8592 ref->u.ss.start = start;
8593 if (end == NULL && e->ts.cl)
8594 end = gfc_copy_expr (e->ts.cl->length);
8595 ref->u.ss.end = end;
8596 ref->u.ss.length = e->ts.cl;
8603 /* Any further ref is an error. */
8606 gcc_assert (ref->type == REF_ARRAY);
8607 gfc_error ("Syntax error in EQUIVALENCE statement at %L",
8613 if (gfc_resolve_expr (e) == FAILURE)
8616 sym = e->symtree->n.sym;
8618 if (sym->attr.protected)
8620 if (cnt_protected > 0 && cnt_protected != object)
8622 gfc_error ("Either all or none of the objects in the "
8623 "EQUIVALENCE set at %L shall have the "
8624 "PROTECTED attribute",
8629 /* Shall not equivalence common block variables in a PURE procedure. */
8630 if (sym->ns->proc_name
8631 && sym->ns->proc_name->attr.pure
8632 && sym->attr.in_common)
8634 gfc_error ("Common block member '%s' at %L cannot be an EQUIVALENCE "
8635 "object in the pure procedure '%s'",
8636 sym->name, &e->where, sym->ns->proc_name->name);
8640 /* Shall not be a named constant. */
8641 if (e->expr_type == EXPR_CONSTANT)
8643 gfc_error ("Named constant '%s' at %L cannot be an EQUIVALENCE "
8644 "object", sym->name, &e->where);
8648 derived = e->ts.derived;
8649 if (derived && resolve_equivalence_derived (derived, sym, e) == FAILURE)
8652 /* Check that the types correspond correctly:
8654 A numeric sequence structure may be equivalenced to another sequence
8655 structure, an object of default integer type, default real type, double
8656 precision real type, default logical type such that components of the
8657 structure ultimately only become associated to objects of the same
8658 kind. A character sequence structure may be equivalenced to an object
8659 of default character kind or another character sequence structure.
8660 Other objects may be equivalenced only to objects of the same type and
8663 /* Identical types are unconditionally OK. */
8664 if (object == 1 || gfc_compare_types (last_ts, &sym->ts))
8665 goto identical_types;
8667 last_eq_type = sequence_type (*last_ts);
8668 eq_type = sequence_type (sym->ts);
8670 /* Since the pair of objects is not of the same type, mixed or
8671 non-default sequences can be rejected. */
8673 msg = "Sequence %s with mixed components in EQUIVALENCE "
8674 "statement at %L with different type objects";
8676 && last_eq_type == SEQ_MIXED
8677 && gfc_notify_std (GFC_STD_GNU, msg, first_sym->name, last_where)
8679 || (eq_type == SEQ_MIXED
8680 && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
8681 &e->where) == FAILURE))
8684 msg = "Non-default type object or sequence %s in EQUIVALENCE "
8685 "statement at %L with objects of different type";
8687 && last_eq_type == SEQ_NONDEFAULT
8688 && gfc_notify_std (GFC_STD_GNU, msg, first_sym->name,
8689 last_where) == FAILURE)
8690 || (eq_type == SEQ_NONDEFAULT
8691 && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
8692 &e->where) == FAILURE))
8695 msg ="Non-CHARACTER object '%s' in default CHARACTER "
8696 "EQUIVALENCE statement at %L";
8697 if (last_eq_type == SEQ_CHARACTER
8698 && eq_type != SEQ_CHARACTER
8699 && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
8700 &e->where) == FAILURE)
8703 msg ="Non-NUMERIC object '%s' in default NUMERIC "
8704 "EQUIVALENCE statement at %L";
8705 if (last_eq_type == SEQ_NUMERIC
8706 && eq_type != SEQ_NUMERIC
8707 && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
8708 &e->where) == FAILURE)
8713 last_where = &e->where;
8718 /* Shall not be an automatic array. */
8719 if (e->ref->type == REF_ARRAY
8720 && gfc_resolve_array_spec (e->ref->u.ar.as, 1) == FAILURE)
8722 gfc_error ("Array '%s' at %L with non-constant bounds cannot be "
8723 "an EQUIVALENCE object", sym->name, &e->where);
8730 /* Shall not be a structure component. */
8731 if (r->type == REF_COMPONENT)
8733 gfc_error ("Structure component '%s' at %L cannot be an "
8734 "EQUIVALENCE object",
8735 r->u.c.component->name, &e->where);
8739 /* A substring shall not have length zero. */
8740 if (r->type == REF_SUBSTRING)
8742 if (compare_bound (r->u.ss.start, r->u.ss.end) == CMP_GT)
8744 gfc_error ("Substring at %L has length zero",
8745 &r->u.ss.start->where);
8755 /* Resolve function and ENTRY types, issue diagnostics if needed. */
8758 resolve_fntype (gfc_namespace *ns)
8763 if (ns->proc_name == NULL || !ns->proc_name->attr.function)
8766 /* If there are any entries, ns->proc_name is the entry master
8767 synthetic symbol and ns->entries->sym actual FUNCTION symbol. */
8769 sym = ns->entries->sym;
8771 sym = ns->proc_name;
8772 if (sym->result == sym
8773 && sym->ts.type == BT_UNKNOWN
8774 && gfc_set_default_type (sym, 0, NULL) == FAILURE
8775 && !sym->attr.untyped)
8777 gfc_error ("Function '%s' at %L has no IMPLICIT type",
8778 sym->name, &sym->declared_at);
8779 sym->attr.untyped = 1;
8782 if (sym->ts.type == BT_DERIVED && !sym->ts.derived->attr.use_assoc
8783 && !gfc_check_access (sym->ts.derived->attr.access,
8784 sym->ts.derived->ns->default_access)
8785 && gfc_check_access (sym->attr.access, sym->ns->default_access))
8787 gfc_error ("PUBLIC function '%s' at %L cannot be of PRIVATE type '%s'",
8788 sym->name, &sym->declared_at, sym->ts.derived->name);
8792 for (el = ns->entries->next; el; el = el->next)
8794 if (el->sym->result == el->sym
8795 && el->sym->ts.type == BT_UNKNOWN
8796 && gfc_set_default_type (el->sym, 0, NULL) == FAILURE
8797 && !el->sym->attr.untyped)
8799 gfc_error ("ENTRY '%s' at %L has no IMPLICIT type",
8800 el->sym->name, &el->sym->declared_at);
8801 el->sym->attr.untyped = 1;
8806 /* 12.3.2.1.1 Defined operators. */
8809 gfc_resolve_uops (gfc_symtree *symtree)
8813 gfc_formal_arglist *formal;
8815 if (symtree == NULL)
8818 gfc_resolve_uops (symtree->left);
8819 gfc_resolve_uops (symtree->right);
8821 for (itr = symtree->n.uop->operator; itr; itr = itr->next)
8824 if (!sym->attr.function)
8825 gfc_error ("User operator procedure '%s' at %L must be a FUNCTION",
8826 sym->name, &sym->declared_at);
8828 if (sym->ts.type == BT_CHARACTER
8829 && !(sym->ts.cl && sym->ts.cl->length)
8830 && !(sym->result && sym->result->ts.cl
8831 && sym->result->ts.cl->length))
8832 gfc_error ("User operator procedure '%s' at %L cannot be assumed "
8833 "character length", sym->name, &sym->declared_at);
8835 formal = sym->formal;
8836 if (!formal || !formal->sym)
8838 gfc_error ("User operator procedure '%s' at %L must have at least "
8839 "one argument", sym->name, &sym->declared_at);
8843 if (formal->sym->attr.intent != INTENT_IN)
8844 gfc_error ("First argument of operator interface at %L must be "
8845 "INTENT(IN)", &sym->declared_at);
8847 if (formal->sym->attr.optional)
8848 gfc_error ("First argument of operator interface at %L cannot be "
8849 "optional", &sym->declared_at);
8851 formal = formal->next;
8852 if (!formal || !formal->sym)
8855 if (formal->sym->attr.intent != INTENT_IN)
8856 gfc_error ("Second argument of operator interface at %L must be "
8857 "INTENT(IN)", &sym->declared_at);
8859 if (formal->sym->attr.optional)
8860 gfc_error ("Second argument of operator interface at %L cannot be "
8861 "optional", &sym->declared_at);
8864 gfc_error ("Operator interface at %L must have, at most, two "
8865 "arguments", &sym->declared_at);
8870 /* Examine all of the expressions associated with a program unit,
8871 assign types to all intermediate expressions, make sure that all
8872 assignments are to compatible types and figure out which names
8873 refer to which functions or subroutines. It doesn't check code
8874 block, which is handled by resolve_code. */
8877 resolve_types (gfc_namespace *ns)
8884 gfc_current_ns = ns;
8886 resolve_entries (ns);
8888 resolve_common_blocks (ns->common_root);
8890 resolve_contained_functions (ns);
8892 gfc_traverse_ns (ns, resolve_bind_c_derived_types);
8894 for (cl = ns->cl_list; cl; cl = cl->next)
8895 resolve_charlen (cl);
8897 gfc_traverse_ns (ns, resolve_symbol);
8899 resolve_fntype (ns);
8901 for (n = ns->contained; n; n = n->sibling)
8903 if (gfc_pure (ns->proc_name) && !gfc_pure (n->proc_name))
8904 gfc_error ("Contained procedure '%s' at %L of a PURE procedure must "
8905 "also be PURE", n->proc_name->name,
8906 &n->proc_name->declared_at);
8912 gfc_check_interfaces (ns);
8914 gfc_traverse_ns (ns, resolve_values);
8920 for (d = ns->data; d; d = d->next)
8924 gfc_traverse_ns (ns, gfc_formalize_init_value);
8926 gfc_traverse_ns (ns, gfc_verify_binding_labels);
8928 if (ns->common_root != NULL)
8929 gfc_traverse_symtree (ns->common_root, resolve_bind_c_comms);
8931 for (eq = ns->equiv; eq; eq = eq->next)
8932 resolve_equivalence (eq);
8934 /* Warn about unused labels. */
8935 if (warn_unused_label)
8936 warn_unused_fortran_label (ns->st_labels);
8938 gfc_resolve_uops (ns->uop_root);
8942 /* Call resolve_code recursively. */
8945 resolve_codes (gfc_namespace *ns)
8949 for (n = ns->contained; n; n = n->sibling)
8952 gfc_current_ns = ns;
8954 /* Set to an out of range value. */
8955 current_entry_id = -1;
8957 bitmap_obstack_initialize (&labels_obstack);
8958 resolve_code (ns->code, ns);
8959 bitmap_obstack_release (&labels_obstack);
8963 /* This function is called after a complete program unit has been compiled.
8964 Its purpose is to examine all of the expressions associated with a program
8965 unit, assign types to all intermediate expressions, make sure that all
8966 assignments are to compatible types and figure out which names refer to
8967 which functions or subroutines. */
8970 gfc_resolve (gfc_namespace *ns)
8972 gfc_namespace *old_ns;
8974 old_ns = gfc_current_ns;
8979 gfc_current_ns = old_ns;