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 /* See if the user is trying to invoke a structure constructor for one of
732 the iso_c_binding derived types. */
733 if (expr->ts.derived && expr->ts.derived->ts.is_iso_c && cons
734 && cons->expr != NULL)
736 gfc_error ("Components of structure constructor '%s' at %L are PRIVATE",
737 expr->ts.derived->name, &(expr->where));
741 for (; comp; comp = comp->next, cons = cons->next)
746 if (gfc_resolve_expr (cons->expr) == FAILURE)
752 if (cons->expr->expr_type != EXPR_NULL
753 && comp->as && comp->as->rank != cons->expr->rank
754 && (comp->allocatable || cons->expr->rank))
756 gfc_error ("The rank of the element in the derived type "
757 "constructor at %L does not match that of the "
758 "component (%d/%d)", &cons->expr->where,
759 cons->expr->rank, comp->as ? comp->as->rank : 0);
763 /* If we don't have the right type, try to convert it. */
765 if (!gfc_compare_types (&cons->expr->ts, &comp->ts))
768 if (comp->pointer && cons->expr->ts.type != BT_UNKNOWN)
769 gfc_error ("The element in the derived type constructor at %L, "
770 "for pointer component '%s', is %s but should be %s",
771 &cons->expr->where, comp->name,
772 gfc_basic_typename (cons->expr->ts.type),
773 gfc_basic_typename (comp->ts.type));
775 t = gfc_convert_type (cons->expr, &comp->ts, 1);
778 if (!comp->pointer || cons->expr->expr_type == EXPR_NULL)
781 a = gfc_expr_attr (cons->expr);
783 if (!a.pointer && !a.target)
786 gfc_error ("The element in the derived type constructor at %L, "
787 "for pointer component '%s' should be a POINTER or "
788 "a TARGET", &cons->expr->where, comp->name);
796 /****************** Expression name resolution ******************/
798 /* Returns 0 if a symbol was not declared with a type or
799 attribute declaration statement, nonzero otherwise. */
802 was_declared (gfc_symbol *sym)
808 if (!a.implicit_type && sym->ts.type != BT_UNKNOWN)
811 if (a.allocatable || a.dimension || a.dummy || a.external || a.intrinsic
812 || a.optional || a.pointer || a.save || a.target || a.volatile_
813 || a.value || a.access != ACCESS_UNKNOWN || a.intent != INTENT_UNKNOWN)
820 /* Determine if a symbol is generic or not. */
823 generic_sym (gfc_symbol *sym)
827 if (sym->attr.generic ||
828 (sym->attr.intrinsic && gfc_generic_intrinsic (sym->name)))
831 if (was_declared (sym) || sym->ns->parent == NULL)
834 gfc_find_symbol (sym->name, sym->ns->parent, 1, &s);
841 return generic_sym (s);
848 /* Determine if a symbol is specific or not. */
851 specific_sym (gfc_symbol *sym)
855 if (sym->attr.if_source == IFSRC_IFBODY
856 || sym->attr.proc == PROC_MODULE
857 || sym->attr.proc == PROC_INTERNAL
858 || sym->attr.proc == PROC_ST_FUNCTION
859 || (sym->attr.intrinsic && gfc_specific_intrinsic (sym->name))
860 || sym->attr.external)
863 if (was_declared (sym) || sym->ns->parent == NULL)
866 gfc_find_symbol (sym->name, sym->ns->parent, 1, &s);
868 return (s == NULL) ? 0 : specific_sym (s);
872 /* Figure out if the procedure is specific, generic or unknown. */
875 { PTYPE_GENERIC = 1, PTYPE_SPECIFIC, PTYPE_UNKNOWN }
879 procedure_kind (gfc_symbol *sym)
881 if (generic_sym (sym))
882 return PTYPE_GENERIC;
884 if (specific_sym (sym))
885 return PTYPE_SPECIFIC;
887 return PTYPE_UNKNOWN;
890 /* Check references to assumed size arrays. The flag need_full_assumed_size
891 is nonzero when matching actual arguments. */
893 static int need_full_assumed_size = 0;
896 check_assumed_size_reference (gfc_symbol *sym, gfc_expr *e)
902 if (need_full_assumed_size || !(sym->as && sym->as->type == AS_ASSUMED_SIZE))
905 for (ref = e->ref; ref; ref = ref->next)
906 if (ref->type == REF_ARRAY)
907 for (dim = 0; dim < ref->u.ar.as->rank; dim++)
908 last = (ref->u.ar.end[dim] == NULL)
909 && (ref->u.ar.type == DIMEN_ELEMENT);
913 gfc_error ("The upper bound in the last dimension must "
914 "appear in the reference to the assumed size "
915 "array '%s' at %L", sym->name, &e->where);
922 /* Look for bad assumed size array references in argument expressions
923 of elemental and array valued intrinsic procedures. Since this is
924 called from procedure resolution functions, it only recurses at
928 resolve_assumed_size_actual (gfc_expr *e)
933 switch (e->expr_type)
936 if (e->symtree && check_assumed_size_reference (e->symtree->n.sym, e))
941 if (resolve_assumed_size_actual (e->value.op.op1)
942 || resolve_assumed_size_actual (e->value.op.op2))
953 /* Resolve an actual argument list. Most of the time, this is just
954 resolving the expressions in the list.
955 The exception is that we sometimes have to decide whether arguments
956 that look like procedure arguments are really simple variable
960 resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype)
963 gfc_symtree *parent_st;
966 for (; arg; arg = arg->next)
971 /* Check the label is a valid branching target. */
974 if (arg->label->defined == ST_LABEL_UNKNOWN)
976 gfc_error ("Label %d referenced at %L is never defined",
977 arg->label->value, &arg->label->where);
984 if (e->expr_type == FL_VARIABLE && e->symtree->ambiguous)
986 gfc_error ("'%s' at %L is ambiguous", e->symtree->n.sym->name,
991 if (e->ts.type != BT_PROCEDURE)
993 if (gfc_resolve_expr (e) != SUCCESS)
998 /* See if the expression node should really be a variable reference. */
1000 sym = e->symtree->n.sym;
1002 if (sym->attr.flavor == FL_PROCEDURE
1003 || sym->attr.intrinsic
1004 || sym->attr.external)
1008 /* If a procedure is not already determined to be something else
1009 check if it is intrinsic. */
1010 if (!sym->attr.intrinsic
1011 && !(sym->attr.external || sym->attr.use_assoc
1012 || sym->attr.if_source == IFSRC_IFBODY)
1013 && gfc_intrinsic_name (sym->name, sym->attr.subroutine))
1014 sym->attr.intrinsic = 1;
1016 if (sym->attr.proc == PROC_ST_FUNCTION)
1018 gfc_error ("Statement function '%s' at %L is not allowed as an "
1019 "actual argument", sym->name, &e->where);
1022 actual_ok = gfc_intrinsic_actual_ok (sym->name,
1023 sym->attr.subroutine);
1024 if (sym->attr.intrinsic && actual_ok == 0)
1026 gfc_error ("Intrinsic '%s' at %L is not allowed as an "
1027 "actual argument", sym->name, &e->where);
1030 if (sym->attr.contained && !sym->attr.use_assoc
1031 && sym->ns->proc_name->attr.flavor != FL_MODULE)
1033 gfc_error ("Internal procedure '%s' is not allowed as an "
1034 "actual argument at %L", sym->name, &e->where);
1037 if (sym->attr.elemental && !sym->attr.intrinsic)
1039 gfc_error ("ELEMENTAL non-INTRINSIC procedure '%s' is not "
1040 "allowed as an actual argument at %L", sym->name,
1044 /* Check if a generic interface has a specific procedure
1045 with the same name before emitting an error. */
1046 if (sym->attr.generic)
1049 for (p = sym->generic; p; p = p->next)
1050 if (strcmp (sym->name, p->sym->name) == 0)
1052 e->symtree = gfc_find_symtree
1053 (p->sym->ns->sym_root, sym->name);
1058 if (p == NULL || e->symtree == NULL)
1059 gfc_error ("GENERIC procedure '%s' is not "
1060 "allowed as an actual argument at %L", sym->name,
1064 /* If the symbol is the function that names the current (or
1065 parent) scope, then we really have a variable reference. */
1067 if (sym->attr.function && sym->result == sym
1068 && (sym->ns->proc_name == sym
1069 || (sym->ns->parent != NULL
1070 && sym->ns->parent->proc_name == sym)))
1073 /* If all else fails, see if we have a specific intrinsic. */
1074 if (sym->ts.type == BT_UNKNOWN && sym->attr.intrinsic)
1076 gfc_intrinsic_sym *isym;
1078 isym = gfc_find_function (sym->name);
1079 if (isym == NULL || !isym->specific)
1081 gfc_error ("Unable to find a specific INTRINSIC procedure "
1082 "for the reference '%s' at %L", sym->name,
1087 sym->attr.intrinsic = 1;
1088 sym->attr.function = 1;
1093 /* See if the name is a module procedure in a parent unit. */
1095 if (was_declared (sym) || sym->ns->parent == NULL)
1098 if (gfc_find_sym_tree (sym->name, sym->ns->parent, 1, &parent_st))
1100 gfc_error ("Symbol '%s' at %L is ambiguous", sym->name, &e->where);
1104 if (parent_st == NULL)
1107 sym = parent_st->n.sym;
1108 e->symtree = parent_st; /* Point to the right thing. */
1110 if (sym->attr.flavor == FL_PROCEDURE
1111 || sym->attr.intrinsic
1112 || sym->attr.external)
1118 e->expr_type = EXPR_VARIABLE;
1120 if (sym->as != NULL)
1122 e->rank = sym->as->rank;
1123 e->ref = gfc_get_ref ();
1124 e->ref->type = REF_ARRAY;
1125 e->ref->u.ar.type = AR_FULL;
1126 e->ref->u.ar.as = sym->as;
1129 /* Expressions are assigned a default ts.type of BT_PROCEDURE in
1130 primary.c (match_actual_arg). If above code determines that it
1131 is a variable instead, it needs to be resolved as it was not
1132 done at the beginning of this function. */
1133 if (gfc_resolve_expr (e) != SUCCESS)
1137 /* Check argument list functions %VAL, %LOC and %REF. There is
1138 nothing to do for %REF. */
1139 if (arg->name && arg->name[0] == '%')
1141 if (strncmp ("%VAL", arg->name, 4) == 0)
1143 if (e->ts.type == BT_CHARACTER || e->ts.type == BT_DERIVED)
1145 gfc_error ("By-value argument at %L is not of numeric "
1152 gfc_error ("By-value argument at %L cannot be an array or "
1153 "an array section", &e->where);
1157 /* Intrinsics are still PROC_UNKNOWN here. However,
1158 since same file external procedures are not resolvable
1159 in gfortran, it is a good deal easier to leave them to
1161 if (ptype != PROC_UNKNOWN
1162 && ptype != PROC_DUMMY
1163 && ptype != PROC_EXTERNAL
1164 && ptype != PROC_MODULE)
1166 gfc_error ("By-value argument at %L is not allowed "
1167 "in this context", &e->where);
1172 /* Statement functions have already been excluded above. */
1173 else if (strncmp ("%LOC", arg->name, 4) == 0
1174 && e->ts.type == BT_PROCEDURE)
1176 if (e->symtree->n.sym->attr.proc == PROC_INTERNAL)
1178 gfc_error ("Passing internal procedure at %L by location "
1179 "not allowed", &e->where);
1190 /* Do the checks of the actual argument list that are specific to elemental
1191 procedures. If called with c == NULL, we have a function, otherwise if
1192 expr == NULL, we have a subroutine. */
1195 resolve_elemental_actual (gfc_expr *expr, gfc_code *c)
1197 gfc_actual_arglist *arg0;
1198 gfc_actual_arglist *arg;
1199 gfc_symbol *esym = NULL;
1200 gfc_intrinsic_sym *isym = NULL;
1202 gfc_intrinsic_arg *iformal = NULL;
1203 gfc_formal_arglist *eformal = NULL;
1204 bool formal_optional = false;
1205 bool set_by_optional = false;
1209 /* Is this an elemental procedure? */
1210 if (expr && expr->value.function.actual != NULL)
1212 if (expr->value.function.esym != NULL
1213 && expr->value.function.esym->attr.elemental)
1215 arg0 = expr->value.function.actual;
1216 esym = expr->value.function.esym;
1218 else if (expr->value.function.isym != NULL
1219 && expr->value.function.isym->elemental)
1221 arg0 = expr->value.function.actual;
1222 isym = expr->value.function.isym;
1227 else if (c && c->ext.actual != NULL && c->symtree->n.sym->attr.elemental)
1229 arg0 = c->ext.actual;
1230 esym = c->symtree->n.sym;
1235 /* The rank of an elemental is the rank of its array argument(s). */
1236 for (arg = arg0; arg; arg = arg->next)
1238 if (arg->expr != NULL && arg->expr->rank > 0)
1240 rank = arg->expr->rank;
1241 if (arg->expr->expr_type == EXPR_VARIABLE
1242 && arg->expr->symtree->n.sym->attr.optional)
1243 set_by_optional = true;
1245 /* Function specific; set the result rank and shape. */
1249 if (!expr->shape && arg->expr->shape)
1251 expr->shape = gfc_get_shape (rank);
1252 for (i = 0; i < rank; i++)
1253 mpz_init_set (expr->shape[i], arg->expr->shape[i]);
1260 /* If it is an array, it shall not be supplied as an actual argument
1261 to an elemental procedure unless an array of the same rank is supplied
1262 as an actual argument corresponding to a nonoptional dummy argument of
1263 that elemental procedure(12.4.1.5). */
1264 formal_optional = false;
1266 iformal = isym->formal;
1268 eformal = esym->formal;
1270 for (arg = arg0; arg; arg = arg->next)
1274 if (eformal->sym && eformal->sym->attr.optional)
1275 formal_optional = true;
1276 eformal = eformal->next;
1278 else if (isym && iformal)
1280 if (iformal->optional)
1281 formal_optional = true;
1282 iformal = iformal->next;
1285 formal_optional = true;
1287 if (pedantic && arg->expr != NULL
1288 && arg->expr->expr_type == EXPR_VARIABLE
1289 && arg->expr->symtree->n.sym->attr.optional
1292 && (set_by_optional || arg->expr->rank != rank)
1293 && !(isym && isym->id == GFC_ISYM_CONVERSION))
1295 gfc_warning ("'%s' at %L is an array and OPTIONAL; IF IT IS "
1296 "MISSING, it cannot be the actual argument of an "
1297 "ELEMENTAL procedure unless there is a non-optional "
1298 "argument with the same rank (12.4.1.5)",
1299 arg->expr->symtree->n.sym->name, &arg->expr->where);
1304 for (arg = arg0; arg; arg = arg->next)
1306 if (arg->expr == NULL || arg->expr->rank == 0)
1309 /* Being elemental, the last upper bound of an assumed size array
1310 argument must be present. */
1311 if (resolve_assumed_size_actual (arg->expr))
1314 /* Elemental procedure's array actual arguments must conform. */
1317 if (gfc_check_conformance ("elemental procedure", arg->expr, e)
1325 /* INTENT(OUT) is only allowed for subroutines; if any actual argument
1326 is an array, the intent inout/out variable needs to be also an array. */
1327 if (rank > 0 && esym && expr == NULL)
1328 for (eformal = esym->formal, arg = arg0; arg && eformal;
1329 arg = arg->next, eformal = eformal->next)
1330 if ((eformal->sym->attr.intent == INTENT_OUT
1331 || eformal->sym->attr.intent == INTENT_INOUT)
1332 && arg->expr && arg->expr->rank == 0)
1334 gfc_error ("Actual argument at %L for INTENT(%s) dummy '%s' of "
1335 "ELEMENTAL subroutine '%s' is a scalar, but another "
1336 "actual argument is an array", &arg->expr->where,
1337 (eformal->sym->attr.intent == INTENT_OUT) ? "OUT"
1338 : "INOUT", eformal->sym->name, esym->name);
1345 /* Go through each actual argument in ACTUAL and see if it can be
1346 implemented as an inlined, non-copying intrinsic. FNSYM is the
1347 function being called, or NULL if not known. */
1350 find_noncopying_intrinsics (gfc_symbol *fnsym, gfc_actual_arglist *actual)
1352 gfc_actual_arglist *ap;
1355 for (ap = actual; ap; ap = ap->next)
1357 && (expr = gfc_get_noncopying_intrinsic_argument (ap->expr))
1358 && !gfc_check_fncall_dependency (expr, INTENT_IN, fnsym, actual))
1359 ap->expr->inline_noncopying_intrinsic = 1;
1363 /* This function does the checking of references to global procedures
1364 as defined in sections 18.1 and 14.1, respectively, of the Fortran
1365 77 and 95 standards. It checks for a gsymbol for the name, making
1366 one if it does not already exist. If it already exists, then the
1367 reference being resolved must correspond to the type of gsymbol.
1368 Otherwise, the new symbol is equipped with the attributes of the
1369 reference. The corresponding code that is called in creating
1370 global entities is parse.c. */
1373 resolve_global_procedure (gfc_symbol *sym, locus *where, int sub)
1378 type = sub ? GSYM_SUBROUTINE : GSYM_FUNCTION;
1380 gsym = gfc_get_gsymbol (sym->name);
1382 if ((gsym->type != GSYM_UNKNOWN && gsym->type != type))
1383 gfc_global_used (gsym, where);
1385 if (gsym->type == GSYM_UNKNOWN)
1388 gsym->where = *where;
1395 /************* Function resolution *************/
1397 /* Resolve a function call known to be generic.
1398 Section 14.1.2.4.1. */
1401 resolve_generic_f0 (gfc_expr *expr, gfc_symbol *sym)
1405 if (sym->attr.generic)
1407 s = gfc_search_interface (sym->generic, 0, &expr->value.function.actual);
1410 expr->value.function.name = s->name;
1411 expr->value.function.esym = s;
1413 if (s->ts.type != BT_UNKNOWN)
1415 else if (s->result != NULL && s->result->ts.type != BT_UNKNOWN)
1416 expr->ts = s->result->ts;
1419 expr->rank = s->as->rank;
1420 else if (s->result != NULL && s->result->as != NULL)
1421 expr->rank = s->result->as->rank;
1426 /* TODO: Need to search for elemental references in generic
1430 if (sym->attr.intrinsic)
1431 return gfc_intrinsic_func_interface (expr, 0);
1438 resolve_generic_f (gfc_expr *expr)
1443 sym = expr->symtree->n.sym;
1447 m = resolve_generic_f0 (expr, sym);
1450 else if (m == MATCH_ERROR)
1454 if (sym->ns->parent == NULL)
1456 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
1460 if (!generic_sym (sym))
1464 /* Last ditch attempt. See if the reference is to an intrinsic
1465 that possesses a matching interface. 14.1.2.4 */
1466 if (sym && !gfc_intrinsic_name (sym->name, 0))
1468 gfc_error ("There is no specific function for the generic '%s' at %L",
1469 expr->symtree->n.sym->name, &expr->where);
1473 m = gfc_intrinsic_func_interface (expr, 0);
1477 gfc_error ("Generic function '%s' at %L is not consistent with a "
1478 "specific intrinsic interface", expr->symtree->n.sym->name,
1485 /* Resolve a function call known to be specific. */
1488 resolve_specific_f0 (gfc_symbol *sym, gfc_expr *expr)
1492 /* See if we have an intrinsic interface. */
1494 if (sym->interface != NULL && sym->interface->attr.intrinsic)
1496 gfc_intrinsic_sym *isym;
1497 isym = gfc_find_function (sym->interface->name);
1499 /* Existance of isym should be checked already. */
1503 sym->attr.function = 1;
1504 sym->attr.proc = PROC_EXTERNAL;
1508 if (sym->attr.external || sym->attr.if_source == IFSRC_IFBODY)
1510 if (sym->attr.dummy)
1512 sym->attr.proc = PROC_DUMMY;
1516 sym->attr.proc = PROC_EXTERNAL;
1520 if (sym->attr.proc == PROC_MODULE
1521 || sym->attr.proc == PROC_ST_FUNCTION
1522 || sym->attr.proc == PROC_INTERNAL)
1525 if (sym->attr.intrinsic)
1527 m = gfc_intrinsic_func_interface (expr, 1);
1531 gfc_error ("Function '%s' at %L is INTRINSIC but is not compatible "
1532 "with an intrinsic", sym->name, &expr->where);
1540 gfc_procedure_use (sym, &expr->value.function.actual, &expr->where);
1543 expr->value.function.name = sym->name;
1544 expr->value.function.esym = sym;
1545 if (sym->as != NULL)
1546 expr->rank = sym->as->rank;
1553 resolve_specific_f (gfc_expr *expr)
1558 sym = expr->symtree->n.sym;
1562 m = resolve_specific_f0 (sym, expr);
1565 if (m == MATCH_ERROR)
1568 if (sym->ns->parent == NULL)
1571 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
1577 gfc_error ("Unable to resolve the specific function '%s' at %L",
1578 expr->symtree->n.sym->name, &expr->where);
1584 /* Resolve a procedure call not known to be generic nor specific. */
1587 resolve_unknown_f (gfc_expr *expr)
1592 sym = expr->symtree->n.sym;
1594 if (sym->attr.dummy)
1596 sym->attr.proc = PROC_DUMMY;
1597 expr->value.function.name = sym->name;
1601 /* See if we have an intrinsic function reference. */
1603 if (gfc_intrinsic_name (sym->name, 0))
1605 if (gfc_intrinsic_func_interface (expr, 1) == MATCH_YES)
1610 /* The reference is to an external name. */
1612 sym->attr.proc = PROC_EXTERNAL;
1613 expr->value.function.name = sym->name;
1614 expr->value.function.esym = expr->symtree->n.sym;
1616 if (sym->as != NULL)
1617 expr->rank = sym->as->rank;
1619 /* Type of the expression is either the type of the symbol or the
1620 default type of the symbol. */
1623 gfc_procedure_use (sym, &expr->value.function.actual, &expr->where);
1625 if (sym->ts.type != BT_UNKNOWN)
1629 ts = gfc_get_default_type (sym, sym->ns);
1631 if (ts->type == BT_UNKNOWN)
1633 gfc_error ("Function '%s' at %L has no IMPLICIT type",
1634 sym->name, &expr->where);
1645 /* Return true, if the symbol is an external procedure. */
1647 is_external_proc (gfc_symbol *sym)
1649 if (!sym->attr.dummy && !sym->attr.contained
1650 && !(sym->attr.intrinsic
1651 || gfc_intrinsic_name (sym->name, sym->attr.subroutine))
1652 && sym->attr.proc != PROC_ST_FUNCTION
1653 && !sym->attr.use_assoc
1661 /* Figure out if a function reference is pure or not. Also set the name
1662 of the function for a potential error message. Return nonzero if the
1663 function is PURE, zero if not. */
1666 pure_function (gfc_expr *e, const char **name)
1672 if (e->symtree != NULL
1673 && e->symtree->n.sym != NULL
1674 && e->symtree->n.sym->attr.proc == PROC_ST_FUNCTION)
1677 if (e->value.function.esym)
1679 pure = gfc_pure (e->value.function.esym);
1680 *name = e->value.function.esym->name;
1682 else if (e->value.function.isym)
1684 pure = e->value.function.isym->pure
1685 || e->value.function.isym->elemental;
1686 *name = e->value.function.isym->name;
1690 /* Implicit functions are not pure. */
1692 *name = e->value.function.name;
1700 is_scalar_expr_ptr (gfc_expr *expr)
1702 try retval = SUCCESS;
1707 /* See if we have a gfc_ref, which means we have a substring, array
1708 reference, or a component. */
1709 if (expr->ref != NULL)
1712 while (ref->next != NULL)
1718 if (ref->u.ss.length != NULL
1719 && ref->u.ss.length->length != NULL
1721 && ref->u.ss.start->expr_type == EXPR_CONSTANT
1723 && ref->u.ss.end->expr_type == EXPR_CONSTANT)
1725 start = (int) mpz_get_si (ref->u.ss.start->value.integer);
1726 end = (int) mpz_get_si (ref->u.ss.end->value.integer);
1727 if (end - start + 1 != 1)
1734 if (ref->u.ar.type == AR_ELEMENT)
1736 else if (ref->u.ar.type == AR_FULL)
1738 /* The user can give a full array if the array is of size 1. */
1739 if (ref->u.ar.as != NULL
1740 && ref->u.ar.as->rank == 1
1741 && ref->u.ar.as->type == AS_EXPLICIT
1742 && ref->u.ar.as->lower[0] != NULL
1743 && ref->u.ar.as->lower[0]->expr_type == EXPR_CONSTANT
1744 && ref->u.ar.as->upper[0] != NULL
1745 && ref->u.ar.as->upper[0]->expr_type == EXPR_CONSTANT)
1747 /* If we have a character string, we need to check if
1748 its length is one. */
1749 if (expr->ts.type == BT_CHARACTER)
1751 if (expr->ts.cl == NULL
1752 || expr->ts.cl->length == NULL
1753 || mpz_cmp_si (expr->ts.cl->length->value.integer, 1)
1759 /* We have constant lower and upper bounds. If the
1760 difference between is 1, it can be considered a
1762 start = (int) mpz_get_si
1763 (ref->u.ar.as->lower[0]->value.integer);
1764 end = (int) mpz_get_si
1765 (ref->u.ar.as->upper[0]->value.integer);
1766 if (end - start + 1 != 1)
1781 else if (expr->ts.type == BT_CHARACTER && expr->rank == 0)
1783 /* Character string. Make sure it's of length 1. */
1784 if (expr->ts.cl == NULL
1785 || expr->ts.cl->length == NULL
1786 || mpz_cmp_si (expr->ts.cl->length->value.integer, 1) != 0)
1789 else if (expr->rank != 0)
1796 /* Match one of the iso_c_binding functions (c_associated or c_loc)
1797 and, in the case of c_associated, set the binding label based on
1801 gfc_iso_c_func_interface (gfc_symbol *sym, gfc_actual_arglist *args,
1802 gfc_symbol **new_sym)
1804 char name[GFC_MAX_SYMBOL_LEN + 1];
1805 char binding_label[GFC_MAX_BINDING_LABEL_LEN + 1];
1806 int optional_arg = 0;
1807 try retval = SUCCESS;
1808 gfc_symbol *args_sym;
1809 gfc_typespec *arg_ts;
1810 gfc_ref *parent_ref;
1813 if (args->expr->expr_type == EXPR_CONSTANT
1814 || args->expr->expr_type == EXPR_OP
1815 || args->expr->expr_type == EXPR_NULL)
1817 gfc_error ("Argument to '%s' at %L is not a variable",
1818 sym->name, &(args->expr->where));
1822 args_sym = args->expr->symtree->n.sym;
1824 /* The typespec for the actual arg should be that stored in the expr
1825 and not necessarily that of the expr symbol (args_sym), because
1826 the actual expression could be a part-ref of the expr symbol. */
1827 arg_ts = &(args->expr->ts);
1829 /* Get the parent reference (if any) for the expression. This happens for
1830 cases such as a%b%c. */
1831 parent_ref = args->expr->ref;
1833 if (parent_ref != NULL)
1835 curr_ref = parent_ref->next;
1836 while (curr_ref != NULL && curr_ref->next != NULL)
1838 parent_ref = curr_ref;
1839 curr_ref = curr_ref->next;
1843 /* If curr_ref is non-NULL, we had a part-ref expression. If the curr_ref
1844 is for a REF_COMPONENT, then we need to use it as the parent_ref for
1845 the name, etc. Otherwise, the current parent_ref should be correct. */
1846 if (curr_ref != NULL && curr_ref->type == REF_COMPONENT)
1847 parent_ref = curr_ref;
1849 if (parent_ref == args->expr->ref)
1851 else if (parent_ref != NULL && parent_ref->type != REF_COMPONENT)
1852 gfc_internal_error ("Unexpected expression reference type in "
1853 "gfc_iso_c_func_interface");
1855 if (sym->intmod_sym_id == ISOCBINDING_ASSOCIATED)
1857 /* If the user gave two args then they are providing something for
1858 the optional arg (the second cptr). Therefore, set the name and
1859 binding label to the c_associated for two cptrs. Otherwise,
1860 set c_associated to expect one cptr. */
1864 sprintf (name, "%s_2", sym->name);
1865 sprintf (binding_label, "%s_2", sym->binding_label);
1871 sprintf (name, "%s_1", sym->name);
1872 sprintf (binding_label, "%s_1", sym->binding_label);
1876 /* Get a new symbol for the version of c_associated that
1878 *new_sym = get_iso_c_sym (sym, name, binding_label, optional_arg);
1880 else if (sym->intmod_sym_id == ISOCBINDING_LOC
1881 || sym->intmod_sym_id == ISOCBINDING_FUNLOC)
1883 sprintf (name, "%s", sym->name);
1884 sprintf (binding_label, "%s", sym->binding_label);
1886 /* Error check the call. */
1887 if (args->next != NULL)
1889 gfc_error_now ("More actual than formal arguments in '%s' "
1890 "call at %L", name, &(args->expr->where));
1893 else if (sym->intmod_sym_id == ISOCBINDING_LOC)
1895 /* Make sure we have either the target or pointer attribute. */
1896 if (!(args_sym->attr.target)
1897 && !(args_sym->attr.pointer)
1898 && (parent_ref == NULL ||
1899 !parent_ref->u.c.component->pointer))
1901 gfc_error_now ("Parameter '%s' to '%s' at %L must be either "
1902 "a TARGET or an associated pointer",
1904 sym->name, &(args->expr->where));
1908 /* See if we have interoperable type and type param. */
1909 if (verify_c_interop (arg_ts,
1910 (parent_ref ? parent_ref->u.c.component->name
1912 &(args->expr->where)) == SUCCESS
1913 || gfc_check_any_c_kind (arg_ts) == SUCCESS)
1915 if (args_sym->attr.target == 1)
1917 /* Case 1a, section 15.1.2.5, J3/04-007: variable that
1918 has the target attribute and is interoperable. */
1919 /* Case 1b, section 15.1.2.5, J3/04-007: allocated
1920 allocatable variable that has the TARGET attribute and
1921 is not an array of zero size. */
1922 if (args_sym->attr.allocatable == 1)
1924 if (args_sym->attr.dimension != 0
1925 && (args_sym->as && args_sym->as->rank == 0))
1927 gfc_error_now ("Allocatable variable '%s' used as a "
1928 "parameter to '%s' at %L must not be "
1929 "an array of zero size",
1930 args_sym->name, sym->name,
1931 &(args->expr->where));
1937 /* A non-allocatable target variable with C
1938 interoperable type and type parameters must be
1940 if (args_sym && args_sym->attr.dimension)
1942 if (args_sym->as->type == AS_ASSUMED_SHAPE)
1944 gfc_error ("Assumed-shape array '%s' at %L "
1945 "cannot be an argument to the "
1946 "procedure '%s' because "
1947 "it is not C interoperable",
1949 &(args->expr->where), sym->name);
1952 else if (args_sym->as->type == AS_DEFERRED)
1954 gfc_error ("Deferred-shape array '%s' at %L "
1955 "cannot be an argument to the "
1956 "procedure '%s' because "
1957 "it is not C interoperable",
1959 &(args->expr->where), sym->name);
1964 /* Make sure it's not a character string. Arrays of
1965 any type should be ok if the variable is of a C
1966 interoperable type. */
1967 if (arg_ts->type == BT_CHARACTER)
1968 if (arg_ts->cl != NULL
1969 && (arg_ts->cl->length == NULL
1970 || arg_ts->cl->length->expr_type
1973 (arg_ts->cl->length->value.integer, 1)
1975 && is_scalar_expr_ptr (args->expr) != SUCCESS)
1977 gfc_error_now ("CHARACTER argument '%s' to '%s' "
1978 "at %L must have a length of 1",
1979 args_sym->name, sym->name,
1980 &(args->expr->where));
1985 else if ((args_sym->attr.pointer == 1 ||
1987 && parent_ref->u.c.component->pointer))
1988 && is_scalar_expr_ptr (args->expr) != SUCCESS)
1990 /* Case 1c, section 15.1.2.5, J3/04-007: an associated
1992 gfc_error_now ("Argument '%s' to '%s' at %L must be an "
1993 "associated scalar POINTER", args_sym->name,
1994 sym->name, &(args->expr->where));
2000 /* The parameter is not required to be C interoperable. If it
2001 is not C interoperable, it must be a nonpolymorphic scalar
2002 with no length type parameters. It still must have either
2003 the pointer or target attribute, and it can be
2004 allocatable (but must be allocated when c_loc is called). */
2005 if (args->expr->rank != 0
2006 && is_scalar_expr_ptr (args->expr) != SUCCESS)
2008 gfc_error_now ("Parameter '%s' to '%s' at %L must be a "
2009 "scalar", args_sym->name, sym->name,
2010 &(args->expr->where));
2013 else if (arg_ts->type == BT_CHARACTER
2014 && is_scalar_expr_ptr (args->expr) != SUCCESS)
2016 gfc_error_now ("CHARACTER argument '%s' to '%s' at "
2017 "%L must have a length of 1",
2018 args_sym->name, sym->name,
2019 &(args->expr->where));
2024 else if (sym->intmod_sym_id == ISOCBINDING_FUNLOC)
2026 if (args_sym->attr.flavor != FL_PROCEDURE)
2028 /* TODO: Update this error message to allow for procedure
2029 pointers once they are implemented. */
2030 gfc_error_now ("Parameter '%s' to '%s' at %L must be a "
2032 args_sym->name, sym->name,
2033 &(args->expr->where));
2036 else if (args_sym->attr.is_bind_c != 1)
2038 gfc_error_now ("Parameter '%s' to '%s' at %L must be "
2040 args_sym->name, sym->name,
2041 &(args->expr->where));
2046 /* for c_loc/c_funloc, the new symbol is the same as the old one */
2051 gfc_internal_error ("gfc_iso_c_func_interface(): Unhandled "
2052 "iso_c_binding function: '%s'!\n", sym->name);
2059 /* Resolve a function call, which means resolving the arguments, then figuring
2060 out which entity the name refers to. */
2061 /* TODO: Check procedure arguments so that an INTENT(IN) isn't passed
2062 to INTENT(OUT) or INTENT(INOUT). */
2065 resolve_function (gfc_expr *expr)
2067 gfc_actual_arglist *arg;
2072 procedure_type p = PROC_INTRINSIC;
2076 sym = expr->symtree->n.sym;
2078 if (sym && sym->attr.flavor == FL_VARIABLE)
2080 gfc_error ("'%s' at %L is not a function", sym->name, &expr->where);
2084 if (sym && sym->attr.abstract)
2086 gfc_error ("ABSTRACT INTERFACE '%s' must not be referenced at %L",
2087 sym->name, &expr->where);
2091 /* If the procedure is external, check for usage. */
2092 if (sym && is_external_proc (sym))
2093 resolve_global_procedure (sym, &expr->where, 0);
2095 /* Switch off assumed size checking and do this again for certain kinds
2096 of procedure, once the procedure itself is resolved. */
2097 need_full_assumed_size++;
2099 if (expr->symtree && expr->symtree->n.sym)
2100 p = expr->symtree->n.sym->attr.proc;
2102 if (resolve_actual_arglist (expr->value.function.actual, p) == FAILURE)
2105 /* Need to setup the call to the correct c_associated, depending on
2106 the number of cptrs to user gives to compare. */
2107 if (sym && sym->attr.is_iso_c == 1)
2109 if (gfc_iso_c_func_interface (sym, expr->value.function.actual, &sym)
2113 /* Get the symtree for the new symbol (resolved func).
2114 the old one will be freed later, when it's no longer used. */
2115 gfc_find_sym_tree (sym->name, sym->ns, 1, &(expr->symtree));
2118 /* Resume assumed_size checking. */
2119 need_full_assumed_size--;
2121 if (sym && sym->ts.type == BT_CHARACTER
2123 && sym->ts.cl->length == NULL
2125 && expr->value.function.esym == NULL
2126 && !sym->attr.contained)
2128 /* Internal procedures are taken care of in resolve_contained_fntype. */
2129 gfc_error ("Function '%s' is declared CHARACTER(*) and cannot "
2130 "be used at %L since it is not a dummy argument",
2131 sym->name, &expr->where);
2135 /* See if function is already resolved. */
2137 if (expr->value.function.name != NULL)
2139 if (expr->ts.type == BT_UNKNOWN)
2145 /* Apply the rules of section 14.1.2. */
2147 switch (procedure_kind (sym))
2150 t = resolve_generic_f (expr);
2153 case PTYPE_SPECIFIC:
2154 t = resolve_specific_f (expr);
2158 t = resolve_unknown_f (expr);
2162 gfc_internal_error ("resolve_function(): bad function type");
2166 /* If the expression is still a function (it might have simplified),
2167 then we check to see if we are calling an elemental function. */
2169 if (expr->expr_type != EXPR_FUNCTION)
2172 temp = need_full_assumed_size;
2173 need_full_assumed_size = 0;
2175 if (resolve_elemental_actual (expr, NULL) == FAILURE)
2178 if (omp_workshare_flag
2179 && expr->value.function.esym
2180 && ! gfc_elemental (expr->value.function.esym))
2182 gfc_error ("User defined non-ELEMENTAL function '%s' at %L not allowed "
2183 "in WORKSHARE construct", expr->value.function.esym->name,
2188 #define GENERIC_ID expr->value.function.isym->id
2189 else if (expr->value.function.actual != NULL
2190 && expr->value.function.isym != NULL
2191 && GENERIC_ID != GFC_ISYM_LBOUND
2192 && GENERIC_ID != GFC_ISYM_LEN
2193 && GENERIC_ID != GFC_ISYM_LOC
2194 && GENERIC_ID != GFC_ISYM_PRESENT)
2196 /* Array intrinsics must also have the last upper bound of an
2197 assumed size array argument. UBOUND and SIZE have to be
2198 excluded from the check if the second argument is anything
2201 inquiry = GENERIC_ID == GFC_ISYM_UBOUND
2202 || GENERIC_ID == GFC_ISYM_SIZE;
2204 for (arg = expr->value.function.actual; arg; arg = arg->next)
2206 if (inquiry && arg->next != NULL && arg->next->expr)
2208 if (arg->next->expr->expr_type != EXPR_CONSTANT)
2211 if ((int)mpz_get_si (arg->next->expr->value.integer)
2216 if (arg->expr != NULL
2217 && arg->expr->rank > 0
2218 && resolve_assumed_size_actual (arg->expr))
2224 need_full_assumed_size = temp;
2227 if (!pure_function (expr, &name) && name)
2231 gfc_error ("reference to non-PURE function '%s' at %L inside a "
2232 "FORALL %s", name, &expr->where,
2233 forall_flag == 2 ? "mask" : "block");
2236 else if (gfc_pure (NULL))
2238 gfc_error ("Function reference to '%s' at %L is to a non-PURE "
2239 "procedure within a PURE procedure", name, &expr->where);
2244 /* Functions without the RECURSIVE attribution are not allowed to
2245 * call themselves. */
2246 if (expr->value.function.esym && !expr->value.function.esym->attr.recursive)
2248 gfc_symbol *esym, *proc;
2249 esym = expr->value.function.esym;
2250 proc = gfc_current_ns->proc_name;
2253 gfc_error ("Function '%s' at %L cannot call itself, as it is not "
2254 "RECURSIVE", name, &expr->where);
2258 if (esym->attr.entry && esym->ns->entries && proc->ns->entries
2259 && esym->ns->entries->sym == proc->ns->entries->sym)
2261 gfc_error ("Call to ENTRY '%s' at %L is recursive, but function "
2262 "'%s' is not declared as RECURSIVE",
2263 esym->name, &expr->where, esym->ns->entries->sym->name);
2268 /* Character lengths of use associated functions may contains references to
2269 symbols not referenced from the current program unit otherwise. Make sure
2270 those symbols are marked as referenced. */
2272 if (expr->ts.type == BT_CHARACTER && expr->value.function.esym
2273 && expr->value.function.esym->attr.use_assoc)
2275 gfc_expr_set_symbols_referenced (expr->ts.cl->length);
2279 find_noncopying_intrinsics (expr->value.function.esym,
2280 expr->value.function.actual);
2282 /* Make sure that the expression has a typespec that works. */
2283 if (expr->ts.type == BT_UNKNOWN)
2285 if (expr->symtree->n.sym->result
2286 && expr->symtree->n.sym->result->ts.type != BT_UNKNOWN)
2287 expr->ts = expr->symtree->n.sym->result->ts;
2294 /************* Subroutine resolution *************/
2297 pure_subroutine (gfc_code *c, gfc_symbol *sym)
2303 gfc_error ("Subroutine call to '%s' in FORALL block at %L is not PURE",
2304 sym->name, &c->loc);
2305 else if (gfc_pure (NULL))
2306 gfc_error ("Subroutine call to '%s' at %L is not PURE", sym->name,
2312 resolve_generic_s0 (gfc_code *c, gfc_symbol *sym)
2316 if (sym->attr.generic)
2318 s = gfc_search_interface (sym->generic, 1, &c->ext.actual);
2321 c->resolved_sym = s;
2322 pure_subroutine (c, s);
2326 /* TODO: Need to search for elemental references in generic interface. */
2329 if (sym->attr.intrinsic)
2330 return gfc_intrinsic_sub_interface (c, 0);
2337 resolve_generic_s (gfc_code *c)
2342 sym = c->symtree->n.sym;
2346 m = resolve_generic_s0 (c, sym);
2349 else if (m == MATCH_ERROR)
2353 if (sym->ns->parent == NULL)
2355 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
2359 if (!generic_sym (sym))
2363 /* Last ditch attempt. See if the reference is to an intrinsic
2364 that possesses a matching interface. 14.1.2.4 */
2365 sym = c->symtree->n.sym;
2367 if (!gfc_intrinsic_name (sym->name, 1))
2369 gfc_error ("There is no specific subroutine for the generic '%s' at %L",
2370 sym->name, &c->loc);
2374 m = gfc_intrinsic_sub_interface (c, 0);
2378 gfc_error ("Generic subroutine '%s' at %L is not consistent with an "
2379 "intrinsic subroutine interface", sym->name, &c->loc);
2385 /* Set the name and binding label of the subroutine symbol in the call
2386 expression represented by 'c' to include the type and kind of the
2387 second parameter. This function is for resolving the appropriate
2388 version of c_f_pointer() and c_f_procpointer(). For example, a
2389 call to c_f_pointer() for a default integer pointer could have a
2390 name of c_f_pointer_i4. If no second arg exists, which is an error
2391 for these two functions, it defaults to the generic symbol's name
2392 and binding label. */
2395 set_name_and_label (gfc_code *c, gfc_symbol *sym,
2396 char *name, char *binding_label)
2398 gfc_expr *arg = NULL;
2402 /* The second arg of c_f_pointer and c_f_procpointer determines
2403 the type and kind for the procedure name. */
2404 arg = c->ext.actual->next->expr;
2408 /* Set up the name to have the given symbol's name,
2409 plus the type and kind. */
2410 /* a derived type is marked with the type letter 'u' */
2411 if (arg->ts.type == BT_DERIVED)
2414 kind = 0; /* set the kind as 0 for now */
2418 type = gfc_type_letter (arg->ts.type);
2419 kind = arg->ts.kind;
2422 if (arg->ts.type == BT_CHARACTER)
2423 /* Kind info for character strings not needed. */
2426 sprintf (name, "%s_%c%d", sym->name, type, kind);
2427 /* Set up the binding label as the given symbol's label plus
2428 the type and kind. */
2429 sprintf (binding_label, "%s_%c%d", sym->binding_label, type, kind);
2433 /* If the second arg is missing, set the name and label as
2434 was, cause it should at least be found, and the missing
2435 arg error will be caught by compare_parameters(). */
2436 sprintf (name, "%s", sym->name);
2437 sprintf (binding_label, "%s", sym->binding_label);
2444 /* Resolve a generic version of the iso_c_binding procedure given
2445 (sym) to the specific one based on the type and kind of the
2446 argument(s). Currently, this function resolves c_f_pointer() and
2447 c_f_procpointer based on the type and kind of the second argument
2448 (FPTR). Other iso_c_binding procedures aren't specially handled.
2449 Upon successfully exiting, c->resolved_sym will hold the resolved
2450 symbol. Returns MATCH_ERROR if an error occurred; MATCH_YES
2454 gfc_iso_c_sub_interface (gfc_code *c, gfc_symbol *sym)
2456 gfc_symbol *new_sym;
2457 /* this is fine, since we know the names won't use the max */
2458 char name[GFC_MAX_SYMBOL_LEN + 1];
2459 char binding_label[GFC_MAX_BINDING_LABEL_LEN + 1];
2460 /* default to success; will override if find error */
2461 match m = MATCH_YES;
2463 /* Make sure the actual arguments are in the necessary order (based on the
2464 formal args) before resolving. */
2465 gfc_procedure_use (sym, &c->ext.actual, &(c->loc));
2467 if ((sym->intmod_sym_id == ISOCBINDING_F_POINTER) ||
2468 (sym->intmod_sym_id == ISOCBINDING_F_PROCPOINTER))
2470 set_name_and_label (c, sym, name, binding_label);
2472 if (sym->intmod_sym_id == ISOCBINDING_F_POINTER)
2474 if (c->ext.actual != NULL && c->ext.actual->next != NULL)
2476 /* Make sure we got a third arg if the second arg has non-zero
2477 rank. We must also check that the type and rank are
2478 correct since we short-circuit this check in
2479 gfc_procedure_use() (called above to sort actual args). */
2480 if (c->ext.actual->next->expr->rank != 0)
2482 if(c->ext.actual->next->next == NULL
2483 || c->ext.actual->next->next->expr == NULL)
2486 gfc_error ("Missing SHAPE parameter for call to %s "
2487 "at %L", sym->name, &(c->loc));
2489 else if (c->ext.actual->next->next->expr->ts.type
2491 || c->ext.actual->next->next->expr->rank != 1)
2494 gfc_error ("SHAPE parameter for call to %s at %L must "
2495 "be a rank 1 INTEGER array", sym->name,
2502 if (m != MATCH_ERROR)
2504 /* the 1 means to add the optional arg to formal list */
2505 new_sym = get_iso_c_sym (sym, name, binding_label, 1);
2507 /* for error reporting, say it's declared where the original was */
2508 new_sym->declared_at = sym->declared_at;
2513 /* no differences for c_loc or c_funloc */
2517 /* set the resolved symbol */
2518 if (m != MATCH_ERROR)
2519 c->resolved_sym = new_sym;
2521 c->resolved_sym = sym;
2527 /* Resolve a subroutine call known to be specific. */
2530 resolve_specific_s0 (gfc_code *c, gfc_symbol *sym)
2534 /* See if we have an intrinsic interface. */
2535 if (sym->interface != NULL && !sym->interface->attr.abstract
2536 && !sym->interface->attr.subroutine)
2538 gfc_intrinsic_sym *isym;
2540 isym = gfc_find_function (sym->interface->name);
2542 /* Existance of isym should be checked already. */
2546 sym->attr.function = 1;
2550 if(sym->attr.is_iso_c)
2552 m = gfc_iso_c_sub_interface (c,sym);
2556 if (sym->attr.external || sym->attr.if_source == IFSRC_IFBODY)
2558 if (sym->attr.dummy)
2560 sym->attr.proc = PROC_DUMMY;
2564 sym->attr.proc = PROC_EXTERNAL;
2568 if (sym->attr.proc == PROC_MODULE || sym->attr.proc == PROC_INTERNAL)
2571 if (sym->attr.intrinsic)
2573 m = gfc_intrinsic_sub_interface (c, 1);
2577 gfc_error ("Subroutine '%s' at %L is INTRINSIC but is not compatible "
2578 "with an intrinsic", sym->name, &c->loc);
2586 gfc_procedure_use (sym, &c->ext.actual, &c->loc);
2588 c->resolved_sym = sym;
2589 pure_subroutine (c, sym);
2596 resolve_specific_s (gfc_code *c)
2601 sym = c->symtree->n.sym;
2605 m = resolve_specific_s0 (c, sym);
2608 if (m == MATCH_ERROR)
2611 if (sym->ns->parent == NULL)
2614 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
2620 sym = c->symtree->n.sym;
2621 gfc_error ("Unable to resolve the specific subroutine '%s' at %L",
2622 sym->name, &c->loc);
2628 /* Resolve a subroutine call not known to be generic nor specific. */
2631 resolve_unknown_s (gfc_code *c)
2635 sym = c->symtree->n.sym;
2637 if (sym->attr.dummy)
2639 sym->attr.proc = PROC_DUMMY;
2643 /* See if we have an intrinsic function reference. */
2645 if (gfc_intrinsic_name (sym->name, 1))
2647 if (gfc_intrinsic_sub_interface (c, 1) == MATCH_YES)
2652 /* The reference is to an external name. */
2655 gfc_procedure_use (sym, &c->ext.actual, &c->loc);
2657 c->resolved_sym = sym;
2659 pure_subroutine (c, sym);
2665 /* Resolve a subroutine call. Although it was tempting to use the same code
2666 for functions, subroutines and functions are stored differently and this
2667 makes things awkward. */
2670 resolve_call (gfc_code *c)
2673 procedure_type ptype = PROC_INTRINSIC;
2675 if (c->symtree && c->symtree->n.sym
2676 && c->symtree->n.sym->ts.type != BT_UNKNOWN)
2678 gfc_error ("'%s' at %L has a type, which is not consistent with "
2679 "the CALL at %L", c->symtree->n.sym->name,
2680 &c->symtree->n.sym->declared_at, &c->loc);
2684 /* If external, check for usage. */
2685 if (c->symtree && is_external_proc (c->symtree->n.sym))
2686 resolve_global_procedure (c->symtree->n.sym, &c->loc, 1);
2688 /* Subroutines without the RECURSIVE attribution are not allowed to
2689 * call themselves. */
2690 if (c->symtree && c->symtree->n.sym && !c->symtree->n.sym->attr.recursive)
2692 gfc_symbol *csym, *proc;
2693 csym = c->symtree->n.sym;
2694 proc = gfc_current_ns->proc_name;
2697 gfc_error ("SUBROUTINE '%s' at %L cannot call itself, as it is not "
2698 "RECURSIVE", csym->name, &c->loc);
2702 if (csym->attr.entry && csym->ns->entries && proc->ns->entries
2703 && csym->ns->entries->sym == proc->ns->entries->sym)
2705 gfc_error ("Call to ENTRY '%s' at %L is recursive, but subroutine "
2706 "'%s' is not declared as RECURSIVE",
2707 csym->name, &c->loc, csym->ns->entries->sym->name);
2712 /* Switch off assumed size checking and do this again for certain kinds
2713 of procedure, once the procedure itself is resolved. */
2714 need_full_assumed_size++;
2716 if (c->symtree && c->symtree->n.sym)
2717 ptype = c->symtree->n.sym->attr.proc;
2719 if (resolve_actual_arglist (c->ext.actual, ptype) == FAILURE)
2722 /* Resume assumed_size checking. */
2723 need_full_assumed_size--;
2726 if (c->resolved_sym == NULL)
2727 switch (procedure_kind (c->symtree->n.sym))
2730 t = resolve_generic_s (c);
2733 case PTYPE_SPECIFIC:
2734 t = resolve_specific_s (c);
2738 t = resolve_unknown_s (c);
2742 gfc_internal_error ("resolve_subroutine(): bad function type");
2745 /* Some checks of elemental subroutine actual arguments. */
2746 if (resolve_elemental_actual (NULL, c) == FAILURE)
2750 find_noncopying_intrinsics (c->resolved_sym, c->ext.actual);
2755 /* Compare the shapes of two arrays that have non-NULL shapes. If both
2756 op1->shape and op2->shape are non-NULL return SUCCESS if their shapes
2757 match. If both op1->shape and op2->shape are non-NULL return FAILURE
2758 if their shapes do not match. If either op1->shape or op2->shape is
2759 NULL, return SUCCESS. */
2762 compare_shapes (gfc_expr *op1, gfc_expr *op2)
2769 if (op1->shape != NULL && op2->shape != NULL)
2771 for (i = 0; i < op1->rank; i++)
2773 if (mpz_cmp (op1->shape[i], op2->shape[i]) != 0)
2775 gfc_error ("Shapes for operands at %L and %L are not conformable",
2776 &op1->where, &op2->where);
2787 /* Resolve an operator expression node. This can involve replacing the
2788 operation with a user defined function call. */
2791 resolve_operator (gfc_expr *e)
2793 gfc_expr *op1, *op2;
2795 bool dual_locus_error;
2798 /* Resolve all subnodes-- give them types. */
2800 switch (e->value.op.operator)
2803 if (gfc_resolve_expr (e->value.op.op2) == FAILURE)
2806 /* Fall through... */
2809 case INTRINSIC_UPLUS:
2810 case INTRINSIC_UMINUS:
2811 case INTRINSIC_PARENTHESES:
2812 if (gfc_resolve_expr (e->value.op.op1) == FAILURE)
2817 /* Typecheck the new node. */
2819 op1 = e->value.op.op1;
2820 op2 = e->value.op.op2;
2821 dual_locus_error = false;
2823 if ((op1 && op1->expr_type == EXPR_NULL)
2824 || (op2 && op2->expr_type == EXPR_NULL))
2826 sprintf (msg, _("Invalid context for NULL() pointer at %%L"));
2830 switch (e->value.op.operator)
2832 case INTRINSIC_UPLUS:
2833 case INTRINSIC_UMINUS:
2834 if (op1->ts.type == BT_INTEGER
2835 || op1->ts.type == BT_REAL
2836 || op1->ts.type == BT_COMPLEX)
2842 sprintf (msg, _("Operand of unary numeric operator '%s' at %%L is %s"),
2843 gfc_op2string (e->value.op.operator), gfc_typename (&e->ts));
2846 case INTRINSIC_PLUS:
2847 case INTRINSIC_MINUS:
2848 case INTRINSIC_TIMES:
2849 case INTRINSIC_DIVIDE:
2850 case INTRINSIC_POWER:
2851 if (gfc_numeric_ts (&op1->ts) && gfc_numeric_ts (&op2->ts))
2853 gfc_type_convert_binary (e);
2858 _("Operands of binary numeric operator '%s' at %%L are %s/%s"),
2859 gfc_op2string (e->value.op.operator), gfc_typename (&op1->ts),
2860 gfc_typename (&op2->ts));
2863 case INTRINSIC_CONCAT:
2864 if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER)
2866 e->ts.type = BT_CHARACTER;
2867 e->ts.kind = op1->ts.kind;
2872 _("Operands of string concatenation operator at %%L are %s/%s"),
2873 gfc_typename (&op1->ts), gfc_typename (&op2->ts));
2879 case INTRINSIC_NEQV:
2880 if (op1->ts.type == BT_LOGICAL && op2->ts.type == BT_LOGICAL)
2882 e->ts.type = BT_LOGICAL;
2883 e->ts.kind = gfc_kind_max (op1, op2);
2884 if (op1->ts.kind < e->ts.kind)
2885 gfc_convert_type (op1, &e->ts, 2);
2886 else if (op2->ts.kind < e->ts.kind)
2887 gfc_convert_type (op2, &e->ts, 2);
2891 sprintf (msg, _("Operands of logical operator '%s' at %%L are %s/%s"),
2892 gfc_op2string (e->value.op.operator), gfc_typename (&op1->ts),
2893 gfc_typename (&op2->ts));
2898 if (op1->ts.type == BT_LOGICAL)
2900 e->ts.type = BT_LOGICAL;
2901 e->ts.kind = op1->ts.kind;
2905 sprintf (msg, _("Operand of .not. operator at %%L is %s"),
2906 gfc_typename (&op1->ts));
2910 case INTRINSIC_GT_OS:
2912 case INTRINSIC_GE_OS:
2914 case INTRINSIC_LT_OS:
2916 case INTRINSIC_LE_OS:
2917 if (op1->ts.type == BT_COMPLEX || op2->ts.type == BT_COMPLEX)
2919 strcpy (msg, _("COMPLEX quantities cannot be compared at %L"));
2923 /* Fall through... */
2926 case INTRINSIC_EQ_OS:
2928 case INTRINSIC_NE_OS:
2929 if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER)
2931 e->ts.type = BT_LOGICAL;
2932 e->ts.kind = gfc_default_logical_kind;
2936 if (gfc_numeric_ts (&op1->ts) && gfc_numeric_ts (&op2->ts))
2938 gfc_type_convert_binary (e);
2940 e->ts.type = BT_LOGICAL;
2941 e->ts.kind = gfc_default_logical_kind;
2945 if (op1->ts.type == BT_LOGICAL && op2->ts.type == BT_LOGICAL)
2947 _("Logicals at %%L must be compared with %s instead of %s"),
2948 (e->value.op.operator == INTRINSIC_EQ
2949 || e->value.op.operator == INTRINSIC_EQ_OS)
2950 ? ".eqv." : ".neqv.", gfc_op2string (e->value.op.operator));
2953 _("Operands of comparison operator '%s' at %%L are %s/%s"),
2954 gfc_op2string (e->value.op.operator), gfc_typename (&op1->ts),
2955 gfc_typename (&op2->ts));
2959 case INTRINSIC_USER:
2960 if (e->value.op.uop->operator == NULL)
2961 sprintf (msg, _("Unknown operator '%s' at %%L"), e->value.op.uop->name);
2962 else if (op2 == NULL)
2963 sprintf (msg, _("Operand of user operator '%s' at %%L is %s"),
2964 e->value.op.uop->name, gfc_typename (&op1->ts));
2966 sprintf (msg, _("Operands of user operator '%s' at %%L are %s/%s"),
2967 e->value.op.uop->name, gfc_typename (&op1->ts),
2968 gfc_typename (&op2->ts));
2972 case INTRINSIC_PARENTHESES:
2974 if (e->ts.type == BT_CHARACTER)
2975 e->ts.cl = op1->ts.cl;
2979 gfc_internal_error ("resolve_operator(): Bad intrinsic");
2982 /* Deal with arrayness of an operand through an operator. */
2986 switch (e->value.op.operator)
2988 case INTRINSIC_PLUS:
2989 case INTRINSIC_MINUS:
2990 case INTRINSIC_TIMES:
2991 case INTRINSIC_DIVIDE:
2992 case INTRINSIC_POWER:
2993 case INTRINSIC_CONCAT:
2997 case INTRINSIC_NEQV:
2999 case INTRINSIC_EQ_OS:
3001 case INTRINSIC_NE_OS:
3003 case INTRINSIC_GT_OS:
3005 case INTRINSIC_GE_OS:
3007 case INTRINSIC_LT_OS:
3009 case INTRINSIC_LE_OS:
3011 if (op1->rank == 0 && op2->rank == 0)
3014 if (op1->rank == 0 && op2->rank != 0)
3016 e->rank = op2->rank;
3018 if (e->shape == NULL)
3019 e->shape = gfc_copy_shape (op2->shape, op2->rank);
3022 if (op1->rank != 0 && op2->rank == 0)
3024 e->rank = op1->rank;
3026 if (e->shape == NULL)
3027 e->shape = gfc_copy_shape (op1->shape, op1->rank);
3030 if (op1->rank != 0 && op2->rank != 0)
3032 if (op1->rank == op2->rank)
3034 e->rank = op1->rank;
3035 if (e->shape == NULL)
3037 t = compare_shapes(op1, op2);
3041 e->shape = gfc_copy_shape (op1->shape, op1->rank);
3046 /* Allow higher level expressions to work. */
3049 /* Try user-defined operators, and otherwise throw an error. */
3050 dual_locus_error = true;
3052 _("Inconsistent ranks for operator at %%L and %%L"));
3059 case INTRINSIC_PARENTHESES:
3061 case INTRINSIC_UPLUS:
3062 case INTRINSIC_UMINUS:
3063 /* Simply copy arrayness attribute */
3064 e->rank = op1->rank;
3066 if (e->shape == NULL)
3067 e->shape = gfc_copy_shape (op1->shape, op1->rank);
3075 /* Attempt to simplify the expression. */
3078 t = gfc_simplify_expr (e, 0);
3079 /* Some calls do not succeed in simplification and return FAILURE
3080 even though there is no error; eg. variable references to
3081 PARAMETER arrays. */
3082 if (!gfc_is_constant_expr (e))
3089 if (gfc_extend_expr (e) == SUCCESS)
3092 if (dual_locus_error)
3093 gfc_error (msg, &op1->where, &op2->where);
3095 gfc_error (msg, &e->where);
3101 /************** Array resolution subroutines **************/
3104 { CMP_LT, CMP_EQ, CMP_GT, CMP_UNKNOWN }
3107 /* Compare two integer expressions. */
3110 compare_bound (gfc_expr *a, gfc_expr *b)
3114 if (a == NULL || a->expr_type != EXPR_CONSTANT
3115 || b == NULL || b->expr_type != EXPR_CONSTANT)
3118 if (a->ts.type != BT_INTEGER || b->ts.type != BT_INTEGER)
3119 gfc_internal_error ("compare_bound(): Bad expression");
3121 i = mpz_cmp (a->value.integer, b->value.integer);
3131 /* Compare an integer expression with an integer. */
3134 compare_bound_int (gfc_expr *a, int b)
3138 if (a == NULL || a->expr_type != EXPR_CONSTANT)
3141 if (a->ts.type != BT_INTEGER)
3142 gfc_internal_error ("compare_bound_int(): Bad expression");
3144 i = mpz_cmp_si (a->value.integer, b);
3154 /* Compare an integer expression with a mpz_t. */
3157 compare_bound_mpz_t (gfc_expr *a, mpz_t b)
3161 if (a == NULL || a->expr_type != EXPR_CONSTANT)
3164 if (a->ts.type != BT_INTEGER)
3165 gfc_internal_error ("compare_bound_int(): Bad expression");
3167 i = mpz_cmp (a->value.integer, b);
3177 /* Compute the last value of a sequence given by a triplet.
3178 Return 0 if it wasn't able to compute the last value, or if the
3179 sequence if empty, and 1 otherwise. */
3182 compute_last_value_for_triplet (gfc_expr *start, gfc_expr *end,
3183 gfc_expr *stride, mpz_t last)
3187 if (start == NULL || start->expr_type != EXPR_CONSTANT
3188 || end == NULL || end->expr_type != EXPR_CONSTANT
3189 || (stride != NULL && stride->expr_type != EXPR_CONSTANT))
3192 if (start->ts.type != BT_INTEGER || end->ts.type != BT_INTEGER
3193 || (stride != NULL && stride->ts.type != BT_INTEGER))
3196 if (stride == NULL || compare_bound_int(stride, 1) == CMP_EQ)
3198 if (compare_bound (start, end) == CMP_GT)
3200 mpz_set (last, end->value.integer);
3204 if (compare_bound_int (stride, 0) == CMP_GT)
3206 /* Stride is positive */
3207 if (mpz_cmp (start->value.integer, end->value.integer) > 0)
3212 /* Stride is negative */
3213 if (mpz_cmp (start->value.integer, end->value.integer) < 0)
3218 mpz_sub (rem, end->value.integer, start->value.integer);
3219 mpz_tdiv_r (rem, rem, stride->value.integer);
3220 mpz_sub (last, end->value.integer, rem);
3227 /* Compare a single dimension of an array reference to the array
3231 check_dimension (int i, gfc_array_ref *ar, gfc_array_spec *as)
3235 /* Given start, end and stride values, calculate the minimum and
3236 maximum referenced indexes. */
3238 switch (ar->dimen_type[i])
3244 if (compare_bound (ar->start[i], as->lower[i]) == CMP_LT)
3246 gfc_warning ("Array reference at %L is out of bounds "
3247 "(%ld < %ld) in dimension %d", &ar->c_where[i],
3248 mpz_get_si (ar->start[i]->value.integer),
3249 mpz_get_si (as->lower[i]->value.integer), i+1);
3252 if (compare_bound (ar->start[i], as->upper[i]) == CMP_GT)
3254 gfc_warning ("Array reference at %L is out of bounds "
3255 "(%ld > %ld) in dimension %d", &ar->c_where[i],
3256 mpz_get_si (ar->start[i]->value.integer),
3257 mpz_get_si (as->upper[i]->value.integer), i+1);
3265 #define AR_START (ar->start[i] ? ar->start[i] : as->lower[i])
3266 #define AR_END (ar->end[i] ? ar->end[i] : as->upper[i])
3268 comparison comp_start_end = compare_bound (AR_START, AR_END);
3270 /* Check for zero stride, which is not allowed. */
3271 if (compare_bound_int (ar->stride[i], 0) == CMP_EQ)
3273 gfc_error ("Illegal stride of zero at %L", &ar->c_where[i]);
3277 /* if start == len || (stride > 0 && start < len)
3278 || (stride < 0 && start > len),
3279 then the array section contains at least one element. In this
3280 case, there is an out-of-bounds access if
3281 (start < lower || start > upper). */
3282 if (compare_bound (AR_START, AR_END) == CMP_EQ
3283 || ((compare_bound_int (ar->stride[i], 0) == CMP_GT
3284 || ar->stride[i] == NULL) && comp_start_end == CMP_LT)
3285 || (compare_bound_int (ar->stride[i], 0) == CMP_LT
3286 && comp_start_end == CMP_GT))
3288 if (compare_bound (AR_START, as->lower[i]) == CMP_LT)
3290 gfc_warning ("Lower array reference at %L is out of bounds "
3291 "(%ld < %ld) in dimension %d", &ar->c_where[i],
3292 mpz_get_si (AR_START->value.integer),
3293 mpz_get_si (as->lower[i]->value.integer), i+1);
3296 if (compare_bound (AR_START, as->upper[i]) == CMP_GT)
3298 gfc_warning ("Lower array reference at %L is out of bounds "
3299 "(%ld > %ld) in dimension %d", &ar->c_where[i],
3300 mpz_get_si (AR_START->value.integer),
3301 mpz_get_si (as->upper[i]->value.integer), i+1);
3306 /* If we can compute the highest index of the array section,
3307 then it also has to be between lower and upper. */
3308 mpz_init (last_value);
3309 if (compute_last_value_for_triplet (AR_START, AR_END, ar->stride[i],
3312 if (compare_bound_mpz_t (as->lower[i], last_value) == CMP_GT)
3314 gfc_warning ("Upper array reference at %L is out of bounds "
3315 "(%ld < %ld) in dimension %d", &ar->c_where[i],
3316 mpz_get_si (last_value),
3317 mpz_get_si (as->lower[i]->value.integer), i+1);
3318 mpz_clear (last_value);
3321 if (compare_bound_mpz_t (as->upper[i], last_value) == CMP_LT)
3323 gfc_warning ("Upper array reference at %L is out of bounds "
3324 "(%ld > %ld) in dimension %d", &ar->c_where[i],
3325 mpz_get_si (last_value),
3326 mpz_get_si (as->upper[i]->value.integer), i+1);
3327 mpz_clear (last_value);
3331 mpz_clear (last_value);
3339 gfc_internal_error ("check_dimension(): Bad array reference");
3346 /* Compare an array reference with an array specification. */
3349 compare_spec_to_ref (gfc_array_ref *ar)
3356 /* TODO: Full array sections are only allowed as actual parameters. */
3357 if (as->type == AS_ASSUMED_SIZE
3358 && (/*ar->type == AR_FULL
3359 ||*/ (ar->type == AR_SECTION
3360 && ar->dimen_type[i] == DIMEN_RANGE && ar->end[i] == NULL)))
3362 gfc_error ("Rightmost upper bound of assumed size array section "
3363 "not specified at %L", &ar->where);
3367 if (ar->type == AR_FULL)
3370 if (as->rank != ar->dimen)
3372 gfc_error ("Rank mismatch in array reference at %L (%d/%d)",
3373 &ar->where, ar->dimen, as->rank);
3377 for (i = 0; i < as->rank; i++)
3378 if (check_dimension (i, ar, as) == FAILURE)
3385 /* Resolve one part of an array index. */
3388 gfc_resolve_index (gfc_expr *index, int check_scalar)
3395 if (gfc_resolve_expr (index) == FAILURE)
3398 if (check_scalar && index->rank != 0)
3400 gfc_error ("Array index at %L must be scalar", &index->where);
3404 if (index->ts.type != BT_INTEGER && index->ts.type != BT_REAL)
3406 gfc_error ("Array index at %L must be of INTEGER type",
3411 if (index->ts.type == BT_REAL)
3412 if (gfc_notify_std (GFC_STD_LEGACY, "Extension: REAL array index at %L",
3413 &index->where) == FAILURE)
3416 if (index->ts.kind != gfc_index_integer_kind
3417 || index->ts.type != BT_INTEGER)
3420 ts.type = BT_INTEGER;
3421 ts.kind = gfc_index_integer_kind;
3423 gfc_convert_type_warn (index, &ts, 2, 0);
3429 /* Resolve a dim argument to an intrinsic function. */
3432 gfc_resolve_dim_arg (gfc_expr *dim)
3437 if (gfc_resolve_expr (dim) == FAILURE)
3442 gfc_error ("Argument dim at %L must be scalar", &dim->where);
3446 if (dim->ts.type != BT_INTEGER)
3448 gfc_error ("Argument dim at %L must be of INTEGER type", &dim->where);
3451 if (dim->ts.kind != gfc_index_integer_kind)
3455 ts.type = BT_INTEGER;
3456 ts.kind = gfc_index_integer_kind;
3458 gfc_convert_type_warn (dim, &ts, 2, 0);
3464 /* Given an expression that contains array references, update those array
3465 references to point to the right array specifications. While this is
3466 filled in during matching, this information is difficult to save and load
3467 in a module, so we take care of it here.
3469 The idea here is that the original array reference comes from the
3470 base symbol. We traverse the list of reference structures, setting
3471 the stored reference to references. Component references can
3472 provide an additional array specification. */
3475 find_array_spec (gfc_expr *e)
3479 gfc_symbol *derived;
3482 as = e->symtree->n.sym->as;
3485 for (ref = e->ref; ref; ref = ref->next)
3490 gfc_internal_error ("find_array_spec(): Missing spec");
3497 if (derived == NULL)
3498 derived = e->symtree->n.sym->ts.derived;
3500 c = derived->components;
3502 for (; c; c = c->next)
3503 if (c == ref->u.c.component)
3505 /* Track the sequence of component references. */
3506 if (c->ts.type == BT_DERIVED)
3507 derived = c->ts.derived;
3512 gfc_internal_error ("find_array_spec(): Component not found");
3517 gfc_internal_error ("find_array_spec(): unused as(1)");
3528 gfc_internal_error ("find_array_spec(): unused as(2)");
3532 /* Resolve an array reference. */
3535 resolve_array_ref (gfc_array_ref *ar)
3537 int i, check_scalar;
3540 for (i = 0; i < ar->dimen; i++)
3542 check_scalar = ar->dimen_type[i] == DIMEN_RANGE;
3544 if (gfc_resolve_index (ar->start[i], check_scalar) == FAILURE)
3546 if (gfc_resolve_index (ar->end[i], check_scalar) == FAILURE)
3548 if (gfc_resolve_index (ar->stride[i], check_scalar) == FAILURE)
3553 if (ar->dimen_type[i] == DIMEN_UNKNOWN)
3557 ar->dimen_type[i] = DIMEN_ELEMENT;
3561 ar->dimen_type[i] = DIMEN_VECTOR;
3562 if (e->expr_type == EXPR_VARIABLE
3563 && e->symtree->n.sym->ts.type == BT_DERIVED)
3564 ar->start[i] = gfc_get_parentheses (e);
3568 gfc_error ("Array index at %L is an array of rank %d",
3569 &ar->c_where[i], e->rank);
3574 /* If the reference type is unknown, figure out what kind it is. */
3576 if (ar->type == AR_UNKNOWN)
3578 ar->type = AR_ELEMENT;
3579 for (i = 0; i < ar->dimen; i++)
3580 if (ar->dimen_type[i] == DIMEN_RANGE
3581 || ar->dimen_type[i] == DIMEN_VECTOR)
3583 ar->type = AR_SECTION;
3588 if (!ar->as->cray_pointee && compare_spec_to_ref (ar) == FAILURE)
3596 resolve_substring (gfc_ref *ref)
3598 if (ref->u.ss.start != NULL)
3600 if (gfc_resolve_expr (ref->u.ss.start) == FAILURE)
3603 if (ref->u.ss.start->ts.type != BT_INTEGER)
3605 gfc_error ("Substring start index at %L must be of type INTEGER",
3606 &ref->u.ss.start->where);
3610 if (ref->u.ss.start->rank != 0)
3612 gfc_error ("Substring start index at %L must be scalar",
3613 &ref->u.ss.start->where);
3617 if (compare_bound_int (ref->u.ss.start, 1) == CMP_LT
3618 && (compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_EQ
3619 || compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_GT))
3621 gfc_error ("Substring start index at %L is less than one",
3622 &ref->u.ss.start->where);
3627 if (ref->u.ss.end != NULL)
3629 if (gfc_resolve_expr (ref->u.ss.end) == FAILURE)
3632 if (ref->u.ss.end->ts.type != BT_INTEGER)
3634 gfc_error ("Substring end index at %L must be of type INTEGER",
3635 &ref->u.ss.end->where);
3639 if (ref->u.ss.end->rank != 0)
3641 gfc_error ("Substring end index at %L must be scalar",
3642 &ref->u.ss.end->where);
3646 if (ref->u.ss.length != NULL
3647 && compare_bound (ref->u.ss.end, ref->u.ss.length->length) == CMP_GT
3648 && (compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_EQ
3649 || compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_GT))
3651 gfc_error ("Substring end index at %L exceeds the string length",
3652 &ref->u.ss.start->where);
3661 /* This function supplies missing substring charlens. */
3664 gfc_resolve_substring_charlen (gfc_expr *e)
3667 gfc_expr *start, *end;
3669 for (char_ref = e->ref; char_ref; char_ref = char_ref->next)
3670 if (char_ref->type == REF_SUBSTRING)
3676 gcc_assert (char_ref->next == NULL);
3680 if (e->ts.cl->length)
3681 gfc_free_expr (e->ts.cl->length);
3682 else if (e->expr_type == EXPR_VARIABLE
3683 && e->symtree->n.sym->attr.dummy)
3687 e->ts.type = BT_CHARACTER;
3688 e->ts.kind = gfc_default_character_kind;
3692 e->ts.cl = gfc_get_charlen ();
3693 e->ts.cl->next = gfc_current_ns->cl_list;
3694 gfc_current_ns->cl_list = e->ts.cl;
3697 if (char_ref->u.ss.start)
3698 start = gfc_copy_expr (char_ref->u.ss.start);
3700 start = gfc_int_expr (1);
3702 if (char_ref->u.ss.end)
3703 end = gfc_copy_expr (char_ref->u.ss.end);
3704 else if (e->expr_type == EXPR_VARIABLE)
3705 end = gfc_copy_expr (e->symtree->n.sym->ts.cl->length);
3712 /* Length = (end - start +1). */
3713 e->ts.cl->length = gfc_subtract (end, start);
3714 e->ts.cl->length = gfc_add (e->ts.cl->length, gfc_int_expr (1));
3716 e->ts.cl->length->ts.type = BT_INTEGER;
3717 e->ts.cl->length->ts.kind = gfc_charlen_int_kind;;
3719 /* Make sure that the length is simplified. */
3720 gfc_simplify_expr (e->ts.cl->length, 1);
3721 gfc_resolve_expr (e->ts.cl->length);
3725 /* Resolve subtype references. */
3728 resolve_ref (gfc_expr *expr)
3730 int current_part_dimension, n_components, seen_part_dimension;
3733 for (ref = expr->ref; ref; ref = ref->next)
3734 if (ref->type == REF_ARRAY && ref->u.ar.as == NULL)
3736 find_array_spec (expr);
3740 for (ref = expr->ref; ref; ref = ref->next)
3744 if (resolve_array_ref (&ref->u.ar) == FAILURE)
3752 resolve_substring (ref);
3756 /* Check constraints on part references. */
3758 current_part_dimension = 0;
3759 seen_part_dimension = 0;
3762 for (ref = expr->ref; ref; ref = ref->next)
3767 switch (ref->u.ar.type)
3771 current_part_dimension = 1;
3775 current_part_dimension = 0;
3779 gfc_internal_error ("resolve_ref(): Bad array reference");
3785 if (current_part_dimension || seen_part_dimension)
3787 if (ref->u.c.component->pointer)
3789 gfc_error ("Component to the right of a part reference "
3790 "with nonzero rank must not have the POINTER "
3791 "attribute at %L", &expr->where);
3794 else if (ref->u.c.component->allocatable)
3796 gfc_error ("Component to the right of a part reference "
3797 "with nonzero rank must not have the ALLOCATABLE "
3798 "attribute at %L", &expr->where);
3810 if (((ref->type == REF_COMPONENT && n_components > 1)
3811 || ref->next == NULL)
3812 && current_part_dimension
3813 && seen_part_dimension)
3815 gfc_error ("Two or more part references with nonzero rank must "
3816 "not be specified at %L", &expr->where);
3820 if (ref->type == REF_COMPONENT)
3822 if (current_part_dimension)
3823 seen_part_dimension = 1;
3825 /* reset to make sure */
3826 current_part_dimension = 0;
3834 /* Given an expression, determine its shape. This is easier than it sounds.
3835 Leaves the shape array NULL if it is not possible to determine the shape. */
3838 expression_shape (gfc_expr *e)
3840 mpz_t array[GFC_MAX_DIMENSIONS];
3843 if (e->rank == 0 || e->shape != NULL)
3846 for (i = 0; i < e->rank; i++)
3847 if (gfc_array_dimen_size (e, i, &array[i]) == FAILURE)
3850 e->shape = gfc_get_shape (e->rank);
3852 memcpy (e->shape, array, e->rank * sizeof (mpz_t));
3857 for (i--; i >= 0; i--)
3858 mpz_clear (array[i]);
3862 /* Given a variable expression node, compute the rank of the expression by
3863 examining the base symbol and any reference structures it may have. */
3866 expression_rank (gfc_expr *e)
3873 if (e->expr_type == EXPR_ARRAY)
3875 /* Constructors can have a rank different from one via RESHAPE(). */
3877 if (e->symtree == NULL)
3883 e->rank = (e->symtree->n.sym->as == NULL)
3884 ? 0 : e->symtree->n.sym->as->rank;
3890 for (ref = e->ref; ref; ref = ref->next)
3892 if (ref->type != REF_ARRAY)
3895 if (ref->u.ar.type == AR_FULL)
3897 rank = ref->u.ar.as->rank;
3901 if (ref->u.ar.type == AR_SECTION)
3903 /* Figure out the rank of the section. */
3905 gfc_internal_error ("expression_rank(): Two array specs");
3907 for (i = 0; i < ref->u.ar.dimen; i++)
3908 if (ref->u.ar.dimen_type[i] == DIMEN_RANGE
3909 || ref->u.ar.dimen_type[i] == DIMEN_VECTOR)
3919 expression_shape (e);
3923 /* Resolve a variable expression. */
3926 resolve_variable (gfc_expr *e)
3933 if (e->symtree == NULL)
3936 if (e->ref && resolve_ref (e) == FAILURE)
3939 sym = e->symtree->n.sym;
3940 if (sym->attr.flavor == FL_PROCEDURE && !sym->attr.function)
3942 e->ts.type = BT_PROCEDURE;
3946 if (sym->ts.type != BT_UNKNOWN)
3947 gfc_variable_attr (e, &e->ts);
3950 /* Must be a simple variable reference. */
3951 if (gfc_set_default_type (sym, 1, sym->ns) == FAILURE)
3956 if (check_assumed_size_reference (sym, e))
3959 /* Deal with forward references to entries during resolve_code, to
3960 satisfy, at least partially, 12.5.2.5. */
3961 if (gfc_current_ns->entries
3962 && current_entry_id == sym->entry_id
3965 && cs_base->current->op != EXEC_ENTRY)
3967 gfc_entry_list *entry;
3968 gfc_formal_arglist *formal;
3972 /* If the symbol is a dummy... */
3973 if (sym->attr.dummy && sym->ns == gfc_current_ns)
3975 entry = gfc_current_ns->entries;
3978 /* ...test if the symbol is a parameter of previous entries. */
3979 for (; entry && entry->id <= current_entry_id; entry = entry->next)
3980 for (formal = entry->sym->formal; formal; formal = formal->next)
3982 if (formal->sym && sym->name == formal->sym->name)
3986 /* If it has not been seen as a dummy, this is an error. */
3989 if (specification_expr)
3990 gfc_error ("Variable '%s', used in a specification expression"
3991 ", is referenced at %L before the ENTRY statement "
3992 "in which it is a parameter",
3993 sym->name, &cs_base->current->loc);
3995 gfc_error ("Variable '%s' is used at %L before the ENTRY "
3996 "statement in which it is a parameter",
3997 sym->name, &cs_base->current->loc);
4002 /* Now do the same check on the specification expressions. */
4003 specification_expr = 1;
4004 if (sym->ts.type == BT_CHARACTER
4005 && gfc_resolve_expr (sym->ts.cl->length) == FAILURE)
4009 for (n = 0; n < sym->as->rank; n++)
4011 specification_expr = 1;
4012 if (gfc_resolve_expr (sym->as->lower[n]) == FAILURE)
4014 specification_expr = 1;
4015 if (gfc_resolve_expr (sym->as->upper[n]) == FAILURE)
4018 specification_expr = 0;
4021 /* Update the symbol's entry level. */
4022 sym->entry_id = current_entry_id + 1;
4029 /* Checks to see that the correct symbol has been host associated.
4030 The only situation where this arises is that in which a twice
4031 contained function is parsed after the host association is made.
4032 Therefore, on detecting this, the line is rematched, having got
4033 rid of the existing references and actual_arg_list. */
4035 check_host_association (gfc_expr *e)
4037 gfc_symbol *sym, *old_sym;
4041 bool retval = e->expr_type == EXPR_FUNCTION;
4043 if (e->symtree == NULL || e->symtree->n.sym == NULL)
4046 old_sym = e->symtree->n.sym;
4048 if (old_sym->attr.use_assoc)
4051 if (gfc_current_ns->parent
4052 && old_sym->ns != gfc_current_ns)
4054 gfc_find_symbol (old_sym->name, gfc_current_ns, 1, &sym);
4055 if (sym && old_sym != sym
4056 && sym->attr.flavor == FL_PROCEDURE
4057 && sym->attr.contained)
4059 temp_locus = gfc_current_locus;
4060 gfc_current_locus = e->where;
4062 gfc_buffer_error (1);
4064 gfc_free_ref_list (e->ref);
4069 gfc_free_actual_arglist (e->value.function.actual);
4070 e->value.function.actual = NULL;
4073 if (e->shape != NULL)
4075 for (n = 0; n < e->rank; n++)
4076 mpz_clear (e->shape[n]);
4078 gfc_free (e->shape);
4081 gfc_match_rvalue (&expr);
4083 gfc_buffer_error (0);
4085 gcc_assert (expr && sym == expr->symtree->n.sym);
4091 gfc_current_locus = temp_locus;
4094 /* This might have changed! */
4095 return e->expr_type == EXPR_FUNCTION;
4100 gfc_resolve_character_operator (gfc_expr *e)
4102 gfc_expr *op1 = e->value.op.op1;
4103 gfc_expr *op2 = e->value.op.op2;
4104 gfc_expr *e1 = NULL;
4105 gfc_expr *e2 = NULL;
4107 gcc_assert (e->value.op.operator == INTRINSIC_CONCAT);
4109 if (op1->ts.cl && op1->ts.cl->length)
4110 e1 = gfc_copy_expr (op1->ts.cl->length);
4111 else if (op1->expr_type == EXPR_CONSTANT)
4112 e1 = gfc_int_expr (op1->value.character.length);
4114 if (op2->ts.cl && op2->ts.cl->length)
4115 e2 = gfc_copy_expr (op2->ts.cl->length);
4116 else if (op2->expr_type == EXPR_CONSTANT)
4117 e2 = gfc_int_expr (op2->value.character.length);
4119 e->ts.cl = gfc_get_charlen ();
4120 e->ts.cl->next = gfc_current_ns->cl_list;
4121 gfc_current_ns->cl_list = e->ts.cl;
4126 e->ts.cl->length = gfc_add (e1, e2);
4127 e->ts.cl->length->ts.type = BT_INTEGER;
4128 e->ts.cl->length->ts.kind = gfc_charlen_int_kind;;
4129 gfc_simplify_expr (e->ts.cl->length, 0);
4130 gfc_resolve_expr (e->ts.cl->length);
4136 /* Ensure that an character expression has a charlen and, if possible, a
4137 length expression. */
4140 fixup_charlen (gfc_expr *e)
4142 /* The cases fall through so that changes in expression type and the need
4143 for multiple fixes are picked up. In all circumstances, a charlen should
4144 be available for the middle end to hang a backend_decl on. */
4145 switch (e->expr_type)
4148 gfc_resolve_character_operator (e);
4151 if (e->expr_type == EXPR_ARRAY)
4152 gfc_resolve_character_array_constructor (e);
4154 case EXPR_SUBSTRING:
4155 if (!e->ts.cl && e->ref)
4156 gfc_resolve_substring_charlen (e);
4161 e->ts.cl = gfc_get_charlen ();
4162 e->ts.cl->next = gfc_current_ns->cl_list;
4163 gfc_current_ns->cl_list = e->ts.cl;
4171 /* Resolve an expression. That is, make sure that types of operands agree
4172 with their operators, intrinsic operators are converted to function calls
4173 for overloaded types and unresolved function references are resolved. */
4176 gfc_resolve_expr (gfc_expr *e)
4183 switch (e->expr_type)
4186 t = resolve_operator (e);
4192 if (check_host_association (e))
4193 t = resolve_function (e);
4196 t = resolve_variable (e);
4198 expression_rank (e);
4201 if (e->ts.type == BT_CHARACTER && e->ts.cl == NULL && e->ref
4202 && e->ref->type != REF_SUBSTRING)
4203 gfc_resolve_substring_charlen (e);
4207 case EXPR_SUBSTRING:
4208 t = resolve_ref (e);
4218 if (resolve_ref (e) == FAILURE)
4221 t = gfc_resolve_array_constructor (e);
4222 /* Also try to expand a constructor. */
4225 expression_rank (e);
4226 gfc_expand_constructor (e);
4229 /* This provides the opportunity for the length of constructors with
4230 character valued function elements to propagate the string length
4231 to the expression. */
4232 if (e->ts.type == BT_CHARACTER)
4233 gfc_resolve_character_array_constructor (e);
4237 case EXPR_STRUCTURE:
4238 t = resolve_ref (e);
4242 t = resolve_structure_cons (e);
4246 t = gfc_simplify_expr (e, 0);
4250 gfc_internal_error ("gfc_resolve_expr(): Bad expression type");
4253 if (e->ts.type == BT_CHARACTER && t == SUCCESS && !e->ts.cl)
4260 /* Resolve an expression from an iterator. They must be scalar and have
4261 INTEGER or (optionally) REAL type. */
4264 gfc_resolve_iterator_expr (gfc_expr *expr, bool real_ok,
4265 const char *name_msgid)
4267 if (gfc_resolve_expr (expr) == FAILURE)
4270 if (expr->rank != 0)
4272 gfc_error ("%s at %L must be a scalar", _(name_msgid), &expr->where);
4276 if (expr->ts.type != BT_INTEGER)
4278 if (expr->ts.type == BT_REAL)
4281 return gfc_notify_std (GFC_STD_F95_DEL,
4282 "Deleted feature: %s at %L must be integer",
4283 _(name_msgid), &expr->where);
4286 gfc_error ("%s at %L must be INTEGER", _(name_msgid),
4293 gfc_error ("%s at %L must be INTEGER", _(name_msgid), &expr->where);
4301 /* Resolve the expressions in an iterator structure. If REAL_OK is
4302 false allow only INTEGER type iterators, otherwise allow REAL types. */
4305 gfc_resolve_iterator (gfc_iterator *iter, bool real_ok)
4307 if (gfc_resolve_iterator_expr (iter->var, real_ok, "Loop variable")
4311 if (gfc_pure (NULL) && gfc_impure_variable (iter->var->symtree->n.sym))
4313 gfc_error ("Cannot assign to loop variable in PURE procedure at %L",
4318 if (gfc_resolve_iterator_expr (iter->start, real_ok,
4319 "Start expression in DO loop") == FAILURE)
4322 if (gfc_resolve_iterator_expr (iter->end, real_ok,
4323 "End expression in DO loop") == FAILURE)
4326 if (gfc_resolve_iterator_expr (iter->step, real_ok,
4327 "Step expression in DO loop") == FAILURE)
4330 if (iter->step->expr_type == EXPR_CONSTANT)
4332 if ((iter->step->ts.type == BT_INTEGER
4333 && mpz_cmp_ui (iter->step->value.integer, 0) == 0)
4334 || (iter->step->ts.type == BT_REAL
4335 && mpfr_sgn (iter->step->value.real) == 0))
4337 gfc_error ("Step expression in DO loop at %L cannot be zero",
4338 &iter->step->where);
4343 /* Convert start, end, and step to the same type as var. */
4344 if (iter->start->ts.kind != iter->var->ts.kind
4345 || iter->start->ts.type != iter->var->ts.type)
4346 gfc_convert_type (iter->start, &iter->var->ts, 2);
4348 if (iter->end->ts.kind != iter->var->ts.kind
4349 || iter->end->ts.type != iter->var->ts.type)
4350 gfc_convert_type (iter->end, &iter->var->ts, 2);
4352 if (iter->step->ts.kind != iter->var->ts.kind
4353 || iter->step->ts.type != iter->var->ts.type)
4354 gfc_convert_type (iter->step, &iter->var->ts, 2);
4360 /* Traversal function for find_forall_index. f == 2 signals that
4361 that variable itself is not to be checked - only the references. */
4364 forall_index (gfc_expr *expr, gfc_symbol *sym, int *f)
4366 gcc_assert (expr->expr_type == EXPR_VARIABLE);
4368 /* A scalar assignment */
4369 if (!expr->ref || *f == 1)
4371 if (expr->symtree->n.sym == sym)
4383 /* Check whether the FORALL index appears in the expression or not.
4384 Returns SUCCESS if SYM is found in EXPR. */
4387 find_forall_index (gfc_expr *expr, gfc_symbol *sym, int f)
4389 if (gfc_traverse_expr (expr, sym, forall_index, f))
4396 /* Resolve a list of FORALL iterators. The FORALL index-name is constrained
4397 to be a scalar INTEGER variable. The subscripts and stride are scalar
4398 INTEGERs, and if stride is a constant it must be nonzero.
4399 Furthermore "A subscript or stride in a forall-triplet-spec shall
4400 not contain a reference to any index-name in the
4401 forall-triplet-spec-list in which it appears." (7.5.4.1) */
4404 resolve_forall_iterators (gfc_forall_iterator *it)
4406 gfc_forall_iterator *iter, *iter2;
4408 for (iter = it; iter; iter = iter->next)
4410 if (gfc_resolve_expr (iter->var) == SUCCESS
4411 && (iter->var->ts.type != BT_INTEGER || iter->var->rank != 0))
4412 gfc_error ("FORALL index-name at %L must be a scalar INTEGER",
4415 if (gfc_resolve_expr (iter->start) == SUCCESS
4416 && (iter->start->ts.type != BT_INTEGER || iter->start->rank != 0))
4417 gfc_error ("FORALL start expression at %L must be a scalar INTEGER",
4418 &iter->start->where);
4419 if (iter->var->ts.kind != iter->start->ts.kind)
4420 gfc_convert_type (iter->start, &iter->var->ts, 2);
4422 if (gfc_resolve_expr (iter->end) == SUCCESS
4423 && (iter->end->ts.type != BT_INTEGER || iter->end->rank != 0))
4424 gfc_error ("FORALL end expression at %L must be a scalar INTEGER",
4426 if (iter->var->ts.kind != iter->end->ts.kind)
4427 gfc_convert_type (iter->end, &iter->var->ts, 2);
4429 if (gfc_resolve_expr (iter->stride) == SUCCESS)
4431 if (iter->stride->ts.type != BT_INTEGER || iter->stride->rank != 0)
4432 gfc_error ("FORALL stride expression at %L must be a scalar %s",
4433 &iter->stride->where, "INTEGER");
4435 if (iter->stride->expr_type == EXPR_CONSTANT
4436 && mpz_cmp_ui(iter->stride->value.integer, 0) == 0)
4437 gfc_error ("FORALL stride expression at %L cannot be zero",
4438 &iter->stride->where);
4440 if (iter->var->ts.kind != iter->stride->ts.kind)
4441 gfc_convert_type (iter->stride, &iter->var->ts, 2);
4444 for (iter = it; iter; iter = iter->next)
4445 for (iter2 = iter; iter2; iter2 = iter2->next)
4447 if (find_forall_index (iter2->start,
4448 iter->var->symtree->n.sym, 0) == SUCCESS
4449 || find_forall_index (iter2->end,
4450 iter->var->symtree->n.sym, 0) == SUCCESS
4451 || find_forall_index (iter2->stride,
4452 iter->var->symtree->n.sym, 0) == SUCCESS)
4453 gfc_error ("FORALL index '%s' may not appear in triplet "
4454 "specification at %L", iter->var->symtree->name,
4455 &iter2->start->where);
4460 /* Given a pointer to a symbol that is a derived type, see if it's
4461 inaccessible, i.e. if it's defined in another module and the components are
4462 PRIVATE. The search is recursive if necessary. Returns zero if no
4463 inaccessible components are found, nonzero otherwise. */
4466 derived_inaccessible (gfc_symbol *sym)
4470 if (sym->attr.use_assoc && sym->attr.private_comp)
4473 for (c = sym->components; c; c = c->next)
4475 if (c->ts.type == BT_DERIVED && derived_inaccessible (c->ts.derived))
4483 /* Resolve the argument of a deallocate expression. The expression must be
4484 a pointer or a full array. */
4487 resolve_deallocate_expr (gfc_expr *e)
4489 symbol_attribute attr;
4490 int allocatable, pointer, check_intent_in;
4493 /* Check INTENT(IN), unless the object is a sub-component of a pointer. */
4494 check_intent_in = 1;
4496 if (gfc_resolve_expr (e) == FAILURE)
4499 if (e->expr_type != EXPR_VARIABLE)
4502 allocatable = e->symtree->n.sym->attr.allocatable;
4503 pointer = e->symtree->n.sym->attr.pointer;
4504 for (ref = e->ref; ref; ref = ref->next)
4507 check_intent_in = 0;
4512 if (ref->u.ar.type != AR_FULL)
4517 allocatable = (ref->u.c.component->as != NULL
4518 && ref->u.c.component->as->type == AS_DEFERRED);
4519 pointer = ref->u.c.component->pointer;
4528 attr = gfc_expr_attr (e);
4530 if (allocatable == 0 && attr.pointer == 0)
4533 gfc_error ("Expression in DEALLOCATE statement at %L must be "
4534 "ALLOCATABLE or a POINTER", &e->where);
4538 && e->symtree->n.sym->attr.intent == INTENT_IN)
4540 gfc_error ("Cannot deallocate INTENT(IN) variable '%s' at %L",
4541 e->symtree->n.sym->name, &e->where);
4549 /* Returns true if the expression e contains a reference the symbol sym. */
4551 find_sym_in_expr (gfc_symbol *sym, gfc_expr *e)
4553 gfc_actual_arglist *arg;
4561 switch (e->expr_type)
4564 for (arg = e->value.function.actual; arg; arg = arg->next)
4565 rv = rv || find_sym_in_expr (sym, arg->expr);
4568 /* If the variable is not the same as the dependent, 'sym', and
4569 it is not marked as being declared and it is in the same
4570 namespace as 'sym', add it to the local declarations. */
4572 if (sym == e->symtree->n.sym)
4577 rv = rv || find_sym_in_expr (sym, e->value.op.op1);
4578 rv = rv || find_sym_in_expr (sym, e->value.op.op2);
4587 for (ref = e->ref; ref; ref = ref->next)
4592 for (i = 0; i < ref->u.ar.dimen; i++)
4594 rv = rv || find_sym_in_expr (sym, ref->u.ar.start[i]);
4595 rv = rv || find_sym_in_expr (sym, ref->u.ar.end[i]);
4596 rv = rv || find_sym_in_expr (sym, ref->u.ar.stride[i]);
4601 rv = rv || find_sym_in_expr (sym, ref->u.ss.start);
4602 rv = rv || find_sym_in_expr (sym, ref->u.ss.end);
4606 if (ref->u.c.component->ts.type == BT_CHARACTER
4607 && ref->u.c.component->ts.cl->length->expr_type
4610 || find_sym_in_expr (sym,
4611 ref->u.c.component->ts.cl->length);
4613 if (ref->u.c.component->as)
4614 for (i = 0; i < ref->u.c.component->as->rank; i++)
4617 || find_sym_in_expr (sym,
4618 ref->u.c.component->as->lower[i]);
4620 || find_sym_in_expr (sym,
4621 ref->u.c.component->as->upper[i]);
4631 /* Given the expression node e for an allocatable/pointer of derived type to be
4632 allocated, get the expression node to be initialized afterwards (needed for
4633 derived types with default initializers, and derived types with allocatable
4634 components that need nullification.) */
4637 expr_to_initialize (gfc_expr *e)
4643 result = gfc_copy_expr (e);
4645 /* Change the last array reference from AR_ELEMENT to AR_FULL. */
4646 for (ref = result->ref; ref; ref = ref->next)
4647 if (ref->type == REF_ARRAY && ref->next == NULL)
4649 ref->u.ar.type = AR_FULL;
4651 for (i = 0; i < ref->u.ar.dimen; i++)
4652 ref->u.ar.start[i] = ref->u.ar.end[i] = ref->u.ar.stride[i] = NULL;
4654 result->rank = ref->u.ar.dimen;
4662 /* Resolve the expression in an ALLOCATE statement, doing the additional
4663 checks to see whether the expression is OK or not. The expression must
4664 have a trailing array reference that gives the size of the array. */
4667 resolve_allocate_expr (gfc_expr *e, gfc_code *code)
4669 int i, pointer, allocatable, dimension, check_intent_in;
4670 symbol_attribute attr;
4671 gfc_ref *ref, *ref2;
4678 /* Check INTENT(IN), unless the object is a sub-component of a pointer. */
4679 check_intent_in = 1;
4681 if (gfc_resolve_expr (e) == FAILURE)
4684 if (code->expr && code->expr->expr_type == EXPR_VARIABLE)
4685 sym = code->expr->symtree->n.sym;
4689 /* Make sure the expression is allocatable or a pointer. If it is
4690 pointer, the next-to-last reference must be a pointer. */
4694 if (e->expr_type != EXPR_VARIABLE)
4697 attr = gfc_expr_attr (e);
4698 pointer = attr.pointer;
4699 dimension = attr.dimension;
4703 allocatable = e->symtree->n.sym->attr.allocatable;
4704 pointer = e->symtree->n.sym->attr.pointer;
4705 dimension = e->symtree->n.sym->attr.dimension;
4707 if (sym == e->symtree->n.sym && sym->ts.type != BT_DERIVED)
4709 gfc_error ("The STAT variable '%s' in an ALLOCATE statement must "
4710 "not be allocated in the same statement at %L",
4711 sym->name, &e->where);
4715 for (ref = e->ref; ref; ref2 = ref, ref = ref->next)
4718 check_intent_in = 0;
4723 if (ref->next != NULL)
4728 allocatable = (ref->u.c.component->as != NULL
4729 && ref->u.c.component->as->type == AS_DEFERRED);
4731 pointer = ref->u.c.component->pointer;
4732 dimension = ref->u.c.component->dimension;
4743 if (allocatable == 0 && pointer == 0)
4745 gfc_error ("Expression in ALLOCATE statement at %L must be "
4746 "ALLOCATABLE or a POINTER", &e->where);
4751 && e->symtree->n.sym->attr.intent == INTENT_IN)
4753 gfc_error ("Cannot allocate INTENT(IN) variable '%s' at %L",
4754 e->symtree->n.sym->name, &e->where);
4758 /* Add default initializer for those derived types that need them. */
4759 if (e->ts.type == BT_DERIVED && (init_e = gfc_default_initializer (&e->ts)))
4761 init_st = gfc_get_code ();
4762 init_st->loc = code->loc;
4763 init_st->op = EXEC_INIT_ASSIGN;
4764 init_st->expr = expr_to_initialize (e);
4765 init_st->expr2 = init_e;
4766 init_st->next = code->next;
4767 code->next = init_st;
4770 if (pointer && dimension == 0)
4773 /* Make sure the next-to-last reference node is an array specification. */
4775 if (ref2 == NULL || ref2->type != REF_ARRAY || ref2->u.ar.type == AR_FULL)
4777 gfc_error ("Array specification required in ALLOCATE statement "
4778 "at %L", &e->where);
4782 /* Make sure that the array section reference makes sense in the
4783 context of an ALLOCATE specification. */
4787 for (i = 0; i < ar->dimen; i++)
4789 if (ref2->u.ar.type == AR_ELEMENT)
4792 switch (ar->dimen_type[i])
4798 if (ar->start[i] != NULL
4799 && ar->end[i] != NULL
4800 && ar->stride[i] == NULL)
4803 /* Fall Through... */
4807 gfc_error ("Bad array specification in ALLOCATE statement at %L",
4814 for (a = code->ext.alloc_list; a; a = a->next)
4816 sym = a->expr->symtree->n.sym;
4818 /* TODO - check derived type components. */
4819 if (sym->ts.type == BT_DERIVED)
4822 if ((ar->start[i] != NULL && find_sym_in_expr (sym, ar->start[i]))
4823 || (ar->end[i] != NULL && find_sym_in_expr (sym, ar->end[i])))
4825 gfc_error ("'%s' must not appear an the array specification at "
4826 "%L in the same ALLOCATE statement where it is "
4827 "itself allocated", sym->name, &ar->where);
4837 /************ SELECT CASE resolution subroutines ************/
4839 /* Callback function for our mergesort variant. Determines interval
4840 overlaps for CASEs. Return <0 if op1 < op2, 0 for overlap, >0 for
4841 op1 > op2. Assumes we're not dealing with the default case.
4842 We have op1 = (:L), (K:L) or (K:) and op2 = (:N), (M:N) or (M:).
4843 There are nine situations to check. */
4846 compare_cases (const gfc_case *op1, const gfc_case *op2)
4850 if (op1->low == NULL) /* op1 = (:L) */
4852 /* op2 = (:N), so overlap. */
4854 /* op2 = (M:) or (M:N), L < M */
4855 if (op2->low != NULL
4856 && gfc_compare_expr (op1->high, op2->low) < 0)
4859 else if (op1->high == NULL) /* op1 = (K:) */
4861 /* op2 = (M:), so overlap. */
4863 /* op2 = (:N) or (M:N), K > N */
4864 if (op2->high != NULL
4865 && gfc_compare_expr (op1->low, op2->high) > 0)
4868 else /* op1 = (K:L) */
4870 if (op2->low == NULL) /* op2 = (:N), K > N */
4871 retval = (gfc_compare_expr (op1->low, op2->high) > 0) ? 1 : 0;
4872 else if (op2->high == NULL) /* op2 = (M:), L < M */
4873 retval = (gfc_compare_expr (op1->high, op2->low) < 0) ? -1 : 0;
4874 else /* op2 = (M:N) */
4878 if (gfc_compare_expr (op1->high, op2->low) < 0)
4881 else if (gfc_compare_expr (op1->low, op2->high) > 0)
4890 /* Merge-sort a double linked case list, detecting overlap in the
4891 process. LIST is the head of the double linked case list before it
4892 is sorted. Returns the head of the sorted list if we don't see any
4893 overlap, or NULL otherwise. */
4896 check_case_overlap (gfc_case *list)
4898 gfc_case *p, *q, *e, *tail;
4899 int insize, nmerges, psize, qsize, cmp, overlap_seen;
4901 /* If the passed list was empty, return immediately. */
4908 /* Loop unconditionally. The only exit from this loop is a return
4909 statement, when we've finished sorting the case list. */
4916 /* Count the number of merges we do in this pass. */
4919 /* Loop while there exists a merge to be done. */
4924 /* Count this merge. */
4927 /* Cut the list in two pieces by stepping INSIZE places
4928 forward in the list, starting from P. */
4931 for (i = 0; i < insize; i++)
4940 /* Now we have two lists. Merge them! */
4941 while (psize > 0 || (qsize > 0 && q != NULL))
4943 /* See from which the next case to merge comes from. */
4946 /* P is empty so the next case must come from Q. */
4951 else if (qsize == 0 || q == NULL)
4960 cmp = compare_cases (p, q);
4963 /* The whole case range for P is less than the
4971 /* The whole case range for Q is greater than
4972 the case range for P. */
4979 /* The cases overlap, or they are the same
4980 element in the list. Either way, we must
4981 issue an error and get the next case from P. */
4982 /* FIXME: Sort P and Q by line number. */
4983 gfc_error ("CASE label at %L overlaps with CASE "
4984 "label at %L", &p->where, &q->where);
4992 /* Add the next element to the merged list. */
5001 /* P has now stepped INSIZE places along, and so has Q. So
5002 they're the same. */
5007 /* If we have done only one merge or none at all, we've
5008 finished sorting the cases. */
5017 /* Otherwise repeat, merging lists twice the size. */
5023 /* Check to see if an expression is suitable for use in a CASE statement.
5024 Makes sure that all case expressions are scalar constants of the same
5025 type. Return FAILURE if anything is wrong. */
5028 validate_case_label_expr (gfc_expr *e, gfc_expr *case_expr)
5030 if (e == NULL) return SUCCESS;
5032 if (e->ts.type != case_expr->ts.type)
5034 gfc_error ("Expression in CASE statement at %L must be of type %s",
5035 &e->where, gfc_basic_typename (case_expr->ts.type));
5039 /* C805 (R808) For a given case-construct, each case-value shall be of
5040 the same type as case-expr. For character type, length differences
5041 are allowed, but the kind type parameters shall be the same. */
5043 if (case_expr->ts.type == BT_CHARACTER && e->ts.kind != case_expr->ts.kind)
5045 gfc_error("Expression in CASE statement at %L must be kind %d",
5046 &e->where, case_expr->ts.kind);
5050 /* Convert the case value kind to that of case expression kind, if needed.
5051 FIXME: Should a warning be issued? */
5052 if (e->ts.kind != case_expr->ts.kind)
5053 gfc_convert_type_warn (e, &case_expr->ts, 2, 0);
5057 gfc_error ("Expression in CASE statement at %L must be scalar",
5066 /* Given a completely parsed select statement, we:
5068 - Validate all expressions and code within the SELECT.
5069 - Make sure that the selection expression is not of the wrong type.
5070 - Make sure that no case ranges overlap.
5071 - Eliminate unreachable cases and unreachable code resulting from
5072 removing case labels.
5074 The standard does allow unreachable cases, e.g. CASE (5:3). But
5075 they are a hassle for code generation, and to prevent that, we just
5076 cut them out here. This is not necessary for overlapping cases
5077 because they are illegal and we never even try to generate code.
5079 We have the additional caveat that a SELECT construct could have
5080 been a computed GOTO in the source code. Fortunately we can fairly
5081 easily work around that here: The case_expr for a "real" SELECT CASE
5082 is in code->expr1, but for a computed GOTO it is in code->expr2. All
5083 we have to do is make sure that the case_expr is a scalar integer
5087 resolve_select (gfc_code *code)
5090 gfc_expr *case_expr;
5091 gfc_case *cp, *default_case, *tail, *head;
5092 int seen_unreachable;
5098 if (code->expr == NULL)
5100 /* This was actually a computed GOTO statement. */
5101 case_expr = code->expr2;
5102 if (case_expr->ts.type != BT_INTEGER|| case_expr->rank != 0)
5103 gfc_error ("Selection expression in computed GOTO statement "
5104 "at %L must be a scalar integer expression",
5107 /* Further checking is not necessary because this SELECT was built
5108 by the compiler, so it should always be OK. Just move the
5109 case_expr from expr2 to expr so that we can handle computed
5110 GOTOs as normal SELECTs from here on. */
5111 code->expr = code->expr2;
5116 case_expr = code->expr;
5118 type = case_expr->ts.type;
5119 if (type != BT_LOGICAL && type != BT_INTEGER && type != BT_CHARACTER)
5121 gfc_error ("Argument of SELECT statement at %L cannot be %s",
5122 &case_expr->where, gfc_typename (&case_expr->ts));
5124 /* Punt. Going on here just produce more garbage error messages. */
5128 if (case_expr->rank != 0)
5130 gfc_error ("Argument of SELECT statement at %L must be a scalar "
5131 "expression", &case_expr->where);
5137 /* PR 19168 has a long discussion concerning a mismatch of the kinds
5138 of the SELECT CASE expression and its CASE values. Walk the lists
5139 of case values, and if we find a mismatch, promote case_expr to
5140 the appropriate kind. */
5142 if (type == BT_LOGICAL || type == BT_INTEGER)
5144 for (body = code->block; body; body = body->block)
5146 /* Walk the case label list. */
5147 for (cp = body->ext.case_list; cp; cp = cp->next)
5149 /* Intercept the DEFAULT case. It does not have a kind. */
5150 if (cp->low == NULL && cp->high == NULL)
5153 /* Unreachable case ranges are discarded, so ignore. */
5154 if (cp->low != NULL && cp->high != NULL
5155 && cp->low != cp->high
5156 && gfc_compare_expr (cp->low, cp->high) > 0)
5159 /* FIXME: Should a warning be issued? */
5161 && case_expr->ts.kind != gfc_kind_max(case_expr, cp->low))
5162 gfc_convert_type_warn (case_expr, &cp->low->ts, 2, 0);
5164 if (cp->high != NULL
5165 && case_expr->ts.kind != gfc_kind_max(case_expr, cp->high))
5166 gfc_convert_type_warn (case_expr, &cp->high->ts, 2, 0);
5171 /* Assume there is no DEFAULT case. */
5172 default_case = NULL;
5177 for (body = code->block; body; body = body->block)
5179 /* Assume the CASE list is OK, and all CASE labels can be matched. */
5181 seen_unreachable = 0;
5183 /* Walk the case label list, making sure that all case labels
5185 for (cp = body->ext.case_list; cp; cp = cp->next)
5187 /* Count the number of cases in the whole construct. */
5190 /* Intercept the DEFAULT case. */
5191 if (cp->low == NULL && cp->high == NULL)
5193 if (default_case != NULL)
5195 gfc_error ("The DEFAULT CASE at %L cannot be followed "
5196 "by a second DEFAULT CASE at %L",
5197 &default_case->where, &cp->where);
5208 /* Deal with single value cases and case ranges. Errors are
5209 issued from the validation function. */
5210 if(validate_case_label_expr (cp->low, case_expr) != SUCCESS
5211 || validate_case_label_expr (cp->high, case_expr) != SUCCESS)
5217 if (type == BT_LOGICAL
5218 && ((cp->low == NULL || cp->high == NULL)
5219 || cp->low != cp->high))
5221 gfc_error ("Logical range in CASE statement at %L is not "
5222 "allowed", &cp->low->where);
5227 if (type == BT_LOGICAL && cp->low->expr_type == EXPR_CONSTANT)
5230 value = cp->low->value.logical == 0 ? 2 : 1;
5231 if (value & seen_logical)
5233 gfc_error ("constant logical value in CASE statement "
5234 "is repeated at %L",
5239 seen_logical |= value;
5242 if (cp->low != NULL && cp->high != NULL
5243 && cp->low != cp->high
5244 && gfc_compare_expr (cp->low, cp->high) > 0)
5246 if (gfc_option.warn_surprising)
5247 gfc_warning ("Range specification at %L can never "
5248 "be matched", &cp->where);
5250 cp->unreachable = 1;
5251 seen_unreachable = 1;
5255 /* If the case range can be matched, it can also overlap with
5256 other cases. To make sure it does not, we put it in a
5257 double linked list here. We sort that with a merge sort
5258 later on to detect any overlapping cases. */
5262 head->right = head->left = NULL;
5267 tail->right->left = tail;
5274 /* It there was a failure in the previous case label, give up
5275 for this case label list. Continue with the next block. */
5279 /* See if any case labels that are unreachable have been seen.
5280 If so, we eliminate them. This is a bit of a kludge because
5281 the case lists for a single case statement (label) is a
5282 single forward linked lists. */
5283 if (seen_unreachable)
5285 /* Advance until the first case in the list is reachable. */
5286 while (body->ext.case_list != NULL
5287 && body->ext.case_list->unreachable)
5289 gfc_case *n = body->ext.case_list;
5290 body->ext.case_list = body->ext.case_list->next;
5292 gfc_free_case_list (n);
5295 /* Strip all other unreachable cases. */
5296 if (body->ext.case_list)
5298 for (cp = body->ext.case_list; cp->next; cp = cp->next)
5300 if (cp->next->unreachable)
5302 gfc_case *n = cp->next;
5303 cp->next = cp->next->next;
5305 gfc_free_case_list (n);
5312 /* See if there were overlapping cases. If the check returns NULL,
5313 there was overlap. In that case we don't do anything. If head
5314 is non-NULL, we prepend the DEFAULT case. The sorted list can
5315 then used during code generation for SELECT CASE constructs with
5316 a case expression of a CHARACTER type. */
5319 head = check_case_overlap (head);
5321 /* Prepend the default_case if it is there. */
5322 if (head != NULL && default_case)
5324 default_case->left = NULL;
5325 default_case->right = head;
5326 head->left = default_case;
5330 /* Eliminate dead blocks that may be the result if we've seen
5331 unreachable case labels for a block. */
5332 for (body = code; body && body->block; body = body->block)
5334 if (body->block->ext.case_list == NULL)
5336 /* Cut the unreachable block from the code chain. */
5337 gfc_code *c = body->block;
5338 body->block = c->block;
5340 /* Kill the dead block, but not the blocks below it. */
5342 gfc_free_statements (c);
5346 /* More than two cases is legal but insane for logical selects.
5347 Issue a warning for it. */
5348 if (gfc_option.warn_surprising && type == BT_LOGICAL
5350 gfc_warning ("Logical SELECT CASE block at %L has more that two cases",
5355 /* Resolve a transfer statement. This is making sure that:
5356 -- a derived type being transferred has only non-pointer components
5357 -- a derived type being transferred doesn't have private components, unless
5358 it's being transferred from the module where the type was defined
5359 -- we're not trying to transfer a whole assumed size array. */
5362 resolve_transfer (gfc_code *code)
5371 if (exp->expr_type != EXPR_VARIABLE && exp->expr_type != EXPR_FUNCTION)
5374 sym = exp->symtree->n.sym;
5377 /* Go to actual component transferred. */
5378 for (ref = code->expr->ref; ref; ref = ref->next)
5379 if (ref->type == REF_COMPONENT)
5380 ts = &ref->u.c.component->ts;
5382 if (ts->type == BT_DERIVED)
5384 /* Check that transferred derived type doesn't contain POINTER
5386 if (ts->derived->attr.pointer_comp)
5388 gfc_error ("Data transfer element at %L cannot have "
5389 "POINTER components", &code->loc);
5393 if (ts->derived->attr.alloc_comp)
5395 gfc_error ("Data transfer element at %L cannot have "
5396 "ALLOCATABLE components", &code->loc);
5400 if (derived_inaccessible (ts->derived))
5402 gfc_error ("Data transfer element at %L cannot have "
5403 "PRIVATE components",&code->loc);
5408 if (sym->as != NULL && sym->as->type == AS_ASSUMED_SIZE
5409 && exp->ref->type == REF_ARRAY && exp->ref->u.ar.type == AR_FULL)
5411 gfc_error ("Data transfer element at %L cannot be a full reference to "
5412 "an assumed-size array", &code->loc);
5418 /*********** Toplevel code resolution subroutines ***********/
5420 /* Find the set of labels that are reachable from this block. We also
5421 record the last statement in each block so that we don't have to do
5422 a linear search to find the END DO statements of the blocks. */
5425 reachable_labels (gfc_code *block)
5432 cs_base->reachable_labels = bitmap_obstack_alloc (&labels_obstack);
5434 /* Collect labels in this block. */
5435 for (c = block; c; c = c->next)
5438 bitmap_set_bit (cs_base->reachable_labels, c->here->value);
5440 if (!c->next && cs_base->prev)
5441 cs_base->prev->tail = c;
5444 /* Merge with labels from parent block. */
5447 gcc_assert (cs_base->prev->reachable_labels);
5448 bitmap_ior_into (cs_base->reachable_labels,
5449 cs_base->prev->reachable_labels);
5453 /* Given a branch to a label and a namespace, if the branch is conforming.
5454 The code node describes where the branch is located. */
5457 resolve_branch (gfc_st_label *label, gfc_code *code)
5464 /* Step one: is this a valid branching target? */
5466 if (label->defined == ST_LABEL_UNKNOWN)
5468 gfc_error ("Label %d referenced at %L is never defined", label->value,
5473 if (label->defined != ST_LABEL_TARGET)
5475 gfc_error ("Statement at %L is not a valid branch target statement "
5476 "for the branch statement at %L", &label->where, &code->loc);
5480 /* Step two: make sure this branch is not a branch to itself ;-) */
5482 if (code->here == label)
5484 gfc_warning ("Branch at %L causes an infinite loop", &code->loc);
5488 /* Step three: See if the label is in the same block as the
5489 branching statement. The hard work has been done by setting up
5490 the bitmap reachable_labels. */
5492 if (!bitmap_bit_p (cs_base->reachable_labels, label->value))
5494 /* The label is not in an enclosing block, so illegal. This was
5495 allowed in Fortran 66, so we allow it as extension. No
5496 further checks are necessary in this case. */
5497 gfc_notify_std (GFC_STD_LEGACY, "Label at %L is not in the same block "
5498 "as the GOTO statement at %L", &label->where,
5503 /* Step four: Make sure that the branching target is legal if
5504 the statement is an END {SELECT,IF}. */
5506 for (stack = cs_base; stack; stack = stack->prev)
5507 if (stack->current->next && stack->current->next->here == label)
5510 if (stack && stack->current->next->op == EXEC_NOP)
5512 gfc_notify_std (GFC_STD_F95_DEL, "Deleted feature: GOTO at %L jumps to "
5513 "END of construct at %L", &code->loc,
5514 &stack->current->next->loc);
5515 return; /* We know this is not an END DO. */
5518 /* Step five: Make sure that we're not jumping to the end of a DO
5519 loop from within the loop. */
5521 for (stack = cs_base; stack; stack = stack->prev)
5522 if ((stack->current->op == EXEC_DO
5523 || stack->current->op == EXEC_DO_WHILE)
5524 && stack->tail->here == label && stack->tail->op == EXEC_NOP)
5526 gfc_notify_std (GFC_STD_F95_DEL, "Deleted feature: GOTO at %L jumps "
5527 "to END of construct at %L", &code->loc,
5535 /* Check whether EXPR1 has the same shape as EXPR2. */
5538 resolve_where_shape (gfc_expr *expr1, gfc_expr *expr2)
5540 mpz_t shape[GFC_MAX_DIMENSIONS];
5541 mpz_t shape2[GFC_MAX_DIMENSIONS];
5542 try result = FAILURE;
5545 /* Compare the rank. */
5546 if (expr1->rank != expr2->rank)
5549 /* Compare the size of each dimension. */
5550 for (i=0; i<expr1->rank; i++)
5552 if (gfc_array_dimen_size (expr1, i, &shape[i]) == FAILURE)
5555 if (gfc_array_dimen_size (expr2, i, &shape2[i]) == FAILURE)
5558 if (mpz_cmp (shape[i], shape2[i]))
5562 /* When either of the two expression is an assumed size array, we
5563 ignore the comparison of dimension sizes. */
5568 for (i--; i >= 0; i--)
5570 mpz_clear (shape[i]);
5571 mpz_clear (shape2[i]);
5577 /* Check whether a WHERE assignment target or a WHERE mask expression
5578 has the same shape as the outmost WHERE mask expression. */
5581 resolve_where (gfc_code *code, gfc_expr *mask)
5587 cblock = code->block;
5589 /* Store the first WHERE mask-expr of the WHERE statement or construct.
5590 In case of nested WHERE, only the outmost one is stored. */
5591 if (mask == NULL) /* outmost WHERE */
5593 else /* inner WHERE */
5600 /* Check if the mask-expr has a consistent shape with the
5601 outmost WHERE mask-expr. */
5602 if (resolve_where_shape (cblock->expr, e) == FAILURE)
5603 gfc_error ("WHERE mask at %L has inconsistent shape",
5604 &cblock->expr->where);
5607 /* the assignment statement of a WHERE statement, or the first
5608 statement in where-body-construct of a WHERE construct */
5609 cnext = cblock->next;
5614 /* WHERE assignment statement */
5617 /* Check shape consistent for WHERE assignment target. */
5618 if (e && resolve_where_shape (cnext->expr, e) == FAILURE)
5619 gfc_error ("WHERE assignment target at %L has "
5620 "inconsistent shape", &cnext->expr->where);
5624 case EXEC_ASSIGN_CALL:
5625 resolve_call (cnext);
5628 /* WHERE or WHERE construct is part of a where-body-construct */
5630 resolve_where (cnext, e);
5634 gfc_error ("Unsupported statement inside WHERE at %L",
5637 /* the next statement within the same where-body-construct */
5638 cnext = cnext->next;
5640 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
5641 cblock = cblock->block;
5646 /* Resolve assignment in FORALL construct.
5647 NVAR is the number of FORALL index variables, and VAR_EXPR records the
5648 FORALL index variables. */
5651 gfc_resolve_assign_in_forall (gfc_code *code, int nvar, gfc_expr **var_expr)
5655 for (n = 0; n < nvar; n++)
5657 gfc_symbol *forall_index;
5659 forall_index = var_expr[n]->symtree->n.sym;
5661 /* Check whether the assignment target is one of the FORALL index
5663 if ((code->expr->expr_type == EXPR_VARIABLE)
5664 && (code->expr->symtree->n.sym == forall_index))
5665 gfc_error ("Assignment to a FORALL index variable at %L",
5666 &code->expr->where);
5669 /* If one of the FORALL index variables doesn't appear in the
5670 assignment target, then there will be a many-to-one
5672 if (find_forall_index (code->expr, forall_index, 0) == FAILURE)
5673 gfc_error ("The FORALL with index '%s' cause more than one "
5674 "assignment to this object at %L",
5675 var_expr[n]->symtree->name, &code->expr->where);
5681 /* Resolve WHERE statement in FORALL construct. */
5684 gfc_resolve_where_code_in_forall (gfc_code *code, int nvar,
5685 gfc_expr **var_expr)
5690 cblock = code->block;
5693 /* the assignment statement of a WHERE statement, or the first
5694 statement in where-body-construct of a WHERE construct */
5695 cnext = cblock->next;
5700 /* WHERE assignment statement */
5702 gfc_resolve_assign_in_forall (cnext, nvar, var_expr);
5705 /* WHERE operator assignment statement */
5706 case EXEC_ASSIGN_CALL:
5707 resolve_call (cnext);
5710 /* WHERE or WHERE construct is part of a where-body-construct */
5712 gfc_resolve_where_code_in_forall (cnext, nvar, var_expr);
5716 gfc_error ("Unsupported statement inside WHERE at %L",
5719 /* the next statement within the same where-body-construct */
5720 cnext = cnext->next;
5722 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
5723 cblock = cblock->block;
5728 /* Traverse the FORALL body to check whether the following errors exist:
5729 1. For assignment, check if a many-to-one assignment happens.
5730 2. For WHERE statement, check the WHERE body to see if there is any
5731 many-to-one assignment. */
5734 gfc_resolve_forall_body (gfc_code *code, int nvar, gfc_expr **var_expr)
5738 c = code->block->next;
5744 case EXEC_POINTER_ASSIGN:
5745 gfc_resolve_assign_in_forall (c, nvar, var_expr);
5748 case EXEC_ASSIGN_CALL:
5752 /* Because the gfc_resolve_blocks() will handle the nested FORALL,
5753 there is no need to handle it here. */
5757 gfc_resolve_where_code_in_forall(c, nvar, var_expr);
5762 /* The next statement in the FORALL body. */
5768 /* Given a FORALL construct, first resolve the FORALL iterator, then call
5769 gfc_resolve_forall_body to resolve the FORALL body. */
5772 gfc_resolve_forall (gfc_code *code, gfc_namespace *ns, int forall_save)
5774 static gfc_expr **var_expr;
5775 static int total_var = 0;
5776 static int nvar = 0;
5777 gfc_forall_iterator *fa;
5781 /* Start to resolve a FORALL construct */
5782 if (forall_save == 0)
5784 /* Count the total number of FORALL index in the nested FORALL
5785 construct in order to allocate the VAR_EXPR with proper size. */
5787 while ((next != NULL) && (next->op == EXEC_FORALL))
5789 for (fa = next->ext.forall_iterator; fa; fa = fa->next)
5791 next = next->block->next;
5794 /* Allocate VAR_EXPR with NUMBER_OF_FORALL_INDEX elements. */
5795 var_expr = (gfc_expr **) gfc_getmem (total_var * sizeof (gfc_expr *));
5798 /* The information about FORALL iterator, including FORALL index start, end
5799 and stride. The FORALL index can not appear in start, end or stride. */
5800 for (fa = code->ext.forall_iterator; fa; fa = fa->next)
5802 /* Check if any outer FORALL index name is the same as the current
5804 for (i = 0; i < nvar; i++)
5806 if (fa->var->symtree->n.sym == var_expr[i]->symtree->n.sym)
5808 gfc_error ("An outer FORALL construct already has an index "
5809 "with this name %L", &fa->var->where);
5813 /* Record the current FORALL index. */
5814 var_expr[nvar] = gfc_copy_expr (fa->var);
5819 /* Resolve the FORALL body. */
5820 gfc_resolve_forall_body (code, nvar, var_expr);
5822 /* May call gfc_resolve_forall to resolve the inner FORALL loop. */
5823 gfc_resolve_blocks (code->block, ns);
5825 /* Free VAR_EXPR after the whole FORALL construct resolved. */
5826 for (i = 0; i < total_var; i++)
5827 gfc_free_expr (var_expr[i]);
5829 /* Reset the counters. */
5835 /* Resolve lists of blocks found in IF, SELECT CASE, WHERE, FORALL ,GOTO and
5838 static void resolve_code (gfc_code *, gfc_namespace *);
5841 gfc_resolve_blocks (gfc_code *b, gfc_namespace *ns)
5845 for (; b; b = b->block)
5847 t = gfc_resolve_expr (b->expr);
5848 if (gfc_resolve_expr (b->expr2) == FAILURE)
5854 if (t == SUCCESS && b->expr != NULL
5855 && (b->expr->ts.type != BT_LOGICAL || b->expr->rank != 0))
5856 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
5863 && (b->expr->ts.type != BT_LOGICAL || b->expr->rank == 0))
5864 gfc_error ("WHERE/ELSEWHERE clause at %L requires a LOGICAL array",
5869 resolve_branch (b->label, b);
5881 case EXEC_OMP_ATOMIC:
5882 case EXEC_OMP_CRITICAL:
5884 case EXEC_OMP_MASTER:
5885 case EXEC_OMP_ORDERED:
5886 case EXEC_OMP_PARALLEL:
5887 case EXEC_OMP_PARALLEL_DO:
5888 case EXEC_OMP_PARALLEL_SECTIONS:
5889 case EXEC_OMP_PARALLEL_WORKSHARE:
5890 case EXEC_OMP_SECTIONS:
5891 case EXEC_OMP_SINGLE:
5892 case EXEC_OMP_WORKSHARE:
5896 gfc_internal_error ("resolve_block(): Bad block type");
5899 resolve_code (b->next, ns);
5904 /* Does everything to resolve an ordinary assignment. Returns true
5905 if this is an interface asignment. */
5907 resolve_ordinary_assign (gfc_code *code, gfc_namespace *ns)
5918 if (gfc_extend_assign (code, ns) == SUCCESS)
5920 lhs = code->ext.actual->expr;
5921 rhs = code->ext.actual->next->expr;
5922 if (gfc_pure (NULL) && !gfc_pure (code->symtree->n.sym))
5924 gfc_error ("Subroutine '%s' called instead of assignment at "
5925 "%L must be PURE", code->symtree->n.sym->name,
5930 /* Make a temporary rhs when there is a default initializer
5931 and rhs is the same symbol as the lhs. */
5932 if (rhs->expr_type == EXPR_VARIABLE
5933 && rhs->symtree->n.sym->ts.type == BT_DERIVED
5934 && has_default_initializer (rhs->symtree->n.sym->ts.derived)
5935 && (lhs->symtree->n.sym == rhs->symtree->n.sym))
5936 code->ext.actual->next->expr = gfc_get_parentheses (rhs);
5944 if (lhs->ts.type == BT_CHARACTER
5945 && gfc_option.warn_character_truncation)
5947 if (lhs->ts.cl != NULL
5948 && lhs->ts.cl->length != NULL
5949 && lhs->ts.cl->length->expr_type == EXPR_CONSTANT)
5950 llen = mpz_get_si (lhs->ts.cl->length->value.integer);
5952 if (rhs->expr_type == EXPR_CONSTANT)
5953 rlen = rhs->value.character.length;
5955 else if (rhs->ts.cl != NULL
5956 && rhs->ts.cl->length != NULL
5957 && rhs->ts.cl->length->expr_type == EXPR_CONSTANT)
5958 rlen = mpz_get_si (rhs->ts.cl->length->value.integer);
5960 if (rlen && llen && rlen > llen)
5961 gfc_warning_now ("CHARACTER expression will be truncated "
5962 "in assignment (%d/%d) at %L",
5963 llen, rlen, &code->loc);
5966 /* Ensure that a vector index expression for the lvalue is evaluated
5970 for (ref = lhs->ref; ref; ref= ref->next)
5971 if (ref->type == REF_ARRAY)
5973 for (n = 0; n < ref->u.ar.dimen; n++)
5974 if (ref->u.ar.dimen_type[n] == DIMEN_VECTOR)
5976 = gfc_get_parentheses (ref->u.ar.start[n]);
5980 if (gfc_pure (NULL))
5982 if (gfc_impure_variable (lhs->symtree->n.sym))
5984 gfc_error ("Cannot assign to variable '%s' in PURE "
5986 lhs->symtree->n.sym->name,
5991 if (lhs->ts.type == BT_DERIVED
5992 && lhs->expr_type == EXPR_VARIABLE
5993 && lhs->ts.derived->attr.pointer_comp
5994 && gfc_impure_variable (rhs->symtree->n.sym))
5996 gfc_error ("The impure variable at %L is assigned to "
5997 "a derived type variable with a POINTER "
5998 "component in a PURE procedure (12.6)",
6004 gfc_check_assign (lhs, rhs, 1);
6008 /* Given a block of code, recursively resolve everything pointed to by this
6012 resolve_code (gfc_code *code, gfc_namespace *ns)
6014 int omp_workshare_save;
6020 frame.prev = cs_base;
6024 reachable_labels (code);
6026 for (; code; code = code->next)
6028 frame.current = code;
6029 forall_save = forall_flag;
6031 if (code->op == EXEC_FORALL)
6034 gfc_resolve_forall (code, ns, forall_save);
6037 else if (code->block)
6039 omp_workshare_save = -1;
6042 case EXEC_OMP_PARALLEL_WORKSHARE:
6043 omp_workshare_save = omp_workshare_flag;
6044 omp_workshare_flag = 1;
6045 gfc_resolve_omp_parallel_blocks (code, ns);
6047 case EXEC_OMP_PARALLEL:
6048 case EXEC_OMP_PARALLEL_DO:
6049 case EXEC_OMP_PARALLEL_SECTIONS:
6050 omp_workshare_save = omp_workshare_flag;
6051 omp_workshare_flag = 0;
6052 gfc_resolve_omp_parallel_blocks (code, ns);
6055 gfc_resolve_omp_do_blocks (code, ns);
6057 case EXEC_OMP_WORKSHARE:
6058 omp_workshare_save = omp_workshare_flag;
6059 omp_workshare_flag = 1;
6062 gfc_resolve_blocks (code->block, ns);
6066 if (omp_workshare_save != -1)
6067 omp_workshare_flag = omp_workshare_save;
6070 t = gfc_resolve_expr (code->expr);
6071 forall_flag = forall_save;
6073 if (gfc_resolve_expr (code->expr2) == FAILURE)
6088 /* Keep track of which entry we are up to. */
6089 current_entry_id = code->ext.entry->id;
6093 resolve_where (code, NULL);
6097 if (code->expr != NULL)
6099 if (code->expr->ts.type != BT_INTEGER)
6100 gfc_error ("ASSIGNED GOTO statement at %L requires an "
6101 "INTEGER variable", &code->expr->where);
6102 else if (code->expr->symtree->n.sym->attr.assign != 1)
6103 gfc_error ("Variable '%s' has not been assigned a target "
6104 "label at %L", code->expr->symtree->n.sym->name,
6105 &code->expr->where);
6108 resolve_branch (code->label, code);
6112 if (code->expr != NULL
6113 && (code->expr->ts.type != BT_INTEGER || code->expr->rank))
6114 gfc_error ("Alternate RETURN statement at %L requires a SCALAR-"
6115 "INTEGER return specifier", &code->expr->where);
6118 case EXEC_INIT_ASSIGN:
6125 if (resolve_ordinary_assign (code, ns))
6130 case EXEC_LABEL_ASSIGN:
6131 if (code->label->defined == ST_LABEL_UNKNOWN)
6132 gfc_error ("Label %d referenced at %L is never defined",
6133 code->label->value, &code->label->where);
6135 && (code->expr->expr_type != EXPR_VARIABLE
6136 || code->expr->symtree->n.sym->ts.type != BT_INTEGER
6137 || code->expr->symtree->n.sym->ts.kind
6138 != gfc_default_integer_kind
6139 || code->expr->symtree->n.sym->as != NULL))
6140 gfc_error ("ASSIGN statement at %L requires a scalar "
6141 "default INTEGER variable", &code->expr->where);
6144 case EXEC_POINTER_ASSIGN:
6148 gfc_check_pointer_assign (code->expr, code->expr2);
6151 case EXEC_ARITHMETIC_IF:
6153 && code->expr->ts.type != BT_INTEGER
6154 && code->expr->ts.type != BT_REAL)
6155 gfc_error ("Arithmetic IF statement at %L requires a numeric "
6156 "expression", &code->expr->where);
6158 resolve_branch (code->label, code);
6159 resolve_branch (code->label2, code);
6160 resolve_branch (code->label3, code);
6164 if (t == SUCCESS && code->expr != NULL
6165 && (code->expr->ts.type != BT_LOGICAL
6166 || code->expr->rank != 0))
6167 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
6168 &code->expr->where);
6173 resolve_call (code);
6177 /* Select is complicated. Also, a SELECT construct could be
6178 a transformed computed GOTO. */
6179 resolve_select (code);
6183 if (code->ext.iterator != NULL)
6185 gfc_iterator *iter = code->ext.iterator;
6186 if (gfc_resolve_iterator (iter, true) != FAILURE)
6187 gfc_resolve_do_iterator (code, iter->var->symtree->n.sym);
6192 if (code->expr == NULL)
6193 gfc_internal_error ("resolve_code(): No expression on DO WHILE");
6195 && (code->expr->rank != 0
6196 || code->expr->ts.type != BT_LOGICAL))
6197 gfc_error ("Exit condition of DO WHILE loop at %L must be "
6198 "a scalar LOGICAL expression", &code->expr->where);
6202 if (t == SUCCESS && code->expr != NULL
6203 && code->expr->ts.type != BT_INTEGER)
6204 gfc_error ("STAT tag in ALLOCATE statement at %L must be "
6205 "of type INTEGER", &code->expr->where);
6207 for (a = code->ext.alloc_list; a; a = a->next)
6208 resolve_allocate_expr (a->expr, code);
6212 case EXEC_DEALLOCATE:
6213 if (t == SUCCESS && code->expr != NULL
6214 && code->expr->ts.type != BT_INTEGER)
6216 ("STAT tag in DEALLOCATE statement at %L must be of type "
6217 "INTEGER", &code->expr->where);
6219 for (a = code->ext.alloc_list; a; a = a->next)
6220 resolve_deallocate_expr (a->expr);
6225 if (gfc_resolve_open (code->ext.open) == FAILURE)
6228 resolve_branch (code->ext.open->err, code);
6232 if (gfc_resolve_close (code->ext.close) == FAILURE)
6235 resolve_branch (code->ext.close->err, code);
6238 case EXEC_BACKSPACE:
6242 if (gfc_resolve_filepos (code->ext.filepos) == FAILURE)
6245 resolve_branch (code->ext.filepos->err, code);
6249 if (gfc_resolve_inquire (code->ext.inquire) == FAILURE)
6252 resolve_branch (code->ext.inquire->err, code);
6256 gcc_assert (code->ext.inquire != NULL);
6257 if (gfc_resolve_inquire (code->ext.inquire) == FAILURE)
6260 resolve_branch (code->ext.inquire->err, code);
6265 if (gfc_resolve_dt (code->ext.dt) == FAILURE)
6268 resolve_branch (code->ext.dt->err, code);
6269 resolve_branch (code->ext.dt->end, code);
6270 resolve_branch (code->ext.dt->eor, code);
6274 resolve_transfer (code);
6278 resolve_forall_iterators (code->ext.forall_iterator);
6280 if (code->expr != NULL && code->expr->ts.type != BT_LOGICAL)
6281 gfc_error ("FORALL mask clause at %L requires a LOGICAL "
6282 "expression", &code->expr->where);
6285 case EXEC_OMP_ATOMIC:
6286 case EXEC_OMP_BARRIER:
6287 case EXEC_OMP_CRITICAL:
6288 case EXEC_OMP_FLUSH:
6290 case EXEC_OMP_MASTER:
6291 case EXEC_OMP_ORDERED:
6292 case EXEC_OMP_SECTIONS:
6293 case EXEC_OMP_SINGLE:
6294 case EXEC_OMP_WORKSHARE:
6295 gfc_resolve_omp_directive (code, ns);
6298 case EXEC_OMP_PARALLEL:
6299 case EXEC_OMP_PARALLEL_DO:
6300 case EXEC_OMP_PARALLEL_SECTIONS:
6301 case EXEC_OMP_PARALLEL_WORKSHARE:
6302 omp_workshare_save = omp_workshare_flag;
6303 omp_workshare_flag = 0;
6304 gfc_resolve_omp_directive (code, ns);
6305 omp_workshare_flag = omp_workshare_save;
6309 gfc_internal_error ("resolve_code(): Bad statement code");
6313 cs_base = frame.prev;
6317 /* Resolve initial values and make sure they are compatible with
6321 resolve_values (gfc_symbol *sym)
6323 if (sym->value == NULL)
6326 if (gfc_resolve_expr (sym->value) == FAILURE)
6329 gfc_check_assign_symbol (sym, sym->value);
6333 /* Verify the binding labels for common blocks that are BIND(C). The label
6334 for a BIND(C) common block must be identical in all scoping units in which
6335 the common block is declared. Further, the binding label can not collide
6336 with any other global entity in the program. */
6339 resolve_bind_c_comms (gfc_symtree *comm_block_tree)
6341 if (comm_block_tree->n.common->is_bind_c == 1)
6343 gfc_gsymbol *binding_label_gsym;
6344 gfc_gsymbol *comm_name_gsym;
6346 /* See if a global symbol exists by the common block's name. It may
6347 be NULL if the common block is use-associated. */
6348 comm_name_gsym = gfc_find_gsymbol (gfc_gsym_root,
6349 comm_block_tree->n.common->name);
6350 if (comm_name_gsym != NULL && comm_name_gsym->type != GSYM_COMMON)
6351 gfc_error ("Binding label '%s' for common block '%s' at %L collides "
6352 "with the global entity '%s' at %L",
6353 comm_block_tree->n.common->binding_label,
6354 comm_block_tree->n.common->name,
6355 &(comm_block_tree->n.common->where),
6356 comm_name_gsym->name, &(comm_name_gsym->where));
6357 else if (comm_name_gsym != NULL
6358 && strcmp (comm_name_gsym->name,
6359 comm_block_tree->n.common->name) == 0)
6361 /* TODO: Need to make sure the fields of gfc_gsymbol are initialized
6363 if (comm_name_gsym->binding_label == NULL)
6364 /* No binding label for common block stored yet; save this one. */
6365 comm_name_gsym->binding_label =
6366 comm_block_tree->n.common->binding_label;
6368 if (strcmp (comm_name_gsym->binding_label,
6369 comm_block_tree->n.common->binding_label) != 0)
6371 /* Common block names match but binding labels do not. */
6372 gfc_error ("Binding label '%s' for common block '%s' at %L "
6373 "does not match the binding label '%s' for common "
6375 comm_block_tree->n.common->binding_label,
6376 comm_block_tree->n.common->name,
6377 &(comm_block_tree->n.common->where),
6378 comm_name_gsym->binding_label,
6379 comm_name_gsym->name,
6380 &(comm_name_gsym->where));
6385 /* There is no binding label (NAME="") so we have nothing further to
6386 check and nothing to add as a global symbol for the label. */
6387 if (comm_block_tree->n.common->binding_label[0] == '\0' )
6390 binding_label_gsym =
6391 gfc_find_gsymbol (gfc_gsym_root,
6392 comm_block_tree->n.common->binding_label);
6393 if (binding_label_gsym == NULL)
6395 /* Need to make a global symbol for the binding label to prevent
6396 it from colliding with another. */
6397 binding_label_gsym =
6398 gfc_get_gsymbol (comm_block_tree->n.common->binding_label);
6399 binding_label_gsym->sym_name = comm_block_tree->n.common->name;
6400 binding_label_gsym->type = GSYM_COMMON;
6404 /* If comm_name_gsym is NULL, the name common block is use
6405 associated and the name could be colliding. */
6406 if (binding_label_gsym->type != GSYM_COMMON)
6407 gfc_error ("Binding label '%s' for common block '%s' at %L "
6408 "collides with the global entity '%s' at %L",
6409 comm_block_tree->n.common->binding_label,
6410 comm_block_tree->n.common->name,
6411 &(comm_block_tree->n.common->where),
6412 binding_label_gsym->name,
6413 &(binding_label_gsym->where));
6414 else if (comm_name_gsym != NULL
6415 && (strcmp (binding_label_gsym->name,
6416 comm_name_gsym->binding_label) != 0)
6417 && (strcmp (binding_label_gsym->sym_name,
6418 comm_name_gsym->name) != 0))
6419 gfc_error ("Binding label '%s' for common block '%s' at %L "
6420 "collides with global entity '%s' at %L",
6421 binding_label_gsym->name, binding_label_gsym->sym_name,
6422 &(comm_block_tree->n.common->where),
6423 comm_name_gsym->name, &(comm_name_gsym->where));
6431 /* Verify any BIND(C) derived types in the namespace so we can report errors
6432 for them once, rather than for each variable declared of that type. */
6435 resolve_bind_c_derived_types (gfc_symbol *derived_sym)
6437 if (derived_sym != NULL && derived_sym->attr.flavor == FL_DERIVED
6438 && derived_sym->attr.is_bind_c == 1)
6439 verify_bind_c_derived_type (derived_sym);
6445 /* Verify that any binding labels used in a given namespace do not collide
6446 with the names or binding labels of any global symbols. */
6449 gfc_verify_binding_labels (gfc_symbol *sym)
6453 if (sym != NULL && sym->attr.is_bind_c && sym->attr.is_iso_c == 0
6454 && sym->attr.flavor != FL_DERIVED && sym->binding_label[0] != '\0')
6456 gfc_gsymbol *bind_c_sym;
6458 bind_c_sym = gfc_find_gsymbol (gfc_gsym_root, sym->binding_label);
6459 if (bind_c_sym != NULL
6460 && strcmp (bind_c_sym->name, sym->binding_label) == 0)
6462 if (sym->attr.if_source == IFSRC_DECL
6463 && (bind_c_sym->type != GSYM_SUBROUTINE
6464 && bind_c_sym->type != GSYM_FUNCTION)
6465 && ((sym->attr.contained == 1
6466 && strcmp (bind_c_sym->sym_name, sym->name) != 0)
6467 || (sym->attr.use_assoc == 1
6468 && (strcmp (bind_c_sym->mod_name, sym->module) != 0))))
6470 /* Make sure global procedures don't collide with anything. */
6471 gfc_error ("Binding label '%s' at %L collides with the global "
6472 "entity '%s' at %L", sym->binding_label,
6473 &(sym->declared_at), bind_c_sym->name,
6474 &(bind_c_sym->where));
6477 else if (sym->attr.contained == 0
6478 && (sym->attr.if_source == IFSRC_IFBODY
6479 && sym->attr.flavor == FL_PROCEDURE)
6480 && (bind_c_sym->sym_name != NULL
6481 && strcmp (bind_c_sym->sym_name, sym->name) != 0))
6483 /* Make sure procedures in interface bodies don't collide. */
6484 gfc_error ("Binding label '%s' in interface body at %L collides "
6485 "with the global entity '%s' at %L",
6487 &(sym->declared_at), bind_c_sym->name,
6488 &(bind_c_sym->where));
6491 else if (sym->attr.contained == 0
6492 && (sym->attr.if_source == IFSRC_UNKNOWN))
6493 if ((sym->attr.use_assoc
6494 && (strcmp (bind_c_sym->mod_name, sym->module) != 0))
6495 || sym->attr.use_assoc == 0)
6497 gfc_error ("Binding label '%s' at %L collides with global "
6498 "entity '%s' at %L", sym->binding_label,
6499 &(sym->declared_at), bind_c_sym->name,
6500 &(bind_c_sym->where));
6505 /* Clear the binding label to prevent checking multiple times. */
6506 sym->binding_label[0] = '\0';
6508 else if (bind_c_sym == NULL)
6510 bind_c_sym = gfc_get_gsymbol (sym->binding_label);
6511 bind_c_sym->where = sym->declared_at;
6512 bind_c_sym->sym_name = sym->name;
6514 if (sym->attr.use_assoc == 1)
6515 bind_c_sym->mod_name = sym->module;
6517 if (sym->ns->proc_name != NULL)
6518 bind_c_sym->mod_name = sym->ns->proc_name->name;
6520 if (sym->attr.contained == 0)
6522 if (sym->attr.subroutine)
6523 bind_c_sym->type = GSYM_SUBROUTINE;
6524 else if (sym->attr.function)
6525 bind_c_sym->type = GSYM_FUNCTION;
6533 /* Resolve an index expression. */
6536 resolve_index_expr (gfc_expr *e)
6538 if (gfc_resolve_expr (e) == FAILURE)
6541 if (gfc_simplify_expr (e, 0) == FAILURE)
6544 if (gfc_specification_expr (e) == FAILURE)
6550 /* Resolve a charlen structure. */
6553 resolve_charlen (gfc_charlen *cl)
6562 specification_expr = 1;
6564 if (resolve_index_expr (cl->length) == FAILURE)
6566 specification_expr = 0;
6570 /* "If the character length parameter value evaluates to a negative
6571 value, the length of character entities declared is zero." */
6572 if (cl->length && !gfc_extract_int (cl->length, &i) && i < 0)
6574 gfc_warning_now ("CHARACTER variable has zero length at %L",
6575 &cl->length->where);
6576 gfc_replace_expr (cl->length, gfc_int_expr (0));
6583 /* Test for non-constant shape arrays. */
6586 is_non_constant_shape_array (gfc_symbol *sym)
6592 not_constant = false;
6593 if (sym->as != NULL)
6595 /* Unfortunately, !gfc_is_compile_time_shape hits a legal case that
6596 has not been simplified; parameter array references. Do the
6597 simplification now. */
6598 for (i = 0; i < sym->as->rank; i++)
6600 e = sym->as->lower[i];
6601 if (e && (resolve_index_expr (e) == FAILURE
6602 || !gfc_is_constant_expr (e)))
6603 not_constant = true;
6605 e = sym->as->upper[i];
6606 if (e && (resolve_index_expr (e) == FAILURE
6607 || !gfc_is_constant_expr (e)))
6608 not_constant = true;
6611 return not_constant;
6614 /* Given a symbol and an initialization expression, add code to initialize
6615 the symbol to the function entry. */
6617 build_init_assign (gfc_symbol *sym, gfc_expr *init)
6621 gfc_namespace *ns = sym->ns;
6623 /* Search for the function namespace if this is a contained
6624 function without an explicit result. */
6625 if (sym->attr.function && sym == sym->result
6626 && sym->name != sym->ns->proc_name->name)
6629 for (;ns; ns = ns->sibling)
6630 if (strcmp (ns->proc_name->name, sym->name) == 0)
6636 gfc_free_expr (init);
6640 /* Build an l-value expression for the result. */
6641 lval = gfc_lval_expr_from_sym (sym);
6643 /* Add the code at scope entry. */
6644 init_st = gfc_get_code ();
6645 init_st->next = ns->code;
6648 /* Assign the default initializer to the l-value. */
6649 init_st->loc = sym->declared_at;
6650 init_st->op = EXEC_INIT_ASSIGN;
6651 init_st->expr = lval;
6652 init_st->expr2 = init;
6655 /* Assign the default initializer to a derived type variable or result. */
6658 apply_default_init (gfc_symbol *sym)
6660 gfc_expr *init = NULL;
6662 if (sym->attr.flavor != FL_VARIABLE && !sym->attr.function)
6665 if (sym->ts.type == BT_DERIVED && sym->ts.derived)
6666 init = gfc_default_initializer (&sym->ts);
6671 build_init_assign (sym, init);
6674 /* Build an initializer for a local integer, real, complex, logical, or
6675 character variable, based on the command line flags finit-local-zero,
6676 finit-integer=, finit-real=, finit-logical=, and finit-runtime. Returns
6677 null if the symbol should not have a default initialization. */
6679 build_default_init_expr (gfc_symbol *sym)
6682 gfc_expr *init_expr;
6686 /* These symbols should never have a default initialization. */
6687 if ((sym->attr.dimension && !gfc_is_compile_time_shape (sym->as))
6688 || sym->attr.external
6690 || sym->attr.pointer
6691 || sym->attr.in_equivalence
6692 || sym->attr.in_common
6695 || sym->attr.cray_pointee
6696 || sym->attr.cray_pointer)
6699 /* Now we'll try to build an initializer expression. */
6700 init_expr = gfc_get_expr ();
6701 init_expr->expr_type = EXPR_CONSTANT;
6702 init_expr->ts.type = sym->ts.type;
6703 init_expr->ts.kind = sym->ts.kind;
6704 init_expr->where = sym->declared_at;
6706 /* We will only initialize integers, reals, complex, logicals, and
6707 characters, and only if the corresponding command-line flags
6708 were set. Otherwise, we free init_expr and return null. */
6709 switch (sym->ts.type)
6712 if (gfc_option.flag_init_integer != GFC_INIT_INTEGER_OFF)
6713 mpz_init_set_si (init_expr->value.integer,
6714 gfc_option.flag_init_integer_value);
6717 gfc_free_expr (init_expr);
6723 mpfr_init (init_expr->value.real);
6724 switch (gfc_option.flag_init_real)
6726 case GFC_INIT_REAL_NAN:
6727 mpfr_set_nan (init_expr->value.real);
6730 case GFC_INIT_REAL_INF:
6731 mpfr_set_inf (init_expr->value.real, 1);
6734 case GFC_INIT_REAL_NEG_INF:
6735 mpfr_set_inf (init_expr->value.real, -1);
6738 case GFC_INIT_REAL_ZERO:
6739 mpfr_set_ui (init_expr->value.real, 0.0, GFC_RND_MODE);
6743 gfc_free_expr (init_expr);
6750 mpfr_init (init_expr->value.complex.r);
6751 mpfr_init (init_expr->value.complex.i);
6752 switch (gfc_option.flag_init_real)
6754 case GFC_INIT_REAL_NAN:
6755 mpfr_set_nan (init_expr->value.complex.r);
6756 mpfr_set_nan (init_expr->value.complex.i);
6759 case GFC_INIT_REAL_INF:
6760 mpfr_set_inf (init_expr->value.complex.r, 1);
6761 mpfr_set_inf (init_expr->value.complex.i, 1);
6764 case GFC_INIT_REAL_NEG_INF:
6765 mpfr_set_inf (init_expr->value.complex.r, -1);
6766 mpfr_set_inf (init_expr->value.complex.i, -1);
6769 case GFC_INIT_REAL_ZERO:
6770 mpfr_set_ui (init_expr->value.complex.r, 0.0, GFC_RND_MODE);
6771 mpfr_set_ui (init_expr->value.complex.i, 0.0, GFC_RND_MODE);
6775 gfc_free_expr (init_expr);
6782 if (gfc_option.flag_init_logical == GFC_INIT_LOGICAL_FALSE)
6783 init_expr->value.logical = 0;
6784 else if (gfc_option.flag_init_logical == GFC_INIT_LOGICAL_TRUE)
6785 init_expr->value.logical = 1;
6788 gfc_free_expr (init_expr);
6794 /* For characters, the length must be constant in order to
6795 create a default initializer. */
6796 if (gfc_option.flag_init_character == GFC_INIT_CHARACTER_ON
6797 && sym->ts.cl->length
6798 && sym->ts.cl->length->expr_type == EXPR_CONSTANT)
6800 char_len = mpz_get_si (sym->ts.cl->length->value.integer);
6801 init_expr->value.character.length = char_len;
6802 init_expr->value.character.string = gfc_getmem (char_len+1);
6803 ch = init_expr->value.character.string;
6804 for (i = 0; i < char_len; i++)
6805 *(ch++) = gfc_option.flag_init_character_value;
6809 gfc_free_expr (init_expr);
6815 gfc_free_expr (init_expr);
6821 /* Add an initialization expression to a local variable. */
6823 apply_default_init_local (gfc_symbol *sym)
6825 gfc_expr *init = NULL;
6827 /* The symbol should be a variable or a function return value. */
6828 if ((sym->attr.flavor != FL_VARIABLE && !sym->attr.function)
6829 || (sym->attr.function && sym->result != sym))
6832 /* Try to build the initializer expression. If we can't initialize
6833 this symbol, then init will be NULL. */
6834 init = build_default_init_expr (sym);
6838 /* For saved variables, we don't want to add an initializer at
6839 function entry, so we just add a static initializer. */
6840 if (sym->attr.save || sym->ns->save_all)
6842 /* Don't clobber an existing initializer! */
6843 gcc_assert (sym->value == NULL);
6848 build_init_assign (sym, init);
6851 /* Resolution of common features of flavors variable and procedure. */
6854 resolve_fl_var_and_proc (gfc_symbol *sym, int mp_flag)
6856 /* Constraints on deferred shape variable. */
6857 if (sym->as == NULL || sym->as->type != AS_DEFERRED)
6859 if (sym->attr.allocatable)
6861 if (sym->attr.dimension)
6862 gfc_error ("Allocatable array '%s' at %L must have "
6863 "a deferred shape", sym->name, &sym->declared_at);
6865 gfc_error ("Scalar object '%s' at %L may not be ALLOCATABLE",
6866 sym->name, &sym->declared_at);
6870 if (sym->attr.pointer && sym->attr.dimension)
6872 gfc_error ("Array pointer '%s' at %L must have a deferred shape",
6873 sym->name, &sym->declared_at);
6880 if (!mp_flag && !sym->attr.allocatable
6881 && !sym->attr.pointer && !sym->attr.dummy)
6883 gfc_error ("Array '%s' at %L cannot have a deferred shape",
6884 sym->name, &sym->declared_at);
6892 /* Additional checks for symbols with flavor variable and derived
6893 type. To be called from resolve_fl_variable. */
6896 resolve_fl_variable_derived (gfc_symbol *sym, int no_init_flag)
6898 gcc_assert (sym->ts.type == BT_DERIVED);
6900 /* Check to see if a derived type is blocked from being host
6901 associated by the presence of another class I symbol in the same
6902 namespace. 14.6.1.3 of the standard and the discussion on
6903 comp.lang.fortran. */
6904 if (sym->ns != sym->ts.derived->ns
6905 && sym->ns->proc_name->attr.if_source != IFSRC_IFBODY)
6908 gfc_find_symbol (sym->ts.derived->name, sym->ns, 0, &s);
6909 if (s && (s->attr.flavor != FL_DERIVED
6910 || !gfc_compare_derived_types (s, sym->ts.derived)))
6912 gfc_error ("The type '%s' cannot be host associated at %L "
6913 "because it is blocked by an incompatible object "
6914 "of the same name declared at %L",
6915 sym->ts.derived->name, &sym->declared_at,
6921 /* 4th constraint in section 11.3: "If an object of a type for which
6922 component-initialization is specified (R429) appears in the
6923 specification-part of a module and does not have the ALLOCATABLE
6924 or POINTER attribute, the object shall have the SAVE attribute."
6926 The check for initializers is performed with
6927 has_default_initializer because gfc_default_initializer generates
6928 a hidden default for allocatable components. */
6929 if (!(sym->value || no_init_flag) && sym->ns->proc_name
6930 && sym->ns->proc_name->attr.flavor == FL_MODULE
6931 && !sym->ns->save_all && !sym->attr.save
6932 && !sym->attr.pointer && !sym->attr.allocatable
6933 && has_default_initializer (sym->ts.derived))
6935 gfc_error("Object '%s' at %L must have the SAVE attribute for "
6936 "default initialization of a component",
6937 sym->name, &sym->declared_at);
6941 /* Assign default initializer. */
6942 if (!(sym->value || sym->attr.pointer || sym->attr.allocatable)
6943 && (!no_init_flag || sym->attr.intent == INTENT_OUT))
6945 sym->value = gfc_default_initializer (&sym->ts);
6952 /* Resolve symbols with flavor variable. */
6955 resolve_fl_variable (gfc_symbol *sym, int mp_flag)
6957 int no_init_flag, automatic_flag;
6959 const char *auto_save_msg;
6961 auto_save_msg = "Automatic object '%s' at %L cannot have the "
6964 if (resolve_fl_var_and_proc (sym, mp_flag) == FAILURE)
6967 /* Set this flag to check that variables are parameters of all entries.
6968 This check is effected by the call to gfc_resolve_expr through
6969 is_non_constant_shape_array. */
6970 specification_expr = 1;
6972 if (sym->ns->proc_name
6973 && (sym->ns->proc_name->attr.flavor == FL_MODULE
6974 || sym->ns->proc_name->attr.is_main_program)
6975 && !sym->attr.use_assoc
6976 && !sym->attr.allocatable
6977 && !sym->attr.pointer
6978 && is_non_constant_shape_array (sym))
6980 /* The shape of a main program or module array needs to be
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;
6988 if (sym->ts.type == BT_CHARACTER)
6990 /* Make sure that character string variables with assumed length are
6992 e = sym->ts.cl->length;
6993 if (e == NULL && !sym->attr.dummy && !sym->attr.result)
6995 gfc_error ("Entity with assumed character length at %L must be a "
6996 "dummy argument or a PARAMETER", &sym->declared_at);
7000 if (e && sym->attr.save && !gfc_is_constant_expr (e))
7002 gfc_error (auto_save_msg, sym->name, &sym->declared_at);
7006 if (!gfc_is_constant_expr (e)
7007 && !(e->expr_type == EXPR_VARIABLE
7008 && e->symtree->n.sym->attr.flavor == FL_PARAMETER)
7009 && sym->ns->proc_name
7010 && (sym->ns->proc_name->attr.flavor == FL_MODULE
7011 || sym->ns->proc_name->attr.is_main_program)
7012 && !sym->attr.use_assoc)
7014 gfc_error ("'%s' at %L must have constant character length "
7015 "in this context", sym->name, &sym->declared_at);
7020 if (sym->value == NULL && sym->attr.referenced)
7021 apply_default_init_local (sym); /* Try to apply a default initialization. */
7023 /* Determine if the symbol may not have an initializer. */
7024 no_init_flag = automatic_flag = 0;
7025 if (sym->attr.allocatable || sym->attr.external || sym->attr.dummy
7026 || sym->attr.intrinsic || sym->attr.result)
7028 else if (sym->attr.dimension && !sym->attr.pointer
7029 && is_non_constant_shape_array (sym))
7031 no_init_flag = automatic_flag = 1;
7033 /* Also, they must not have the SAVE attribute.
7034 SAVE_IMPLICIT is checked below. */
7035 if (sym->attr.save == SAVE_EXPLICIT)
7037 gfc_error (auto_save_msg, sym->name, &sym->declared_at);
7042 /* Reject illegal initializers. */
7043 if (!sym->mark && sym->value)
7045 if (sym->attr.allocatable)
7046 gfc_error ("Allocatable '%s' at %L cannot have an initializer",
7047 sym->name, &sym->declared_at);
7048 else if (sym->attr.external)
7049 gfc_error ("External '%s' at %L cannot have an initializer",
7050 sym->name, &sym->declared_at);
7051 else if (sym->attr.dummy
7052 && !(sym->ts.type == BT_DERIVED && sym->attr.intent == INTENT_OUT))
7053 gfc_error ("Dummy '%s' at %L cannot have an initializer",
7054 sym->name, &sym->declared_at);
7055 else if (sym->attr.intrinsic)
7056 gfc_error ("Intrinsic '%s' at %L cannot have an initializer",
7057 sym->name, &sym->declared_at);
7058 else if (sym->attr.result)
7059 gfc_error ("Function result '%s' at %L cannot have an initializer",
7060 sym->name, &sym->declared_at);
7061 else if (automatic_flag)
7062 gfc_error ("Automatic array '%s' at %L cannot have an initializer",
7063 sym->name, &sym->declared_at);
7070 if (sym->ts.type == BT_DERIVED)
7071 return resolve_fl_variable_derived (sym, no_init_flag);
7077 /* Resolve a procedure. */
7080 resolve_fl_procedure (gfc_symbol *sym, int mp_flag)
7082 gfc_formal_arglist *arg;
7084 if (sym->attr.ambiguous_interfaces && !sym->attr.referenced)
7085 gfc_warning ("Although not referenced, '%s' at %L has ambiguous "
7086 "interfaces", sym->name, &sym->declared_at);
7088 if (sym->attr.function
7089 && resolve_fl_var_and_proc (sym, mp_flag) == FAILURE)
7092 if (sym->ts.type == BT_CHARACTER)
7094 gfc_charlen *cl = sym->ts.cl;
7096 if (cl && cl->length && gfc_is_constant_expr (cl->length)
7097 && resolve_charlen (cl) == FAILURE)
7100 if (!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT)
7102 if (sym->attr.proc == PROC_ST_FUNCTION)
7104 gfc_error ("Character-valued statement function '%s' at %L must "
7105 "have constant length", sym->name, &sym->declared_at);
7109 if (sym->attr.external && sym->formal == NULL
7110 && cl && cl->length && cl->length->expr_type != EXPR_CONSTANT)
7112 gfc_error ("Automatic character length function '%s' at %L must "
7113 "have an explicit interface", sym->name,
7120 /* Ensure that derived type for are not of a private type. Internal
7121 module procedures are excluded by 2.2.3.3 - ie. they are not
7122 externally accessible and can access all the objects accessible in
7124 if (!(sym->ns->parent
7125 && sym->ns->parent->proc_name->attr.flavor == FL_MODULE)
7126 && gfc_check_access(sym->attr.access, sym->ns->default_access))
7128 gfc_interface *iface;
7130 for (arg = sym->formal; arg; arg = arg->next)
7133 && arg->sym->ts.type == BT_DERIVED
7134 && !arg->sym->ts.derived->attr.use_assoc
7135 && !gfc_check_access (arg->sym->ts.derived->attr.access,
7136 arg->sym->ts.derived->ns->default_access)
7137 && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: '%s' is of a "
7138 "PRIVATE type and cannot be a dummy argument"
7139 " of '%s', which is PUBLIC at %L",
7140 arg->sym->name, sym->name, &sym->declared_at)
7143 /* Stop this message from recurring. */
7144 arg->sym->ts.derived->attr.access = ACCESS_PUBLIC;
7149 /* PUBLIC interfaces may expose PRIVATE procedures that take types
7150 PRIVATE to the containing module. */
7151 for (iface = sym->generic; iface; iface = iface->next)
7153 for (arg = iface->sym->formal; arg; arg = arg->next)
7156 && arg->sym->ts.type == BT_DERIVED
7157 && !arg->sym->ts.derived->attr.use_assoc
7158 && !gfc_check_access (arg->sym->ts.derived->attr.access,
7159 arg->sym->ts.derived->ns->default_access)
7160 && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Procedure "
7161 "'%s' in PUBLIC interface '%s' at %L "
7162 "takes dummy arguments of '%s' which is "
7163 "PRIVATE", iface->sym->name, sym->name,
7164 &iface->sym->declared_at,
7165 gfc_typename (&arg->sym->ts)) == FAILURE)
7167 /* Stop this message from recurring. */
7168 arg->sym->ts.derived->attr.access = ACCESS_PUBLIC;
7174 /* PUBLIC interfaces may expose PRIVATE procedures that take types
7175 PRIVATE to the containing module. */
7176 for (iface = sym->generic; iface; iface = iface->next)
7178 for (arg = iface->sym->formal; arg; arg = arg->next)
7181 && arg->sym->ts.type == BT_DERIVED
7182 && !arg->sym->ts.derived->attr.use_assoc
7183 && !gfc_check_access (arg->sym->ts.derived->attr.access,
7184 arg->sym->ts.derived->ns->default_access)
7185 && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Procedure "
7186 "'%s' in PUBLIC interface '%s' at %L "
7187 "takes dummy arguments of '%s' which is "
7188 "PRIVATE", iface->sym->name, sym->name,
7189 &iface->sym->declared_at,
7190 gfc_typename (&arg->sym->ts)) == FAILURE)
7192 /* Stop this message from recurring. */
7193 arg->sym->ts.derived->attr.access = ACCESS_PUBLIC;
7200 if (sym->attr.function && sym->value && sym->attr.proc != PROC_ST_FUNCTION)
7202 gfc_error ("Function '%s' at %L cannot have an initializer",
7203 sym->name, &sym->declared_at);
7207 /* An external symbol may not have an initializer because it is taken to be
7209 if (sym->attr.external && sym->value)
7211 gfc_error ("External object '%s' at %L may not have an initializer",
7212 sym->name, &sym->declared_at);
7216 /* An elemental function is required to return a scalar 12.7.1 */
7217 if (sym->attr.elemental && sym->attr.function && sym->as)
7219 gfc_error ("ELEMENTAL function '%s' at %L must have a scalar "
7220 "result", sym->name, &sym->declared_at);
7221 /* Reset so that the error only occurs once. */
7222 sym->attr.elemental = 0;
7226 /* 5.1.1.5 of the Standard: A function name declared with an asterisk
7227 char-len-param shall not be array-valued, pointer-valued, recursive
7228 or pure. ....snip... A character value of * may only be used in the
7229 following ways: (i) Dummy arg of procedure - dummy associates with
7230 actual length; (ii) To declare a named constant; or (iii) External
7231 function - but length must be declared in calling scoping unit. */
7232 if (sym->attr.function
7233 && sym->ts.type == BT_CHARACTER
7234 && sym->ts.cl && sym->ts.cl->length == NULL)
7236 if ((sym->as && sym->as->rank) || (sym->attr.pointer)
7237 || (sym->attr.recursive) || (sym->attr.pure))
7239 if (sym->as && sym->as->rank)
7240 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
7241 "array-valued", sym->name, &sym->declared_at);
7243 if (sym->attr.pointer)
7244 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
7245 "pointer-valued", sym->name, &sym->declared_at);
7248 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
7249 "pure", sym->name, &sym->declared_at);
7251 if (sym->attr.recursive)
7252 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
7253 "recursive", sym->name, &sym->declared_at);
7258 /* Appendix B.2 of the standard. Contained functions give an
7259 error anyway. Fixed-form is likely to be F77/legacy. */
7260 if (!sym->attr.contained && gfc_current_form != FORM_FIXED)
7261 gfc_notify_std (GFC_STD_F95_OBS, "CHARACTER(*) function "
7262 "'%s' at %L is obsolescent in fortran 95",
7263 sym->name, &sym->declared_at);
7266 if (sym->attr.is_bind_c && sym->attr.is_c_interop != 1)
7268 gfc_formal_arglist *curr_arg;
7269 int has_non_interop_arg = 0;
7271 if (verify_bind_c_sym (sym, &(sym->ts), sym->attr.in_common,
7272 sym->common_block) == FAILURE)
7274 /* Clear these to prevent looking at them again if there was an
7276 sym->attr.is_bind_c = 0;
7277 sym->attr.is_c_interop = 0;
7278 sym->ts.is_c_interop = 0;
7282 /* So far, no errors have been found. */
7283 sym->attr.is_c_interop = 1;
7284 sym->ts.is_c_interop = 1;
7287 curr_arg = sym->formal;
7288 while (curr_arg != NULL)
7290 /* Skip implicitly typed dummy args here. */
7291 if (curr_arg->sym->attr.implicit_type == 0)
7292 if (verify_c_interop_param (curr_arg->sym) == FAILURE)
7293 /* If something is found to fail, record the fact so we
7294 can mark the symbol for the procedure as not being
7295 BIND(C) to try and prevent multiple errors being
7297 has_non_interop_arg = 1;
7299 curr_arg = curr_arg->next;
7302 /* See if any of the arguments were not interoperable and if so, clear
7303 the procedure symbol to prevent duplicate error messages. */
7304 if (has_non_interop_arg != 0)
7306 sym->attr.is_c_interop = 0;
7307 sym->ts.is_c_interop = 0;
7308 sym->attr.is_bind_c = 0;
7316 /* Resolve the components of a derived type. */
7319 resolve_fl_derived (gfc_symbol *sym)
7322 gfc_dt_list * dt_list;
7325 for (c = sym->components; c != NULL; c = c->next)
7327 if (c->ts.type == BT_CHARACTER)
7329 if (c->ts.cl->length == NULL
7330 || (resolve_charlen (c->ts.cl) == FAILURE)
7331 || !gfc_is_constant_expr (c->ts.cl->length))
7333 gfc_error ("Character length of component '%s' needs to "
7334 "be a constant specification expression at %L",
7336 c->ts.cl->length ? &c->ts.cl->length->where : &c->loc);
7341 if (c->ts.type == BT_DERIVED
7342 && sym->component_access != ACCESS_PRIVATE
7343 && gfc_check_access (sym->attr.access, sym->ns->default_access)
7344 && !c->ts.derived->attr.use_assoc
7345 && !gfc_check_access (c->ts.derived->attr.access,
7346 c->ts.derived->ns->default_access))
7348 gfc_error ("The component '%s' is a PRIVATE type and cannot be "
7349 "a component of '%s', which is PUBLIC at %L",
7350 c->name, sym->name, &sym->declared_at);
7354 if (sym->attr.sequence)
7356 if (c->ts.type == BT_DERIVED && c->ts.derived->attr.sequence == 0)
7358 gfc_error ("Component %s of SEQUENCE type declared at %L does "
7359 "not have the SEQUENCE attribute",
7360 c->ts.derived->name, &sym->declared_at);
7365 if (c->ts.type == BT_DERIVED && c->pointer
7366 && c->ts.derived->components == NULL)
7368 gfc_error ("The pointer component '%s' of '%s' at %L is a type "
7369 "that has not been declared", c->name, sym->name,
7374 if (c->pointer || c->allocatable || c->as == NULL)
7377 for (i = 0; i < c->as->rank; i++)
7379 if (c->as->lower[i] == NULL
7380 || !gfc_is_constant_expr (c->as->lower[i])
7381 || (resolve_index_expr (c->as->lower[i]) == FAILURE)
7382 || c->as->upper[i] == NULL
7383 || (resolve_index_expr (c->as->upper[i]) == FAILURE)
7384 || !gfc_is_constant_expr (c->as->upper[i]))
7386 gfc_error ("Component '%s' of '%s' at %L must have "
7387 "constant array bounds",
7388 c->name, sym->name, &c->loc);
7394 /* Add derived type to the derived type list. */
7395 for (dt_list = gfc_derived_types; dt_list; dt_list = dt_list->next)
7396 if (sym == dt_list->derived)
7399 if (dt_list == NULL)
7401 dt_list = gfc_get_dt_list ();
7402 dt_list->next = gfc_derived_types;
7403 dt_list->derived = sym;
7404 gfc_derived_types = dt_list;
7412 resolve_fl_namelist (gfc_symbol *sym)
7417 /* Reject PRIVATE objects in a PUBLIC namelist. */
7418 if (gfc_check_access(sym->attr.access, sym->ns->default_access))
7420 for (nl = sym->namelist; nl; nl = nl->next)
7422 if (!nl->sym->attr.use_assoc
7423 && !(sym->ns->parent == nl->sym->ns)
7424 && !(sym->ns->parent
7425 && sym->ns->parent->parent == nl->sym->ns)
7426 && !gfc_check_access(nl->sym->attr.access,
7427 nl->sym->ns->default_access))
7429 gfc_error ("NAMELIST object '%s' was declared PRIVATE and "
7430 "cannot be member of PUBLIC namelist '%s' at %L",
7431 nl->sym->name, sym->name, &sym->declared_at);
7435 /* Types with private components that came here by USE-association. */
7436 if (nl->sym->ts.type == BT_DERIVED
7437 && derived_inaccessible (nl->sym->ts.derived))
7439 gfc_error ("NAMELIST object '%s' has use-associated PRIVATE "
7440 "components and cannot be member of namelist '%s' at %L",
7441 nl->sym->name, sym->name, &sym->declared_at);
7445 /* Types with private components that are defined in the same module. */
7446 if (nl->sym->ts.type == BT_DERIVED
7447 && !(sym->ns->parent == nl->sym->ts.derived->ns)
7448 && !gfc_check_access (nl->sym->ts.derived->attr.private_comp
7449 ? ACCESS_PRIVATE : ACCESS_UNKNOWN,
7450 nl->sym->ns->default_access))
7452 gfc_error ("NAMELIST object '%s' has PRIVATE components and "
7453 "cannot be a member of PUBLIC namelist '%s' at %L",
7454 nl->sym->name, sym->name, &sym->declared_at);
7460 for (nl = sym->namelist; nl; nl = nl->next)
7462 /* Reject namelist arrays of assumed shape. */
7463 if (nl->sym->as && nl->sym->as->type == AS_ASSUMED_SHAPE
7464 && gfc_notify_std (GFC_STD_F2003, "NAMELIST array object '%s' "
7465 "must not have assumed shape in namelist "
7466 "'%s' at %L", nl->sym->name, sym->name,
7467 &sym->declared_at) == FAILURE)
7470 /* Reject namelist arrays that are not constant shape. */
7471 if (is_non_constant_shape_array (nl->sym))
7473 gfc_error ("NAMELIST array object '%s' must have constant "
7474 "shape in namelist '%s' at %L", nl->sym->name,
7475 sym->name, &sym->declared_at);
7479 /* Namelist objects cannot have allocatable or pointer components. */
7480 if (nl->sym->ts.type != BT_DERIVED)
7483 if (nl->sym->ts.derived->attr.alloc_comp)
7485 gfc_error ("NAMELIST object '%s' in namelist '%s' at %L cannot "
7486 "have ALLOCATABLE components",
7487 nl->sym->name, sym->name, &sym->declared_at);
7491 if (nl->sym->ts.derived->attr.pointer_comp)
7493 gfc_error ("NAMELIST object '%s' in namelist '%s' at %L cannot "
7494 "have POINTER components",
7495 nl->sym->name, sym->name, &sym->declared_at);
7501 /* 14.1.2 A module or internal procedure represent local entities
7502 of the same type as a namelist member and so are not allowed. */
7503 for (nl = sym->namelist; nl; nl = nl->next)
7505 if (nl->sym->ts.kind != 0 && nl->sym->attr.flavor == FL_VARIABLE)
7508 if (nl->sym->attr.function && nl->sym == nl->sym->result)
7509 if ((nl->sym == sym->ns->proc_name)
7511 (sym->ns->parent && nl->sym == sym->ns->parent->proc_name))
7515 if (nl->sym && nl->sym->name)
7516 gfc_find_symbol (nl->sym->name, sym->ns, 1, &nlsym);
7517 if (nlsym && nlsym->attr.flavor == FL_PROCEDURE)
7519 gfc_error ("PROCEDURE attribute conflicts with NAMELIST "
7520 "attribute in '%s' at %L", nlsym->name,
7531 resolve_fl_parameter (gfc_symbol *sym)
7533 /* A parameter array's shape needs to be constant. */
7535 && (sym->as->type == AS_DEFERRED
7536 || is_non_constant_shape_array (sym)))
7538 gfc_error ("Parameter array '%s' at %L cannot be automatic "
7539 "or of deferred shape", sym->name, &sym->declared_at);
7543 /* Make sure a parameter that has been implicitly typed still
7544 matches the implicit type, since PARAMETER statements can precede
7545 IMPLICIT statements. */
7546 if (sym->attr.implicit_type
7547 && !gfc_compare_types (&sym->ts, gfc_get_default_type (sym, sym->ns)))
7549 gfc_error ("Implicitly typed PARAMETER '%s' at %L doesn't match a "
7550 "later IMPLICIT type", sym->name, &sym->declared_at);
7554 /* Make sure the types of derived parameters are consistent. This
7555 type checking is deferred until resolution because the type may
7556 refer to a derived type from the host. */
7557 if (sym->ts.type == BT_DERIVED
7558 && !gfc_compare_types (&sym->ts, &sym->value->ts))
7560 gfc_error ("Incompatible derived type in PARAMETER at %L",
7561 &sym->value->where);
7568 /* Do anything necessary to resolve a symbol. Right now, we just
7569 assume that an otherwise unknown symbol is a variable. This sort
7570 of thing commonly happens for symbols in module. */
7573 resolve_symbol (gfc_symbol *sym)
7575 int check_constant, mp_flag;
7576 gfc_symtree *symtree;
7577 gfc_symtree *this_symtree;
7581 if (sym->attr.flavor == FL_UNKNOWN)
7584 /* If we find that a flavorless symbol is an interface in one of the
7585 parent namespaces, find its symtree in this namespace, free the
7586 symbol and set the symtree to point to the interface symbol. */
7587 for (ns = gfc_current_ns->parent; ns; ns = ns->parent)
7589 symtree = gfc_find_symtree (ns->sym_root, sym->name);
7590 if (symtree && symtree->n.sym->generic)
7592 this_symtree = gfc_find_symtree (gfc_current_ns->sym_root,
7596 gfc_free_symbol (sym);
7597 symtree->n.sym->refs++;
7598 this_symtree->n.sym = symtree->n.sym;
7603 /* Otherwise give it a flavor according to such attributes as
7605 if (sym->attr.external == 0 && sym->attr.intrinsic == 0)
7606 sym->attr.flavor = FL_VARIABLE;
7609 sym->attr.flavor = FL_PROCEDURE;
7610 if (sym->attr.dimension)
7611 sym->attr.function = 1;
7615 if (sym->attr.procedure && sym->interface
7616 && sym->attr.if_source != IFSRC_DECL)
7618 while (sym->interface->interface)
7619 sym->interface = sym->interface->interface;
7621 /* Get the attributes from the interface (now resolved). */
7622 if (sym->interface->attr.if_source || sym->interface->attr.intrinsic)
7624 sym->ts = sym->interface->ts;
7625 sym->attr.function = sym->interface->attr.function;
7626 sym->attr.subroutine = sym->interface->attr.subroutine;
7627 copy_formal_args (sym, sym->interface);
7629 else if (sym->interface->name[0] != '\0')
7631 gfc_error ("Interface '%s' of procedure '%s' at %L must be explicit",
7632 sym->interface->name, sym->name, &sym->declared_at);
7637 if (sym->attr.flavor == FL_DERIVED && resolve_fl_derived (sym) == FAILURE)
7640 /* Symbols that are module procedures with results (functions) have
7641 the types and array specification copied for type checking in
7642 procedures that call them, as well as for saving to a module
7643 file. These symbols can't stand the scrutiny that their results
7645 mp_flag = (sym->result != NULL && sym->result != sym);
7648 /* Make sure that the intrinsic is consistent with its internal
7649 representation. This needs to be done before assigning a default
7650 type to avoid spurious warnings. */
7651 if (sym->attr.flavor != FL_MODULE && sym->attr.intrinsic)
7653 if (gfc_intrinsic_name (sym->name, 0))
7655 if (sym->ts.type != BT_UNKNOWN && gfc_option.warn_surprising)
7656 gfc_warning ("Type specified for intrinsic function '%s' at %L is ignored",
7657 sym->name, &sym->declared_at);
7659 else if (gfc_intrinsic_name (sym->name, 1))
7661 if (sym->ts.type != BT_UNKNOWN)
7663 gfc_error ("Intrinsic subroutine '%s' at %L shall not have a type specifier",
7664 sym->name, &sym->declared_at);
7670 gfc_error ("Intrinsic '%s' at %L does not exist", sym->name, &sym->declared_at);
7675 /* Assign default type to symbols that need one and don't have one. */
7676 if (sym->ts.type == BT_UNKNOWN)
7678 if (sym->attr.flavor == FL_VARIABLE || sym->attr.flavor == FL_PARAMETER)
7679 gfc_set_default_type (sym, 1, NULL);
7681 if (sym->attr.flavor == FL_PROCEDURE && sym->attr.function)
7683 /* The specific case of an external procedure should emit an error
7684 in the case that there is no implicit type. */
7686 gfc_set_default_type (sym, sym->attr.external, NULL);
7689 /* Result may be in another namespace. */
7690 resolve_symbol (sym->result);
7692 sym->ts = sym->result->ts;
7693 sym->as = gfc_copy_array_spec (sym->result->as);
7694 sym->attr.dimension = sym->result->attr.dimension;
7695 sym->attr.pointer = sym->result->attr.pointer;
7696 sym->attr.allocatable = sym->result->attr.allocatable;
7701 /* Assumed size arrays and assumed shape arrays must be dummy
7705 && (sym->as->type == AS_ASSUMED_SIZE
7706 || sym->as->type == AS_ASSUMED_SHAPE)
7707 && sym->attr.dummy == 0)
7709 if (sym->as->type == AS_ASSUMED_SIZE)
7710 gfc_error ("Assumed size array at %L must be a dummy argument",
7713 gfc_error ("Assumed shape array at %L must be a dummy argument",
7718 /* Make sure symbols with known intent or optional are really dummy
7719 variable. Because of ENTRY statement, this has to be deferred
7720 until resolution time. */
7722 if (!sym->attr.dummy
7723 && (sym->attr.optional || sym->attr.intent != INTENT_UNKNOWN))
7725 gfc_error ("Symbol at %L is not a DUMMY variable", &sym->declared_at);
7729 if (sym->attr.value && !sym->attr.dummy)
7731 gfc_error ("'%s' at %L cannot have the VALUE attribute because "
7732 "it is not a dummy argument", sym->name, &sym->declared_at);
7736 if (sym->attr.value && sym->ts.type == BT_CHARACTER)
7738 gfc_charlen *cl = sym->ts.cl;
7739 if (!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT)
7741 gfc_error ("Character dummy variable '%s' at %L with VALUE "
7742 "attribute must have constant length",
7743 sym->name, &sym->declared_at);
7747 if (sym->ts.is_c_interop
7748 && mpz_cmp_si (cl->length->value.integer, 1) != 0)
7750 gfc_error ("C interoperable character dummy variable '%s' at %L "
7751 "with VALUE attribute must have length one",
7752 sym->name, &sym->declared_at);
7757 /* If the symbol is marked as bind(c), verify it's type and kind. Do not
7758 do this for something that was implicitly typed because that is handled
7759 in gfc_set_default_type. Handle dummy arguments and procedure
7760 definitions separately. Also, anything that is use associated is not
7761 handled here but instead is handled in the module it is declared in.
7762 Finally, derived type definitions are allowed to be BIND(C) since that
7763 only implies that they're interoperable, and they are checked fully for
7764 interoperability when a variable is declared of that type. */
7765 if (sym->attr.is_bind_c && sym->attr.implicit_type == 0 &&
7766 sym->attr.use_assoc == 0 && sym->attr.dummy == 0 &&
7767 sym->attr.flavor != FL_PROCEDURE && sym->attr.flavor != FL_DERIVED)
7771 /* First, make sure the variable is declared at the
7772 module-level scope (J3/04-007, Section 15.3). */
7773 if (sym->ns->proc_name->attr.flavor != FL_MODULE &&
7774 sym->attr.in_common == 0)
7776 gfc_error ("Variable '%s' at %L cannot be BIND(C) because it "
7777 "is neither a COMMON block nor declared at the "
7778 "module level scope", sym->name, &(sym->declared_at));
7781 else if (sym->common_head != NULL)
7783 t = verify_com_block_vars_c_interop (sym->common_head);
7787 /* If type() declaration, we need to verify that the components
7788 of the given type are all C interoperable, etc. */
7789 if (sym->ts.type == BT_DERIVED &&
7790 sym->ts.derived->attr.is_c_interop != 1)
7792 /* Make sure the user marked the derived type as BIND(C). If
7793 not, call the verify routine. This could print an error
7794 for the derived type more than once if multiple variables
7795 of that type are declared. */
7796 if (sym->ts.derived->attr.is_bind_c != 1)
7797 verify_bind_c_derived_type (sym->ts.derived);
7801 /* Verify the variable itself as C interoperable if it
7802 is BIND(C). It is not possible for this to succeed if
7803 the verify_bind_c_derived_type failed, so don't have to handle
7804 any error returned by verify_bind_c_derived_type. */
7805 t = verify_bind_c_sym (sym, &(sym->ts), sym->attr.in_common,
7811 /* clear the is_bind_c flag to prevent reporting errors more than
7812 once if something failed. */
7813 sym->attr.is_bind_c = 0;
7818 /* If a derived type symbol has reached this point, without its
7819 type being declared, we have an error. Notice that most
7820 conditions that produce undefined derived types have already
7821 been dealt with. However, the likes of:
7822 implicit type(t) (t) ..... call foo (t) will get us here if
7823 the type is not declared in the scope of the implicit
7824 statement. Change the type to BT_UNKNOWN, both because it is so
7825 and to prevent an ICE. */
7826 if (sym->ts.type == BT_DERIVED && sym->ts.derived->components == NULL
7827 && !sym->ts.derived->attr.zero_comp)
7829 gfc_error ("The derived type '%s' at %L is of type '%s', "
7830 "which has not been defined", sym->name,
7831 &sym->declared_at, sym->ts.derived->name);
7832 sym->ts.type = BT_UNKNOWN;
7836 /* Unless the derived-type declaration is use associated, Fortran 95
7837 does not allow public entries of private derived types.
7838 See 4.4.1 (F95) and 4.5.1.1 (F2003); and related interpretation
7840 if (sym->ts.type == BT_DERIVED
7841 && gfc_check_access (sym->attr.access, sym->ns->default_access)
7842 && !gfc_check_access (sym->ts.derived->attr.access,
7843 sym->ts.derived->ns->default_access)
7844 && !sym->ts.derived->attr.use_assoc
7845 && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: PUBLIC %s '%s' at %L "
7846 "of PRIVATE derived type '%s'",
7847 (sym->attr.flavor == FL_PARAMETER) ? "parameter"
7848 : "variable", sym->name, &sym->declared_at,
7849 sym->ts.derived->name) == FAILURE)
7852 /* An assumed-size array with INTENT(OUT) shall not be of a type for which
7853 default initialization is defined (5.1.2.4.4). */
7854 if (sym->ts.type == BT_DERIVED
7856 && sym->attr.intent == INTENT_OUT
7858 && sym->as->type == AS_ASSUMED_SIZE)
7860 for (c = sym->ts.derived->components; c; c = c->next)
7864 gfc_error ("The INTENT(OUT) dummy argument '%s' at %L is "
7865 "ASSUMED SIZE and so cannot have a default initializer",
7866 sym->name, &sym->declared_at);
7872 switch (sym->attr.flavor)
7875 if (resolve_fl_variable (sym, mp_flag) == FAILURE)
7880 if (resolve_fl_procedure (sym, mp_flag) == FAILURE)
7885 if (resolve_fl_namelist (sym) == FAILURE)
7890 if (resolve_fl_parameter (sym) == FAILURE)
7898 /* Resolve array specifier. Check as well some constraints
7899 on COMMON blocks. */
7901 check_constant = sym->attr.in_common && !sym->attr.pointer;
7903 /* Set the formal_arg_flag so that check_conflict will not throw
7904 an error for host associated variables in the specification
7905 expression for an array_valued function. */
7906 if (sym->attr.function && sym->as)
7907 formal_arg_flag = 1;
7909 gfc_resolve_array_spec (sym->as, check_constant);
7911 formal_arg_flag = 0;
7913 /* Resolve formal namespaces. */
7914 if (sym->formal_ns && sym->formal_ns != gfc_current_ns)
7915 gfc_resolve (sym->formal_ns);
7917 /* Check threadprivate restrictions. */
7918 if (sym->attr.threadprivate && !sym->attr.save && !sym->ns->save_all
7919 && (!sym->attr.in_common
7920 && sym->module == NULL
7921 && (sym->ns->proc_name == NULL
7922 || sym->ns->proc_name->attr.flavor != FL_MODULE)))
7923 gfc_error ("Threadprivate at %L isn't SAVEd", &sym->declared_at);
7925 /* If we have come this far we can apply default-initializers, as
7926 described in 14.7.5, to those variables that have not already
7927 been assigned one. */
7928 if (sym->ts.type == BT_DERIVED
7929 && sym->attr.referenced
7930 && sym->ns == gfc_current_ns
7932 && !sym->attr.allocatable
7933 && !sym->attr.alloc_comp)
7935 symbol_attribute *a = &sym->attr;
7937 if ((!a->save && !a->dummy && !a->pointer
7938 && !a->in_common && !a->use_assoc
7939 && !(a->function && sym != sym->result))
7940 || (a->dummy && a->intent == INTENT_OUT))
7941 apply_default_init (sym);
7946 /************* Resolve DATA statements *************/
7950 gfc_data_value *vnode;
7956 /* Advance the values structure to point to the next value in the data list. */
7959 next_data_value (void)
7962 while (mpz_cmp_ui (values.left, 0) == 0)
7964 if (values.vnode->next == NULL)
7967 values.vnode = values.vnode->next;
7968 mpz_set (values.left, values.vnode->repeat);
7976 check_data_variable (gfc_data_variable *var, locus *where)
7982 ar_type mark = AR_UNKNOWN;
7984 mpz_t section_index[GFC_MAX_DIMENSIONS];
7988 if (gfc_resolve_expr (var->expr) == FAILURE)
7992 mpz_init_set_si (offset, 0);
7995 if (e->expr_type != EXPR_VARIABLE)
7996 gfc_internal_error ("check_data_variable(): Bad expression");
7998 if (e->symtree->n.sym->ns->is_block_data
7999 && !e->symtree->n.sym->attr.in_common)
8001 gfc_error ("BLOCK DATA element '%s' at %L must be in COMMON",
8002 e->symtree->n.sym->name, &e->symtree->n.sym->declared_at);
8007 mpz_init_set_ui (size, 1);
8014 /* Find the array section reference. */
8015 for (ref = e->ref; ref; ref = ref->next)
8017 if (ref->type != REF_ARRAY)
8019 if (ref->u.ar.type == AR_ELEMENT)
8025 /* Set marks according to the reference pattern. */
8026 switch (ref->u.ar.type)
8034 /* Get the start position of array section. */
8035 gfc_get_section_index (ar, section_index, &offset);
8043 if (gfc_array_size (e, &size) == FAILURE)
8045 gfc_error ("Nonconstant array section at %L in DATA statement",
8054 while (mpz_cmp_ui (size, 0) > 0)
8056 if (next_data_value () == FAILURE)
8058 gfc_error ("DATA statement at %L has more variables than values",
8064 t = gfc_check_assign (var->expr, values.vnode->expr, 0);
8068 /* If we have more than one element left in the repeat count,
8069 and we have more than one element left in the target variable,
8070 then create a range assignment. */
8071 /* FIXME: Only done for full arrays for now, since array sections
8073 if (mark == AR_FULL && ref && ref->next == NULL
8074 && mpz_cmp_ui (values.left, 1) > 0 && mpz_cmp_ui (size, 1) > 0)
8078 if (mpz_cmp (size, values.left) >= 0)
8080 mpz_init_set (range, values.left);
8081 mpz_sub (size, size, values.left);
8082 mpz_set_ui (values.left, 0);
8086 mpz_init_set (range, size);
8087 mpz_sub (values.left, values.left, size);
8088 mpz_set_ui (size, 0);
8091 gfc_assign_data_value_range (var->expr, values.vnode->expr,
8094 mpz_add (offset, offset, range);
8098 /* Assign initial value to symbol. */
8101 mpz_sub_ui (values.left, values.left, 1);
8102 mpz_sub_ui (size, size, 1);
8104 t = gfc_assign_data_value (var->expr, values.vnode->expr, offset);
8108 if (mark == AR_FULL)
8109 mpz_add_ui (offset, offset, 1);
8111 /* Modify the array section indexes and recalculate the offset
8112 for next element. */
8113 else if (mark == AR_SECTION)
8114 gfc_advance_section (section_index, ar, &offset);
8118 if (mark == AR_SECTION)
8120 for (i = 0; i < ar->dimen; i++)
8121 mpz_clear (section_index[i]);
8131 static try traverse_data_var (gfc_data_variable *, locus *);
8133 /* Iterate over a list of elements in a DATA statement. */
8136 traverse_data_list (gfc_data_variable *var, locus *where)
8139 iterator_stack frame;
8140 gfc_expr *e, *start, *end, *step;
8141 try retval = SUCCESS;
8143 mpz_init (frame.value);
8145 start = gfc_copy_expr (var->iter.start);
8146 end = gfc_copy_expr (var->iter.end);
8147 step = gfc_copy_expr (var->iter.step);
8149 if (gfc_simplify_expr (start, 1) == FAILURE
8150 || start->expr_type != EXPR_CONSTANT)
8152 gfc_error ("iterator start at %L does not simplify", &start->where);
8156 if (gfc_simplify_expr (end, 1) == FAILURE
8157 || end->expr_type != EXPR_CONSTANT)
8159 gfc_error ("iterator end at %L does not simplify", &end->where);
8163 if (gfc_simplify_expr (step, 1) == FAILURE
8164 || step->expr_type != EXPR_CONSTANT)
8166 gfc_error ("iterator step at %L does not simplify", &step->where);
8171 mpz_init_set (trip, end->value.integer);
8172 mpz_sub (trip, trip, start->value.integer);
8173 mpz_add (trip, trip, step->value.integer);
8175 mpz_div (trip, trip, step->value.integer);
8177 mpz_set (frame.value, start->value.integer);
8179 frame.prev = iter_stack;
8180 frame.variable = var->iter.var->symtree;
8181 iter_stack = &frame;
8183 while (mpz_cmp_ui (trip, 0) > 0)
8185 if (traverse_data_var (var->list, where) == FAILURE)
8192 e = gfc_copy_expr (var->expr);
8193 if (gfc_simplify_expr (e, 1) == FAILURE)
8201 mpz_add (frame.value, frame.value, step->value.integer);
8203 mpz_sub_ui (trip, trip, 1);
8208 mpz_clear (frame.value);
8210 gfc_free_expr (start);
8211 gfc_free_expr (end);
8212 gfc_free_expr (step);
8214 iter_stack = frame.prev;
8219 /* Type resolve variables in the variable list of a DATA statement. */
8222 traverse_data_var (gfc_data_variable *var, locus *where)
8226 for (; var; var = var->next)
8228 if (var->expr == NULL)
8229 t = traverse_data_list (var, where);
8231 t = check_data_variable (var, where);
8241 /* Resolve the expressions and iterators associated with a data statement.
8242 This is separate from the assignment checking because data lists should
8243 only be resolved once. */
8246 resolve_data_variables (gfc_data_variable *d)
8248 for (; d; d = d->next)
8250 if (d->list == NULL)
8252 if (gfc_resolve_expr (d->expr) == FAILURE)
8257 if (gfc_resolve_iterator (&d->iter, false) == FAILURE)
8260 if (resolve_data_variables (d->list) == FAILURE)
8269 /* Resolve a single DATA statement. We implement this by storing a pointer to
8270 the value list into static variables, and then recursively traversing the
8271 variables list, expanding iterators and such. */
8274 resolve_data (gfc_data *d)
8277 if (resolve_data_variables (d->var) == FAILURE)
8280 values.vnode = d->value;
8281 if (d->value == NULL)
8282 mpz_set_ui (values.left, 0);
8284 mpz_set (values.left, d->value->repeat);
8286 if (traverse_data_var (d->var, &d->where) == FAILURE)
8289 /* At this point, we better not have any values left. */
8291 if (next_data_value () == SUCCESS)
8292 gfc_error ("DATA statement at %L has more values than variables",
8297 /* 12.6 Constraint: In a pure subprogram any variable which is in common or
8298 accessed by host or use association, is a dummy argument to a pure function,
8299 is a dummy argument with INTENT (IN) to a pure subroutine, or an object that
8300 is storage associated with any such variable, shall not be used in the
8301 following contexts: (clients of this function). */
8303 /* Determines if a variable is not 'pure', ie not assignable within a pure
8304 procedure. Returns zero if assignment is OK, nonzero if there is a
8307 gfc_impure_variable (gfc_symbol *sym)
8311 if (sym->attr.use_assoc || sym->attr.in_common)
8314 if (sym->ns != gfc_current_ns)
8315 return !sym->attr.function;
8317 proc = sym->ns->proc_name;
8318 if (sym->attr.dummy && gfc_pure (proc)
8319 && ((proc->attr.subroutine && sym->attr.intent == INTENT_IN)
8321 proc->attr.function))
8324 /* TODO: Sort out what can be storage associated, if anything, and include
8325 it here. In principle equivalences should be scanned but it does not
8326 seem to be possible to storage associate an impure variable this way. */
8331 /* Test whether a symbol is pure or not. For a NULL pointer, checks the
8332 symbol of the current procedure. */
8335 gfc_pure (gfc_symbol *sym)
8337 symbol_attribute attr;
8340 sym = gfc_current_ns->proc_name;
8346 return attr.flavor == FL_PROCEDURE && (attr.pure || attr.elemental);
8350 /* Test whether the current procedure is elemental or not. */
8353 gfc_elemental (gfc_symbol *sym)
8355 symbol_attribute attr;
8358 sym = gfc_current_ns->proc_name;
8363 return attr.flavor == FL_PROCEDURE && attr.elemental;
8367 /* Warn about unused labels. */
8370 warn_unused_fortran_label (gfc_st_label *label)
8375 warn_unused_fortran_label (label->left);
8377 if (label->defined == ST_LABEL_UNKNOWN)
8380 switch (label->referenced)
8382 case ST_LABEL_UNKNOWN:
8383 gfc_warning ("Label %d at %L defined but not used", label->value,
8387 case ST_LABEL_BAD_TARGET:
8388 gfc_warning ("Label %d at %L defined but cannot be used",
8389 label->value, &label->where);
8396 warn_unused_fortran_label (label->right);
8400 /* Returns the sequence type of a symbol or sequence. */
8403 sequence_type (gfc_typespec ts)
8412 if (ts.derived->components == NULL)
8413 return SEQ_NONDEFAULT;
8415 result = sequence_type (ts.derived->components->ts);
8416 for (c = ts.derived->components->next; c; c = c->next)
8417 if (sequence_type (c->ts) != result)
8423 if (ts.kind != gfc_default_character_kind)
8424 return SEQ_NONDEFAULT;
8426 return SEQ_CHARACTER;
8429 if (ts.kind != gfc_default_integer_kind)
8430 return SEQ_NONDEFAULT;
8435 if (!(ts.kind == gfc_default_real_kind
8436 || ts.kind == gfc_default_double_kind))
8437 return SEQ_NONDEFAULT;
8442 if (ts.kind != gfc_default_complex_kind)
8443 return SEQ_NONDEFAULT;
8448 if (ts.kind != gfc_default_logical_kind)
8449 return SEQ_NONDEFAULT;
8454 return SEQ_NONDEFAULT;
8459 /* Resolve derived type EQUIVALENCE object. */
8462 resolve_equivalence_derived (gfc_symbol *derived, gfc_symbol *sym, gfc_expr *e)
8465 gfc_component *c = derived->components;
8470 /* Shall not be an object of nonsequence derived type. */
8471 if (!derived->attr.sequence)
8473 gfc_error ("Derived type variable '%s' at %L must have SEQUENCE "
8474 "attribute to be an EQUIVALENCE object", sym->name,
8479 /* Shall not have allocatable components. */
8480 if (derived->attr.alloc_comp)
8482 gfc_error ("Derived type variable '%s' at %L cannot have ALLOCATABLE "
8483 "components to be an EQUIVALENCE object",sym->name,
8488 for (; c ; c = c->next)
8492 && (resolve_equivalence_derived (c->ts.derived, sym, e) == FAILURE))
8495 /* Shall not be an object of sequence derived type containing a pointer
8496 in the structure. */
8499 gfc_error ("Derived type variable '%s' at %L with pointer "
8500 "component(s) cannot be an EQUIVALENCE object",
8501 sym->name, &e->where);
8509 /* Resolve equivalence object.
8510 An EQUIVALENCE object shall not be a dummy argument, a pointer, a target,
8511 an allocatable array, an object of nonsequence derived type, an object of
8512 sequence derived type containing a pointer at any level of component
8513 selection, an automatic object, a function name, an entry name, a result
8514 name, a named constant, a structure component, or a subobject of any of
8515 the preceding objects. A substring shall not have length zero. A
8516 derived type shall not have components with default initialization nor
8517 shall two objects of an equivalence group be initialized.
8518 Either all or none of the objects shall have an protected attribute.
8519 The simple constraints are done in symbol.c(check_conflict) and the rest
8520 are implemented here. */
8523 resolve_equivalence (gfc_equiv *eq)
8526 gfc_symbol *derived;
8527 gfc_symbol *first_sym;
8530 locus *last_where = NULL;
8531 seq_type eq_type, last_eq_type;
8532 gfc_typespec *last_ts;
8533 int object, cnt_protected;
8534 const char *value_name;
8538 last_ts = &eq->expr->symtree->n.sym->ts;
8540 first_sym = eq->expr->symtree->n.sym;
8544 for (object = 1; eq; eq = eq->eq, object++)
8548 e->ts = e->symtree->n.sym->ts;
8549 /* match_varspec might not know yet if it is seeing
8550 array reference or substring reference, as it doesn't
8552 if (e->ref && e->ref->type == REF_ARRAY)
8554 gfc_ref *ref = e->ref;
8555 sym = e->symtree->n.sym;
8557 if (sym->attr.dimension)
8559 ref->u.ar.as = sym->as;
8563 /* For substrings, convert REF_ARRAY into REF_SUBSTRING. */
8564 if (e->ts.type == BT_CHARACTER
8566 && ref->type == REF_ARRAY
8567 && ref->u.ar.dimen == 1
8568 && ref->u.ar.dimen_type[0] == DIMEN_RANGE
8569 && ref->u.ar.stride[0] == NULL)
8571 gfc_expr *start = ref->u.ar.start[0];
8572 gfc_expr *end = ref->u.ar.end[0];
8575 /* Optimize away the (:) reference. */
8576 if (start == NULL && end == NULL)
8581 e->ref->next = ref->next;
8586 ref->type = REF_SUBSTRING;
8588 start = gfc_int_expr (1);
8589 ref->u.ss.start = start;
8590 if (end == NULL && e->ts.cl)
8591 end = gfc_copy_expr (e->ts.cl->length);
8592 ref->u.ss.end = end;
8593 ref->u.ss.length = e->ts.cl;
8600 /* Any further ref is an error. */
8603 gcc_assert (ref->type == REF_ARRAY);
8604 gfc_error ("Syntax error in EQUIVALENCE statement at %L",
8610 if (gfc_resolve_expr (e) == FAILURE)
8613 sym = e->symtree->n.sym;
8615 if (sym->attr.protected)
8617 if (cnt_protected > 0 && cnt_protected != object)
8619 gfc_error ("Either all or none of the objects in the "
8620 "EQUIVALENCE set at %L shall have the "
8621 "PROTECTED attribute",
8626 /* Shall not equivalence common block variables in a PURE procedure. */
8627 if (sym->ns->proc_name
8628 && sym->ns->proc_name->attr.pure
8629 && sym->attr.in_common)
8631 gfc_error ("Common block member '%s' at %L cannot be an EQUIVALENCE "
8632 "object in the pure procedure '%s'",
8633 sym->name, &e->where, sym->ns->proc_name->name);
8637 /* Shall not be a named constant. */
8638 if (e->expr_type == EXPR_CONSTANT)
8640 gfc_error ("Named constant '%s' at %L cannot be an EQUIVALENCE "
8641 "object", sym->name, &e->where);
8645 derived = e->ts.derived;
8646 if (derived && resolve_equivalence_derived (derived, sym, e) == FAILURE)
8649 /* Check that the types correspond correctly:
8651 A numeric sequence structure may be equivalenced to another sequence
8652 structure, an object of default integer type, default real type, double
8653 precision real type, default logical type such that components of the
8654 structure ultimately only become associated to objects of the same
8655 kind. A character sequence structure may be equivalenced to an object
8656 of default character kind or another character sequence structure.
8657 Other objects may be equivalenced only to objects of the same type and
8660 /* Identical types are unconditionally OK. */
8661 if (object == 1 || gfc_compare_types (last_ts, &sym->ts))
8662 goto identical_types;
8664 last_eq_type = sequence_type (*last_ts);
8665 eq_type = sequence_type (sym->ts);
8667 /* Since the pair of objects is not of the same type, mixed or
8668 non-default sequences can be rejected. */
8670 msg = "Sequence %s with mixed components in EQUIVALENCE "
8671 "statement at %L with different type objects";
8673 && last_eq_type == SEQ_MIXED
8674 && gfc_notify_std (GFC_STD_GNU, msg, first_sym->name, last_where)
8676 || (eq_type == SEQ_MIXED
8677 && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
8678 &e->where) == FAILURE))
8681 msg = "Non-default type object or sequence %s in EQUIVALENCE "
8682 "statement at %L with objects of different type";
8684 && last_eq_type == SEQ_NONDEFAULT
8685 && gfc_notify_std (GFC_STD_GNU, msg, first_sym->name,
8686 last_where) == FAILURE)
8687 || (eq_type == SEQ_NONDEFAULT
8688 && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
8689 &e->where) == FAILURE))
8692 msg ="Non-CHARACTER object '%s' in default CHARACTER "
8693 "EQUIVALENCE statement at %L";
8694 if (last_eq_type == SEQ_CHARACTER
8695 && eq_type != SEQ_CHARACTER
8696 && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
8697 &e->where) == FAILURE)
8700 msg ="Non-NUMERIC object '%s' in default NUMERIC "
8701 "EQUIVALENCE statement at %L";
8702 if (last_eq_type == SEQ_NUMERIC
8703 && eq_type != SEQ_NUMERIC
8704 && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
8705 &e->where) == FAILURE)
8710 last_where = &e->where;
8715 /* Shall not be an automatic array. */
8716 if (e->ref->type == REF_ARRAY
8717 && gfc_resolve_array_spec (e->ref->u.ar.as, 1) == FAILURE)
8719 gfc_error ("Array '%s' at %L with non-constant bounds cannot be "
8720 "an EQUIVALENCE object", sym->name, &e->where);
8727 /* Shall not be a structure component. */
8728 if (r->type == REF_COMPONENT)
8730 gfc_error ("Structure component '%s' at %L cannot be an "
8731 "EQUIVALENCE object",
8732 r->u.c.component->name, &e->where);
8736 /* A substring shall not have length zero. */
8737 if (r->type == REF_SUBSTRING)
8739 if (compare_bound (r->u.ss.start, r->u.ss.end) == CMP_GT)
8741 gfc_error ("Substring at %L has length zero",
8742 &r->u.ss.start->where);
8752 /* Resolve function and ENTRY types, issue diagnostics if needed. */
8755 resolve_fntype (gfc_namespace *ns)
8760 if (ns->proc_name == NULL || !ns->proc_name->attr.function)
8763 /* If there are any entries, ns->proc_name is the entry master
8764 synthetic symbol and ns->entries->sym actual FUNCTION symbol. */
8766 sym = ns->entries->sym;
8768 sym = ns->proc_name;
8769 if (sym->result == sym
8770 && sym->ts.type == BT_UNKNOWN
8771 && gfc_set_default_type (sym, 0, NULL) == FAILURE
8772 && !sym->attr.untyped)
8774 gfc_error ("Function '%s' at %L has no IMPLICIT type",
8775 sym->name, &sym->declared_at);
8776 sym->attr.untyped = 1;
8779 if (sym->ts.type == BT_DERIVED && !sym->ts.derived->attr.use_assoc
8780 && !gfc_check_access (sym->ts.derived->attr.access,
8781 sym->ts.derived->ns->default_access)
8782 && gfc_check_access (sym->attr.access, sym->ns->default_access))
8784 gfc_error ("PUBLIC function '%s' at %L cannot be of PRIVATE type '%s'",
8785 sym->name, &sym->declared_at, sym->ts.derived->name);
8789 for (el = ns->entries->next; el; el = el->next)
8791 if (el->sym->result == el->sym
8792 && el->sym->ts.type == BT_UNKNOWN
8793 && gfc_set_default_type (el->sym, 0, NULL) == FAILURE
8794 && !el->sym->attr.untyped)
8796 gfc_error ("ENTRY '%s' at %L has no IMPLICIT type",
8797 el->sym->name, &el->sym->declared_at);
8798 el->sym->attr.untyped = 1;
8803 /* 12.3.2.1.1 Defined operators. */
8806 gfc_resolve_uops (gfc_symtree *symtree)
8810 gfc_formal_arglist *formal;
8812 if (symtree == NULL)
8815 gfc_resolve_uops (symtree->left);
8816 gfc_resolve_uops (symtree->right);
8818 for (itr = symtree->n.uop->operator; itr; itr = itr->next)
8821 if (!sym->attr.function)
8822 gfc_error ("User operator procedure '%s' at %L must be a FUNCTION",
8823 sym->name, &sym->declared_at);
8825 if (sym->ts.type == BT_CHARACTER
8826 && !(sym->ts.cl && sym->ts.cl->length)
8827 && !(sym->result && sym->result->ts.cl
8828 && sym->result->ts.cl->length))
8829 gfc_error ("User operator procedure '%s' at %L cannot be assumed "
8830 "character length", sym->name, &sym->declared_at);
8832 formal = sym->formal;
8833 if (!formal || !formal->sym)
8835 gfc_error ("User operator procedure '%s' at %L must have at least "
8836 "one argument", sym->name, &sym->declared_at);
8840 if (formal->sym->attr.intent != INTENT_IN)
8841 gfc_error ("First argument of operator interface at %L must be "
8842 "INTENT(IN)", &sym->declared_at);
8844 if (formal->sym->attr.optional)
8845 gfc_error ("First argument of operator interface at %L cannot be "
8846 "optional", &sym->declared_at);
8848 formal = formal->next;
8849 if (!formal || !formal->sym)
8852 if (formal->sym->attr.intent != INTENT_IN)
8853 gfc_error ("Second argument of operator interface at %L must be "
8854 "INTENT(IN)", &sym->declared_at);
8856 if (formal->sym->attr.optional)
8857 gfc_error ("Second argument of operator interface at %L cannot be "
8858 "optional", &sym->declared_at);
8861 gfc_error ("Operator interface at %L must have, at most, two "
8862 "arguments", &sym->declared_at);
8867 /* Examine all of the expressions associated with a program unit,
8868 assign types to all intermediate expressions, make sure that all
8869 assignments are to compatible types and figure out which names
8870 refer to which functions or subroutines. It doesn't check code
8871 block, which is handled by resolve_code. */
8874 resolve_types (gfc_namespace *ns)
8881 gfc_current_ns = ns;
8883 resolve_entries (ns);
8885 resolve_common_blocks (ns->common_root);
8887 resolve_contained_functions (ns);
8889 gfc_traverse_ns (ns, resolve_bind_c_derived_types);
8891 for (cl = ns->cl_list; cl; cl = cl->next)
8892 resolve_charlen (cl);
8894 gfc_traverse_ns (ns, resolve_symbol);
8896 resolve_fntype (ns);
8898 for (n = ns->contained; n; n = n->sibling)
8900 if (gfc_pure (ns->proc_name) && !gfc_pure (n->proc_name))
8901 gfc_error ("Contained procedure '%s' at %L of a PURE procedure must "
8902 "also be PURE", n->proc_name->name,
8903 &n->proc_name->declared_at);
8909 gfc_check_interfaces (ns);
8911 gfc_traverse_ns (ns, resolve_values);
8917 for (d = ns->data; d; d = d->next)
8921 gfc_traverse_ns (ns, gfc_formalize_init_value);
8923 gfc_traverse_ns (ns, gfc_verify_binding_labels);
8925 if (ns->common_root != NULL)
8926 gfc_traverse_symtree (ns->common_root, resolve_bind_c_comms);
8928 for (eq = ns->equiv; eq; eq = eq->next)
8929 resolve_equivalence (eq);
8931 /* Warn about unused labels. */
8932 if (warn_unused_label)
8933 warn_unused_fortran_label (ns->st_labels);
8935 gfc_resolve_uops (ns->uop_root);
8939 /* Call resolve_code recursively. */
8942 resolve_codes (gfc_namespace *ns)
8946 for (n = ns->contained; n; n = n->sibling)
8949 gfc_current_ns = ns;
8951 /* Set to an out of range value. */
8952 current_entry_id = -1;
8954 bitmap_obstack_initialize (&labels_obstack);
8955 resolve_code (ns->code, ns);
8956 bitmap_obstack_release (&labels_obstack);
8960 /* This function is called after a complete program unit has been compiled.
8961 Its purpose is to examine all of the expressions associated with a program
8962 unit, assign types to all intermediate expressions, make sure that all
8963 assignments are to compatible types and figure out which names refer to
8964 which functions or subroutines. */
8967 gfc_resolve (gfc_namespace *ns)
8969 gfc_namespace *old_ns;
8971 old_ns = gfc_current_ns;
8976 gfc_current_ns = old_ns;