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->attr.function
1075 && sym->ts.type == BT_UNKNOWN && sym->attr.intrinsic)
1077 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,
1090 /* See if the name is a module procedure in a parent unit. */
1092 if (was_declared (sym) || sym->ns->parent == NULL)
1095 if (gfc_find_sym_tree (sym->name, sym->ns->parent, 1, &parent_st))
1097 gfc_error ("Symbol '%s' at %L is ambiguous", sym->name, &e->where);
1101 if (parent_st == NULL)
1104 sym = parent_st->n.sym;
1105 e->symtree = parent_st; /* Point to the right thing. */
1107 if (sym->attr.flavor == FL_PROCEDURE
1108 || sym->attr.intrinsic
1109 || sym->attr.external)
1115 e->expr_type = EXPR_VARIABLE;
1117 if (sym->as != NULL)
1119 e->rank = sym->as->rank;
1120 e->ref = gfc_get_ref ();
1121 e->ref->type = REF_ARRAY;
1122 e->ref->u.ar.type = AR_FULL;
1123 e->ref->u.ar.as = sym->as;
1126 /* Expressions are assigned a default ts.type of BT_PROCEDURE in
1127 primary.c (match_actual_arg). If above code determines that it
1128 is a variable instead, it needs to be resolved as it was not
1129 done at the beginning of this function. */
1130 if (gfc_resolve_expr (e) != SUCCESS)
1134 /* Check argument list functions %VAL, %LOC and %REF. There is
1135 nothing to do for %REF. */
1136 if (arg->name && arg->name[0] == '%')
1138 if (strncmp ("%VAL", arg->name, 4) == 0)
1140 if (e->ts.type == BT_CHARACTER || e->ts.type == BT_DERIVED)
1142 gfc_error ("By-value argument at %L is not of numeric "
1149 gfc_error ("By-value argument at %L cannot be an array or "
1150 "an array section", &e->where);
1154 /* Intrinsics are still PROC_UNKNOWN here. However,
1155 since same file external procedures are not resolvable
1156 in gfortran, it is a good deal easier to leave them to
1158 if (ptype != PROC_UNKNOWN
1159 && ptype != PROC_DUMMY
1160 && ptype != PROC_EXTERNAL
1161 && ptype != PROC_MODULE)
1163 gfc_error ("By-value argument at %L is not allowed "
1164 "in this context", &e->where);
1169 /* Statement functions have already been excluded above. */
1170 else if (strncmp ("%LOC", arg->name, 4) == 0
1171 && e->ts.type == BT_PROCEDURE)
1173 if (e->symtree->n.sym->attr.proc == PROC_INTERNAL)
1175 gfc_error ("Passing internal procedure at %L by location "
1176 "not allowed", &e->where);
1187 /* Do the checks of the actual argument list that are specific to elemental
1188 procedures. If called with c == NULL, we have a function, otherwise if
1189 expr == NULL, we have a subroutine. */
1192 resolve_elemental_actual (gfc_expr *expr, gfc_code *c)
1194 gfc_actual_arglist *arg0;
1195 gfc_actual_arglist *arg;
1196 gfc_symbol *esym = NULL;
1197 gfc_intrinsic_sym *isym = NULL;
1199 gfc_intrinsic_arg *iformal = NULL;
1200 gfc_formal_arglist *eformal = NULL;
1201 bool formal_optional = false;
1202 bool set_by_optional = false;
1206 /* Is this an elemental procedure? */
1207 if (expr && expr->value.function.actual != NULL)
1209 if (expr->value.function.esym != NULL
1210 && expr->value.function.esym->attr.elemental)
1212 arg0 = expr->value.function.actual;
1213 esym = expr->value.function.esym;
1215 else if (expr->value.function.isym != NULL
1216 && expr->value.function.isym->elemental)
1218 arg0 = expr->value.function.actual;
1219 isym = expr->value.function.isym;
1224 else if (c && c->ext.actual != NULL && c->symtree->n.sym->attr.elemental)
1226 arg0 = c->ext.actual;
1227 esym = c->symtree->n.sym;
1232 /* The rank of an elemental is the rank of its array argument(s). */
1233 for (arg = arg0; arg; arg = arg->next)
1235 if (arg->expr != NULL && arg->expr->rank > 0)
1237 rank = arg->expr->rank;
1238 if (arg->expr->expr_type == EXPR_VARIABLE
1239 && arg->expr->symtree->n.sym->attr.optional)
1240 set_by_optional = true;
1242 /* Function specific; set the result rank and shape. */
1246 if (!expr->shape && arg->expr->shape)
1248 expr->shape = gfc_get_shape (rank);
1249 for (i = 0; i < rank; i++)
1250 mpz_init_set (expr->shape[i], arg->expr->shape[i]);
1257 /* If it is an array, it shall not be supplied as an actual argument
1258 to an elemental procedure unless an array of the same rank is supplied
1259 as an actual argument corresponding to a nonoptional dummy argument of
1260 that elemental procedure(12.4.1.5). */
1261 formal_optional = false;
1263 iformal = isym->formal;
1265 eformal = esym->formal;
1267 for (arg = arg0; arg; arg = arg->next)
1271 if (eformal->sym && eformal->sym->attr.optional)
1272 formal_optional = true;
1273 eformal = eformal->next;
1275 else if (isym && iformal)
1277 if (iformal->optional)
1278 formal_optional = true;
1279 iformal = iformal->next;
1282 formal_optional = true;
1284 if (pedantic && arg->expr != NULL
1285 && arg->expr->expr_type == EXPR_VARIABLE
1286 && arg->expr->symtree->n.sym->attr.optional
1289 && (set_by_optional || arg->expr->rank != rank)
1290 && !(isym && isym->id == GFC_ISYM_CONVERSION))
1292 gfc_warning ("'%s' at %L is an array and OPTIONAL; IF IT IS "
1293 "MISSING, it cannot be the actual argument of an "
1294 "ELEMENTAL procedure unless there is a non-optional "
1295 "argument with the same rank (12.4.1.5)",
1296 arg->expr->symtree->n.sym->name, &arg->expr->where);
1301 for (arg = arg0; arg; arg = arg->next)
1303 if (arg->expr == NULL || arg->expr->rank == 0)
1306 /* Being elemental, the last upper bound of an assumed size array
1307 argument must be present. */
1308 if (resolve_assumed_size_actual (arg->expr))
1311 /* Elemental procedure's array actual arguments must conform. */
1314 if (gfc_check_conformance ("elemental procedure", arg->expr, e)
1322 /* INTENT(OUT) is only allowed for subroutines; if any actual argument
1323 is an array, the intent inout/out variable needs to be also an array. */
1324 if (rank > 0 && esym && expr == NULL)
1325 for (eformal = esym->formal, arg = arg0; arg && eformal;
1326 arg = arg->next, eformal = eformal->next)
1327 if ((eformal->sym->attr.intent == INTENT_OUT
1328 || eformal->sym->attr.intent == INTENT_INOUT)
1329 && arg->expr && arg->expr->rank == 0)
1331 gfc_error ("Actual argument at %L for INTENT(%s) dummy '%s' of "
1332 "ELEMENTAL subroutine '%s' is a scalar, but another "
1333 "actual argument is an array", &arg->expr->where,
1334 (eformal->sym->attr.intent == INTENT_OUT) ? "OUT"
1335 : "INOUT", eformal->sym->name, esym->name);
1342 /* Go through each actual argument in ACTUAL and see if it can be
1343 implemented as an inlined, non-copying intrinsic. FNSYM is the
1344 function being called, or NULL if not known. */
1347 find_noncopying_intrinsics (gfc_symbol *fnsym, gfc_actual_arglist *actual)
1349 gfc_actual_arglist *ap;
1352 for (ap = actual; ap; ap = ap->next)
1354 && (expr = gfc_get_noncopying_intrinsic_argument (ap->expr))
1355 && !gfc_check_fncall_dependency (expr, INTENT_IN, fnsym, actual))
1356 ap->expr->inline_noncopying_intrinsic = 1;
1360 /* This function does the checking of references to global procedures
1361 as defined in sections 18.1 and 14.1, respectively, of the Fortran
1362 77 and 95 standards. It checks for a gsymbol for the name, making
1363 one if it does not already exist. If it already exists, then the
1364 reference being resolved must correspond to the type of gsymbol.
1365 Otherwise, the new symbol is equipped with the attributes of the
1366 reference. The corresponding code that is called in creating
1367 global entities is parse.c. */
1370 resolve_global_procedure (gfc_symbol *sym, locus *where, int sub)
1375 type = sub ? GSYM_SUBROUTINE : GSYM_FUNCTION;
1377 gsym = gfc_get_gsymbol (sym->name);
1379 if ((gsym->type != GSYM_UNKNOWN && gsym->type != type))
1380 gfc_global_used (gsym, where);
1382 if (gsym->type == GSYM_UNKNOWN)
1385 gsym->where = *where;
1392 /************* Function resolution *************/
1394 /* Resolve a function call known to be generic.
1395 Section 14.1.2.4.1. */
1398 resolve_generic_f0 (gfc_expr *expr, gfc_symbol *sym)
1402 if (sym->attr.generic)
1404 s = gfc_search_interface (sym->generic, 0, &expr->value.function.actual);
1407 expr->value.function.name = s->name;
1408 expr->value.function.esym = s;
1410 if (s->ts.type != BT_UNKNOWN)
1412 else if (s->result != NULL && s->result->ts.type != BT_UNKNOWN)
1413 expr->ts = s->result->ts;
1416 expr->rank = s->as->rank;
1417 else if (s->result != NULL && s->result->as != NULL)
1418 expr->rank = s->result->as->rank;
1423 /* TODO: Need to search for elemental references in generic
1427 if (sym->attr.intrinsic)
1428 return gfc_intrinsic_func_interface (expr, 0);
1435 resolve_generic_f (gfc_expr *expr)
1440 sym = expr->symtree->n.sym;
1444 m = resolve_generic_f0 (expr, sym);
1447 else if (m == MATCH_ERROR)
1451 if (sym->ns->parent == NULL)
1453 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
1457 if (!generic_sym (sym))
1461 /* Last ditch attempt. See if the reference is to an intrinsic
1462 that possesses a matching interface. 14.1.2.4 */
1463 if (sym && !gfc_intrinsic_name (sym->name, 0))
1465 gfc_error ("There is no specific function for the generic '%s' at %L",
1466 expr->symtree->n.sym->name, &expr->where);
1470 m = gfc_intrinsic_func_interface (expr, 0);
1474 gfc_error ("Generic function '%s' at %L is not consistent with a "
1475 "specific intrinsic interface", expr->symtree->n.sym->name,
1482 /* Resolve a function call known to be specific. */
1485 resolve_specific_f0 (gfc_symbol *sym, gfc_expr *expr)
1489 if (sym->attr.external || sym->attr.if_source == IFSRC_IFBODY)
1491 if (sym->attr.dummy)
1493 sym->attr.proc = PROC_DUMMY;
1497 sym->attr.proc = PROC_EXTERNAL;
1501 if (sym->attr.proc == PROC_MODULE
1502 || sym->attr.proc == PROC_ST_FUNCTION
1503 || sym->attr.proc == PROC_INTERNAL)
1506 if (sym->attr.intrinsic)
1508 m = gfc_intrinsic_func_interface (expr, 1);
1512 gfc_error ("Function '%s' at %L is INTRINSIC but is not compatible "
1513 "with an intrinsic", sym->name, &expr->where);
1521 gfc_procedure_use (sym, &expr->value.function.actual, &expr->where);
1524 expr->value.function.name = sym->name;
1525 expr->value.function.esym = sym;
1526 if (sym->as != NULL)
1527 expr->rank = sym->as->rank;
1534 resolve_specific_f (gfc_expr *expr)
1539 sym = expr->symtree->n.sym;
1543 m = resolve_specific_f0 (sym, expr);
1546 if (m == MATCH_ERROR)
1549 if (sym->ns->parent == NULL)
1552 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
1558 gfc_error ("Unable to resolve the specific function '%s' at %L",
1559 expr->symtree->n.sym->name, &expr->where);
1565 /* Resolve a procedure call not known to be generic nor specific. */
1568 resolve_unknown_f (gfc_expr *expr)
1573 sym = expr->symtree->n.sym;
1575 if (sym->attr.dummy)
1577 sym->attr.proc = PROC_DUMMY;
1578 expr->value.function.name = sym->name;
1582 /* See if we have an intrinsic function reference. */
1584 if (gfc_intrinsic_name (sym->name, 0))
1586 if (gfc_intrinsic_func_interface (expr, 1) == MATCH_YES)
1591 /* The reference is to an external name. */
1593 sym->attr.proc = PROC_EXTERNAL;
1594 expr->value.function.name = sym->name;
1595 expr->value.function.esym = expr->symtree->n.sym;
1597 if (sym->as != NULL)
1598 expr->rank = sym->as->rank;
1600 /* Type of the expression is either the type of the symbol or the
1601 default type of the symbol. */
1604 gfc_procedure_use (sym, &expr->value.function.actual, &expr->where);
1606 if (sym->ts.type != BT_UNKNOWN)
1610 ts = gfc_get_default_type (sym, sym->ns);
1612 if (ts->type == BT_UNKNOWN)
1614 gfc_error ("Function '%s' at %L has no IMPLICIT type",
1615 sym->name, &expr->where);
1626 /* Return true, if the symbol is an external procedure. */
1628 is_external_proc (gfc_symbol *sym)
1630 if (!sym->attr.dummy && !sym->attr.contained
1631 && !(sym->attr.intrinsic
1632 || gfc_intrinsic_name (sym->name, sym->attr.subroutine))
1633 && sym->attr.proc != PROC_ST_FUNCTION
1634 && !sym->attr.use_assoc
1642 /* Figure out if a function reference is pure or not. Also set the name
1643 of the function for a potential error message. Return nonzero if the
1644 function is PURE, zero if not. */
1647 pure_function (gfc_expr *e, const char **name)
1653 if (e->symtree != NULL
1654 && e->symtree->n.sym != NULL
1655 && e->symtree->n.sym->attr.proc == PROC_ST_FUNCTION)
1658 if (e->value.function.esym)
1660 pure = gfc_pure (e->value.function.esym);
1661 *name = e->value.function.esym->name;
1663 else if (e->value.function.isym)
1665 pure = e->value.function.isym->pure
1666 || e->value.function.isym->elemental;
1667 *name = e->value.function.isym->name;
1671 /* Implicit functions are not pure. */
1673 *name = e->value.function.name;
1681 is_scalar_expr_ptr (gfc_expr *expr)
1683 try retval = SUCCESS;
1688 /* See if we have a gfc_ref, which means we have a substring, array
1689 reference, or a component. */
1690 if (expr->ref != NULL)
1693 while (ref->next != NULL)
1699 if (ref->u.ss.length != NULL
1700 && ref->u.ss.length->length != NULL
1702 && ref->u.ss.start->expr_type == EXPR_CONSTANT
1704 && ref->u.ss.end->expr_type == EXPR_CONSTANT)
1706 start = (int) mpz_get_si (ref->u.ss.start->value.integer);
1707 end = (int) mpz_get_si (ref->u.ss.end->value.integer);
1708 if (end - start + 1 != 1)
1715 if (ref->u.ar.type == AR_ELEMENT)
1717 else if (ref->u.ar.type == AR_FULL)
1719 /* The user can give a full array if the array is of size 1. */
1720 if (ref->u.ar.as != NULL
1721 && ref->u.ar.as->rank == 1
1722 && ref->u.ar.as->type == AS_EXPLICIT
1723 && ref->u.ar.as->lower[0] != NULL
1724 && ref->u.ar.as->lower[0]->expr_type == EXPR_CONSTANT
1725 && ref->u.ar.as->upper[0] != NULL
1726 && ref->u.ar.as->upper[0]->expr_type == EXPR_CONSTANT)
1728 /* If we have a character string, we need to check if
1729 its length is one. */
1730 if (expr->ts.type == BT_CHARACTER)
1732 if (expr->ts.cl == NULL
1733 || expr->ts.cl->length == NULL
1734 || mpz_cmp_si (expr->ts.cl->length->value.integer, 1)
1740 /* We have constant lower and upper bounds. If the
1741 difference between is 1, it can be considered a
1743 start = (int) mpz_get_si
1744 (ref->u.ar.as->lower[0]->value.integer);
1745 end = (int) mpz_get_si
1746 (ref->u.ar.as->upper[0]->value.integer);
1747 if (end - start + 1 != 1)
1762 else if (expr->ts.type == BT_CHARACTER && expr->rank == 0)
1764 /* Character string. Make sure it's of length 1. */
1765 if (expr->ts.cl == NULL
1766 || expr->ts.cl->length == NULL
1767 || mpz_cmp_si (expr->ts.cl->length->value.integer, 1) != 0)
1770 else if (expr->rank != 0)
1777 /* Match one of the iso_c_binding functions (c_associated or c_loc)
1778 and, in the case of c_associated, set the binding label based on
1782 gfc_iso_c_func_interface (gfc_symbol *sym, gfc_actual_arglist *args,
1783 gfc_symbol **new_sym)
1785 char name[GFC_MAX_SYMBOL_LEN + 1];
1786 char binding_label[GFC_MAX_BINDING_LABEL_LEN + 1];
1787 int optional_arg = 0;
1788 try retval = SUCCESS;
1789 gfc_symbol *args_sym;
1790 gfc_typespec *arg_ts;
1791 gfc_ref *parent_ref;
1794 if (args->expr->expr_type == EXPR_CONSTANT
1795 || args->expr->expr_type == EXPR_OP
1796 || args->expr->expr_type == EXPR_NULL)
1798 gfc_error ("Argument to '%s' at %L is not a variable",
1799 sym->name, &(args->expr->where));
1803 args_sym = args->expr->symtree->n.sym;
1805 /* The typespec for the actual arg should be that stored in the expr
1806 and not necessarily that of the expr symbol (args_sym), because
1807 the actual expression could be a part-ref of the expr symbol. */
1808 arg_ts = &(args->expr->ts);
1810 /* Get the parent reference (if any) for the expression. This happens for
1811 cases such as a%b%c. */
1812 parent_ref = args->expr->ref;
1814 if (parent_ref != NULL)
1816 curr_ref = parent_ref->next;
1817 while (curr_ref != NULL && curr_ref->next != NULL)
1819 parent_ref = curr_ref;
1820 curr_ref = curr_ref->next;
1824 /* If curr_ref is non-NULL, we had a part-ref expression. If the curr_ref
1825 is for a REF_COMPONENT, then we need to use it as the parent_ref for
1826 the name, etc. Otherwise, the current parent_ref should be correct. */
1827 if (curr_ref != NULL && curr_ref->type == REF_COMPONENT)
1828 parent_ref = curr_ref;
1830 if (parent_ref == args->expr->ref)
1832 else if (parent_ref != NULL && parent_ref->type != REF_COMPONENT)
1833 gfc_internal_error ("Unexpected expression reference type in "
1834 "gfc_iso_c_func_interface");
1836 if (sym->intmod_sym_id == ISOCBINDING_ASSOCIATED)
1838 /* If the user gave two args then they are providing something for
1839 the optional arg (the second cptr). Therefore, set the name and
1840 binding label to the c_associated for two cptrs. Otherwise,
1841 set c_associated to expect one cptr. */
1845 sprintf (name, "%s_2", sym->name);
1846 sprintf (binding_label, "%s_2", sym->binding_label);
1852 sprintf (name, "%s_1", sym->name);
1853 sprintf (binding_label, "%s_1", sym->binding_label);
1857 /* Get a new symbol for the version of c_associated that
1859 *new_sym = get_iso_c_sym (sym, name, binding_label, optional_arg);
1861 else if (sym->intmod_sym_id == ISOCBINDING_LOC
1862 || sym->intmod_sym_id == ISOCBINDING_FUNLOC)
1864 sprintf (name, "%s", sym->name);
1865 sprintf (binding_label, "%s", sym->binding_label);
1867 /* Error check the call. */
1868 if (args->next != NULL)
1870 gfc_error_now ("More actual than formal arguments in '%s' "
1871 "call at %L", name, &(args->expr->where));
1874 else if (sym->intmod_sym_id == ISOCBINDING_LOC)
1876 /* Make sure we have either the target or pointer attribute. */
1877 if (!(args_sym->attr.target)
1878 && !(args_sym->attr.pointer)
1879 && (parent_ref == NULL ||
1880 !parent_ref->u.c.component->pointer))
1882 gfc_error_now ("Parameter '%s' to '%s' at %L must be either "
1883 "a TARGET or an associated pointer",
1885 sym->name, &(args->expr->where));
1889 /* See if we have interoperable type and type param. */
1890 if (verify_c_interop (arg_ts,
1891 (parent_ref ? parent_ref->u.c.component->name
1893 &(args->expr->where)) == SUCCESS
1894 || gfc_check_any_c_kind (arg_ts) == SUCCESS)
1896 if (args_sym->attr.target == 1)
1898 /* Case 1a, section 15.1.2.5, J3/04-007: variable that
1899 has the target attribute and is interoperable. */
1900 /* Case 1b, section 15.1.2.5, J3/04-007: allocated
1901 allocatable variable that has the TARGET attribute and
1902 is not an array of zero size. */
1903 if (args_sym->attr.allocatable == 1)
1905 if (args_sym->attr.dimension != 0
1906 && (args_sym->as && args_sym->as->rank == 0))
1908 gfc_error_now ("Allocatable variable '%s' used as a "
1909 "parameter to '%s' at %L must not be "
1910 "an array of zero size",
1911 args_sym->name, sym->name,
1912 &(args->expr->where));
1918 /* A non-allocatable target variable with C
1919 interoperable type and type parameters must be
1921 if (args_sym && args_sym->attr.dimension)
1923 if (args_sym->as->type == AS_ASSUMED_SHAPE)
1925 gfc_error ("Assumed-shape array '%s' at %L "
1926 "cannot be an argument to the "
1927 "procedure '%s' because "
1928 "it is not C interoperable",
1930 &(args->expr->where), sym->name);
1933 else if (args_sym->as->type == AS_DEFERRED)
1935 gfc_error ("Deferred-shape array '%s' at %L "
1936 "cannot be an argument to the "
1937 "procedure '%s' because "
1938 "it is not C interoperable",
1940 &(args->expr->where), sym->name);
1945 /* Make sure it's not a character string. Arrays of
1946 any type should be ok if the variable is of a C
1947 interoperable type. */
1948 if (arg_ts->type == BT_CHARACTER)
1949 if (arg_ts->cl != NULL
1950 && (arg_ts->cl->length == NULL
1951 || arg_ts->cl->length->expr_type
1954 (arg_ts->cl->length->value.integer, 1)
1956 && is_scalar_expr_ptr (args->expr) != SUCCESS)
1958 gfc_error_now ("CHARACTER argument '%s' to '%s' "
1959 "at %L must have a length of 1",
1960 args_sym->name, sym->name,
1961 &(args->expr->where));
1966 else if ((args_sym->attr.pointer == 1 ||
1968 && parent_ref->u.c.component->pointer))
1969 && is_scalar_expr_ptr (args->expr) != SUCCESS)
1971 /* Case 1c, section 15.1.2.5, J3/04-007: an associated
1973 gfc_error_now ("Argument '%s' to '%s' at %L must be an "
1974 "associated scalar POINTER", args_sym->name,
1975 sym->name, &(args->expr->where));
1981 /* The parameter is not required to be C interoperable. If it
1982 is not C interoperable, it must be a nonpolymorphic scalar
1983 with no length type parameters. It still must have either
1984 the pointer or target attribute, and it can be
1985 allocatable (but must be allocated when c_loc is called). */
1986 if (args->expr->rank != 0
1987 && is_scalar_expr_ptr (args->expr) != SUCCESS)
1989 gfc_error_now ("Parameter '%s' to '%s' at %L must be a "
1990 "scalar", args_sym->name, sym->name,
1991 &(args->expr->where));
1994 else if (arg_ts->type == BT_CHARACTER
1995 && is_scalar_expr_ptr (args->expr) != SUCCESS)
1997 gfc_error_now ("CHARACTER argument '%s' to '%s' at "
1998 "%L must have a length of 1",
1999 args_sym->name, sym->name,
2000 &(args->expr->where));
2005 else if (sym->intmod_sym_id == ISOCBINDING_FUNLOC)
2007 if (args_sym->attr.flavor != FL_PROCEDURE)
2009 /* TODO: Update this error message to allow for procedure
2010 pointers once they are implemented. */
2011 gfc_error_now ("Parameter '%s' to '%s' at %L must be a "
2013 args_sym->name, sym->name,
2014 &(args->expr->where));
2017 else if (args_sym->attr.is_bind_c != 1)
2019 gfc_error_now ("Parameter '%s' to '%s' at %L must be "
2021 args_sym->name, sym->name,
2022 &(args->expr->where));
2027 /* for c_loc/c_funloc, the new symbol is the same as the old one */
2032 gfc_internal_error ("gfc_iso_c_func_interface(): Unhandled "
2033 "iso_c_binding function: '%s'!\n", sym->name);
2040 /* Resolve a function call, which means resolving the arguments, then figuring
2041 out which entity the name refers to. */
2042 /* TODO: Check procedure arguments so that an INTENT(IN) isn't passed
2043 to INTENT(OUT) or INTENT(INOUT). */
2046 resolve_function (gfc_expr *expr)
2048 gfc_actual_arglist *arg;
2053 procedure_type p = PROC_INTRINSIC;
2057 sym = expr->symtree->n.sym;
2059 if (sym && sym->attr.flavor == FL_VARIABLE)
2061 gfc_error ("'%s' at %L is not a function", sym->name, &expr->where);
2065 if (sym && sym->attr.abstract)
2067 gfc_error ("ABSTRACT INTERFACE '%s' must not be referenced at %L",
2068 sym->name, &expr->where);
2072 /* If the procedure is external, check for usage. */
2073 if (sym && is_external_proc (sym))
2074 resolve_global_procedure (sym, &expr->where, 0);
2076 /* Switch off assumed size checking and do this again for certain kinds
2077 of procedure, once the procedure itself is resolved. */
2078 need_full_assumed_size++;
2080 if (expr->symtree && expr->symtree->n.sym)
2081 p = expr->symtree->n.sym->attr.proc;
2083 if (resolve_actual_arglist (expr->value.function.actual, p) == FAILURE)
2086 /* Need to setup the call to the correct c_associated, depending on
2087 the number of cptrs to user gives to compare. */
2088 if (sym && sym->attr.is_iso_c == 1)
2090 if (gfc_iso_c_func_interface (sym, expr->value.function.actual, &sym)
2094 /* Get the symtree for the new symbol (resolved func).
2095 the old one will be freed later, when it's no longer used. */
2096 gfc_find_sym_tree (sym->name, sym->ns, 1, &(expr->symtree));
2099 /* Resume assumed_size checking. */
2100 need_full_assumed_size--;
2102 if (sym && sym->ts.type == BT_CHARACTER
2104 && sym->ts.cl->length == NULL
2106 && expr->value.function.esym == NULL
2107 && !sym->attr.contained)
2109 /* Internal procedures are taken care of in resolve_contained_fntype. */
2110 gfc_error ("Function '%s' is declared CHARACTER(*) and cannot "
2111 "be used at %L since it is not a dummy argument",
2112 sym->name, &expr->where);
2116 /* See if function is already resolved. */
2118 if (expr->value.function.name != NULL)
2120 if (expr->ts.type == BT_UNKNOWN)
2126 /* Apply the rules of section 14.1.2. */
2128 switch (procedure_kind (sym))
2131 t = resolve_generic_f (expr);
2134 case PTYPE_SPECIFIC:
2135 t = resolve_specific_f (expr);
2139 t = resolve_unknown_f (expr);
2143 gfc_internal_error ("resolve_function(): bad function type");
2147 /* If the expression is still a function (it might have simplified),
2148 then we check to see if we are calling an elemental function. */
2150 if (expr->expr_type != EXPR_FUNCTION)
2153 temp = need_full_assumed_size;
2154 need_full_assumed_size = 0;
2156 if (resolve_elemental_actual (expr, NULL) == FAILURE)
2159 if (omp_workshare_flag
2160 && expr->value.function.esym
2161 && ! gfc_elemental (expr->value.function.esym))
2163 gfc_error ("User defined non-ELEMENTAL function '%s' at %L not allowed "
2164 "in WORKSHARE construct", expr->value.function.esym->name,
2169 #define GENERIC_ID expr->value.function.isym->id
2170 else if (expr->value.function.actual != NULL
2171 && expr->value.function.isym != NULL
2172 && GENERIC_ID != GFC_ISYM_LBOUND
2173 && GENERIC_ID != GFC_ISYM_LEN
2174 && GENERIC_ID != GFC_ISYM_LOC
2175 && GENERIC_ID != GFC_ISYM_PRESENT)
2177 /* Array intrinsics must also have the last upper bound of an
2178 assumed size array argument. UBOUND and SIZE have to be
2179 excluded from the check if the second argument is anything
2182 inquiry = GENERIC_ID == GFC_ISYM_UBOUND
2183 || GENERIC_ID == GFC_ISYM_SIZE;
2185 for (arg = expr->value.function.actual; arg; arg = arg->next)
2187 if (inquiry && arg->next != NULL && arg->next->expr)
2189 if (arg->next->expr->expr_type != EXPR_CONSTANT)
2192 if ((int)mpz_get_si (arg->next->expr->value.integer)
2197 if (arg->expr != NULL
2198 && arg->expr->rank > 0
2199 && resolve_assumed_size_actual (arg->expr))
2205 need_full_assumed_size = temp;
2208 if (!pure_function (expr, &name) && name)
2212 gfc_error ("reference to non-PURE function '%s' at %L inside a "
2213 "FORALL %s", name, &expr->where,
2214 forall_flag == 2 ? "mask" : "block");
2217 else if (gfc_pure (NULL))
2219 gfc_error ("Function reference to '%s' at %L is to a non-PURE "
2220 "procedure within a PURE procedure", name, &expr->where);
2225 /* Functions without the RECURSIVE attribution are not allowed to
2226 * call themselves. */
2227 if (expr->value.function.esym && !expr->value.function.esym->attr.recursive)
2229 gfc_symbol *esym, *proc;
2230 esym = expr->value.function.esym;
2231 proc = gfc_current_ns->proc_name;
2234 gfc_error ("Function '%s' at %L cannot call itself, as it is not "
2235 "RECURSIVE", name, &expr->where);
2239 if (esym->attr.entry && esym->ns->entries && proc->ns->entries
2240 && esym->ns->entries->sym == proc->ns->entries->sym)
2242 gfc_error ("Call to ENTRY '%s' at %L is recursive, but function "
2243 "'%s' is not declared as RECURSIVE",
2244 esym->name, &expr->where, esym->ns->entries->sym->name);
2249 /* Character lengths of use associated functions may contains references to
2250 symbols not referenced from the current program unit otherwise. Make sure
2251 those symbols are marked as referenced. */
2253 if (expr->ts.type == BT_CHARACTER && expr->value.function.esym
2254 && expr->value.function.esym->attr.use_assoc)
2256 gfc_expr_set_symbols_referenced (expr->ts.cl->length);
2260 find_noncopying_intrinsics (expr->value.function.esym,
2261 expr->value.function.actual);
2263 /* Make sure that the expression has a typespec that works. */
2264 if (expr->ts.type == BT_UNKNOWN)
2266 if (expr->symtree->n.sym->result
2267 && expr->symtree->n.sym->result->ts.type != BT_UNKNOWN)
2268 expr->ts = expr->symtree->n.sym->result->ts;
2275 /************* Subroutine resolution *************/
2278 pure_subroutine (gfc_code *c, gfc_symbol *sym)
2284 gfc_error ("Subroutine call to '%s' in FORALL block at %L is not PURE",
2285 sym->name, &c->loc);
2286 else if (gfc_pure (NULL))
2287 gfc_error ("Subroutine call to '%s' at %L is not PURE", sym->name,
2293 resolve_generic_s0 (gfc_code *c, gfc_symbol *sym)
2297 if (sym->attr.generic)
2299 s = gfc_search_interface (sym->generic, 1, &c->ext.actual);
2302 c->resolved_sym = s;
2303 pure_subroutine (c, s);
2307 /* TODO: Need to search for elemental references in generic interface. */
2310 if (sym->attr.intrinsic)
2311 return gfc_intrinsic_sub_interface (c, 0);
2318 resolve_generic_s (gfc_code *c)
2323 sym = c->symtree->n.sym;
2327 m = resolve_generic_s0 (c, sym);
2330 else if (m == MATCH_ERROR)
2334 if (sym->ns->parent == NULL)
2336 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
2340 if (!generic_sym (sym))
2344 /* Last ditch attempt. See if the reference is to an intrinsic
2345 that possesses a matching interface. 14.1.2.4 */
2346 sym = c->symtree->n.sym;
2348 if (!gfc_intrinsic_name (sym->name, 1))
2350 gfc_error ("There is no specific subroutine for the generic '%s' at %L",
2351 sym->name, &c->loc);
2355 m = gfc_intrinsic_sub_interface (c, 0);
2359 gfc_error ("Generic subroutine '%s' at %L is not consistent with an "
2360 "intrinsic subroutine interface", sym->name, &c->loc);
2366 /* Set the name and binding label of the subroutine symbol in the call
2367 expression represented by 'c' to include the type and kind of the
2368 second parameter. This function is for resolving the appropriate
2369 version of c_f_pointer() and c_f_procpointer(). For example, a
2370 call to c_f_pointer() for a default integer pointer could have a
2371 name of c_f_pointer_i4. If no second arg exists, which is an error
2372 for these two functions, it defaults to the generic symbol's name
2373 and binding label. */
2376 set_name_and_label (gfc_code *c, gfc_symbol *sym,
2377 char *name, char *binding_label)
2379 gfc_expr *arg = NULL;
2383 /* The second arg of c_f_pointer and c_f_procpointer determines
2384 the type and kind for the procedure name. */
2385 arg = c->ext.actual->next->expr;
2389 /* Set up the name to have the given symbol's name,
2390 plus the type and kind. */
2391 /* a derived type is marked with the type letter 'u' */
2392 if (arg->ts.type == BT_DERIVED)
2395 kind = 0; /* set the kind as 0 for now */
2399 type = gfc_type_letter (arg->ts.type);
2400 kind = arg->ts.kind;
2403 if (arg->ts.type == BT_CHARACTER)
2404 /* Kind info for character strings not needed. */
2407 sprintf (name, "%s_%c%d", sym->name, type, kind);
2408 /* Set up the binding label as the given symbol's label plus
2409 the type and kind. */
2410 sprintf (binding_label, "%s_%c%d", sym->binding_label, type, kind);
2414 /* If the second arg is missing, set the name and label as
2415 was, cause it should at least be found, and the missing
2416 arg error will be caught by compare_parameters(). */
2417 sprintf (name, "%s", sym->name);
2418 sprintf (binding_label, "%s", sym->binding_label);
2425 /* Resolve a generic version of the iso_c_binding procedure given
2426 (sym) to the specific one based on the type and kind of the
2427 argument(s). Currently, this function resolves c_f_pointer() and
2428 c_f_procpointer based on the type and kind of the second argument
2429 (FPTR). Other iso_c_binding procedures aren't specially handled.
2430 Upon successfully exiting, c->resolved_sym will hold the resolved
2431 symbol. Returns MATCH_ERROR if an error occurred; MATCH_YES
2435 gfc_iso_c_sub_interface (gfc_code *c, gfc_symbol *sym)
2437 gfc_symbol *new_sym;
2438 /* this is fine, since we know the names won't use the max */
2439 char name[GFC_MAX_SYMBOL_LEN + 1];
2440 char binding_label[GFC_MAX_BINDING_LABEL_LEN + 1];
2441 /* default to success; will override if find error */
2442 match m = MATCH_YES;
2444 /* Make sure the actual arguments are in the necessary order (based on the
2445 formal args) before resolving. */
2446 gfc_procedure_use (sym, &c->ext.actual, &(c->loc));
2448 if ((sym->intmod_sym_id == ISOCBINDING_F_POINTER) ||
2449 (sym->intmod_sym_id == ISOCBINDING_F_PROCPOINTER))
2451 set_name_and_label (c, sym, name, binding_label);
2453 if (sym->intmod_sym_id == ISOCBINDING_F_POINTER)
2455 if (c->ext.actual != NULL && c->ext.actual->next != NULL)
2457 /* Make sure we got a third arg if the second arg has non-zero
2458 rank. We must also check that the type and rank are
2459 correct since we short-circuit this check in
2460 gfc_procedure_use() (called above to sort actual args). */
2461 if (c->ext.actual->next->expr->rank != 0)
2463 if(c->ext.actual->next->next == NULL
2464 || c->ext.actual->next->next->expr == NULL)
2467 gfc_error ("Missing SHAPE parameter for call to %s "
2468 "at %L", sym->name, &(c->loc));
2470 else if (c->ext.actual->next->next->expr->ts.type
2472 || c->ext.actual->next->next->expr->rank != 1)
2475 gfc_error ("SHAPE parameter for call to %s at %L must "
2476 "be a rank 1 INTEGER array", sym->name,
2483 if (m != MATCH_ERROR)
2485 /* the 1 means to add the optional arg to formal list */
2486 new_sym = get_iso_c_sym (sym, name, binding_label, 1);
2488 /* for error reporting, say it's declared where the original was */
2489 new_sym->declared_at = sym->declared_at;
2494 /* no differences for c_loc or c_funloc */
2498 /* set the resolved symbol */
2499 if (m != MATCH_ERROR)
2500 c->resolved_sym = new_sym;
2502 c->resolved_sym = sym;
2508 /* Resolve a subroutine call known to be specific. */
2511 resolve_specific_s0 (gfc_code *c, gfc_symbol *sym)
2515 if(sym->attr.is_iso_c)
2517 m = gfc_iso_c_sub_interface (c,sym);
2521 if (sym->attr.external || sym->attr.if_source == IFSRC_IFBODY)
2523 if (sym->attr.dummy)
2525 sym->attr.proc = PROC_DUMMY;
2529 sym->attr.proc = PROC_EXTERNAL;
2533 if (sym->attr.proc == PROC_MODULE || sym->attr.proc == PROC_INTERNAL)
2536 if (sym->attr.intrinsic)
2538 m = gfc_intrinsic_sub_interface (c, 1);
2542 gfc_error ("Subroutine '%s' at %L is INTRINSIC but is not compatible "
2543 "with an intrinsic", sym->name, &c->loc);
2551 gfc_procedure_use (sym, &c->ext.actual, &c->loc);
2553 c->resolved_sym = sym;
2554 pure_subroutine (c, sym);
2561 resolve_specific_s (gfc_code *c)
2566 sym = c->symtree->n.sym;
2570 m = resolve_specific_s0 (c, sym);
2573 if (m == MATCH_ERROR)
2576 if (sym->ns->parent == NULL)
2579 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
2585 sym = c->symtree->n.sym;
2586 gfc_error ("Unable to resolve the specific subroutine '%s' at %L",
2587 sym->name, &c->loc);
2593 /* Resolve a subroutine call not known to be generic nor specific. */
2596 resolve_unknown_s (gfc_code *c)
2600 sym = c->symtree->n.sym;
2602 if (sym->attr.dummy)
2604 sym->attr.proc = PROC_DUMMY;
2608 /* See if we have an intrinsic function reference. */
2610 if (gfc_intrinsic_name (sym->name, 1))
2612 if (gfc_intrinsic_sub_interface (c, 1) == MATCH_YES)
2617 /* The reference is to an external name. */
2620 gfc_procedure_use (sym, &c->ext.actual, &c->loc);
2622 c->resolved_sym = sym;
2624 pure_subroutine (c, sym);
2630 /* Resolve a subroutine call. Although it was tempting to use the same code
2631 for functions, subroutines and functions are stored differently and this
2632 makes things awkward. */
2635 resolve_call (gfc_code *c)
2638 procedure_type ptype = PROC_INTRINSIC;
2640 if (c->symtree && c->symtree->n.sym
2641 && c->symtree->n.sym->ts.type != BT_UNKNOWN)
2643 gfc_error ("'%s' at %L has a type, which is not consistent with "
2644 "the CALL at %L", c->symtree->n.sym->name,
2645 &c->symtree->n.sym->declared_at, &c->loc);
2649 /* If external, check for usage. */
2650 if (c->symtree && is_external_proc (c->symtree->n.sym))
2651 resolve_global_procedure (c->symtree->n.sym, &c->loc, 1);
2653 /* Subroutines without the RECURSIVE attribution are not allowed to
2654 * call themselves. */
2655 if (c->symtree && c->symtree->n.sym && !c->symtree->n.sym->attr.recursive)
2657 gfc_symbol *csym, *proc;
2658 csym = c->symtree->n.sym;
2659 proc = gfc_current_ns->proc_name;
2662 gfc_error ("SUBROUTINE '%s' at %L cannot call itself, as it is not "
2663 "RECURSIVE", csym->name, &c->loc);
2667 if (csym->attr.entry && csym->ns->entries && proc->ns->entries
2668 && csym->ns->entries->sym == proc->ns->entries->sym)
2670 gfc_error ("Call to ENTRY '%s' at %L is recursive, but subroutine "
2671 "'%s' is not declared as RECURSIVE",
2672 csym->name, &c->loc, csym->ns->entries->sym->name);
2677 /* Switch off assumed size checking and do this again for certain kinds
2678 of procedure, once the procedure itself is resolved. */
2679 need_full_assumed_size++;
2681 if (c->symtree && c->symtree->n.sym)
2682 ptype = c->symtree->n.sym->attr.proc;
2684 if (resolve_actual_arglist (c->ext.actual, ptype) == FAILURE)
2687 /* Resume assumed_size checking. */
2688 need_full_assumed_size--;
2691 if (c->resolved_sym == NULL)
2692 switch (procedure_kind (c->symtree->n.sym))
2695 t = resolve_generic_s (c);
2698 case PTYPE_SPECIFIC:
2699 t = resolve_specific_s (c);
2703 t = resolve_unknown_s (c);
2707 gfc_internal_error ("resolve_subroutine(): bad function type");
2710 /* Some checks of elemental subroutine actual arguments. */
2711 if (resolve_elemental_actual (NULL, c) == FAILURE)
2715 find_noncopying_intrinsics (c->resolved_sym, c->ext.actual);
2720 /* Compare the shapes of two arrays that have non-NULL shapes. If both
2721 op1->shape and op2->shape are non-NULL return SUCCESS if their shapes
2722 match. If both op1->shape and op2->shape are non-NULL return FAILURE
2723 if their shapes do not match. If either op1->shape or op2->shape is
2724 NULL, return SUCCESS. */
2727 compare_shapes (gfc_expr *op1, gfc_expr *op2)
2734 if (op1->shape != NULL && op2->shape != NULL)
2736 for (i = 0; i < op1->rank; i++)
2738 if (mpz_cmp (op1->shape[i], op2->shape[i]) != 0)
2740 gfc_error ("Shapes for operands at %L and %L are not conformable",
2741 &op1->where, &op2->where);
2752 /* Resolve an operator expression node. This can involve replacing the
2753 operation with a user defined function call. */
2756 resolve_operator (gfc_expr *e)
2758 gfc_expr *op1, *op2;
2760 bool dual_locus_error;
2763 /* Resolve all subnodes-- give them types. */
2765 switch (e->value.op.operator)
2768 if (gfc_resolve_expr (e->value.op.op2) == FAILURE)
2771 /* Fall through... */
2774 case INTRINSIC_UPLUS:
2775 case INTRINSIC_UMINUS:
2776 case INTRINSIC_PARENTHESES:
2777 if (gfc_resolve_expr (e->value.op.op1) == FAILURE)
2782 /* Typecheck the new node. */
2784 op1 = e->value.op.op1;
2785 op2 = e->value.op.op2;
2786 dual_locus_error = false;
2788 if ((op1 && op1->expr_type == EXPR_NULL)
2789 || (op2 && op2->expr_type == EXPR_NULL))
2791 sprintf (msg, _("Invalid context for NULL() pointer at %%L"));
2795 switch (e->value.op.operator)
2797 case INTRINSIC_UPLUS:
2798 case INTRINSIC_UMINUS:
2799 if (op1->ts.type == BT_INTEGER
2800 || op1->ts.type == BT_REAL
2801 || op1->ts.type == BT_COMPLEX)
2807 sprintf (msg, _("Operand of unary numeric operator '%s' at %%L is %s"),
2808 gfc_op2string (e->value.op.operator), gfc_typename (&e->ts));
2811 case INTRINSIC_PLUS:
2812 case INTRINSIC_MINUS:
2813 case INTRINSIC_TIMES:
2814 case INTRINSIC_DIVIDE:
2815 case INTRINSIC_POWER:
2816 if (gfc_numeric_ts (&op1->ts) && gfc_numeric_ts (&op2->ts))
2818 gfc_type_convert_binary (e);
2823 _("Operands of binary numeric operator '%s' at %%L are %s/%s"),
2824 gfc_op2string (e->value.op.operator), gfc_typename (&op1->ts),
2825 gfc_typename (&op2->ts));
2828 case INTRINSIC_CONCAT:
2829 if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER)
2831 e->ts.type = BT_CHARACTER;
2832 e->ts.kind = op1->ts.kind;
2837 _("Operands of string concatenation operator at %%L are %s/%s"),
2838 gfc_typename (&op1->ts), gfc_typename (&op2->ts));
2844 case INTRINSIC_NEQV:
2845 if (op1->ts.type == BT_LOGICAL && op2->ts.type == BT_LOGICAL)
2847 e->ts.type = BT_LOGICAL;
2848 e->ts.kind = gfc_kind_max (op1, op2);
2849 if (op1->ts.kind < e->ts.kind)
2850 gfc_convert_type (op1, &e->ts, 2);
2851 else if (op2->ts.kind < e->ts.kind)
2852 gfc_convert_type (op2, &e->ts, 2);
2856 sprintf (msg, _("Operands of logical operator '%s' at %%L are %s/%s"),
2857 gfc_op2string (e->value.op.operator), gfc_typename (&op1->ts),
2858 gfc_typename (&op2->ts));
2863 if (op1->ts.type == BT_LOGICAL)
2865 e->ts.type = BT_LOGICAL;
2866 e->ts.kind = op1->ts.kind;
2870 sprintf (msg, _("Operand of .not. operator at %%L is %s"),
2871 gfc_typename (&op1->ts));
2875 case INTRINSIC_GT_OS:
2877 case INTRINSIC_GE_OS:
2879 case INTRINSIC_LT_OS:
2881 case INTRINSIC_LE_OS:
2882 if (op1->ts.type == BT_COMPLEX || op2->ts.type == BT_COMPLEX)
2884 strcpy (msg, _("COMPLEX quantities cannot be compared at %L"));
2888 /* Fall through... */
2891 case INTRINSIC_EQ_OS:
2893 case INTRINSIC_NE_OS:
2894 if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER)
2896 e->ts.type = BT_LOGICAL;
2897 e->ts.kind = gfc_default_logical_kind;
2901 if (gfc_numeric_ts (&op1->ts) && gfc_numeric_ts (&op2->ts))
2903 gfc_type_convert_binary (e);
2905 e->ts.type = BT_LOGICAL;
2906 e->ts.kind = gfc_default_logical_kind;
2910 if (op1->ts.type == BT_LOGICAL && op2->ts.type == BT_LOGICAL)
2912 _("Logicals at %%L must be compared with %s instead of %s"),
2913 (e->value.op.operator == INTRINSIC_EQ
2914 || e->value.op.operator == INTRINSIC_EQ_OS)
2915 ? ".eqv." : ".neqv.", gfc_op2string (e->value.op.operator));
2918 _("Operands of comparison operator '%s' at %%L are %s/%s"),
2919 gfc_op2string (e->value.op.operator), gfc_typename (&op1->ts),
2920 gfc_typename (&op2->ts));
2924 case INTRINSIC_USER:
2925 if (e->value.op.uop->operator == NULL)
2926 sprintf (msg, _("Unknown operator '%s' at %%L"), e->value.op.uop->name);
2927 else if (op2 == NULL)
2928 sprintf (msg, _("Operand of user operator '%s' at %%L is %s"),
2929 e->value.op.uop->name, gfc_typename (&op1->ts));
2931 sprintf (msg, _("Operands of user operator '%s' at %%L are %s/%s"),
2932 e->value.op.uop->name, gfc_typename (&op1->ts),
2933 gfc_typename (&op2->ts));
2937 case INTRINSIC_PARENTHESES:
2939 if (e->ts.type == BT_CHARACTER)
2940 e->ts.cl = op1->ts.cl;
2944 gfc_internal_error ("resolve_operator(): Bad intrinsic");
2947 /* Deal with arrayness of an operand through an operator. */
2951 switch (e->value.op.operator)
2953 case INTRINSIC_PLUS:
2954 case INTRINSIC_MINUS:
2955 case INTRINSIC_TIMES:
2956 case INTRINSIC_DIVIDE:
2957 case INTRINSIC_POWER:
2958 case INTRINSIC_CONCAT:
2962 case INTRINSIC_NEQV:
2964 case INTRINSIC_EQ_OS:
2966 case INTRINSIC_NE_OS:
2968 case INTRINSIC_GT_OS:
2970 case INTRINSIC_GE_OS:
2972 case INTRINSIC_LT_OS:
2974 case INTRINSIC_LE_OS:
2976 if (op1->rank == 0 && op2->rank == 0)
2979 if (op1->rank == 0 && op2->rank != 0)
2981 e->rank = op2->rank;
2983 if (e->shape == NULL)
2984 e->shape = gfc_copy_shape (op2->shape, op2->rank);
2987 if (op1->rank != 0 && op2->rank == 0)
2989 e->rank = op1->rank;
2991 if (e->shape == NULL)
2992 e->shape = gfc_copy_shape (op1->shape, op1->rank);
2995 if (op1->rank != 0 && op2->rank != 0)
2997 if (op1->rank == op2->rank)
2999 e->rank = op1->rank;
3000 if (e->shape == NULL)
3002 t = compare_shapes(op1, op2);
3006 e->shape = gfc_copy_shape (op1->shape, op1->rank);
3011 /* Allow higher level expressions to work. */
3014 /* Try user-defined operators, and otherwise throw an error. */
3015 dual_locus_error = true;
3017 _("Inconsistent ranks for operator at %%L and %%L"));
3024 case INTRINSIC_PARENTHESES:
3026 case INTRINSIC_UPLUS:
3027 case INTRINSIC_UMINUS:
3028 /* Simply copy arrayness attribute */
3029 e->rank = op1->rank;
3031 if (e->shape == NULL)
3032 e->shape = gfc_copy_shape (op1->shape, op1->rank);
3040 /* Attempt to simplify the expression. */
3043 t = gfc_simplify_expr (e, 0);
3044 /* Some calls do not succeed in simplification and return FAILURE
3045 even though there is no error; eg. variable references to
3046 PARAMETER arrays. */
3047 if (!gfc_is_constant_expr (e))
3054 if (gfc_extend_expr (e) == SUCCESS)
3057 if (dual_locus_error)
3058 gfc_error (msg, &op1->where, &op2->where);
3060 gfc_error (msg, &e->where);
3066 /************** Array resolution subroutines **************/
3069 { CMP_LT, CMP_EQ, CMP_GT, CMP_UNKNOWN }
3072 /* Compare two integer expressions. */
3075 compare_bound (gfc_expr *a, gfc_expr *b)
3079 if (a == NULL || a->expr_type != EXPR_CONSTANT
3080 || b == NULL || b->expr_type != EXPR_CONSTANT)
3083 if (a->ts.type != BT_INTEGER || b->ts.type != BT_INTEGER)
3084 gfc_internal_error ("compare_bound(): Bad expression");
3086 i = mpz_cmp (a->value.integer, b->value.integer);
3096 /* Compare an integer expression with an integer. */
3099 compare_bound_int (gfc_expr *a, int b)
3103 if (a == NULL || a->expr_type != EXPR_CONSTANT)
3106 if (a->ts.type != BT_INTEGER)
3107 gfc_internal_error ("compare_bound_int(): Bad expression");
3109 i = mpz_cmp_si (a->value.integer, b);
3119 /* Compare an integer expression with a mpz_t. */
3122 compare_bound_mpz_t (gfc_expr *a, mpz_t b)
3126 if (a == NULL || a->expr_type != EXPR_CONSTANT)
3129 if (a->ts.type != BT_INTEGER)
3130 gfc_internal_error ("compare_bound_int(): Bad expression");
3132 i = mpz_cmp (a->value.integer, b);
3142 /* Compute the last value of a sequence given by a triplet.
3143 Return 0 if it wasn't able to compute the last value, or if the
3144 sequence if empty, and 1 otherwise. */
3147 compute_last_value_for_triplet (gfc_expr *start, gfc_expr *end,
3148 gfc_expr *stride, mpz_t last)
3152 if (start == NULL || start->expr_type != EXPR_CONSTANT
3153 || end == NULL || end->expr_type != EXPR_CONSTANT
3154 || (stride != NULL && stride->expr_type != EXPR_CONSTANT))
3157 if (start->ts.type != BT_INTEGER || end->ts.type != BT_INTEGER
3158 || (stride != NULL && stride->ts.type != BT_INTEGER))
3161 if (stride == NULL || compare_bound_int(stride, 1) == CMP_EQ)
3163 if (compare_bound (start, end) == CMP_GT)
3165 mpz_set (last, end->value.integer);
3169 if (compare_bound_int (stride, 0) == CMP_GT)
3171 /* Stride is positive */
3172 if (mpz_cmp (start->value.integer, end->value.integer) > 0)
3177 /* Stride is negative */
3178 if (mpz_cmp (start->value.integer, end->value.integer) < 0)
3183 mpz_sub (rem, end->value.integer, start->value.integer);
3184 mpz_tdiv_r (rem, rem, stride->value.integer);
3185 mpz_sub (last, end->value.integer, rem);
3192 /* Compare a single dimension of an array reference to the array
3196 check_dimension (int i, gfc_array_ref *ar, gfc_array_spec *as)
3200 /* Given start, end and stride values, calculate the minimum and
3201 maximum referenced indexes. */
3203 switch (ar->dimen_type[i])
3209 if (compare_bound (ar->start[i], as->lower[i]) == CMP_LT)
3211 gfc_warning ("Array reference at %L is out of bounds "
3212 "(%ld < %ld) in dimension %d", &ar->c_where[i],
3213 mpz_get_si (ar->start[i]->value.integer),
3214 mpz_get_si (as->lower[i]->value.integer), i+1);
3217 if (compare_bound (ar->start[i], as->upper[i]) == CMP_GT)
3219 gfc_warning ("Array reference at %L is out of bounds "
3220 "(%ld > %ld) in dimension %d", &ar->c_where[i],
3221 mpz_get_si (ar->start[i]->value.integer),
3222 mpz_get_si (as->upper[i]->value.integer), i+1);
3230 #define AR_START (ar->start[i] ? ar->start[i] : as->lower[i])
3231 #define AR_END (ar->end[i] ? ar->end[i] : as->upper[i])
3233 comparison comp_start_end = compare_bound (AR_START, AR_END);
3235 /* Check for zero stride, which is not allowed. */
3236 if (compare_bound_int (ar->stride[i], 0) == CMP_EQ)
3238 gfc_error ("Illegal stride of zero at %L", &ar->c_where[i]);
3242 /* if start == len || (stride > 0 && start < len)
3243 || (stride < 0 && start > len),
3244 then the array section contains at least one element. In this
3245 case, there is an out-of-bounds access if
3246 (start < lower || start > upper). */
3247 if (compare_bound (AR_START, AR_END) == CMP_EQ
3248 || ((compare_bound_int (ar->stride[i], 0) == CMP_GT
3249 || ar->stride[i] == NULL) && comp_start_end == CMP_LT)
3250 || (compare_bound_int (ar->stride[i], 0) == CMP_LT
3251 && comp_start_end == CMP_GT))
3253 if (compare_bound (AR_START, as->lower[i]) == CMP_LT)
3255 gfc_warning ("Lower array reference at %L is out of bounds "
3256 "(%ld < %ld) in dimension %d", &ar->c_where[i],
3257 mpz_get_si (AR_START->value.integer),
3258 mpz_get_si (as->lower[i]->value.integer), i+1);
3261 if (compare_bound (AR_START, as->upper[i]) == CMP_GT)
3263 gfc_warning ("Lower array reference at %L is out of bounds "
3264 "(%ld > %ld) in dimension %d", &ar->c_where[i],
3265 mpz_get_si (AR_START->value.integer),
3266 mpz_get_si (as->upper[i]->value.integer), i+1);
3271 /* If we can compute the highest index of the array section,
3272 then it also has to be between lower and upper. */
3273 mpz_init (last_value);
3274 if (compute_last_value_for_triplet (AR_START, AR_END, ar->stride[i],
3277 if (compare_bound_mpz_t (as->lower[i], last_value) == CMP_GT)
3279 gfc_warning ("Upper array reference at %L is out of bounds "
3280 "(%ld < %ld) in dimension %d", &ar->c_where[i],
3281 mpz_get_si (last_value),
3282 mpz_get_si (as->lower[i]->value.integer), i+1);
3283 mpz_clear (last_value);
3286 if (compare_bound_mpz_t (as->upper[i], last_value) == CMP_LT)
3288 gfc_warning ("Upper array reference at %L is out of bounds "
3289 "(%ld > %ld) in dimension %d", &ar->c_where[i],
3290 mpz_get_si (last_value),
3291 mpz_get_si (as->upper[i]->value.integer), i+1);
3292 mpz_clear (last_value);
3296 mpz_clear (last_value);
3304 gfc_internal_error ("check_dimension(): Bad array reference");
3311 /* Compare an array reference with an array specification. */
3314 compare_spec_to_ref (gfc_array_ref *ar)
3321 /* TODO: Full array sections are only allowed as actual parameters. */
3322 if (as->type == AS_ASSUMED_SIZE
3323 && (/*ar->type == AR_FULL
3324 ||*/ (ar->type == AR_SECTION
3325 && ar->dimen_type[i] == DIMEN_RANGE && ar->end[i] == NULL)))
3327 gfc_error ("Rightmost upper bound of assumed size array section "
3328 "not specified at %L", &ar->where);
3332 if (ar->type == AR_FULL)
3335 if (as->rank != ar->dimen)
3337 gfc_error ("Rank mismatch in array reference at %L (%d/%d)",
3338 &ar->where, ar->dimen, as->rank);
3342 for (i = 0; i < as->rank; i++)
3343 if (check_dimension (i, ar, as) == FAILURE)
3350 /* Resolve one part of an array index. */
3353 gfc_resolve_index (gfc_expr *index, int check_scalar)
3360 if (gfc_resolve_expr (index) == FAILURE)
3363 if (check_scalar && index->rank != 0)
3365 gfc_error ("Array index at %L must be scalar", &index->where);
3369 if (index->ts.type != BT_INTEGER && index->ts.type != BT_REAL)
3371 gfc_error ("Array index at %L must be of INTEGER type",
3376 if (index->ts.type == BT_REAL)
3377 if (gfc_notify_std (GFC_STD_LEGACY, "Extension: REAL array index at %L",
3378 &index->where) == FAILURE)
3381 if (index->ts.kind != gfc_index_integer_kind
3382 || index->ts.type != BT_INTEGER)
3385 ts.type = BT_INTEGER;
3386 ts.kind = gfc_index_integer_kind;
3388 gfc_convert_type_warn (index, &ts, 2, 0);
3394 /* Resolve a dim argument to an intrinsic function. */
3397 gfc_resolve_dim_arg (gfc_expr *dim)
3402 if (gfc_resolve_expr (dim) == FAILURE)
3407 gfc_error ("Argument dim at %L must be scalar", &dim->where);
3411 if (dim->ts.type != BT_INTEGER)
3413 gfc_error ("Argument dim at %L must be of INTEGER type", &dim->where);
3416 if (dim->ts.kind != gfc_index_integer_kind)
3420 ts.type = BT_INTEGER;
3421 ts.kind = gfc_index_integer_kind;
3423 gfc_convert_type_warn (dim, &ts, 2, 0);
3429 /* Given an expression that contains array references, update those array
3430 references to point to the right array specifications. While this is
3431 filled in during matching, this information is difficult to save and load
3432 in a module, so we take care of it here.
3434 The idea here is that the original array reference comes from the
3435 base symbol. We traverse the list of reference structures, setting
3436 the stored reference to references. Component references can
3437 provide an additional array specification. */
3440 find_array_spec (gfc_expr *e)
3444 gfc_symbol *derived;
3447 as = e->symtree->n.sym->as;
3450 for (ref = e->ref; ref; ref = ref->next)
3455 gfc_internal_error ("find_array_spec(): Missing spec");
3462 if (derived == NULL)
3463 derived = e->symtree->n.sym->ts.derived;
3465 c = derived->components;
3467 for (; c; c = c->next)
3468 if (c == ref->u.c.component)
3470 /* Track the sequence of component references. */
3471 if (c->ts.type == BT_DERIVED)
3472 derived = c->ts.derived;
3477 gfc_internal_error ("find_array_spec(): Component not found");
3482 gfc_internal_error ("find_array_spec(): unused as(1)");
3493 gfc_internal_error ("find_array_spec(): unused as(2)");
3497 /* Resolve an array reference. */
3500 resolve_array_ref (gfc_array_ref *ar)
3502 int i, check_scalar;
3505 for (i = 0; i < ar->dimen; i++)
3507 check_scalar = ar->dimen_type[i] == DIMEN_RANGE;
3509 if (gfc_resolve_index (ar->start[i], check_scalar) == FAILURE)
3511 if (gfc_resolve_index (ar->end[i], check_scalar) == FAILURE)
3513 if (gfc_resolve_index (ar->stride[i], check_scalar) == FAILURE)
3518 if (ar->dimen_type[i] == DIMEN_UNKNOWN)
3522 ar->dimen_type[i] = DIMEN_ELEMENT;
3526 ar->dimen_type[i] = DIMEN_VECTOR;
3527 if (e->expr_type == EXPR_VARIABLE
3528 && e->symtree->n.sym->ts.type == BT_DERIVED)
3529 ar->start[i] = gfc_get_parentheses (e);
3533 gfc_error ("Array index at %L is an array of rank %d",
3534 &ar->c_where[i], e->rank);
3539 /* If the reference type is unknown, figure out what kind it is. */
3541 if (ar->type == AR_UNKNOWN)
3543 ar->type = AR_ELEMENT;
3544 for (i = 0; i < ar->dimen; i++)
3545 if (ar->dimen_type[i] == DIMEN_RANGE
3546 || ar->dimen_type[i] == DIMEN_VECTOR)
3548 ar->type = AR_SECTION;
3553 if (!ar->as->cray_pointee && compare_spec_to_ref (ar) == FAILURE)
3561 resolve_substring (gfc_ref *ref)
3563 if (ref->u.ss.start != NULL)
3565 if (gfc_resolve_expr (ref->u.ss.start) == FAILURE)
3568 if (ref->u.ss.start->ts.type != BT_INTEGER)
3570 gfc_error ("Substring start index at %L must be of type INTEGER",
3571 &ref->u.ss.start->where);
3575 if (ref->u.ss.start->rank != 0)
3577 gfc_error ("Substring start index at %L must be scalar",
3578 &ref->u.ss.start->where);
3582 if (compare_bound_int (ref->u.ss.start, 1) == CMP_LT
3583 && (compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_EQ
3584 || compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_GT))
3586 gfc_error ("Substring start index at %L is less than one",
3587 &ref->u.ss.start->where);
3592 if (ref->u.ss.end != NULL)
3594 if (gfc_resolve_expr (ref->u.ss.end) == FAILURE)
3597 if (ref->u.ss.end->ts.type != BT_INTEGER)
3599 gfc_error ("Substring end index at %L must be of type INTEGER",
3600 &ref->u.ss.end->where);
3604 if (ref->u.ss.end->rank != 0)
3606 gfc_error ("Substring end index at %L must be scalar",
3607 &ref->u.ss.end->where);
3611 if (ref->u.ss.length != NULL
3612 && compare_bound (ref->u.ss.end, ref->u.ss.length->length) == CMP_GT
3613 && (compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_EQ
3614 || compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_GT))
3616 gfc_error ("Substring end index at %L exceeds the string length",
3617 &ref->u.ss.start->where);
3626 /* This function supplies missing substring charlens. */
3629 gfc_resolve_substring_charlen (gfc_expr *e)
3632 gfc_expr *start, *end;
3634 for (char_ref = e->ref; char_ref; char_ref = char_ref->next)
3635 if (char_ref->type == REF_SUBSTRING)
3641 gcc_assert (char_ref->next == NULL);
3645 if (e->ts.cl->length)
3646 gfc_free_expr (e->ts.cl->length);
3647 else if (e->expr_type == EXPR_VARIABLE
3648 && e->symtree->n.sym->attr.dummy)
3652 e->ts.type = BT_CHARACTER;
3653 e->ts.kind = gfc_default_character_kind;
3657 e->ts.cl = gfc_get_charlen ();
3658 e->ts.cl->next = gfc_current_ns->cl_list;
3659 gfc_current_ns->cl_list = e->ts.cl;
3662 if (char_ref->u.ss.start)
3663 start = gfc_copy_expr (char_ref->u.ss.start);
3665 start = gfc_int_expr (1);
3667 if (char_ref->u.ss.end)
3668 end = gfc_copy_expr (char_ref->u.ss.end);
3669 else if (e->expr_type == EXPR_VARIABLE)
3670 end = gfc_copy_expr (e->symtree->n.sym->ts.cl->length);
3677 /* Length = (end - start +1). */
3678 e->ts.cl->length = gfc_subtract (end, start);
3679 e->ts.cl->length = gfc_add (e->ts.cl->length, gfc_int_expr (1));
3681 e->ts.cl->length->ts.type = BT_INTEGER;
3682 e->ts.cl->length->ts.kind = gfc_charlen_int_kind;;
3684 /* Make sure that the length is simplified. */
3685 gfc_simplify_expr (e->ts.cl->length, 1);
3686 gfc_resolve_expr (e->ts.cl->length);
3690 /* Resolve subtype references. */
3693 resolve_ref (gfc_expr *expr)
3695 int current_part_dimension, n_components, seen_part_dimension;
3698 for (ref = expr->ref; ref; ref = ref->next)
3699 if (ref->type == REF_ARRAY && ref->u.ar.as == NULL)
3701 find_array_spec (expr);
3705 for (ref = expr->ref; ref; ref = ref->next)
3709 if (resolve_array_ref (&ref->u.ar) == FAILURE)
3717 resolve_substring (ref);
3721 /* Check constraints on part references. */
3723 current_part_dimension = 0;
3724 seen_part_dimension = 0;
3727 for (ref = expr->ref; ref; ref = ref->next)
3732 switch (ref->u.ar.type)
3736 current_part_dimension = 1;
3740 current_part_dimension = 0;
3744 gfc_internal_error ("resolve_ref(): Bad array reference");
3750 if (current_part_dimension || seen_part_dimension)
3752 if (ref->u.c.component->pointer)
3754 gfc_error ("Component to the right of a part reference "
3755 "with nonzero rank must not have the POINTER "
3756 "attribute at %L", &expr->where);
3759 else if (ref->u.c.component->allocatable)
3761 gfc_error ("Component to the right of a part reference "
3762 "with nonzero rank must not have the ALLOCATABLE "
3763 "attribute at %L", &expr->where);
3775 if (((ref->type == REF_COMPONENT && n_components > 1)
3776 || ref->next == NULL)
3777 && current_part_dimension
3778 && seen_part_dimension)
3780 gfc_error ("Two or more part references with nonzero rank must "
3781 "not be specified at %L", &expr->where);
3785 if (ref->type == REF_COMPONENT)
3787 if (current_part_dimension)
3788 seen_part_dimension = 1;
3790 /* reset to make sure */
3791 current_part_dimension = 0;
3799 /* Given an expression, determine its shape. This is easier than it sounds.
3800 Leaves the shape array NULL if it is not possible to determine the shape. */
3803 expression_shape (gfc_expr *e)
3805 mpz_t array[GFC_MAX_DIMENSIONS];
3808 if (e->rank == 0 || e->shape != NULL)
3811 for (i = 0; i < e->rank; i++)
3812 if (gfc_array_dimen_size (e, i, &array[i]) == FAILURE)
3815 e->shape = gfc_get_shape (e->rank);
3817 memcpy (e->shape, array, e->rank * sizeof (mpz_t));
3822 for (i--; i >= 0; i--)
3823 mpz_clear (array[i]);
3827 /* Given a variable expression node, compute the rank of the expression by
3828 examining the base symbol and any reference structures it may have. */
3831 expression_rank (gfc_expr *e)
3838 if (e->expr_type == EXPR_ARRAY)
3840 /* Constructors can have a rank different from one via RESHAPE(). */
3842 if (e->symtree == NULL)
3848 e->rank = (e->symtree->n.sym->as == NULL)
3849 ? 0 : e->symtree->n.sym->as->rank;
3855 for (ref = e->ref; ref; ref = ref->next)
3857 if (ref->type != REF_ARRAY)
3860 if (ref->u.ar.type == AR_FULL)
3862 rank = ref->u.ar.as->rank;
3866 if (ref->u.ar.type == AR_SECTION)
3868 /* Figure out the rank of the section. */
3870 gfc_internal_error ("expression_rank(): Two array specs");
3872 for (i = 0; i < ref->u.ar.dimen; i++)
3873 if (ref->u.ar.dimen_type[i] == DIMEN_RANGE
3874 || ref->u.ar.dimen_type[i] == DIMEN_VECTOR)
3884 expression_shape (e);
3888 /* Resolve a variable expression. */
3891 resolve_variable (gfc_expr *e)
3898 if (e->symtree == NULL)
3901 if (e->ref && resolve_ref (e) == FAILURE)
3904 sym = e->symtree->n.sym;
3905 if (sym->attr.flavor == FL_PROCEDURE && !sym->attr.function)
3907 e->ts.type = BT_PROCEDURE;
3911 if (sym->ts.type != BT_UNKNOWN)
3912 gfc_variable_attr (e, &e->ts);
3915 /* Must be a simple variable reference. */
3916 if (gfc_set_default_type (sym, 1, sym->ns) == FAILURE)
3921 if (check_assumed_size_reference (sym, e))
3924 /* Deal with forward references to entries during resolve_code, to
3925 satisfy, at least partially, 12.5.2.5. */
3926 if (gfc_current_ns->entries
3927 && current_entry_id == sym->entry_id
3930 && cs_base->current->op != EXEC_ENTRY)
3932 gfc_entry_list *entry;
3933 gfc_formal_arglist *formal;
3937 /* If the symbol is a dummy... */
3938 if (sym->attr.dummy && sym->ns == gfc_current_ns)
3940 entry = gfc_current_ns->entries;
3943 /* ...test if the symbol is a parameter of previous entries. */
3944 for (; entry && entry->id <= current_entry_id; entry = entry->next)
3945 for (formal = entry->sym->formal; formal; formal = formal->next)
3947 if (formal->sym && sym->name == formal->sym->name)
3951 /* If it has not been seen as a dummy, this is an error. */
3954 if (specification_expr)
3955 gfc_error ("Variable '%s', used in a specification expression"
3956 ", is referenced at %L before the ENTRY statement "
3957 "in which it is a parameter",
3958 sym->name, &cs_base->current->loc);
3960 gfc_error ("Variable '%s' is used at %L before the ENTRY "
3961 "statement in which it is a parameter",
3962 sym->name, &cs_base->current->loc);
3967 /* Now do the same check on the specification expressions. */
3968 specification_expr = 1;
3969 if (sym->ts.type == BT_CHARACTER
3970 && gfc_resolve_expr (sym->ts.cl->length) == FAILURE)
3974 for (n = 0; n < sym->as->rank; n++)
3976 specification_expr = 1;
3977 if (gfc_resolve_expr (sym->as->lower[n]) == FAILURE)
3979 specification_expr = 1;
3980 if (gfc_resolve_expr (sym->as->upper[n]) == FAILURE)
3983 specification_expr = 0;
3986 /* Update the symbol's entry level. */
3987 sym->entry_id = current_entry_id + 1;
3994 /* Checks to see that the correct symbol has been host associated.
3995 The only situation where this arises is that in which a twice
3996 contained function is parsed after the host association is made.
3997 Therefore, on detecting this, the line is rematched, having got
3998 rid of the existing references and actual_arg_list. */
4000 check_host_association (gfc_expr *e)
4002 gfc_symbol *sym, *old_sym;
4006 bool retval = e->expr_type == EXPR_FUNCTION;
4008 if (e->symtree == NULL || e->symtree->n.sym == NULL)
4011 old_sym = e->symtree->n.sym;
4013 if (old_sym->attr.use_assoc)
4016 if (gfc_current_ns->parent
4017 && old_sym->ns != gfc_current_ns)
4019 gfc_find_symbol (old_sym->name, gfc_current_ns, 1, &sym);
4020 if (sym && old_sym != sym
4021 && sym->attr.flavor == FL_PROCEDURE
4022 && sym->attr.contained)
4024 temp_locus = gfc_current_locus;
4025 gfc_current_locus = e->where;
4027 gfc_buffer_error (1);
4029 gfc_free_ref_list (e->ref);
4034 gfc_free_actual_arglist (e->value.function.actual);
4035 e->value.function.actual = NULL;
4038 if (e->shape != NULL)
4040 for (n = 0; n < e->rank; n++)
4041 mpz_clear (e->shape[n]);
4043 gfc_free (e->shape);
4046 gfc_match_rvalue (&expr);
4048 gfc_buffer_error (0);
4050 gcc_assert (expr && sym == expr->symtree->n.sym);
4056 gfc_current_locus = temp_locus;
4059 /* This might have changed! */
4060 return e->expr_type == EXPR_FUNCTION;
4065 gfc_resolve_character_operator (gfc_expr *e)
4067 gfc_expr *op1 = e->value.op.op1;
4068 gfc_expr *op2 = e->value.op.op2;
4069 gfc_expr *e1 = NULL;
4070 gfc_expr *e2 = NULL;
4072 gcc_assert (e->value.op.operator == INTRINSIC_CONCAT);
4074 if (op1->ts.cl && op1->ts.cl->length)
4075 e1 = gfc_copy_expr (op1->ts.cl->length);
4076 else if (op1->expr_type == EXPR_CONSTANT)
4077 e1 = gfc_int_expr (op1->value.character.length);
4079 if (op2->ts.cl && op2->ts.cl->length)
4080 e2 = gfc_copy_expr (op2->ts.cl->length);
4081 else if (op2->expr_type == EXPR_CONSTANT)
4082 e2 = gfc_int_expr (op2->value.character.length);
4084 e->ts.cl = gfc_get_charlen ();
4085 e->ts.cl->next = gfc_current_ns->cl_list;
4086 gfc_current_ns->cl_list = e->ts.cl;
4091 e->ts.cl->length = gfc_add (e1, e2);
4092 e->ts.cl->length->ts.type = BT_INTEGER;
4093 e->ts.cl->length->ts.kind = gfc_charlen_int_kind;;
4094 gfc_simplify_expr (e->ts.cl->length, 0);
4095 gfc_resolve_expr (e->ts.cl->length);
4101 /* Ensure that an character expression has a charlen and, if possible, a
4102 length expression. */
4105 fixup_charlen (gfc_expr *e)
4107 /* The cases fall through so that changes in expression type and the need
4108 for multiple fixes are picked up. In all circumstances, a charlen should
4109 be available for the middle end to hang a backend_decl on. */
4110 switch (e->expr_type)
4113 gfc_resolve_character_operator (e);
4116 if (e->expr_type == EXPR_ARRAY)
4117 gfc_resolve_character_array_constructor (e);
4119 case EXPR_SUBSTRING:
4120 if (!e->ts.cl && e->ref)
4121 gfc_resolve_substring_charlen (e);
4126 e->ts.cl = gfc_get_charlen ();
4127 e->ts.cl->next = gfc_current_ns->cl_list;
4128 gfc_current_ns->cl_list = e->ts.cl;
4136 /* Resolve an expression. That is, make sure that types of operands agree
4137 with their operators, intrinsic operators are converted to function calls
4138 for overloaded types and unresolved function references are resolved. */
4141 gfc_resolve_expr (gfc_expr *e)
4148 switch (e->expr_type)
4151 t = resolve_operator (e);
4157 if (check_host_association (e))
4158 t = resolve_function (e);
4161 t = resolve_variable (e);
4163 expression_rank (e);
4166 if (e->ts.type == BT_CHARACTER && e->ts.cl == NULL && e->ref
4167 && e->ref->type != REF_SUBSTRING)
4168 gfc_resolve_substring_charlen (e);
4172 case EXPR_SUBSTRING:
4173 t = resolve_ref (e);
4183 if (resolve_ref (e) == FAILURE)
4186 t = gfc_resolve_array_constructor (e);
4187 /* Also try to expand a constructor. */
4190 expression_rank (e);
4191 gfc_expand_constructor (e);
4194 /* This provides the opportunity for the length of constructors with
4195 character valued function elements to propagate the string length
4196 to the expression. */
4197 if (e->ts.type == BT_CHARACTER)
4198 gfc_resolve_character_array_constructor (e);
4202 case EXPR_STRUCTURE:
4203 t = resolve_ref (e);
4207 t = resolve_structure_cons (e);
4211 t = gfc_simplify_expr (e, 0);
4215 gfc_internal_error ("gfc_resolve_expr(): Bad expression type");
4218 if (e->ts.type == BT_CHARACTER && t == SUCCESS && !e->ts.cl)
4225 /* Resolve an expression from an iterator. They must be scalar and have
4226 INTEGER or (optionally) REAL type. */
4229 gfc_resolve_iterator_expr (gfc_expr *expr, bool real_ok,
4230 const char *name_msgid)
4232 if (gfc_resolve_expr (expr) == FAILURE)
4235 if (expr->rank != 0)
4237 gfc_error ("%s at %L must be a scalar", _(name_msgid), &expr->where);
4241 if (expr->ts.type != BT_INTEGER)
4243 if (expr->ts.type == BT_REAL)
4246 return gfc_notify_std (GFC_STD_F95_DEL,
4247 "Deleted feature: %s at %L must be integer",
4248 _(name_msgid), &expr->where);
4251 gfc_error ("%s at %L must be INTEGER", _(name_msgid),
4258 gfc_error ("%s at %L must be INTEGER", _(name_msgid), &expr->where);
4266 /* Resolve the expressions in an iterator structure. If REAL_OK is
4267 false allow only INTEGER type iterators, otherwise allow REAL types. */
4270 gfc_resolve_iterator (gfc_iterator *iter, bool real_ok)
4272 if (gfc_resolve_iterator_expr (iter->var, real_ok, "Loop variable")
4276 if (gfc_pure (NULL) && gfc_impure_variable (iter->var->symtree->n.sym))
4278 gfc_error ("Cannot assign to loop variable in PURE procedure at %L",
4283 if (gfc_resolve_iterator_expr (iter->start, real_ok,
4284 "Start expression in DO loop") == FAILURE)
4287 if (gfc_resolve_iterator_expr (iter->end, real_ok,
4288 "End expression in DO loop") == FAILURE)
4291 if (gfc_resolve_iterator_expr (iter->step, real_ok,
4292 "Step expression in DO loop") == FAILURE)
4295 if (iter->step->expr_type == EXPR_CONSTANT)
4297 if ((iter->step->ts.type == BT_INTEGER
4298 && mpz_cmp_ui (iter->step->value.integer, 0) == 0)
4299 || (iter->step->ts.type == BT_REAL
4300 && mpfr_sgn (iter->step->value.real) == 0))
4302 gfc_error ("Step expression in DO loop at %L cannot be zero",
4303 &iter->step->where);
4308 /* Convert start, end, and step to the same type as var. */
4309 if (iter->start->ts.kind != iter->var->ts.kind
4310 || iter->start->ts.type != iter->var->ts.type)
4311 gfc_convert_type (iter->start, &iter->var->ts, 2);
4313 if (iter->end->ts.kind != iter->var->ts.kind
4314 || iter->end->ts.type != iter->var->ts.type)
4315 gfc_convert_type (iter->end, &iter->var->ts, 2);
4317 if (iter->step->ts.kind != iter->var->ts.kind
4318 || iter->step->ts.type != iter->var->ts.type)
4319 gfc_convert_type (iter->step, &iter->var->ts, 2);
4325 /* Traversal function for find_forall_index. f == 2 signals that
4326 that variable itself is not to be checked - only the references. */
4329 forall_index (gfc_expr *expr, gfc_symbol *sym, int *f)
4331 gcc_assert (expr->expr_type == EXPR_VARIABLE);
4333 /* A scalar assignment */
4334 if (!expr->ref || *f == 1)
4336 if (expr->symtree->n.sym == sym)
4348 /* Check whether the FORALL index appears in the expression or not.
4349 Returns SUCCESS if SYM is found in EXPR. */
4352 find_forall_index (gfc_expr *expr, gfc_symbol *sym, int f)
4354 if (gfc_traverse_expr (expr, sym, forall_index, f))
4361 /* Resolve a list of FORALL iterators. The FORALL index-name is constrained
4362 to be a scalar INTEGER variable. The subscripts and stride are scalar
4363 INTEGERs, and if stride is a constant it must be nonzero.
4364 Furthermore "A subscript or stride in a forall-triplet-spec shall
4365 not contain a reference to any index-name in the
4366 forall-triplet-spec-list in which it appears." (7.5.4.1) */
4369 resolve_forall_iterators (gfc_forall_iterator *it)
4371 gfc_forall_iterator *iter, *iter2;
4373 for (iter = it; iter; iter = iter->next)
4375 if (gfc_resolve_expr (iter->var) == SUCCESS
4376 && (iter->var->ts.type != BT_INTEGER || iter->var->rank != 0))
4377 gfc_error ("FORALL index-name at %L must be a scalar INTEGER",
4380 if (gfc_resolve_expr (iter->start) == SUCCESS
4381 && (iter->start->ts.type != BT_INTEGER || iter->start->rank != 0))
4382 gfc_error ("FORALL start expression at %L must be a scalar INTEGER",
4383 &iter->start->where);
4384 if (iter->var->ts.kind != iter->start->ts.kind)
4385 gfc_convert_type (iter->start, &iter->var->ts, 2);
4387 if (gfc_resolve_expr (iter->end) == SUCCESS
4388 && (iter->end->ts.type != BT_INTEGER || iter->end->rank != 0))
4389 gfc_error ("FORALL end expression at %L must be a scalar INTEGER",
4391 if (iter->var->ts.kind != iter->end->ts.kind)
4392 gfc_convert_type (iter->end, &iter->var->ts, 2);
4394 if (gfc_resolve_expr (iter->stride) == SUCCESS)
4396 if (iter->stride->ts.type != BT_INTEGER || iter->stride->rank != 0)
4397 gfc_error ("FORALL stride expression at %L must be a scalar %s",
4398 &iter->stride->where, "INTEGER");
4400 if (iter->stride->expr_type == EXPR_CONSTANT
4401 && mpz_cmp_ui(iter->stride->value.integer, 0) == 0)
4402 gfc_error ("FORALL stride expression at %L cannot be zero",
4403 &iter->stride->where);
4405 if (iter->var->ts.kind != iter->stride->ts.kind)
4406 gfc_convert_type (iter->stride, &iter->var->ts, 2);
4409 for (iter = it; iter; iter = iter->next)
4410 for (iter2 = iter; iter2; iter2 = iter2->next)
4412 if (find_forall_index (iter2->start,
4413 iter->var->symtree->n.sym, 0) == SUCCESS
4414 || find_forall_index (iter2->end,
4415 iter->var->symtree->n.sym, 0) == SUCCESS
4416 || find_forall_index (iter2->stride,
4417 iter->var->symtree->n.sym, 0) == SUCCESS)
4418 gfc_error ("FORALL index '%s' may not appear in triplet "
4419 "specification at %L", iter->var->symtree->name,
4420 &iter2->start->where);
4425 /* Given a pointer to a symbol that is a derived type, see if it's
4426 inaccessible, i.e. if it's defined in another module and the components are
4427 PRIVATE. The search is recursive if necessary. Returns zero if no
4428 inaccessible components are found, nonzero otherwise. */
4431 derived_inaccessible (gfc_symbol *sym)
4435 if (sym->attr.use_assoc && sym->attr.private_comp)
4438 for (c = sym->components; c; c = c->next)
4440 if (c->ts.type == BT_DERIVED && derived_inaccessible (c->ts.derived))
4448 /* Resolve the argument of a deallocate expression. The expression must be
4449 a pointer or a full array. */
4452 resolve_deallocate_expr (gfc_expr *e)
4454 symbol_attribute attr;
4455 int allocatable, pointer, check_intent_in;
4458 /* Check INTENT(IN), unless the object is a sub-component of a pointer. */
4459 check_intent_in = 1;
4461 if (gfc_resolve_expr (e) == FAILURE)
4464 if (e->expr_type != EXPR_VARIABLE)
4467 allocatable = e->symtree->n.sym->attr.allocatable;
4468 pointer = e->symtree->n.sym->attr.pointer;
4469 for (ref = e->ref; ref; ref = ref->next)
4472 check_intent_in = 0;
4477 if (ref->u.ar.type != AR_FULL)
4482 allocatable = (ref->u.c.component->as != NULL
4483 && ref->u.c.component->as->type == AS_DEFERRED);
4484 pointer = ref->u.c.component->pointer;
4493 attr = gfc_expr_attr (e);
4495 if (allocatable == 0 && attr.pointer == 0)
4498 gfc_error ("Expression in DEALLOCATE statement at %L must be "
4499 "ALLOCATABLE or a POINTER", &e->where);
4503 && e->symtree->n.sym->attr.intent == INTENT_IN)
4505 gfc_error ("Cannot deallocate INTENT(IN) variable '%s' at %L",
4506 e->symtree->n.sym->name, &e->where);
4514 /* Returns true if the expression e contains a reference the symbol sym. */
4516 find_sym_in_expr (gfc_symbol *sym, gfc_expr *e)
4518 gfc_actual_arglist *arg;
4526 switch (e->expr_type)
4529 for (arg = e->value.function.actual; arg; arg = arg->next)
4530 rv = rv || find_sym_in_expr (sym, arg->expr);
4533 /* If the variable is not the same as the dependent, 'sym', and
4534 it is not marked as being declared and it is in the same
4535 namespace as 'sym', add it to the local declarations. */
4537 if (sym == e->symtree->n.sym)
4542 rv = rv || find_sym_in_expr (sym, e->value.op.op1);
4543 rv = rv || find_sym_in_expr (sym, e->value.op.op2);
4552 for (ref = e->ref; ref; ref = ref->next)
4557 for (i = 0; i < ref->u.ar.dimen; i++)
4559 rv = rv || find_sym_in_expr (sym, ref->u.ar.start[i]);
4560 rv = rv || find_sym_in_expr (sym, ref->u.ar.end[i]);
4561 rv = rv || find_sym_in_expr (sym, ref->u.ar.stride[i]);
4566 rv = rv || find_sym_in_expr (sym, ref->u.ss.start);
4567 rv = rv || find_sym_in_expr (sym, ref->u.ss.end);
4571 if (ref->u.c.component->ts.type == BT_CHARACTER
4572 && ref->u.c.component->ts.cl->length->expr_type
4575 || find_sym_in_expr (sym,
4576 ref->u.c.component->ts.cl->length);
4578 if (ref->u.c.component->as)
4579 for (i = 0; i < ref->u.c.component->as->rank; i++)
4582 || find_sym_in_expr (sym,
4583 ref->u.c.component->as->lower[i]);
4585 || find_sym_in_expr (sym,
4586 ref->u.c.component->as->upper[i]);
4596 /* Given the expression node e for an allocatable/pointer of derived type to be
4597 allocated, get the expression node to be initialized afterwards (needed for
4598 derived types with default initializers, and derived types with allocatable
4599 components that need nullification.) */
4602 expr_to_initialize (gfc_expr *e)
4608 result = gfc_copy_expr (e);
4610 /* Change the last array reference from AR_ELEMENT to AR_FULL. */
4611 for (ref = result->ref; ref; ref = ref->next)
4612 if (ref->type == REF_ARRAY && ref->next == NULL)
4614 ref->u.ar.type = AR_FULL;
4616 for (i = 0; i < ref->u.ar.dimen; i++)
4617 ref->u.ar.start[i] = ref->u.ar.end[i] = ref->u.ar.stride[i] = NULL;
4619 result->rank = ref->u.ar.dimen;
4627 /* Resolve the expression in an ALLOCATE statement, doing the additional
4628 checks to see whether the expression is OK or not. The expression must
4629 have a trailing array reference that gives the size of the array. */
4632 resolve_allocate_expr (gfc_expr *e, gfc_code *code)
4634 int i, pointer, allocatable, dimension, check_intent_in;
4635 symbol_attribute attr;
4636 gfc_ref *ref, *ref2;
4643 /* Check INTENT(IN), unless the object is a sub-component of a pointer. */
4644 check_intent_in = 1;
4646 if (gfc_resolve_expr (e) == FAILURE)
4649 if (code->expr && code->expr->expr_type == EXPR_VARIABLE)
4650 sym = code->expr->symtree->n.sym;
4654 /* Make sure the expression is allocatable or a pointer. If it is
4655 pointer, the next-to-last reference must be a pointer. */
4659 if (e->expr_type != EXPR_VARIABLE)
4662 attr = gfc_expr_attr (e);
4663 pointer = attr.pointer;
4664 dimension = attr.dimension;
4668 allocatable = e->symtree->n.sym->attr.allocatable;
4669 pointer = e->symtree->n.sym->attr.pointer;
4670 dimension = e->symtree->n.sym->attr.dimension;
4672 if (sym == e->symtree->n.sym && sym->ts.type != BT_DERIVED)
4674 gfc_error ("The STAT variable '%s' in an ALLOCATE statement must "
4675 "not be allocated in the same statement at %L",
4676 sym->name, &e->where);
4680 for (ref = e->ref; ref; ref2 = ref, ref = ref->next)
4683 check_intent_in = 0;
4688 if (ref->next != NULL)
4693 allocatable = (ref->u.c.component->as != NULL
4694 && ref->u.c.component->as->type == AS_DEFERRED);
4696 pointer = ref->u.c.component->pointer;
4697 dimension = ref->u.c.component->dimension;
4708 if (allocatable == 0 && pointer == 0)
4710 gfc_error ("Expression in ALLOCATE statement at %L must be "
4711 "ALLOCATABLE or a POINTER", &e->where);
4716 && e->symtree->n.sym->attr.intent == INTENT_IN)
4718 gfc_error ("Cannot allocate INTENT(IN) variable '%s' at %L",
4719 e->symtree->n.sym->name, &e->where);
4723 /* Add default initializer for those derived types that need them. */
4724 if (e->ts.type == BT_DERIVED && (init_e = gfc_default_initializer (&e->ts)))
4726 init_st = gfc_get_code ();
4727 init_st->loc = code->loc;
4728 init_st->op = EXEC_INIT_ASSIGN;
4729 init_st->expr = expr_to_initialize (e);
4730 init_st->expr2 = init_e;
4731 init_st->next = code->next;
4732 code->next = init_st;
4735 if (pointer && dimension == 0)
4738 /* Make sure the next-to-last reference node is an array specification. */
4740 if (ref2 == NULL || ref2->type != REF_ARRAY || ref2->u.ar.type == AR_FULL)
4742 gfc_error ("Array specification required in ALLOCATE statement "
4743 "at %L", &e->where);
4747 /* Make sure that the array section reference makes sense in the
4748 context of an ALLOCATE specification. */
4752 for (i = 0; i < ar->dimen; i++)
4754 if (ref2->u.ar.type == AR_ELEMENT)
4757 switch (ar->dimen_type[i])
4763 if (ar->start[i] != NULL
4764 && ar->end[i] != NULL
4765 && ar->stride[i] == NULL)
4768 /* Fall Through... */
4772 gfc_error ("Bad array specification in ALLOCATE statement at %L",
4779 for (a = code->ext.alloc_list; a; a = a->next)
4781 sym = a->expr->symtree->n.sym;
4783 /* TODO - check derived type components. */
4784 if (sym->ts.type == BT_DERIVED)
4787 if ((ar->start[i] != NULL && find_sym_in_expr (sym, ar->start[i]))
4788 || (ar->end[i] != NULL && find_sym_in_expr (sym, ar->end[i])))
4790 gfc_error ("'%s' must not appear an the array specification at "
4791 "%L in the same ALLOCATE statement where it is "
4792 "itself allocated", sym->name, &ar->where);
4802 /************ SELECT CASE resolution subroutines ************/
4804 /* Callback function for our mergesort variant. Determines interval
4805 overlaps for CASEs. Return <0 if op1 < op2, 0 for overlap, >0 for
4806 op1 > op2. Assumes we're not dealing with the default case.
4807 We have op1 = (:L), (K:L) or (K:) and op2 = (:N), (M:N) or (M:).
4808 There are nine situations to check. */
4811 compare_cases (const gfc_case *op1, const gfc_case *op2)
4815 if (op1->low == NULL) /* op1 = (:L) */
4817 /* op2 = (:N), so overlap. */
4819 /* op2 = (M:) or (M:N), L < M */
4820 if (op2->low != NULL
4821 && gfc_compare_expr (op1->high, op2->low) < 0)
4824 else if (op1->high == NULL) /* op1 = (K:) */
4826 /* op2 = (M:), so overlap. */
4828 /* op2 = (:N) or (M:N), K > N */
4829 if (op2->high != NULL
4830 && gfc_compare_expr (op1->low, op2->high) > 0)
4833 else /* op1 = (K:L) */
4835 if (op2->low == NULL) /* op2 = (:N), K > N */
4836 retval = (gfc_compare_expr (op1->low, op2->high) > 0) ? 1 : 0;
4837 else if (op2->high == NULL) /* op2 = (M:), L < M */
4838 retval = (gfc_compare_expr (op1->high, op2->low) < 0) ? -1 : 0;
4839 else /* op2 = (M:N) */
4843 if (gfc_compare_expr (op1->high, op2->low) < 0)
4846 else if (gfc_compare_expr (op1->low, op2->high) > 0)
4855 /* Merge-sort a double linked case list, detecting overlap in the
4856 process. LIST is the head of the double linked case list before it
4857 is sorted. Returns the head of the sorted list if we don't see any
4858 overlap, or NULL otherwise. */
4861 check_case_overlap (gfc_case *list)
4863 gfc_case *p, *q, *e, *tail;
4864 int insize, nmerges, psize, qsize, cmp, overlap_seen;
4866 /* If the passed list was empty, return immediately. */
4873 /* Loop unconditionally. The only exit from this loop is a return
4874 statement, when we've finished sorting the case list. */
4881 /* Count the number of merges we do in this pass. */
4884 /* Loop while there exists a merge to be done. */
4889 /* Count this merge. */
4892 /* Cut the list in two pieces by stepping INSIZE places
4893 forward in the list, starting from P. */
4896 for (i = 0; i < insize; i++)
4905 /* Now we have two lists. Merge them! */
4906 while (psize > 0 || (qsize > 0 && q != NULL))
4908 /* See from which the next case to merge comes from. */
4911 /* P is empty so the next case must come from Q. */
4916 else if (qsize == 0 || q == NULL)
4925 cmp = compare_cases (p, q);
4928 /* The whole case range for P is less than the
4936 /* The whole case range for Q is greater than
4937 the case range for P. */
4944 /* The cases overlap, or they are the same
4945 element in the list. Either way, we must
4946 issue an error and get the next case from P. */
4947 /* FIXME: Sort P and Q by line number. */
4948 gfc_error ("CASE label at %L overlaps with CASE "
4949 "label at %L", &p->where, &q->where);
4957 /* Add the next element to the merged list. */
4966 /* P has now stepped INSIZE places along, and so has Q. So
4967 they're the same. */
4972 /* If we have done only one merge or none at all, we've
4973 finished sorting the cases. */
4982 /* Otherwise repeat, merging lists twice the size. */
4988 /* Check to see if an expression is suitable for use in a CASE statement.
4989 Makes sure that all case expressions are scalar constants of the same
4990 type. Return FAILURE if anything is wrong. */
4993 validate_case_label_expr (gfc_expr *e, gfc_expr *case_expr)
4995 if (e == NULL) return SUCCESS;
4997 if (e->ts.type != case_expr->ts.type)
4999 gfc_error ("Expression in CASE statement at %L must be of type %s",
5000 &e->where, gfc_basic_typename (case_expr->ts.type));
5004 /* C805 (R808) For a given case-construct, each case-value shall be of
5005 the same type as case-expr. For character type, length differences
5006 are allowed, but the kind type parameters shall be the same. */
5008 if (case_expr->ts.type == BT_CHARACTER && e->ts.kind != case_expr->ts.kind)
5010 gfc_error("Expression in CASE statement at %L must be kind %d",
5011 &e->where, case_expr->ts.kind);
5015 /* Convert the case value kind to that of case expression kind, if needed.
5016 FIXME: Should a warning be issued? */
5017 if (e->ts.kind != case_expr->ts.kind)
5018 gfc_convert_type_warn (e, &case_expr->ts, 2, 0);
5022 gfc_error ("Expression in CASE statement at %L must be scalar",
5031 /* Given a completely parsed select statement, we:
5033 - Validate all expressions and code within the SELECT.
5034 - Make sure that the selection expression is not of the wrong type.
5035 - Make sure that no case ranges overlap.
5036 - Eliminate unreachable cases and unreachable code resulting from
5037 removing case labels.
5039 The standard does allow unreachable cases, e.g. CASE (5:3). But
5040 they are a hassle for code generation, and to prevent that, we just
5041 cut them out here. This is not necessary for overlapping cases
5042 because they are illegal and we never even try to generate code.
5044 We have the additional caveat that a SELECT construct could have
5045 been a computed GOTO in the source code. Fortunately we can fairly
5046 easily work around that here: The case_expr for a "real" SELECT CASE
5047 is in code->expr1, but for a computed GOTO it is in code->expr2. All
5048 we have to do is make sure that the case_expr is a scalar integer
5052 resolve_select (gfc_code *code)
5055 gfc_expr *case_expr;
5056 gfc_case *cp, *default_case, *tail, *head;
5057 int seen_unreachable;
5063 if (code->expr == NULL)
5065 /* This was actually a computed GOTO statement. */
5066 case_expr = code->expr2;
5067 if (case_expr->ts.type != BT_INTEGER|| case_expr->rank != 0)
5068 gfc_error ("Selection expression in computed GOTO statement "
5069 "at %L must be a scalar integer expression",
5072 /* Further checking is not necessary because this SELECT was built
5073 by the compiler, so it should always be OK. Just move the
5074 case_expr from expr2 to expr so that we can handle computed
5075 GOTOs as normal SELECTs from here on. */
5076 code->expr = code->expr2;
5081 case_expr = code->expr;
5083 type = case_expr->ts.type;
5084 if (type != BT_LOGICAL && type != BT_INTEGER && type != BT_CHARACTER)
5086 gfc_error ("Argument of SELECT statement at %L cannot be %s",
5087 &case_expr->where, gfc_typename (&case_expr->ts));
5089 /* Punt. Going on here just produce more garbage error messages. */
5093 if (case_expr->rank != 0)
5095 gfc_error ("Argument of SELECT statement at %L must be a scalar "
5096 "expression", &case_expr->where);
5102 /* PR 19168 has a long discussion concerning a mismatch of the kinds
5103 of the SELECT CASE expression and its CASE values. Walk the lists
5104 of case values, and if we find a mismatch, promote case_expr to
5105 the appropriate kind. */
5107 if (type == BT_LOGICAL || type == BT_INTEGER)
5109 for (body = code->block; body; body = body->block)
5111 /* Walk the case label list. */
5112 for (cp = body->ext.case_list; cp; cp = cp->next)
5114 /* Intercept the DEFAULT case. It does not have a kind. */
5115 if (cp->low == NULL && cp->high == NULL)
5118 /* Unreachable case ranges are discarded, so ignore. */
5119 if (cp->low != NULL && cp->high != NULL
5120 && cp->low != cp->high
5121 && gfc_compare_expr (cp->low, cp->high) > 0)
5124 /* FIXME: Should a warning be issued? */
5126 && case_expr->ts.kind != gfc_kind_max(case_expr, cp->low))
5127 gfc_convert_type_warn (case_expr, &cp->low->ts, 2, 0);
5129 if (cp->high != NULL
5130 && case_expr->ts.kind != gfc_kind_max(case_expr, cp->high))
5131 gfc_convert_type_warn (case_expr, &cp->high->ts, 2, 0);
5136 /* Assume there is no DEFAULT case. */
5137 default_case = NULL;
5142 for (body = code->block; body; body = body->block)
5144 /* Assume the CASE list is OK, and all CASE labels can be matched. */
5146 seen_unreachable = 0;
5148 /* Walk the case label list, making sure that all case labels
5150 for (cp = body->ext.case_list; cp; cp = cp->next)
5152 /* Count the number of cases in the whole construct. */
5155 /* Intercept the DEFAULT case. */
5156 if (cp->low == NULL && cp->high == NULL)
5158 if (default_case != NULL)
5160 gfc_error ("The DEFAULT CASE at %L cannot be followed "
5161 "by a second DEFAULT CASE at %L",
5162 &default_case->where, &cp->where);
5173 /* Deal with single value cases and case ranges. Errors are
5174 issued from the validation function. */
5175 if(validate_case_label_expr (cp->low, case_expr) != SUCCESS
5176 || validate_case_label_expr (cp->high, case_expr) != SUCCESS)
5182 if (type == BT_LOGICAL
5183 && ((cp->low == NULL || cp->high == NULL)
5184 || cp->low != cp->high))
5186 gfc_error ("Logical range in CASE statement at %L is not "
5187 "allowed", &cp->low->where);
5192 if (type == BT_LOGICAL && cp->low->expr_type == EXPR_CONSTANT)
5195 value = cp->low->value.logical == 0 ? 2 : 1;
5196 if (value & seen_logical)
5198 gfc_error ("constant logical value in CASE statement "
5199 "is repeated at %L",
5204 seen_logical |= value;
5207 if (cp->low != NULL && cp->high != NULL
5208 && cp->low != cp->high
5209 && gfc_compare_expr (cp->low, cp->high) > 0)
5211 if (gfc_option.warn_surprising)
5212 gfc_warning ("Range specification at %L can never "
5213 "be matched", &cp->where);
5215 cp->unreachable = 1;
5216 seen_unreachable = 1;
5220 /* If the case range can be matched, it can also overlap with
5221 other cases. To make sure it does not, we put it in a
5222 double linked list here. We sort that with a merge sort
5223 later on to detect any overlapping cases. */
5227 head->right = head->left = NULL;
5232 tail->right->left = tail;
5239 /* It there was a failure in the previous case label, give up
5240 for this case label list. Continue with the next block. */
5244 /* See if any case labels that are unreachable have been seen.
5245 If so, we eliminate them. This is a bit of a kludge because
5246 the case lists for a single case statement (label) is a
5247 single forward linked lists. */
5248 if (seen_unreachable)
5250 /* Advance until the first case in the list is reachable. */
5251 while (body->ext.case_list != NULL
5252 && body->ext.case_list->unreachable)
5254 gfc_case *n = body->ext.case_list;
5255 body->ext.case_list = body->ext.case_list->next;
5257 gfc_free_case_list (n);
5260 /* Strip all other unreachable cases. */
5261 if (body->ext.case_list)
5263 for (cp = body->ext.case_list; cp->next; cp = cp->next)
5265 if (cp->next->unreachable)
5267 gfc_case *n = cp->next;
5268 cp->next = cp->next->next;
5270 gfc_free_case_list (n);
5277 /* See if there were overlapping cases. If the check returns NULL,
5278 there was overlap. In that case we don't do anything. If head
5279 is non-NULL, we prepend the DEFAULT case. The sorted list can
5280 then used during code generation for SELECT CASE constructs with
5281 a case expression of a CHARACTER type. */
5284 head = check_case_overlap (head);
5286 /* Prepend the default_case if it is there. */
5287 if (head != NULL && default_case)
5289 default_case->left = NULL;
5290 default_case->right = head;
5291 head->left = default_case;
5295 /* Eliminate dead blocks that may be the result if we've seen
5296 unreachable case labels for a block. */
5297 for (body = code; body && body->block; body = body->block)
5299 if (body->block->ext.case_list == NULL)
5301 /* Cut the unreachable block from the code chain. */
5302 gfc_code *c = body->block;
5303 body->block = c->block;
5305 /* Kill the dead block, but not the blocks below it. */
5307 gfc_free_statements (c);
5311 /* More than two cases is legal but insane for logical selects.
5312 Issue a warning for it. */
5313 if (gfc_option.warn_surprising && type == BT_LOGICAL
5315 gfc_warning ("Logical SELECT CASE block at %L has more that two cases",
5320 /* Resolve a transfer statement. This is making sure that:
5321 -- a derived type being transferred has only non-pointer components
5322 -- a derived type being transferred doesn't have private components, unless
5323 it's being transferred from the module where the type was defined
5324 -- we're not trying to transfer a whole assumed size array. */
5327 resolve_transfer (gfc_code *code)
5336 if (exp->expr_type != EXPR_VARIABLE && exp->expr_type != EXPR_FUNCTION)
5339 sym = exp->symtree->n.sym;
5342 /* Go to actual component transferred. */
5343 for (ref = code->expr->ref; ref; ref = ref->next)
5344 if (ref->type == REF_COMPONENT)
5345 ts = &ref->u.c.component->ts;
5347 if (ts->type == BT_DERIVED)
5349 /* Check that transferred derived type doesn't contain POINTER
5351 if (ts->derived->attr.pointer_comp)
5353 gfc_error ("Data transfer element at %L cannot have "
5354 "POINTER components", &code->loc);
5358 if (ts->derived->attr.alloc_comp)
5360 gfc_error ("Data transfer element at %L cannot have "
5361 "ALLOCATABLE components", &code->loc);
5365 if (derived_inaccessible (ts->derived))
5367 gfc_error ("Data transfer element at %L cannot have "
5368 "PRIVATE components",&code->loc);
5373 if (sym->as != NULL && sym->as->type == AS_ASSUMED_SIZE
5374 && exp->ref->type == REF_ARRAY && exp->ref->u.ar.type == AR_FULL)
5376 gfc_error ("Data transfer element at %L cannot be a full reference to "
5377 "an assumed-size array", &code->loc);
5383 /*********** Toplevel code resolution subroutines ***********/
5385 /* Find the set of labels that are reachable from this block. We also
5386 record the last statement in each block so that we don't have to do
5387 a linear search to find the END DO statements of the blocks. */
5390 reachable_labels (gfc_code *block)
5397 cs_base->reachable_labels = bitmap_obstack_alloc (&labels_obstack);
5399 /* Collect labels in this block. */
5400 for (c = block; c; c = c->next)
5403 bitmap_set_bit (cs_base->reachable_labels, c->here->value);
5405 if (!c->next && cs_base->prev)
5406 cs_base->prev->tail = c;
5409 /* Merge with labels from parent block. */
5412 gcc_assert (cs_base->prev->reachable_labels);
5413 bitmap_ior_into (cs_base->reachable_labels,
5414 cs_base->prev->reachable_labels);
5418 /* Given a branch to a label and a namespace, if the branch is conforming.
5419 The code node describes where the branch is located. */
5422 resolve_branch (gfc_st_label *label, gfc_code *code)
5429 /* Step one: is this a valid branching target? */
5431 if (label->defined == ST_LABEL_UNKNOWN)
5433 gfc_error ("Label %d referenced at %L is never defined", label->value,
5438 if (label->defined != ST_LABEL_TARGET)
5440 gfc_error ("Statement at %L is not a valid branch target statement "
5441 "for the branch statement at %L", &label->where, &code->loc);
5445 /* Step two: make sure this branch is not a branch to itself ;-) */
5447 if (code->here == label)
5449 gfc_warning ("Branch at %L causes an infinite loop", &code->loc);
5453 /* Step three: See if the label is in the same block as the
5454 branching statement. The hard work has been done by setting up
5455 the bitmap reachable_labels. */
5457 if (!bitmap_bit_p (cs_base->reachable_labels, label->value))
5459 /* The label is not in an enclosing block, so illegal. This was
5460 allowed in Fortran 66, so we allow it as extension. No
5461 further checks are necessary in this case. */
5462 gfc_notify_std (GFC_STD_LEGACY, "Label at %L is not in the same block "
5463 "as the GOTO statement at %L", &label->where,
5468 /* Step four: Make sure that the branching target is legal if
5469 the statement is an END {SELECT,IF}. */
5471 for (stack = cs_base; stack; stack = stack->prev)
5472 if (stack->current->next && stack->current->next->here == label)
5475 if (stack && stack->current->next->op == EXEC_NOP)
5477 gfc_notify_std (GFC_STD_F95_DEL, "Deleted feature: GOTO at %L jumps to "
5478 "END of construct at %L", &code->loc,
5479 &stack->current->next->loc);
5480 return; /* We know this is not an END DO. */
5483 /* Step five: Make sure that we're not jumping to the end of a DO
5484 loop from within the loop. */
5486 for (stack = cs_base; stack; stack = stack->prev)
5487 if ((stack->current->op == EXEC_DO
5488 || stack->current->op == EXEC_DO_WHILE)
5489 && stack->tail->here == label && stack->tail->op == EXEC_NOP)
5491 gfc_notify_std (GFC_STD_F95_DEL, "Deleted feature: GOTO at %L jumps "
5492 "to END of construct at %L", &code->loc,
5500 /* Check whether EXPR1 has the same shape as EXPR2. */
5503 resolve_where_shape (gfc_expr *expr1, gfc_expr *expr2)
5505 mpz_t shape[GFC_MAX_DIMENSIONS];
5506 mpz_t shape2[GFC_MAX_DIMENSIONS];
5507 try result = FAILURE;
5510 /* Compare the rank. */
5511 if (expr1->rank != expr2->rank)
5514 /* Compare the size of each dimension. */
5515 for (i=0; i<expr1->rank; i++)
5517 if (gfc_array_dimen_size (expr1, i, &shape[i]) == FAILURE)
5520 if (gfc_array_dimen_size (expr2, i, &shape2[i]) == FAILURE)
5523 if (mpz_cmp (shape[i], shape2[i]))
5527 /* When either of the two expression is an assumed size array, we
5528 ignore the comparison of dimension sizes. */
5533 for (i--; i >= 0; i--)
5535 mpz_clear (shape[i]);
5536 mpz_clear (shape2[i]);
5542 /* Check whether a WHERE assignment target or a WHERE mask expression
5543 has the same shape as the outmost WHERE mask expression. */
5546 resolve_where (gfc_code *code, gfc_expr *mask)
5552 cblock = code->block;
5554 /* Store the first WHERE mask-expr of the WHERE statement or construct.
5555 In case of nested WHERE, only the outmost one is stored. */
5556 if (mask == NULL) /* outmost WHERE */
5558 else /* inner WHERE */
5565 /* Check if the mask-expr has a consistent shape with the
5566 outmost WHERE mask-expr. */
5567 if (resolve_where_shape (cblock->expr, e) == FAILURE)
5568 gfc_error ("WHERE mask at %L has inconsistent shape",
5569 &cblock->expr->where);
5572 /* the assignment statement of a WHERE statement, or the first
5573 statement in where-body-construct of a WHERE construct */
5574 cnext = cblock->next;
5579 /* WHERE assignment statement */
5582 /* Check shape consistent for WHERE assignment target. */
5583 if (e && resolve_where_shape (cnext->expr, e) == FAILURE)
5584 gfc_error ("WHERE assignment target at %L has "
5585 "inconsistent shape", &cnext->expr->where);
5589 case EXEC_ASSIGN_CALL:
5590 resolve_call (cnext);
5593 /* WHERE or WHERE construct is part of a where-body-construct */
5595 resolve_where (cnext, e);
5599 gfc_error ("Unsupported statement inside WHERE at %L",
5602 /* the next statement within the same where-body-construct */
5603 cnext = cnext->next;
5605 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
5606 cblock = cblock->block;
5611 /* Resolve assignment in FORALL construct.
5612 NVAR is the number of FORALL index variables, and VAR_EXPR records the
5613 FORALL index variables. */
5616 gfc_resolve_assign_in_forall (gfc_code *code, int nvar, gfc_expr **var_expr)
5620 for (n = 0; n < nvar; n++)
5622 gfc_symbol *forall_index;
5624 forall_index = var_expr[n]->symtree->n.sym;
5626 /* Check whether the assignment target is one of the FORALL index
5628 if ((code->expr->expr_type == EXPR_VARIABLE)
5629 && (code->expr->symtree->n.sym == forall_index))
5630 gfc_error ("Assignment to a FORALL index variable at %L",
5631 &code->expr->where);
5634 /* If one of the FORALL index variables doesn't appear in the
5635 assignment target, then there will be a many-to-one
5637 if (find_forall_index (code->expr, forall_index, 0) == FAILURE)
5638 gfc_error ("The FORALL with index '%s' cause more than one "
5639 "assignment to this object at %L",
5640 var_expr[n]->symtree->name, &code->expr->where);
5646 /* Resolve WHERE statement in FORALL construct. */
5649 gfc_resolve_where_code_in_forall (gfc_code *code, int nvar,
5650 gfc_expr **var_expr)
5655 cblock = code->block;
5658 /* the assignment statement of a WHERE statement, or the first
5659 statement in where-body-construct of a WHERE construct */
5660 cnext = cblock->next;
5665 /* WHERE assignment statement */
5667 gfc_resolve_assign_in_forall (cnext, nvar, var_expr);
5670 /* WHERE operator assignment statement */
5671 case EXEC_ASSIGN_CALL:
5672 resolve_call (cnext);
5675 /* WHERE or WHERE construct is part of a where-body-construct */
5677 gfc_resolve_where_code_in_forall (cnext, nvar, var_expr);
5681 gfc_error ("Unsupported statement inside WHERE at %L",
5684 /* the next statement within the same where-body-construct */
5685 cnext = cnext->next;
5687 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
5688 cblock = cblock->block;
5693 /* Traverse the FORALL body to check whether the following errors exist:
5694 1. For assignment, check if a many-to-one assignment happens.
5695 2. For WHERE statement, check the WHERE body to see if there is any
5696 many-to-one assignment. */
5699 gfc_resolve_forall_body (gfc_code *code, int nvar, gfc_expr **var_expr)
5703 c = code->block->next;
5709 case EXEC_POINTER_ASSIGN:
5710 gfc_resolve_assign_in_forall (c, nvar, var_expr);
5713 case EXEC_ASSIGN_CALL:
5717 /* Because the gfc_resolve_blocks() will handle the nested FORALL,
5718 there is no need to handle it here. */
5722 gfc_resolve_where_code_in_forall(c, nvar, var_expr);
5727 /* The next statement in the FORALL body. */
5733 /* Given a FORALL construct, first resolve the FORALL iterator, then call
5734 gfc_resolve_forall_body to resolve the FORALL body. */
5737 gfc_resolve_forall (gfc_code *code, gfc_namespace *ns, int forall_save)
5739 static gfc_expr **var_expr;
5740 static int total_var = 0;
5741 static int nvar = 0;
5742 gfc_forall_iterator *fa;
5746 /* Start to resolve a FORALL construct */
5747 if (forall_save == 0)
5749 /* Count the total number of FORALL index in the nested FORALL
5750 construct in order to allocate the VAR_EXPR with proper size. */
5752 while ((next != NULL) && (next->op == EXEC_FORALL))
5754 for (fa = next->ext.forall_iterator; fa; fa = fa->next)
5756 next = next->block->next;
5759 /* Allocate VAR_EXPR with NUMBER_OF_FORALL_INDEX elements. */
5760 var_expr = (gfc_expr **) gfc_getmem (total_var * sizeof (gfc_expr *));
5763 /* The information about FORALL iterator, including FORALL index start, end
5764 and stride. The FORALL index can not appear in start, end or stride. */
5765 for (fa = code->ext.forall_iterator; fa; fa = fa->next)
5767 /* Check if any outer FORALL index name is the same as the current
5769 for (i = 0; i < nvar; i++)
5771 if (fa->var->symtree->n.sym == var_expr[i]->symtree->n.sym)
5773 gfc_error ("An outer FORALL construct already has an index "
5774 "with this name %L", &fa->var->where);
5778 /* Record the current FORALL index. */
5779 var_expr[nvar] = gfc_copy_expr (fa->var);
5784 /* Resolve the FORALL body. */
5785 gfc_resolve_forall_body (code, nvar, var_expr);
5787 /* May call gfc_resolve_forall to resolve the inner FORALL loop. */
5788 gfc_resolve_blocks (code->block, ns);
5790 /* Free VAR_EXPR after the whole FORALL construct resolved. */
5791 for (i = 0; i < total_var; i++)
5792 gfc_free_expr (var_expr[i]);
5794 /* Reset the counters. */
5800 /* Resolve lists of blocks found in IF, SELECT CASE, WHERE, FORALL ,GOTO and
5803 static void resolve_code (gfc_code *, gfc_namespace *);
5806 gfc_resolve_blocks (gfc_code *b, gfc_namespace *ns)
5810 for (; b; b = b->block)
5812 t = gfc_resolve_expr (b->expr);
5813 if (gfc_resolve_expr (b->expr2) == FAILURE)
5819 if (t == SUCCESS && b->expr != NULL
5820 && (b->expr->ts.type != BT_LOGICAL || b->expr->rank != 0))
5821 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
5828 && (b->expr->ts.type != BT_LOGICAL || b->expr->rank == 0))
5829 gfc_error ("WHERE/ELSEWHERE clause at %L requires a LOGICAL array",
5834 resolve_branch (b->label, b);
5846 case EXEC_OMP_ATOMIC:
5847 case EXEC_OMP_CRITICAL:
5849 case EXEC_OMP_MASTER:
5850 case EXEC_OMP_ORDERED:
5851 case EXEC_OMP_PARALLEL:
5852 case EXEC_OMP_PARALLEL_DO:
5853 case EXEC_OMP_PARALLEL_SECTIONS:
5854 case EXEC_OMP_PARALLEL_WORKSHARE:
5855 case EXEC_OMP_SECTIONS:
5856 case EXEC_OMP_SINGLE:
5857 case EXEC_OMP_WORKSHARE:
5861 gfc_internal_error ("resolve_block(): Bad block type");
5864 resolve_code (b->next, ns);
5869 /* Does everything to resolve an ordinary assignment. Returns true
5870 if this is an interface asignment. */
5872 resolve_ordinary_assign (gfc_code *code, gfc_namespace *ns)
5883 if (gfc_extend_assign (code, ns) == SUCCESS)
5885 lhs = code->ext.actual->expr;
5886 rhs = code->ext.actual->next->expr;
5887 if (gfc_pure (NULL) && !gfc_pure (code->symtree->n.sym))
5889 gfc_error ("Subroutine '%s' called instead of assignment at "
5890 "%L must be PURE", code->symtree->n.sym->name,
5895 /* Make a temporary rhs when there is a default initializer
5896 and rhs is the same symbol as the lhs. */
5897 if (rhs->expr_type == EXPR_VARIABLE
5898 && rhs->symtree->n.sym->ts.type == BT_DERIVED
5899 && has_default_initializer (rhs->symtree->n.sym->ts.derived)
5900 && (lhs->symtree->n.sym == rhs->symtree->n.sym))
5901 code->ext.actual->next->expr = gfc_get_parentheses (rhs);
5909 if (lhs->ts.type == BT_CHARACTER
5910 && gfc_option.warn_character_truncation)
5912 if (lhs->ts.cl != NULL
5913 && lhs->ts.cl->length != NULL
5914 && lhs->ts.cl->length->expr_type == EXPR_CONSTANT)
5915 llen = mpz_get_si (lhs->ts.cl->length->value.integer);
5917 if (rhs->expr_type == EXPR_CONSTANT)
5918 rlen = rhs->value.character.length;
5920 else if (rhs->ts.cl != NULL
5921 && rhs->ts.cl->length != NULL
5922 && rhs->ts.cl->length->expr_type == EXPR_CONSTANT)
5923 rlen = mpz_get_si (rhs->ts.cl->length->value.integer);
5925 if (rlen && llen && rlen > llen)
5926 gfc_warning_now ("CHARACTER expression will be truncated "
5927 "in assignment (%d/%d) at %L",
5928 llen, rlen, &code->loc);
5931 /* Ensure that a vector index expression for the lvalue is evaluated
5935 for (ref = lhs->ref; ref; ref= ref->next)
5936 if (ref->type == REF_ARRAY)
5938 for (n = 0; n < ref->u.ar.dimen; n++)
5939 if (ref->u.ar.dimen_type[n] == DIMEN_VECTOR)
5941 = gfc_get_parentheses (ref->u.ar.start[n]);
5945 if (gfc_pure (NULL))
5947 if (gfc_impure_variable (lhs->symtree->n.sym))
5949 gfc_error ("Cannot assign to variable '%s' in PURE "
5951 lhs->symtree->n.sym->name,
5956 if (lhs->ts.type == BT_DERIVED
5957 && lhs->expr_type == EXPR_VARIABLE
5958 && lhs->ts.derived->attr.pointer_comp
5959 && gfc_impure_variable (rhs->symtree->n.sym))
5961 gfc_error ("The impure variable at %L is assigned to "
5962 "a derived type variable with a POINTER "
5963 "component in a PURE procedure (12.6)",
5969 gfc_check_assign (lhs, rhs, 1);
5973 /* Given a block of code, recursively resolve everything pointed to by this
5977 resolve_code (gfc_code *code, gfc_namespace *ns)
5979 int omp_workshare_save;
5985 frame.prev = cs_base;
5989 reachable_labels (code);
5991 for (; code; code = code->next)
5993 frame.current = code;
5994 forall_save = forall_flag;
5996 if (code->op == EXEC_FORALL)
5999 gfc_resolve_forall (code, ns, forall_save);
6002 else if (code->block)
6004 omp_workshare_save = -1;
6007 case EXEC_OMP_PARALLEL_WORKSHARE:
6008 omp_workshare_save = omp_workshare_flag;
6009 omp_workshare_flag = 1;
6010 gfc_resolve_omp_parallel_blocks (code, ns);
6012 case EXEC_OMP_PARALLEL:
6013 case EXEC_OMP_PARALLEL_DO:
6014 case EXEC_OMP_PARALLEL_SECTIONS:
6015 omp_workshare_save = omp_workshare_flag;
6016 omp_workshare_flag = 0;
6017 gfc_resolve_omp_parallel_blocks (code, ns);
6020 gfc_resolve_omp_do_blocks (code, ns);
6022 case EXEC_OMP_WORKSHARE:
6023 omp_workshare_save = omp_workshare_flag;
6024 omp_workshare_flag = 1;
6027 gfc_resolve_blocks (code->block, ns);
6031 if (omp_workshare_save != -1)
6032 omp_workshare_flag = omp_workshare_save;
6035 t = gfc_resolve_expr (code->expr);
6036 forall_flag = forall_save;
6038 if (gfc_resolve_expr (code->expr2) == FAILURE)
6053 /* Keep track of which entry we are up to. */
6054 current_entry_id = code->ext.entry->id;
6058 resolve_where (code, NULL);
6062 if (code->expr != NULL)
6064 if (code->expr->ts.type != BT_INTEGER)
6065 gfc_error ("ASSIGNED GOTO statement at %L requires an "
6066 "INTEGER variable", &code->expr->where);
6067 else if (code->expr->symtree->n.sym->attr.assign != 1)
6068 gfc_error ("Variable '%s' has not been assigned a target "
6069 "label at %L", code->expr->symtree->n.sym->name,
6070 &code->expr->where);
6073 resolve_branch (code->label, code);
6077 if (code->expr != NULL
6078 && (code->expr->ts.type != BT_INTEGER || code->expr->rank))
6079 gfc_error ("Alternate RETURN statement at %L requires a SCALAR-"
6080 "INTEGER return specifier", &code->expr->where);
6083 case EXEC_INIT_ASSIGN:
6090 if (resolve_ordinary_assign (code, ns))
6095 case EXEC_LABEL_ASSIGN:
6096 if (code->label->defined == ST_LABEL_UNKNOWN)
6097 gfc_error ("Label %d referenced at %L is never defined",
6098 code->label->value, &code->label->where);
6100 && (code->expr->expr_type != EXPR_VARIABLE
6101 || code->expr->symtree->n.sym->ts.type != BT_INTEGER
6102 || code->expr->symtree->n.sym->ts.kind
6103 != gfc_default_integer_kind
6104 || code->expr->symtree->n.sym->as != NULL))
6105 gfc_error ("ASSIGN statement at %L requires a scalar "
6106 "default INTEGER variable", &code->expr->where);
6109 case EXEC_POINTER_ASSIGN:
6113 gfc_check_pointer_assign (code->expr, code->expr2);
6116 case EXEC_ARITHMETIC_IF:
6118 && code->expr->ts.type != BT_INTEGER
6119 && code->expr->ts.type != BT_REAL)
6120 gfc_error ("Arithmetic IF statement at %L requires a numeric "
6121 "expression", &code->expr->where);
6123 resolve_branch (code->label, code);
6124 resolve_branch (code->label2, code);
6125 resolve_branch (code->label3, code);
6129 if (t == SUCCESS && code->expr != NULL
6130 && (code->expr->ts.type != BT_LOGICAL
6131 || code->expr->rank != 0))
6132 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
6133 &code->expr->where);
6138 resolve_call (code);
6142 /* Select is complicated. Also, a SELECT construct could be
6143 a transformed computed GOTO. */
6144 resolve_select (code);
6148 if (code->ext.iterator != NULL)
6150 gfc_iterator *iter = code->ext.iterator;
6151 if (gfc_resolve_iterator (iter, true) != FAILURE)
6152 gfc_resolve_do_iterator (code, iter->var->symtree->n.sym);
6157 if (code->expr == NULL)
6158 gfc_internal_error ("resolve_code(): No expression on DO WHILE");
6160 && (code->expr->rank != 0
6161 || code->expr->ts.type != BT_LOGICAL))
6162 gfc_error ("Exit condition of DO WHILE loop at %L must be "
6163 "a scalar LOGICAL expression", &code->expr->where);
6167 if (t == SUCCESS && code->expr != NULL
6168 && code->expr->ts.type != BT_INTEGER)
6169 gfc_error ("STAT tag in ALLOCATE statement at %L must be "
6170 "of type INTEGER", &code->expr->where);
6172 for (a = code->ext.alloc_list; a; a = a->next)
6173 resolve_allocate_expr (a->expr, code);
6177 case EXEC_DEALLOCATE:
6178 if (t == SUCCESS && code->expr != NULL
6179 && code->expr->ts.type != BT_INTEGER)
6181 ("STAT tag in DEALLOCATE statement at %L must be of type "
6182 "INTEGER", &code->expr->where);
6184 for (a = code->ext.alloc_list; a; a = a->next)
6185 resolve_deallocate_expr (a->expr);
6190 if (gfc_resolve_open (code->ext.open) == FAILURE)
6193 resolve_branch (code->ext.open->err, code);
6197 if (gfc_resolve_close (code->ext.close) == FAILURE)
6200 resolve_branch (code->ext.close->err, code);
6203 case EXEC_BACKSPACE:
6207 if (gfc_resolve_filepos (code->ext.filepos) == FAILURE)
6210 resolve_branch (code->ext.filepos->err, code);
6214 if (gfc_resolve_inquire (code->ext.inquire) == FAILURE)
6217 resolve_branch (code->ext.inquire->err, code);
6221 gcc_assert (code->ext.inquire != NULL);
6222 if (gfc_resolve_inquire (code->ext.inquire) == FAILURE)
6225 resolve_branch (code->ext.inquire->err, code);
6230 if (gfc_resolve_dt (code->ext.dt) == FAILURE)
6233 resolve_branch (code->ext.dt->err, code);
6234 resolve_branch (code->ext.dt->end, code);
6235 resolve_branch (code->ext.dt->eor, code);
6239 resolve_transfer (code);
6243 resolve_forall_iterators (code->ext.forall_iterator);
6245 if (code->expr != NULL && code->expr->ts.type != BT_LOGICAL)
6246 gfc_error ("FORALL mask clause at %L requires a LOGICAL "
6247 "expression", &code->expr->where);
6250 case EXEC_OMP_ATOMIC:
6251 case EXEC_OMP_BARRIER:
6252 case EXEC_OMP_CRITICAL:
6253 case EXEC_OMP_FLUSH:
6255 case EXEC_OMP_MASTER:
6256 case EXEC_OMP_ORDERED:
6257 case EXEC_OMP_SECTIONS:
6258 case EXEC_OMP_SINGLE:
6259 case EXEC_OMP_WORKSHARE:
6260 gfc_resolve_omp_directive (code, ns);
6263 case EXEC_OMP_PARALLEL:
6264 case EXEC_OMP_PARALLEL_DO:
6265 case EXEC_OMP_PARALLEL_SECTIONS:
6266 case EXEC_OMP_PARALLEL_WORKSHARE:
6267 omp_workshare_save = omp_workshare_flag;
6268 omp_workshare_flag = 0;
6269 gfc_resolve_omp_directive (code, ns);
6270 omp_workshare_flag = omp_workshare_save;
6274 gfc_internal_error ("resolve_code(): Bad statement code");
6278 cs_base = frame.prev;
6282 /* Resolve initial values and make sure they are compatible with
6286 resolve_values (gfc_symbol *sym)
6288 if (sym->value == NULL)
6291 if (gfc_resolve_expr (sym->value) == FAILURE)
6294 gfc_check_assign_symbol (sym, sym->value);
6298 /* Verify the binding labels for common blocks that are BIND(C). The label
6299 for a BIND(C) common block must be identical in all scoping units in which
6300 the common block is declared. Further, the binding label can not collide
6301 with any other global entity in the program. */
6304 resolve_bind_c_comms (gfc_symtree *comm_block_tree)
6306 if (comm_block_tree->n.common->is_bind_c == 1)
6308 gfc_gsymbol *binding_label_gsym;
6309 gfc_gsymbol *comm_name_gsym;
6311 /* See if a global symbol exists by the common block's name. It may
6312 be NULL if the common block is use-associated. */
6313 comm_name_gsym = gfc_find_gsymbol (gfc_gsym_root,
6314 comm_block_tree->n.common->name);
6315 if (comm_name_gsym != NULL && comm_name_gsym->type != GSYM_COMMON)
6316 gfc_error ("Binding label '%s' for common block '%s' at %L collides "
6317 "with the global entity '%s' at %L",
6318 comm_block_tree->n.common->binding_label,
6319 comm_block_tree->n.common->name,
6320 &(comm_block_tree->n.common->where),
6321 comm_name_gsym->name, &(comm_name_gsym->where));
6322 else if (comm_name_gsym != NULL
6323 && strcmp (comm_name_gsym->name,
6324 comm_block_tree->n.common->name) == 0)
6326 /* TODO: Need to make sure the fields of gfc_gsymbol are initialized
6328 if (comm_name_gsym->binding_label == NULL)
6329 /* No binding label for common block stored yet; save this one. */
6330 comm_name_gsym->binding_label =
6331 comm_block_tree->n.common->binding_label;
6333 if (strcmp (comm_name_gsym->binding_label,
6334 comm_block_tree->n.common->binding_label) != 0)
6336 /* Common block names match but binding labels do not. */
6337 gfc_error ("Binding label '%s' for common block '%s' at %L "
6338 "does not match the binding label '%s' for common "
6340 comm_block_tree->n.common->binding_label,
6341 comm_block_tree->n.common->name,
6342 &(comm_block_tree->n.common->where),
6343 comm_name_gsym->binding_label,
6344 comm_name_gsym->name,
6345 &(comm_name_gsym->where));
6350 /* There is no binding label (NAME="") so we have nothing further to
6351 check and nothing to add as a global symbol for the label. */
6352 if (comm_block_tree->n.common->binding_label[0] == '\0' )
6355 binding_label_gsym =
6356 gfc_find_gsymbol (gfc_gsym_root,
6357 comm_block_tree->n.common->binding_label);
6358 if (binding_label_gsym == NULL)
6360 /* Need to make a global symbol for the binding label to prevent
6361 it from colliding with another. */
6362 binding_label_gsym =
6363 gfc_get_gsymbol (comm_block_tree->n.common->binding_label);
6364 binding_label_gsym->sym_name = comm_block_tree->n.common->name;
6365 binding_label_gsym->type = GSYM_COMMON;
6369 /* If comm_name_gsym is NULL, the name common block is use
6370 associated and the name could be colliding. */
6371 if (binding_label_gsym->type != GSYM_COMMON)
6372 gfc_error ("Binding label '%s' for common block '%s' at %L "
6373 "collides with the global entity '%s' at %L",
6374 comm_block_tree->n.common->binding_label,
6375 comm_block_tree->n.common->name,
6376 &(comm_block_tree->n.common->where),
6377 binding_label_gsym->name,
6378 &(binding_label_gsym->where));
6379 else if (comm_name_gsym != NULL
6380 && (strcmp (binding_label_gsym->name,
6381 comm_name_gsym->binding_label) != 0)
6382 && (strcmp (binding_label_gsym->sym_name,
6383 comm_name_gsym->name) != 0))
6384 gfc_error ("Binding label '%s' for common block '%s' at %L "
6385 "collides with global entity '%s' at %L",
6386 binding_label_gsym->name, binding_label_gsym->sym_name,
6387 &(comm_block_tree->n.common->where),
6388 comm_name_gsym->name, &(comm_name_gsym->where));
6396 /* Verify any BIND(C) derived types in the namespace so we can report errors
6397 for them once, rather than for each variable declared of that type. */
6400 resolve_bind_c_derived_types (gfc_symbol *derived_sym)
6402 if (derived_sym != NULL && derived_sym->attr.flavor == FL_DERIVED
6403 && derived_sym->attr.is_bind_c == 1)
6404 verify_bind_c_derived_type (derived_sym);
6410 /* Verify that any binding labels used in a given namespace do not collide
6411 with the names or binding labels of any global symbols. */
6414 gfc_verify_binding_labels (gfc_symbol *sym)
6418 if (sym != NULL && sym->attr.is_bind_c && sym->attr.is_iso_c == 0
6419 && sym->attr.flavor != FL_DERIVED && sym->binding_label[0] != '\0')
6421 gfc_gsymbol *bind_c_sym;
6423 bind_c_sym = gfc_find_gsymbol (gfc_gsym_root, sym->binding_label);
6424 if (bind_c_sym != NULL
6425 && strcmp (bind_c_sym->name, sym->binding_label) == 0)
6427 if (sym->attr.if_source == IFSRC_DECL
6428 && (bind_c_sym->type != GSYM_SUBROUTINE
6429 && bind_c_sym->type != GSYM_FUNCTION)
6430 && ((sym->attr.contained == 1
6431 && strcmp (bind_c_sym->sym_name, sym->name) != 0)
6432 || (sym->attr.use_assoc == 1
6433 && (strcmp (bind_c_sym->mod_name, sym->module) != 0))))
6435 /* Make sure global procedures don't collide with anything. */
6436 gfc_error ("Binding label '%s' at %L collides with the global "
6437 "entity '%s' at %L", sym->binding_label,
6438 &(sym->declared_at), bind_c_sym->name,
6439 &(bind_c_sym->where));
6442 else if (sym->attr.contained == 0
6443 && (sym->attr.if_source == IFSRC_IFBODY
6444 && sym->attr.flavor == FL_PROCEDURE)
6445 && (bind_c_sym->sym_name != NULL
6446 && strcmp (bind_c_sym->sym_name, sym->name) != 0))
6448 /* Make sure procedures in interface bodies don't collide. */
6449 gfc_error ("Binding label '%s' in interface body at %L collides "
6450 "with the global entity '%s' at %L",
6452 &(sym->declared_at), bind_c_sym->name,
6453 &(bind_c_sym->where));
6456 else if (sym->attr.contained == 0
6457 && (sym->attr.if_source == IFSRC_UNKNOWN))
6458 if ((sym->attr.use_assoc
6459 && (strcmp (bind_c_sym->mod_name, sym->module) != 0))
6460 || sym->attr.use_assoc == 0)
6462 gfc_error ("Binding label '%s' at %L collides with global "
6463 "entity '%s' at %L", sym->binding_label,
6464 &(sym->declared_at), bind_c_sym->name,
6465 &(bind_c_sym->where));
6470 /* Clear the binding label to prevent checking multiple times. */
6471 sym->binding_label[0] = '\0';
6473 else if (bind_c_sym == NULL)
6475 bind_c_sym = gfc_get_gsymbol (sym->binding_label);
6476 bind_c_sym->where = sym->declared_at;
6477 bind_c_sym->sym_name = sym->name;
6479 if (sym->attr.use_assoc == 1)
6480 bind_c_sym->mod_name = sym->module;
6482 if (sym->ns->proc_name != NULL)
6483 bind_c_sym->mod_name = sym->ns->proc_name->name;
6485 if (sym->attr.contained == 0)
6487 if (sym->attr.subroutine)
6488 bind_c_sym->type = GSYM_SUBROUTINE;
6489 else if (sym->attr.function)
6490 bind_c_sym->type = GSYM_FUNCTION;
6498 /* Resolve an index expression. */
6501 resolve_index_expr (gfc_expr *e)
6503 if (gfc_resolve_expr (e) == FAILURE)
6506 if (gfc_simplify_expr (e, 0) == FAILURE)
6509 if (gfc_specification_expr (e) == FAILURE)
6515 /* Resolve a charlen structure. */
6518 resolve_charlen (gfc_charlen *cl)
6527 specification_expr = 1;
6529 if (resolve_index_expr (cl->length) == FAILURE)
6531 specification_expr = 0;
6535 /* "If the character length parameter value evaluates to a negative
6536 value, the length of character entities declared is zero." */
6537 if (cl->length && !gfc_extract_int (cl->length, &i) && i < 0)
6539 gfc_warning_now ("CHARACTER variable has zero length at %L",
6540 &cl->length->where);
6541 gfc_replace_expr (cl->length, gfc_int_expr (0));
6548 /* Test for non-constant shape arrays. */
6551 is_non_constant_shape_array (gfc_symbol *sym)
6557 not_constant = false;
6558 if (sym->as != NULL)
6560 /* Unfortunately, !gfc_is_compile_time_shape hits a legal case that
6561 has not been simplified; parameter array references. Do the
6562 simplification now. */
6563 for (i = 0; i < sym->as->rank; i++)
6565 e = sym->as->lower[i];
6566 if (e && (resolve_index_expr (e) == FAILURE
6567 || !gfc_is_constant_expr (e)))
6568 not_constant = true;
6570 e = sym->as->upper[i];
6571 if (e && (resolve_index_expr (e) == FAILURE
6572 || !gfc_is_constant_expr (e)))
6573 not_constant = true;
6576 return not_constant;
6579 /* Given a symbol and an initialization expression, add code to initialize
6580 the symbol to the function entry. */
6582 build_init_assign (gfc_symbol *sym, gfc_expr *init)
6586 gfc_namespace *ns = sym->ns;
6588 /* Search for the function namespace if this is a contained
6589 function without an explicit result. */
6590 if (sym->attr.function && sym == sym->result
6591 && sym->name != sym->ns->proc_name->name)
6594 for (;ns; ns = ns->sibling)
6595 if (strcmp (ns->proc_name->name, sym->name) == 0)
6601 gfc_free_expr (init);
6605 /* Build an l-value expression for the result. */
6606 lval = gfc_lval_expr_from_sym (sym);
6608 /* Add the code at scope entry. */
6609 init_st = gfc_get_code ();
6610 init_st->next = ns->code;
6613 /* Assign the default initializer to the l-value. */
6614 init_st->loc = sym->declared_at;
6615 init_st->op = EXEC_INIT_ASSIGN;
6616 init_st->expr = lval;
6617 init_st->expr2 = init;
6620 /* Assign the default initializer to a derived type variable or result. */
6623 apply_default_init (gfc_symbol *sym)
6625 gfc_expr *init = NULL;
6627 if (sym->attr.flavor != FL_VARIABLE && !sym->attr.function)
6630 if (sym->ts.type == BT_DERIVED && sym->ts.derived)
6631 init = gfc_default_initializer (&sym->ts);
6636 build_init_assign (sym, init);
6639 /* Build an initializer for a local integer, real, complex, logical, or
6640 character variable, based on the command line flags finit-local-zero,
6641 finit-integer=, finit-real=, finit-logical=, and finit-runtime. Returns
6642 null if the symbol should not have a default initialization. */
6644 build_default_init_expr (gfc_symbol *sym)
6647 gfc_expr *init_expr;
6651 /* These symbols should never have a default initialization. */
6652 if ((sym->attr.dimension && !gfc_is_compile_time_shape (sym->as))
6653 || sym->attr.external
6655 || sym->attr.pointer
6656 || sym->attr.in_equivalence
6657 || sym->attr.in_common
6660 || sym->attr.cray_pointee
6661 || sym->attr.cray_pointer)
6664 /* Now we'll try to build an initializer expression. */
6665 init_expr = gfc_get_expr ();
6666 init_expr->expr_type = EXPR_CONSTANT;
6667 init_expr->ts.type = sym->ts.type;
6668 init_expr->ts.kind = sym->ts.kind;
6669 init_expr->where = sym->declared_at;
6671 /* We will only initialize integers, reals, complex, logicals, and
6672 characters, and only if the corresponding command-line flags
6673 were set. Otherwise, we free init_expr and return null. */
6674 switch (sym->ts.type)
6677 if (gfc_option.flag_init_integer != GFC_INIT_INTEGER_OFF)
6678 mpz_init_set_si (init_expr->value.integer,
6679 gfc_option.flag_init_integer_value);
6682 gfc_free_expr (init_expr);
6688 mpfr_init (init_expr->value.real);
6689 switch (gfc_option.flag_init_real)
6691 case GFC_INIT_REAL_NAN:
6692 mpfr_set_nan (init_expr->value.real);
6695 case GFC_INIT_REAL_INF:
6696 mpfr_set_inf (init_expr->value.real, 1);
6699 case GFC_INIT_REAL_NEG_INF:
6700 mpfr_set_inf (init_expr->value.real, -1);
6703 case GFC_INIT_REAL_ZERO:
6704 mpfr_set_ui (init_expr->value.real, 0.0, GFC_RND_MODE);
6708 gfc_free_expr (init_expr);
6715 mpfr_init (init_expr->value.complex.r);
6716 mpfr_init (init_expr->value.complex.i);
6717 switch (gfc_option.flag_init_real)
6719 case GFC_INIT_REAL_NAN:
6720 mpfr_set_nan (init_expr->value.complex.r);
6721 mpfr_set_nan (init_expr->value.complex.i);
6724 case GFC_INIT_REAL_INF:
6725 mpfr_set_inf (init_expr->value.complex.r, 1);
6726 mpfr_set_inf (init_expr->value.complex.i, 1);
6729 case GFC_INIT_REAL_NEG_INF:
6730 mpfr_set_inf (init_expr->value.complex.r, -1);
6731 mpfr_set_inf (init_expr->value.complex.i, -1);
6734 case GFC_INIT_REAL_ZERO:
6735 mpfr_set_ui (init_expr->value.complex.r, 0.0, GFC_RND_MODE);
6736 mpfr_set_ui (init_expr->value.complex.i, 0.0, GFC_RND_MODE);
6740 gfc_free_expr (init_expr);
6747 if (gfc_option.flag_init_logical == GFC_INIT_LOGICAL_FALSE)
6748 init_expr->value.logical = 0;
6749 else if (gfc_option.flag_init_logical == GFC_INIT_LOGICAL_TRUE)
6750 init_expr->value.logical = 1;
6753 gfc_free_expr (init_expr);
6759 /* For characters, the length must be constant in order to
6760 create a default initializer. */
6761 if (gfc_option.flag_init_character == GFC_INIT_CHARACTER_ON
6762 && sym->ts.cl->length
6763 && sym->ts.cl->length->expr_type == EXPR_CONSTANT)
6765 char_len = mpz_get_si (sym->ts.cl->length->value.integer);
6766 init_expr->value.character.length = char_len;
6767 init_expr->value.character.string = gfc_getmem (char_len+1);
6768 ch = init_expr->value.character.string;
6769 for (i = 0; i < char_len; i++)
6770 *(ch++) = gfc_option.flag_init_character_value;
6774 gfc_free_expr (init_expr);
6780 gfc_free_expr (init_expr);
6786 /* Add an initialization expression to a local variable. */
6788 apply_default_init_local (gfc_symbol *sym)
6790 gfc_expr *init = NULL;
6792 /* The symbol should be a variable or a function return value. */
6793 if ((sym->attr.flavor != FL_VARIABLE && !sym->attr.function)
6794 || (sym->attr.function && sym->result != sym))
6797 /* Try to build the initializer expression. If we can't initialize
6798 this symbol, then init will be NULL. */
6799 init = build_default_init_expr (sym);
6803 /* For saved variables, we don't want to add an initializer at
6804 function entry, so we just add a static initializer. */
6805 if (sym->attr.save || sym->ns->save_all)
6807 /* Don't clobber an existing initializer! */
6808 gcc_assert (sym->value == NULL);
6813 build_init_assign (sym, init);
6816 /* Resolution of common features of flavors variable and procedure. */
6819 resolve_fl_var_and_proc (gfc_symbol *sym, int mp_flag)
6821 /* Constraints on deferred shape variable. */
6822 if (sym->as == NULL || sym->as->type != AS_DEFERRED)
6824 if (sym->attr.allocatable)
6826 if (sym->attr.dimension)
6827 gfc_error ("Allocatable array '%s' at %L must have "
6828 "a deferred shape", sym->name, &sym->declared_at);
6830 gfc_error ("Scalar object '%s' at %L may not be ALLOCATABLE",
6831 sym->name, &sym->declared_at);
6835 if (sym->attr.pointer && sym->attr.dimension)
6837 gfc_error ("Array pointer '%s' at %L must have a deferred shape",
6838 sym->name, &sym->declared_at);
6845 if (!mp_flag && !sym->attr.allocatable
6846 && !sym->attr.pointer && !sym->attr.dummy)
6848 gfc_error ("Array '%s' at %L cannot have a deferred shape",
6849 sym->name, &sym->declared_at);
6857 /* Additional checks for symbols with flavor variable and derived
6858 type. To be called from resolve_fl_variable. */
6861 resolve_fl_variable_derived (gfc_symbol *sym, int no_init_flag)
6863 gcc_assert (sym->ts.type == BT_DERIVED);
6865 /* Check to see if a derived type is blocked from being host
6866 associated by the presence of another class I symbol in the same
6867 namespace. 14.6.1.3 of the standard and the discussion on
6868 comp.lang.fortran. */
6869 if (sym->ns != sym->ts.derived->ns
6870 && sym->ns->proc_name->attr.if_source != IFSRC_IFBODY)
6873 gfc_find_symbol (sym->ts.derived->name, sym->ns, 0, &s);
6874 if (s && (s->attr.flavor != FL_DERIVED
6875 || !gfc_compare_derived_types (s, sym->ts.derived)))
6877 gfc_error ("The type '%s' cannot be host associated at %L "
6878 "because it is blocked by an incompatible object "
6879 "of the same name declared at %L",
6880 sym->ts.derived->name, &sym->declared_at,
6886 /* 4th constraint in section 11.3: "If an object of a type for which
6887 component-initialization is specified (R429) appears in the
6888 specification-part of a module and does not have the ALLOCATABLE
6889 or POINTER attribute, the object shall have the SAVE attribute."
6891 The check for initializers is performed with
6892 has_default_initializer because gfc_default_initializer generates
6893 a hidden default for allocatable components. */
6894 if (!(sym->value || no_init_flag) && sym->ns->proc_name
6895 && sym->ns->proc_name->attr.flavor == FL_MODULE
6896 && !sym->ns->save_all && !sym->attr.save
6897 && !sym->attr.pointer && !sym->attr.allocatable
6898 && has_default_initializer (sym->ts.derived))
6900 gfc_error("Object '%s' at %L must have the SAVE attribute for "
6901 "default initialization of a component",
6902 sym->name, &sym->declared_at);
6906 /* Assign default initializer. */
6907 if (!(sym->value || sym->attr.pointer || sym->attr.allocatable)
6908 && (!no_init_flag || sym->attr.intent == INTENT_OUT))
6910 sym->value = gfc_default_initializer (&sym->ts);
6917 /* Resolve symbols with flavor variable. */
6920 resolve_fl_variable (gfc_symbol *sym, int mp_flag)
6922 int no_init_flag, automatic_flag;
6924 const char *auto_save_msg;
6926 auto_save_msg = "Automatic object '%s' at %L cannot have the "
6929 if (resolve_fl_var_and_proc (sym, mp_flag) == FAILURE)
6932 /* Set this flag to check that variables are parameters of all entries.
6933 This check is effected by the call to gfc_resolve_expr through
6934 is_non_constant_shape_array. */
6935 specification_expr = 1;
6937 if (sym->ns->proc_name
6938 && (sym->ns->proc_name->attr.flavor == FL_MODULE
6939 || sym->ns->proc_name->attr.is_main_program)
6940 && !sym->attr.use_assoc
6941 && !sym->attr.allocatable
6942 && !sym->attr.pointer
6943 && is_non_constant_shape_array (sym))
6945 /* The shape of a main program or module array needs to be
6947 gfc_error ("The module or main program array '%s' at %L must "
6948 "have constant shape", sym->name, &sym->declared_at);
6949 specification_expr = 0;
6953 if (sym->ts.type == BT_CHARACTER)
6955 /* Make sure that character string variables with assumed length are
6957 e = sym->ts.cl->length;
6958 if (e == NULL && !sym->attr.dummy && !sym->attr.result)
6960 gfc_error ("Entity with assumed character length at %L must be a "
6961 "dummy argument or a PARAMETER", &sym->declared_at);
6965 if (e && sym->attr.save && !gfc_is_constant_expr (e))
6967 gfc_error (auto_save_msg, sym->name, &sym->declared_at);
6971 if (!gfc_is_constant_expr (e)
6972 && !(e->expr_type == EXPR_VARIABLE
6973 && e->symtree->n.sym->attr.flavor == FL_PARAMETER)
6974 && sym->ns->proc_name
6975 && (sym->ns->proc_name->attr.flavor == FL_MODULE
6976 || sym->ns->proc_name->attr.is_main_program)
6977 && !sym->attr.use_assoc)
6979 gfc_error ("'%s' at %L must have constant character length "
6980 "in this context", sym->name, &sym->declared_at);
6985 if (sym->value == NULL && sym->attr.referenced)
6986 apply_default_init_local (sym); /* Try to apply a default initialization. */
6988 /* Determine if the symbol may not have an initializer. */
6989 no_init_flag = automatic_flag = 0;
6990 if (sym->attr.allocatable || sym->attr.external || sym->attr.dummy
6991 || sym->attr.intrinsic || sym->attr.result)
6993 else if (sym->attr.dimension && !sym->attr.pointer
6994 && is_non_constant_shape_array (sym))
6996 no_init_flag = automatic_flag = 1;
6998 /* Also, they must not have the SAVE attribute.
6999 SAVE_IMPLICIT is checked below. */
7000 if (sym->attr.save == SAVE_EXPLICIT)
7002 gfc_error (auto_save_msg, sym->name, &sym->declared_at);
7007 /* Reject illegal initializers. */
7008 if (!sym->mark && sym->value)
7010 if (sym->attr.allocatable)
7011 gfc_error ("Allocatable '%s' at %L cannot have an initializer",
7012 sym->name, &sym->declared_at);
7013 else if (sym->attr.external)
7014 gfc_error ("External '%s' at %L cannot have an initializer",
7015 sym->name, &sym->declared_at);
7016 else if (sym->attr.dummy
7017 && !(sym->ts.type == BT_DERIVED && sym->attr.intent == INTENT_OUT))
7018 gfc_error ("Dummy '%s' at %L cannot have an initializer",
7019 sym->name, &sym->declared_at);
7020 else if (sym->attr.intrinsic)
7021 gfc_error ("Intrinsic '%s' at %L cannot have an initializer",
7022 sym->name, &sym->declared_at);
7023 else if (sym->attr.result)
7024 gfc_error ("Function result '%s' at %L cannot have an initializer",
7025 sym->name, &sym->declared_at);
7026 else if (automatic_flag)
7027 gfc_error ("Automatic array '%s' at %L cannot have an initializer",
7028 sym->name, &sym->declared_at);
7035 if (sym->ts.type == BT_DERIVED)
7036 return resolve_fl_variable_derived (sym, no_init_flag);
7042 /* Resolve a procedure. */
7045 resolve_fl_procedure (gfc_symbol *sym, int mp_flag)
7047 gfc_formal_arglist *arg;
7049 if (sym->attr.ambiguous_interfaces && !sym->attr.referenced)
7050 gfc_warning ("Although not referenced, '%s' at %L has ambiguous "
7051 "interfaces", sym->name, &sym->declared_at);
7053 if (sym->attr.function
7054 && resolve_fl_var_and_proc (sym, mp_flag) == FAILURE)
7057 if (sym->ts.type == BT_CHARACTER)
7059 gfc_charlen *cl = sym->ts.cl;
7061 if (cl && cl->length && gfc_is_constant_expr (cl->length)
7062 && resolve_charlen (cl) == FAILURE)
7065 if (!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT)
7067 if (sym->attr.proc == PROC_ST_FUNCTION)
7069 gfc_error ("Character-valued statement function '%s' at %L must "
7070 "have constant length", sym->name, &sym->declared_at);
7074 if (sym->attr.external && sym->formal == NULL
7075 && cl && cl->length && cl->length->expr_type != EXPR_CONSTANT)
7077 gfc_error ("Automatic character length function '%s' at %L must "
7078 "have an explicit interface", sym->name,
7085 /* Ensure that derived type for are not of a private type. Internal
7086 module procedures are excluded by 2.2.3.3 - ie. they are not
7087 externally accessible and can access all the objects accessible in
7089 if (!(sym->ns->parent
7090 && sym->ns->parent->proc_name->attr.flavor == FL_MODULE)
7091 && gfc_check_access(sym->attr.access, sym->ns->default_access))
7093 gfc_interface *iface;
7095 for (arg = sym->formal; arg; arg = arg->next)
7098 && arg->sym->ts.type == BT_DERIVED
7099 && !arg->sym->ts.derived->attr.use_assoc
7100 && !gfc_check_access (arg->sym->ts.derived->attr.access,
7101 arg->sym->ts.derived->ns->default_access)
7102 && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: '%s' is of a "
7103 "PRIVATE type and cannot be a dummy argument"
7104 " of '%s', which is PUBLIC at %L",
7105 arg->sym->name, sym->name, &sym->declared_at)
7108 /* Stop this message from recurring. */
7109 arg->sym->ts.derived->attr.access = ACCESS_PUBLIC;
7114 /* PUBLIC interfaces may expose PRIVATE procedures that take types
7115 PRIVATE to the containing module. */
7116 for (iface = sym->generic; iface; iface = iface->next)
7118 for (arg = iface->sym->formal; arg; arg = arg->next)
7121 && arg->sym->ts.type == BT_DERIVED
7122 && !arg->sym->ts.derived->attr.use_assoc
7123 && !gfc_check_access (arg->sym->ts.derived->attr.access,
7124 arg->sym->ts.derived->ns->default_access)
7125 && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Procedure "
7126 "'%s' in PUBLIC interface '%s' at %L "
7127 "takes dummy arguments of '%s' which is "
7128 "PRIVATE", iface->sym->name, sym->name,
7129 &iface->sym->declared_at,
7130 gfc_typename (&arg->sym->ts)) == FAILURE)
7132 /* Stop this message from recurring. */
7133 arg->sym->ts.derived->attr.access = ACCESS_PUBLIC;
7139 /* PUBLIC interfaces may expose PRIVATE procedures that take types
7140 PRIVATE to the containing module. */
7141 for (iface = sym->generic; iface; iface = iface->next)
7143 for (arg = iface->sym->formal; arg; arg = arg->next)
7146 && arg->sym->ts.type == BT_DERIVED
7147 && !arg->sym->ts.derived->attr.use_assoc
7148 && !gfc_check_access (arg->sym->ts.derived->attr.access,
7149 arg->sym->ts.derived->ns->default_access)
7150 && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Procedure "
7151 "'%s' in PUBLIC interface '%s' at %L "
7152 "takes dummy arguments of '%s' which is "
7153 "PRIVATE", iface->sym->name, sym->name,
7154 &iface->sym->declared_at,
7155 gfc_typename (&arg->sym->ts)) == FAILURE)
7157 /* Stop this message from recurring. */
7158 arg->sym->ts.derived->attr.access = ACCESS_PUBLIC;
7165 if (sym->attr.function && sym->value && sym->attr.proc != PROC_ST_FUNCTION)
7167 gfc_error ("Function '%s' at %L cannot have an initializer",
7168 sym->name, &sym->declared_at);
7172 /* An external symbol may not have an initializer because it is taken to be
7174 if (sym->attr.external && sym->value)
7176 gfc_error ("External object '%s' at %L may not have an initializer",
7177 sym->name, &sym->declared_at);
7181 /* An elemental function is required to return a scalar 12.7.1 */
7182 if (sym->attr.elemental && sym->attr.function && sym->as)
7184 gfc_error ("ELEMENTAL function '%s' at %L must have a scalar "
7185 "result", sym->name, &sym->declared_at);
7186 /* Reset so that the error only occurs once. */
7187 sym->attr.elemental = 0;
7191 /* 5.1.1.5 of the Standard: A function name declared with an asterisk
7192 char-len-param shall not be array-valued, pointer-valued, recursive
7193 or pure. ....snip... A character value of * may only be used in the
7194 following ways: (i) Dummy arg of procedure - dummy associates with
7195 actual length; (ii) To declare a named constant; or (iii) External
7196 function - but length must be declared in calling scoping unit. */
7197 if (sym->attr.function
7198 && sym->ts.type == BT_CHARACTER
7199 && sym->ts.cl && sym->ts.cl->length == NULL)
7201 if ((sym->as && sym->as->rank) || (sym->attr.pointer)
7202 || (sym->attr.recursive) || (sym->attr.pure))
7204 if (sym->as && sym->as->rank)
7205 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
7206 "array-valued", sym->name, &sym->declared_at);
7208 if (sym->attr.pointer)
7209 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
7210 "pointer-valued", sym->name, &sym->declared_at);
7213 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
7214 "pure", sym->name, &sym->declared_at);
7216 if (sym->attr.recursive)
7217 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
7218 "recursive", sym->name, &sym->declared_at);
7223 /* Appendix B.2 of the standard. Contained functions give an
7224 error anyway. Fixed-form is likely to be F77/legacy. */
7225 if (!sym->attr.contained && gfc_current_form != FORM_FIXED)
7226 gfc_notify_std (GFC_STD_F95_OBS, "CHARACTER(*) function "
7227 "'%s' at %L is obsolescent in fortran 95",
7228 sym->name, &sym->declared_at);
7231 if (sym->attr.is_bind_c && sym->attr.is_c_interop != 1)
7233 gfc_formal_arglist *curr_arg;
7234 int has_non_interop_arg = 0;
7236 if (verify_bind_c_sym (sym, &(sym->ts), sym->attr.in_common,
7237 sym->common_block) == FAILURE)
7239 /* Clear these to prevent looking at them again if there was an
7241 sym->attr.is_bind_c = 0;
7242 sym->attr.is_c_interop = 0;
7243 sym->ts.is_c_interop = 0;
7247 /* So far, no errors have been found. */
7248 sym->attr.is_c_interop = 1;
7249 sym->ts.is_c_interop = 1;
7252 curr_arg = sym->formal;
7253 while (curr_arg != NULL)
7255 /* Skip implicitly typed dummy args here. */
7256 if (curr_arg->sym->attr.implicit_type == 0)
7257 if (verify_c_interop_param (curr_arg->sym) == FAILURE)
7258 /* If something is found to fail, record the fact so we
7259 can mark the symbol for the procedure as not being
7260 BIND(C) to try and prevent multiple errors being
7262 has_non_interop_arg = 1;
7264 curr_arg = curr_arg->next;
7267 /* See if any of the arguments were not interoperable and if so, clear
7268 the procedure symbol to prevent duplicate error messages. */
7269 if (has_non_interop_arg != 0)
7271 sym->attr.is_c_interop = 0;
7272 sym->ts.is_c_interop = 0;
7273 sym->attr.is_bind_c = 0;
7281 /* Resolve the components of a derived type. */
7284 resolve_fl_derived (gfc_symbol *sym)
7287 gfc_dt_list * dt_list;
7290 for (c = sym->components; c != NULL; c = c->next)
7292 if (c->ts.type == BT_CHARACTER)
7294 if (c->ts.cl->length == NULL
7295 || (resolve_charlen (c->ts.cl) == FAILURE)
7296 || !gfc_is_constant_expr (c->ts.cl->length))
7298 gfc_error ("Character length of component '%s' needs to "
7299 "be a constant specification expression at %L",
7301 c->ts.cl->length ? &c->ts.cl->length->where : &c->loc);
7306 if (c->ts.type == BT_DERIVED
7307 && sym->component_access != ACCESS_PRIVATE
7308 && gfc_check_access (sym->attr.access, sym->ns->default_access)
7309 && !c->ts.derived->attr.use_assoc
7310 && !gfc_check_access (c->ts.derived->attr.access,
7311 c->ts.derived->ns->default_access))
7313 gfc_error ("The component '%s' is a PRIVATE type and cannot be "
7314 "a component of '%s', which is PUBLIC at %L",
7315 c->name, sym->name, &sym->declared_at);
7319 if (sym->attr.sequence)
7321 if (c->ts.type == BT_DERIVED && c->ts.derived->attr.sequence == 0)
7323 gfc_error ("Component %s of SEQUENCE type declared at %L does "
7324 "not have the SEQUENCE attribute",
7325 c->ts.derived->name, &sym->declared_at);
7330 if (c->ts.type == BT_DERIVED && c->pointer
7331 && c->ts.derived->components == NULL)
7333 gfc_error ("The pointer component '%s' of '%s' at %L is a type "
7334 "that has not been declared", c->name, sym->name,
7339 if (c->pointer || c->allocatable || c->as == NULL)
7342 for (i = 0; i < c->as->rank; i++)
7344 if (c->as->lower[i] == NULL
7345 || !gfc_is_constant_expr (c->as->lower[i])
7346 || (resolve_index_expr (c->as->lower[i]) == FAILURE)
7347 || c->as->upper[i] == NULL
7348 || (resolve_index_expr (c->as->upper[i]) == FAILURE)
7349 || !gfc_is_constant_expr (c->as->upper[i]))
7351 gfc_error ("Component '%s' of '%s' at %L must have "
7352 "constant array bounds",
7353 c->name, sym->name, &c->loc);
7359 /* Add derived type to the derived type list. */
7360 for (dt_list = gfc_derived_types; dt_list; dt_list = dt_list->next)
7361 if (sym == dt_list->derived)
7364 if (dt_list == NULL)
7366 dt_list = gfc_get_dt_list ();
7367 dt_list->next = gfc_derived_types;
7368 dt_list->derived = sym;
7369 gfc_derived_types = dt_list;
7377 resolve_fl_namelist (gfc_symbol *sym)
7382 /* Reject PRIVATE objects in a PUBLIC namelist. */
7383 if (gfc_check_access(sym->attr.access, sym->ns->default_access))
7385 for (nl = sym->namelist; nl; nl = nl->next)
7387 if (!nl->sym->attr.use_assoc
7388 && !(sym->ns->parent == nl->sym->ns)
7389 && !(sym->ns->parent
7390 && sym->ns->parent->parent == nl->sym->ns)
7391 && !gfc_check_access(nl->sym->attr.access,
7392 nl->sym->ns->default_access))
7394 gfc_error ("NAMELIST object '%s' was declared PRIVATE and "
7395 "cannot be member of PUBLIC namelist '%s' at %L",
7396 nl->sym->name, sym->name, &sym->declared_at);
7400 /* Types with private components that came here by USE-association. */
7401 if (nl->sym->ts.type == BT_DERIVED
7402 && derived_inaccessible (nl->sym->ts.derived))
7404 gfc_error ("NAMELIST object '%s' has use-associated PRIVATE "
7405 "components and cannot be member of namelist '%s' at %L",
7406 nl->sym->name, sym->name, &sym->declared_at);
7410 /* Types with private components that are defined in the same module. */
7411 if (nl->sym->ts.type == BT_DERIVED
7412 && !(sym->ns->parent == nl->sym->ts.derived->ns)
7413 && !gfc_check_access (nl->sym->ts.derived->attr.private_comp
7414 ? ACCESS_PRIVATE : ACCESS_UNKNOWN,
7415 nl->sym->ns->default_access))
7417 gfc_error ("NAMELIST object '%s' has PRIVATE components and "
7418 "cannot be a member of PUBLIC namelist '%s' at %L",
7419 nl->sym->name, sym->name, &sym->declared_at);
7425 for (nl = sym->namelist; nl; nl = nl->next)
7427 /* Reject namelist arrays of assumed shape. */
7428 if (nl->sym->as && nl->sym->as->type == AS_ASSUMED_SHAPE
7429 && gfc_notify_std (GFC_STD_F2003, "NAMELIST array object '%s' "
7430 "must not have assumed shape in namelist "
7431 "'%s' at %L", nl->sym->name, sym->name,
7432 &sym->declared_at) == FAILURE)
7435 /* Reject namelist arrays that are not constant shape. */
7436 if (is_non_constant_shape_array (nl->sym))
7438 gfc_error ("NAMELIST array object '%s' must have constant "
7439 "shape in namelist '%s' at %L", nl->sym->name,
7440 sym->name, &sym->declared_at);
7444 /* Namelist objects cannot have allocatable or pointer components. */
7445 if (nl->sym->ts.type != BT_DERIVED)
7448 if (nl->sym->ts.derived->attr.alloc_comp)
7450 gfc_error ("NAMELIST object '%s' in namelist '%s' at %L cannot "
7451 "have ALLOCATABLE components",
7452 nl->sym->name, sym->name, &sym->declared_at);
7456 if (nl->sym->ts.derived->attr.pointer_comp)
7458 gfc_error ("NAMELIST object '%s' in namelist '%s' at %L cannot "
7459 "have POINTER components",
7460 nl->sym->name, sym->name, &sym->declared_at);
7466 /* 14.1.2 A module or internal procedure represent local entities
7467 of the same type as a namelist member and so are not allowed. */
7468 for (nl = sym->namelist; nl; nl = nl->next)
7470 if (nl->sym->ts.kind != 0 && nl->sym->attr.flavor == FL_VARIABLE)
7473 if (nl->sym->attr.function && nl->sym == nl->sym->result)
7474 if ((nl->sym == sym->ns->proc_name)
7476 (sym->ns->parent && nl->sym == sym->ns->parent->proc_name))
7480 if (nl->sym && nl->sym->name)
7481 gfc_find_symbol (nl->sym->name, sym->ns, 1, &nlsym);
7482 if (nlsym && nlsym->attr.flavor == FL_PROCEDURE)
7484 gfc_error ("PROCEDURE attribute conflicts with NAMELIST "
7485 "attribute in '%s' at %L", nlsym->name,
7496 resolve_fl_parameter (gfc_symbol *sym)
7498 /* A parameter array's shape needs to be constant. */
7500 && (sym->as->type == AS_DEFERRED
7501 || is_non_constant_shape_array (sym)))
7503 gfc_error ("Parameter array '%s' at %L cannot be automatic "
7504 "or of deferred shape", sym->name, &sym->declared_at);
7508 /* Make sure a parameter that has been implicitly typed still
7509 matches the implicit type, since PARAMETER statements can precede
7510 IMPLICIT statements. */
7511 if (sym->attr.implicit_type
7512 && !gfc_compare_types (&sym->ts, gfc_get_default_type (sym, sym->ns)))
7514 gfc_error ("Implicitly typed PARAMETER '%s' at %L doesn't match a "
7515 "later IMPLICIT type", sym->name, &sym->declared_at);
7519 /* Make sure the types of derived parameters are consistent. This
7520 type checking is deferred until resolution because the type may
7521 refer to a derived type from the host. */
7522 if (sym->ts.type == BT_DERIVED
7523 && !gfc_compare_types (&sym->ts, &sym->value->ts))
7525 gfc_error ("Incompatible derived type in PARAMETER at %L",
7526 &sym->value->where);
7533 /* Do anything necessary to resolve a symbol. Right now, we just
7534 assume that an otherwise unknown symbol is a variable. This sort
7535 of thing commonly happens for symbols in module. */
7538 resolve_symbol (gfc_symbol *sym)
7540 int check_constant, mp_flag;
7541 gfc_symtree *symtree;
7542 gfc_symtree *this_symtree;
7546 if (sym->attr.flavor == FL_UNKNOWN)
7549 /* If we find that a flavorless symbol is an interface in one of the
7550 parent namespaces, find its symtree in this namespace, free the
7551 symbol and set the symtree to point to the interface symbol. */
7552 for (ns = gfc_current_ns->parent; ns; ns = ns->parent)
7554 symtree = gfc_find_symtree (ns->sym_root, sym->name);
7555 if (symtree && symtree->n.sym->generic)
7557 this_symtree = gfc_find_symtree (gfc_current_ns->sym_root,
7561 gfc_free_symbol (sym);
7562 symtree->n.sym->refs++;
7563 this_symtree->n.sym = symtree->n.sym;
7568 /* Otherwise give it a flavor according to such attributes as
7570 if (sym->attr.external == 0 && sym->attr.intrinsic == 0)
7571 sym->attr.flavor = FL_VARIABLE;
7574 sym->attr.flavor = FL_PROCEDURE;
7575 if (sym->attr.dimension)
7576 sym->attr.function = 1;
7580 if (sym->attr.procedure && sym->interface
7581 && sym->attr.if_source != IFSRC_DECL)
7583 /* Get the attributes from the interface (now resolved). */
7584 if (sym->interface->attr.if_source || sym->interface->attr.intrinsic)
7586 sym->ts = sym->interface->ts;
7587 sym->attr.function = sym->interface->attr.function;
7588 sym->attr.subroutine = sym->interface->attr.subroutine;
7589 copy_formal_args (sym, sym->interface);
7591 else if (sym->interface->name[0] != '\0')
7593 gfc_error ("Interface '%s' of procedure '%s' at %L must be explicit",
7594 sym->interface->name, sym->name, &sym->declared_at);
7599 if (sym->attr.flavor == FL_DERIVED && resolve_fl_derived (sym) == FAILURE)
7602 /* Symbols that are module procedures with results (functions) have
7603 the types and array specification copied for type checking in
7604 procedures that call them, as well as for saving to a module
7605 file. These symbols can't stand the scrutiny that their results
7607 mp_flag = (sym->result != NULL && sym->result != sym);
7610 /* Make sure that the intrinsic is consistent with its internal
7611 representation. This needs to be done before assigning a default
7612 type to avoid spurious warnings. */
7613 if (sym->attr.flavor != FL_MODULE && sym->attr.intrinsic)
7615 if (gfc_intrinsic_name (sym->name, 0))
7617 if (sym->ts.type != BT_UNKNOWN && gfc_option.warn_surprising)
7618 gfc_warning ("Type specified for intrinsic function '%s' at %L is ignored",
7619 sym->name, &sym->declared_at);
7621 else if (gfc_intrinsic_name (sym->name, 1))
7623 if (sym->ts.type != BT_UNKNOWN)
7625 gfc_error ("Intrinsic subroutine '%s' at %L shall not have a type specifier",
7626 sym->name, &sym->declared_at);
7632 gfc_error ("Intrinsic '%s' at %L does not exist", sym->name, &sym->declared_at);
7637 /* Assign default type to symbols that need one and don't have one. */
7638 if (sym->ts.type == BT_UNKNOWN)
7640 if (sym->attr.flavor == FL_VARIABLE || sym->attr.flavor == FL_PARAMETER)
7641 gfc_set_default_type (sym, 1, NULL);
7643 if (sym->attr.flavor == FL_PROCEDURE && sym->attr.function)
7645 /* The specific case of an external procedure should emit an error
7646 in the case that there is no implicit type. */
7648 gfc_set_default_type (sym, sym->attr.external, NULL);
7651 /* Result may be in another namespace. */
7652 resolve_symbol (sym->result);
7654 sym->ts = sym->result->ts;
7655 sym->as = gfc_copy_array_spec (sym->result->as);
7656 sym->attr.dimension = sym->result->attr.dimension;
7657 sym->attr.pointer = sym->result->attr.pointer;
7658 sym->attr.allocatable = sym->result->attr.allocatable;
7663 /* Assumed size arrays and assumed shape arrays must be dummy
7667 && (sym->as->type == AS_ASSUMED_SIZE
7668 || sym->as->type == AS_ASSUMED_SHAPE)
7669 && sym->attr.dummy == 0)
7671 if (sym->as->type == AS_ASSUMED_SIZE)
7672 gfc_error ("Assumed size array at %L must be a dummy argument",
7675 gfc_error ("Assumed shape array at %L must be a dummy argument",
7680 /* Make sure symbols with known intent or optional are really dummy
7681 variable. Because of ENTRY statement, this has to be deferred
7682 until resolution time. */
7684 if (!sym->attr.dummy
7685 && (sym->attr.optional || sym->attr.intent != INTENT_UNKNOWN))
7687 gfc_error ("Symbol at %L is not a DUMMY variable", &sym->declared_at);
7691 if (sym->attr.value && !sym->attr.dummy)
7693 gfc_error ("'%s' at %L cannot have the VALUE attribute because "
7694 "it is not a dummy argument", sym->name, &sym->declared_at);
7698 if (sym->attr.value && sym->ts.type == BT_CHARACTER)
7700 gfc_charlen *cl = sym->ts.cl;
7701 if (!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT)
7703 gfc_error ("Character dummy variable '%s' at %L with VALUE "
7704 "attribute must have constant length",
7705 sym->name, &sym->declared_at);
7709 if (sym->ts.is_c_interop
7710 && mpz_cmp_si (cl->length->value.integer, 1) != 0)
7712 gfc_error ("C interoperable character dummy variable '%s' at %L "
7713 "with VALUE attribute must have length one",
7714 sym->name, &sym->declared_at);
7719 /* If the symbol is marked as bind(c), verify it's type and kind. Do not
7720 do this for something that was implicitly typed because that is handled
7721 in gfc_set_default_type. Handle dummy arguments and procedure
7722 definitions separately. Also, anything that is use associated is not
7723 handled here but instead is handled in the module it is declared in.
7724 Finally, derived type definitions are allowed to be BIND(C) since that
7725 only implies that they're interoperable, and they are checked fully for
7726 interoperability when a variable is declared of that type. */
7727 if (sym->attr.is_bind_c && sym->attr.implicit_type == 0 &&
7728 sym->attr.use_assoc == 0 && sym->attr.dummy == 0 &&
7729 sym->attr.flavor != FL_PROCEDURE && sym->attr.flavor != FL_DERIVED)
7733 /* First, make sure the variable is declared at the
7734 module-level scope (J3/04-007, Section 15.3). */
7735 if (sym->ns->proc_name->attr.flavor != FL_MODULE &&
7736 sym->attr.in_common == 0)
7738 gfc_error ("Variable '%s' at %L cannot be BIND(C) because it "
7739 "is neither a COMMON block nor declared at the "
7740 "module level scope", sym->name, &(sym->declared_at));
7743 else if (sym->common_head != NULL)
7745 t = verify_com_block_vars_c_interop (sym->common_head);
7749 /* If type() declaration, we need to verify that the components
7750 of the given type are all C interoperable, etc. */
7751 if (sym->ts.type == BT_DERIVED &&
7752 sym->ts.derived->attr.is_c_interop != 1)
7754 /* Make sure the user marked the derived type as BIND(C). If
7755 not, call the verify routine. This could print an error
7756 for the derived type more than once if multiple variables
7757 of that type are declared. */
7758 if (sym->ts.derived->attr.is_bind_c != 1)
7759 verify_bind_c_derived_type (sym->ts.derived);
7763 /* Verify the variable itself as C interoperable if it
7764 is BIND(C). It is not possible for this to succeed if
7765 the verify_bind_c_derived_type failed, so don't have to handle
7766 any error returned by verify_bind_c_derived_type. */
7767 t = verify_bind_c_sym (sym, &(sym->ts), sym->attr.in_common,
7773 /* clear the is_bind_c flag to prevent reporting errors more than
7774 once if something failed. */
7775 sym->attr.is_bind_c = 0;
7780 /* If a derived type symbol has reached this point, without its
7781 type being declared, we have an error. Notice that most
7782 conditions that produce undefined derived types have already
7783 been dealt with. However, the likes of:
7784 implicit type(t) (t) ..... call foo (t) will get us here if
7785 the type is not declared in the scope of the implicit
7786 statement. Change the type to BT_UNKNOWN, both because it is so
7787 and to prevent an ICE. */
7788 if (sym->ts.type == BT_DERIVED && sym->ts.derived->components == NULL
7789 && !sym->ts.derived->attr.zero_comp)
7791 gfc_error ("The derived type '%s' at %L is of type '%s', "
7792 "which has not been defined", sym->name,
7793 &sym->declared_at, sym->ts.derived->name);
7794 sym->ts.type = BT_UNKNOWN;
7798 /* Unless the derived-type declaration is use associated, Fortran 95
7799 does not allow public entries of private derived types.
7800 See 4.4.1 (F95) and 4.5.1.1 (F2003); and related interpretation
7802 if (sym->ts.type == BT_DERIVED
7803 && gfc_check_access (sym->attr.access, sym->ns->default_access)
7804 && !gfc_check_access (sym->ts.derived->attr.access,
7805 sym->ts.derived->ns->default_access)
7806 && !sym->ts.derived->attr.use_assoc
7807 && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: PUBLIC %s '%s' at %L "
7808 "of PRIVATE derived type '%s'",
7809 (sym->attr.flavor == FL_PARAMETER) ? "parameter"
7810 : "variable", sym->name, &sym->declared_at,
7811 sym->ts.derived->name) == FAILURE)
7814 /* An assumed-size array with INTENT(OUT) shall not be of a type for which
7815 default initialization is defined (5.1.2.4.4). */
7816 if (sym->ts.type == BT_DERIVED
7818 && sym->attr.intent == INTENT_OUT
7820 && sym->as->type == AS_ASSUMED_SIZE)
7822 for (c = sym->ts.derived->components; c; c = c->next)
7826 gfc_error ("The INTENT(OUT) dummy argument '%s' at %L is "
7827 "ASSUMED SIZE and so cannot have a default initializer",
7828 sym->name, &sym->declared_at);
7834 switch (sym->attr.flavor)
7837 if (resolve_fl_variable (sym, mp_flag) == FAILURE)
7842 if (resolve_fl_procedure (sym, mp_flag) == FAILURE)
7847 if (resolve_fl_namelist (sym) == FAILURE)
7852 if (resolve_fl_parameter (sym) == FAILURE)
7860 /* Resolve array specifier. Check as well some constraints
7861 on COMMON blocks. */
7863 check_constant = sym->attr.in_common && !sym->attr.pointer;
7865 /* Set the formal_arg_flag so that check_conflict will not throw
7866 an error for host associated variables in the specification
7867 expression for an array_valued function. */
7868 if (sym->attr.function && sym->as)
7869 formal_arg_flag = 1;
7871 gfc_resolve_array_spec (sym->as, check_constant);
7873 formal_arg_flag = 0;
7875 /* Resolve formal namespaces. */
7876 if (sym->formal_ns && sym->formal_ns != gfc_current_ns)
7877 gfc_resolve (sym->formal_ns);
7879 /* Check threadprivate restrictions. */
7880 if (sym->attr.threadprivate && !sym->attr.save && !sym->ns->save_all
7881 && (!sym->attr.in_common
7882 && sym->module == NULL
7883 && (sym->ns->proc_name == NULL
7884 || sym->ns->proc_name->attr.flavor != FL_MODULE)))
7885 gfc_error ("Threadprivate at %L isn't SAVEd", &sym->declared_at);
7887 /* If we have come this far we can apply default-initializers, as
7888 described in 14.7.5, to those variables that have not already
7889 been assigned one. */
7890 if (sym->ts.type == BT_DERIVED
7891 && sym->attr.referenced
7892 && sym->ns == gfc_current_ns
7894 && !sym->attr.allocatable
7895 && !sym->attr.alloc_comp)
7897 symbol_attribute *a = &sym->attr;
7899 if ((!a->save && !a->dummy && !a->pointer
7900 && !a->in_common && !a->use_assoc
7901 && !(a->function && sym != sym->result))
7902 || (a->dummy && a->intent == INTENT_OUT))
7903 apply_default_init (sym);
7908 /************* Resolve DATA statements *************/
7912 gfc_data_value *vnode;
7918 /* Advance the values structure to point to the next value in the data list. */
7921 next_data_value (void)
7924 while (mpz_cmp_ui (values.left, 0) == 0)
7926 if (values.vnode->next == NULL)
7929 values.vnode = values.vnode->next;
7930 mpz_set (values.left, values.vnode->repeat);
7938 check_data_variable (gfc_data_variable *var, locus *where)
7944 ar_type mark = AR_UNKNOWN;
7946 mpz_t section_index[GFC_MAX_DIMENSIONS];
7950 if (gfc_resolve_expr (var->expr) == FAILURE)
7954 mpz_init_set_si (offset, 0);
7957 if (e->expr_type != EXPR_VARIABLE)
7958 gfc_internal_error ("check_data_variable(): Bad expression");
7960 if (e->symtree->n.sym->ns->is_block_data
7961 && !e->symtree->n.sym->attr.in_common)
7963 gfc_error ("BLOCK DATA element '%s' at %L must be in COMMON",
7964 e->symtree->n.sym->name, &e->symtree->n.sym->declared_at);
7969 mpz_init_set_ui (size, 1);
7976 /* Find the array section reference. */
7977 for (ref = e->ref; ref; ref = ref->next)
7979 if (ref->type != REF_ARRAY)
7981 if (ref->u.ar.type == AR_ELEMENT)
7987 /* Set marks according to the reference pattern. */
7988 switch (ref->u.ar.type)
7996 /* Get the start position of array section. */
7997 gfc_get_section_index (ar, section_index, &offset);
8005 if (gfc_array_size (e, &size) == FAILURE)
8007 gfc_error ("Nonconstant array section at %L in DATA statement",
8016 while (mpz_cmp_ui (size, 0) > 0)
8018 if (next_data_value () == FAILURE)
8020 gfc_error ("DATA statement at %L has more variables than values",
8026 t = gfc_check_assign (var->expr, values.vnode->expr, 0);
8030 /* If we have more than one element left in the repeat count,
8031 and we have more than one element left in the target variable,
8032 then create a range assignment. */
8033 /* FIXME: Only done for full arrays for now, since array sections
8035 if (mark == AR_FULL && ref && ref->next == NULL
8036 && mpz_cmp_ui (values.left, 1) > 0 && mpz_cmp_ui (size, 1) > 0)
8040 if (mpz_cmp (size, values.left) >= 0)
8042 mpz_init_set (range, values.left);
8043 mpz_sub (size, size, values.left);
8044 mpz_set_ui (values.left, 0);
8048 mpz_init_set (range, size);
8049 mpz_sub (values.left, values.left, size);
8050 mpz_set_ui (size, 0);
8053 gfc_assign_data_value_range (var->expr, values.vnode->expr,
8056 mpz_add (offset, offset, range);
8060 /* Assign initial value to symbol. */
8063 mpz_sub_ui (values.left, values.left, 1);
8064 mpz_sub_ui (size, size, 1);
8066 t = gfc_assign_data_value (var->expr, values.vnode->expr, offset);
8070 if (mark == AR_FULL)
8071 mpz_add_ui (offset, offset, 1);
8073 /* Modify the array section indexes and recalculate the offset
8074 for next element. */
8075 else if (mark == AR_SECTION)
8076 gfc_advance_section (section_index, ar, &offset);
8080 if (mark == AR_SECTION)
8082 for (i = 0; i < ar->dimen; i++)
8083 mpz_clear (section_index[i]);
8093 static try traverse_data_var (gfc_data_variable *, locus *);
8095 /* Iterate over a list of elements in a DATA statement. */
8098 traverse_data_list (gfc_data_variable *var, locus *where)
8101 iterator_stack frame;
8102 gfc_expr *e, *start, *end, *step;
8103 try retval = SUCCESS;
8105 mpz_init (frame.value);
8107 start = gfc_copy_expr (var->iter.start);
8108 end = gfc_copy_expr (var->iter.end);
8109 step = gfc_copy_expr (var->iter.step);
8111 if (gfc_simplify_expr (start, 1) == FAILURE
8112 || start->expr_type != EXPR_CONSTANT)
8114 gfc_error ("iterator start at %L does not simplify", &start->where);
8118 if (gfc_simplify_expr (end, 1) == FAILURE
8119 || end->expr_type != EXPR_CONSTANT)
8121 gfc_error ("iterator end at %L does not simplify", &end->where);
8125 if (gfc_simplify_expr (step, 1) == FAILURE
8126 || step->expr_type != EXPR_CONSTANT)
8128 gfc_error ("iterator step at %L does not simplify", &step->where);
8133 mpz_init_set (trip, end->value.integer);
8134 mpz_sub (trip, trip, start->value.integer);
8135 mpz_add (trip, trip, step->value.integer);
8137 mpz_div (trip, trip, step->value.integer);
8139 mpz_set (frame.value, start->value.integer);
8141 frame.prev = iter_stack;
8142 frame.variable = var->iter.var->symtree;
8143 iter_stack = &frame;
8145 while (mpz_cmp_ui (trip, 0) > 0)
8147 if (traverse_data_var (var->list, where) == FAILURE)
8154 e = gfc_copy_expr (var->expr);
8155 if (gfc_simplify_expr (e, 1) == FAILURE)
8163 mpz_add (frame.value, frame.value, step->value.integer);
8165 mpz_sub_ui (trip, trip, 1);
8170 mpz_clear (frame.value);
8172 gfc_free_expr (start);
8173 gfc_free_expr (end);
8174 gfc_free_expr (step);
8176 iter_stack = frame.prev;
8181 /* Type resolve variables in the variable list of a DATA statement. */
8184 traverse_data_var (gfc_data_variable *var, locus *where)
8188 for (; var; var = var->next)
8190 if (var->expr == NULL)
8191 t = traverse_data_list (var, where);
8193 t = check_data_variable (var, where);
8203 /* Resolve the expressions and iterators associated with a data statement.
8204 This is separate from the assignment checking because data lists should
8205 only be resolved once. */
8208 resolve_data_variables (gfc_data_variable *d)
8210 for (; d; d = d->next)
8212 if (d->list == NULL)
8214 if (gfc_resolve_expr (d->expr) == FAILURE)
8219 if (gfc_resolve_iterator (&d->iter, false) == FAILURE)
8222 if (resolve_data_variables (d->list) == FAILURE)
8231 /* Resolve a single DATA statement. We implement this by storing a pointer to
8232 the value list into static variables, and then recursively traversing the
8233 variables list, expanding iterators and such. */
8236 resolve_data (gfc_data *d)
8239 if (resolve_data_variables (d->var) == FAILURE)
8242 values.vnode = d->value;
8243 if (d->value == NULL)
8244 mpz_set_ui (values.left, 0);
8246 mpz_set (values.left, d->value->repeat);
8248 if (traverse_data_var (d->var, &d->where) == FAILURE)
8251 /* At this point, we better not have any values left. */
8253 if (next_data_value () == SUCCESS)
8254 gfc_error ("DATA statement at %L has more values than variables",
8259 /* 12.6 Constraint: In a pure subprogram any variable which is in common or
8260 accessed by host or use association, is a dummy argument to a pure function,
8261 is a dummy argument with INTENT (IN) to a pure subroutine, or an object that
8262 is storage associated with any such variable, shall not be used in the
8263 following contexts: (clients of this function). */
8265 /* Determines if a variable is not 'pure', ie not assignable within a pure
8266 procedure. Returns zero if assignment is OK, nonzero if there is a
8269 gfc_impure_variable (gfc_symbol *sym)
8273 if (sym->attr.use_assoc || sym->attr.in_common)
8276 if (sym->ns != gfc_current_ns)
8277 return !sym->attr.function;
8279 proc = sym->ns->proc_name;
8280 if (sym->attr.dummy && gfc_pure (proc)
8281 && ((proc->attr.subroutine && sym->attr.intent == INTENT_IN)
8283 proc->attr.function))
8286 /* TODO: Sort out what can be storage associated, if anything, and include
8287 it here. In principle equivalences should be scanned but it does not
8288 seem to be possible to storage associate an impure variable this way. */
8293 /* Test whether a symbol is pure or not. For a NULL pointer, checks the
8294 symbol of the current procedure. */
8297 gfc_pure (gfc_symbol *sym)
8299 symbol_attribute attr;
8302 sym = gfc_current_ns->proc_name;
8308 return attr.flavor == FL_PROCEDURE && (attr.pure || attr.elemental);
8312 /* Test whether the current procedure is elemental or not. */
8315 gfc_elemental (gfc_symbol *sym)
8317 symbol_attribute attr;
8320 sym = gfc_current_ns->proc_name;
8325 return attr.flavor == FL_PROCEDURE && attr.elemental;
8329 /* Warn about unused labels. */
8332 warn_unused_fortran_label (gfc_st_label *label)
8337 warn_unused_fortran_label (label->left);
8339 if (label->defined == ST_LABEL_UNKNOWN)
8342 switch (label->referenced)
8344 case ST_LABEL_UNKNOWN:
8345 gfc_warning ("Label %d at %L defined but not used", label->value,
8349 case ST_LABEL_BAD_TARGET:
8350 gfc_warning ("Label %d at %L defined but cannot be used",
8351 label->value, &label->where);
8358 warn_unused_fortran_label (label->right);
8362 /* Returns the sequence type of a symbol or sequence. */
8365 sequence_type (gfc_typespec ts)
8374 if (ts.derived->components == NULL)
8375 return SEQ_NONDEFAULT;
8377 result = sequence_type (ts.derived->components->ts);
8378 for (c = ts.derived->components->next; c; c = c->next)
8379 if (sequence_type (c->ts) != result)
8385 if (ts.kind != gfc_default_character_kind)
8386 return SEQ_NONDEFAULT;
8388 return SEQ_CHARACTER;
8391 if (ts.kind != gfc_default_integer_kind)
8392 return SEQ_NONDEFAULT;
8397 if (!(ts.kind == gfc_default_real_kind
8398 || ts.kind == gfc_default_double_kind))
8399 return SEQ_NONDEFAULT;
8404 if (ts.kind != gfc_default_complex_kind)
8405 return SEQ_NONDEFAULT;
8410 if (ts.kind != gfc_default_logical_kind)
8411 return SEQ_NONDEFAULT;
8416 return SEQ_NONDEFAULT;
8421 /* Resolve derived type EQUIVALENCE object. */
8424 resolve_equivalence_derived (gfc_symbol *derived, gfc_symbol *sym, gfc_expr *e)
8427 gfc_component *c = derived->components;
8432 /* Shall not be an object of nonsequence derived type. */
8433 if (!derived->attr.sequence)
8435 gfc_error ("Derived type variable '%s' at %L must have SEQUENCE "
8436 "attribute to be an EQUIVALENCE object", sym->name,
8441 /* Shall not have allocatable components. */
8442 if (derived->attr.alloc_comp)
8444 gfc_error ("Derived type variable '%s' at %L cannot have ALLOCATABLE "
8445 "components to be an EQUIVALENCE object",sym->name,
8450 for (; c ; c = c->next)
8454 && (resolve_equivalence_derived (c->ts.derived, sym, e) == FAILURE))
8457 /* Shall not be an object of sequence derived type containing a pointer
8458 in the structure. */
8461 gfc_error ("Derived type variable '%s' at %L with pointer "
8462 "component(s) cannot be an EQUIVALENCE object",
8463 sym->name, &e->where);
8471 /* Resolve equivalence object.
8472 An EQUIVALENCE object shall not be a dummy argument, a pointer, a target,
8473 an allocatable array, an object of nonsequence derived type, an object of
8474 sequence derived type containing a pointer at any level of component
8475 selection, an automatic object, a function name, an entry name, a result
8476 name, a named constant, a structure component, or a subobject of any of
8477 the preceding objects. A substring shall not have length zero. A
8478 derived type shall not have components with default initialization nor
8479 shall two objects of an equivalence group be initialized.
8480 Either all or none of the objects shall have an protected attribute.
8481 The simple constraints are done in symbol.c(check_conflict) and the rest
8482 are implemented here. */
8485 resolve_equivalence (gfc_equiv *eq)
8488 gfc_symbol *derived;
8489 gfc_symbol *first_sym;
8492 locus *last_where = NULL;
8493 seq_type eq_type, last_eq_type;
8494 gfc_typespec *last_ts;
8495 int object, cnt_protected;
8496 const char *value_name;
8500 last_ts = &eq->expr->symtree->n.sym->ts;
8502 first_sym = eq->expr->symtree->n.sym;
8506 for (object = 1; eq; eq = eq->eq, object++)
8510 e->ts = e->symtree->n.sym->ts;
8511 /* match_varspec might not know yet if it is seeing
8512 array reference or substring reference, as it doesn't
8514 if (e->ref && e->ref->type == REF_ARRAY)
8516 gfc_ref *ref = e->ref;
8517 sym = e->symtree->n.sym;
8519 if (sym->attr.dimension)
8521 ref->u.ar.as = sym->as;
8525 /* For substrings, convert REF_ARRAY into REF_SUBSTRING. */
8526 if (e->ts.type == BT_CHARACTER
8528 && ref->type == REF_ARRAY
8529 && ref->u.ar.dimen == 1
8530 && ref->u.ar.dimen_type[0] == DIMEN_RANGE
8531 && ref->u.ar.stride[0] == NULL)
8533 gfc_expr *start = ref->u.ar.start[0];
8534 gfc_expr *end = ref->u.ar.end[0];
8537 /* Optimize away the (:) reference. */
8538 if (start == NULL && end == NULL)
8543 e->ref->next = ref->next;
8548 ref->type = REF_SUBSTRING;
8550 start = gfc_int_expr (1);
8551 ref->u.ss.start = start;
8552 if (end == NULL && e->ts.cl)
8553 end = gfc_copy_expr (e->ts.cl->length);
8554 ref->u.ss.end = end;
8555 ref->u.ss.length = e->ts.cl;
8562 /* Any further ref is an error. */
8565 gcc_assert (ref->type == REF_ARRAY);
8566 gfc_error ("Syntax error in EQUIVALENCE statement at %L",
8572 if (gfc_resolve_expr (e) == FAILURE)
8575 sym = e->symtree->n.sym;
8577 if (sym->attr.protected)
8579 if (cnt_protected > 0 && cnt_protected != object)
8581 gfc_error ("Either all or none of the objects in the "
8582 "EQUIVALENCE set at %L shall have the "
8583 "PROTECTED attribute",
8588 /* Shall not equivalence common block variables in a PURE procedure. */
8589 if (sym->ns->proc_name
8590 && sym->ns->proc_name->attr.pure
8591 && sym->attr.in_common)
8593 gfc_error ("Common block member '%s' at %L cannot be an EQUIVALENCE "
8594 "object in the pure procedure '%s'",
8595 sym->name, &e->where, sym->ns->proc_name->name);
8599 /* Shall not be a named constant. */
8600 if (e->expr_type == EXPR_CONSTANT)
8602 gfc_error ("Named constant '%s' at %L cannot be an EQUIVALENCE "
8603 "object", sym->name, &e->where);
8607 derived = e->ts.derived;
8608 if (derived && resolve_equivalence_derived (derived, sym, e) == FAILURE)
8611 /* Check that the types correspond correctly:
8613 A numeric sequence structure may be equivalenced to another sequence
8614 structure, an object of default integer type, default real type, double
8615 precision real type, default logical type such that components of the
8616 structure ultimately only become associated to objects of the same
8617 kind. A character sequence structure may be equivalenced to an object
8618 of default character kind or another character sequence structure.
8619 Other objects may be equivalenced only to objects of the same type and
8622 /* Identical types are unconditionally OK. */
8623 if (object == 1 || gfc_compare_types (last_ts, &sym->ts))
8624 goto identical_types;
8626 last_eq_type = sequence_type (*last_ts);
8627 eq_type = sequence_type (sym->ts);
8629 /* Since the pair of objects is not of the same type, mixed or
8630 non-default sequences can be rejected. */
8632 msg = "Sequence %s with mixed components in EQUIVALENCE "
8633 "statement at %L with different type objects";
8635 && last_eq_type == SEQ_MIXED
8636 && gfc_notify_std (GFC_STD_GNU, msg, first_sym->name, last_where)
8638 || (eq_type == SEQ_MIXED
8639 && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
8640 &e->where) == FAILURE))
8643 msg = "Non-default type object or sequence %s in EQUIVALENCE "
8644 "statement at %L with objects of different type";
8646 && last_eq_type == SEQ_NONDEFAULT
8647 && gfc_notify_std (GFC_STD_GNU, msg, first_sym->name,
8648 last_where) == FAILURE)
8649 || (eq_type == SEQ_NONDEFAULT
8650 && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
8651 &e->where) == FAILURE))
8654 msg ="Non-CHARACTER object '%s' in default CHARACTER "
8655 "EQUIVALENCE statement at %L";
8656 if (last_eq_type == SEQ_CHARACTER
8657 && eq_type != SEQ_CHARACTER
8658 && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
8659 &e->where) == FAILURE)
8662 msg ="Non-NUMERIC object '%s' in default NUMERIC "
8663 "EQUIVALENCE statement at %L";
8664 if (last_eq_type == SEQ_NUMERIC
8665 && eq_type != SEQ_NUMERIC
8666 && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
8667 &e->where) == FAILURE)
8672 last_where = &e->where;
8677 /* Shall not be an automatic array. */
8678 if (e->ref->type == REF_ARRAY
8679 && gfc_resolve_array_spec (e->ref->u.ar.as, 1) == FAILURE)
8681 gfc_error ("Array '%s' at %L with non-constant bounds cannot be "
8682 "an EQUIVALENCE object", sym->name, &e->where);
8689 /* Shall not be a structure component. */
8690 if (r->type == REF_COMPONENT)
8692 gfc_error ("Structure component '%s' at %L cannot be an "
8693 "EQUIVALENCE object",
8694 r->u.c.component->name, &e->where);
8698 /* A substring shall not have length zero. */
8699 if (r->type == REF_SUBSTRING)
8701 if (compare_bound (r->u.ss.start, r->u.ss.end) == CMP_GT)
8703 gfc_error ("Substring at %L has length zero",
8704 &r->u.ss.start->where);
8714 /* Resolve function and ENTRY types, issue diagnostics if needed. */
8717 resolve_fntype (gfc_namespace *ns)
8722 if (ns->proc_name == NULL || !ns->proc_name->attr.function)
8725 /* If there are any entries, ns->proc_name is the entry master
8726 synthetic symbol and ns->entries->sym actual FUNCTION symbol. */
8728 sym = ns->entries->sym;
8730 sym = ns->proc_name;
8731 if (sym->result == sym
8732 && sym->ts.type == BT_UNKNOWN
8733 && gfc_set_default_type (sym, 0, NULL) == FAILURE
8734 && !sym->attr.untyped)
8736 gfc_error ("Function '%s' at %L has no IMPLICIT type",
8737 sym->name, &sym->declared_at);
8738 sym->attr.untyped = 1;
8741 if (sym->ts.type == BT_DERIVED && !sym->ts.derived->attr.use_assoc
8742 && !gfc_check_access (sym->ts.derived->attr.access,
8743 sym->ts.derived->ns->default_access)
8744 && gfc_check_access (sym->attr.access, sym->ns->default_access))
8746 gfc_error ("PUBLIC function '%s' at %L cannot be of PRIVATE type '%s'",
8747 sym->name, &sym->declared_at, sym->ts.derived->name);
8751 for (el = ns->entries->next; el; el = el->next)
8753 if (el->sym->result == el->sym
8754 && el->sym->ts.type == BT_UNKNOWN
8755 && gfc_set_default_type (el->sym, 0, NULL) == FAILURE
8756 && !el->sym->attr.untyped)
8758 gfc_error ("ENTRY '%s' at %L has no IMPLICIT type",
8759 el->sym->name, &el->sym->declared_at);
8760 el->sym->attr.untyped = 1;
8765 /* 12.3.2.1.1 Defined operators. */
8768 gfc_resolve_uops (gfc_symtree *symtree)
8772 gfc_formal_arglist *formal;
8774 if (symtree == NULL)
8777 gfc_resolve_uops (symtree->left);
8778 gfc_resolve_uops (symtree->right);
8780 for (itr = symtree->n.uop->operator; itr; itr = itr->next)
8783 if (!sym->attr.function)
8784 gfc_error ("User operator procedure '%s' at %L must be a FUNCTION",
8785 sym->name, &sym->declared_at);
8787 if (sym->ts.type == BT_CHARACTER
8788 && !(sym->ts.cl && sym->ts.cl->length)
8789 && !(sym->result && sym->result->ts.cl
8790 && sym->result->ts.cl->length))
8791 gfc_error ("User operator procedure '%s' at %L cannot be assumed "
8792 "character length", sym->name, &sym->declared_at);
8794 formal = sym->formal;
8795 if (!formal || !formal->sym)
8797 gfc_error ("User operator procedure '%s' at %L must have at least "
8798 "one argument", sym->name, &sym->declared_at);
8802 if (formal->sym->attr.intent != INTENT_IN)
8803 gfc_error ("First argument of operator interface at %L must be "
8804 "INTENT(IN)", &sym->declared_at);
8806 if (formal->sym->attr.optional)
8807 gfc_error ("First argument of operator interface at %L cannot be "
8808 "optional", &sym->declared_at);
8810 formal = formal->next;
8811 if (!formal || !formal->sym)
8814 if (formal->sym->attr.intent != INTENT_IN)
8815 gfc_error ("Second argument of operator interface at %L must be "
8816 "INTENT(IN)", &sym->declared_at);
8818 if (formal->sym->attr.optional)
8819 gfc_error ("Second argument of operator interface at %L cannot be "
8820 "optional", &sym->declared_at);
8823 gfc_error ("Operator interface at %L must have, at most, two "
8824 "arguments", &sym->declared_at);
8829 /* Examine all of the expressions associated with a program unit,
8830 assign types to all intermediate expressions, make sure that all
8831 assignments are to compatible types and figure out which names
8832 refer to which functions or subroutines. It doesn't check code
8833 block, which is handled by resolve_code. */
8836 resolve_types (gfc_namespace *ns)
8843 gfc_current_ns = ns;
8845 resolve_entries (ns);
8847 resolve_common_blocks (ns->common_root);
8849 resolve_contained_functions (ns);
8851 gfc_traverse_ns (ns, resolve_bind_c_derived_types);
8853 for (cl = ns->cl_list; cl; cl = cl->next)
8854 resolve_charlen (cl);
8856 gfc_traverse_ns (ns, resolve_symbol);
8858 resolve_fntype (ns);
8860 for (n = ns->contained; n; n = n->sibling)
8862 if (gfc_pure (ns->proc_name) && !gfc_pure (n->proc_name))
8863 gfc_error ("Contained procedure '%s' at %L of a PURE procedure must "
8864 "also be PURE", n->proc_name->name,
8865 &n->proc_name->declared_at);
8871 gfc_check_interfaces (ns);
8873 gfc_traverse_ns (ns, resolve_values);
8879 for (d = ns->data; d; d = d->next)
8883 gfc_traverse_ns (ns, gfc_formalize_init_value);
8885 gfc_traverse_ns (ns, gfc_verify_binding_labels);
8887 if (ns->common_root != NULL)
8888 gfc_traverse_symtree (ns->common_root, resolve_bind_c_comms);
8890 for (eq = ns->equiv; eq; eq = eq->next)
8891 resolve_equivalence (eq);
8893 /* Warn about unused labels. */
8894 if (warn_unused_label)
8895 warn_unused_fortran_label (ns->st_labels);
8897 gfc_resolve_uops (ns->uop_root);
8901 /* Call resolve_code recursively. */
8904 resolve_codes (gfc_namespace *ns)
8908 for (n = ns->contained; n; n = n->sibling)
8911 gfc_current_ns = ns;
8913 /* Set to an out of range value. */
8914 current_entry_id = -1;
8916 bitmap_obstack_initialize (&labels_obstack);
8917 resolve_code (ns->code, ns);
8918 bitmap_obstack_release (&labels_obstack);
8922 /* This function is called after a complete program unit has been compiled.
8923 Its purpose is to examine all of the expressions associated with a program
8924 unit, assign types to all intermediate expressions, make sure that all
8925 assignments are to compatible types and figure out which names refer to
8926 which functions or subroutines. */
8929 gfc_resolve (gfc_namespace *ns)
8931 gfc_namespace *old_ns;
8933 old_ns = gfc_current_ns;
8938 gfc_current_ns = old_ns;