1 /* Perform type resolution on the various stuctures.
2 Copyright (C) 2001, 2002, 2003, 2004, 2005, 2006, 2007
3 Free Software Foundation, Inc.
4 Contributed by Andy Vaught
6 This file is part of GCC.
8 GCC is free software; you can redistribute it and/or modify it under
9 the terms of the GNU General Public License as published by the Free
10 Software Foundation; either version 2, or (at your option) any later
13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
14 WARRANTY; without even the implied warranty of MERCHANTABILITY or
15 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
18 You should have received a copy of the GNU General Public License
19 along with GCC; see the file COPYING. If not, write to the Free
20 Software Foundation, 51 Franklin Street, Fifth Floor,Boston, MA
27 #include "arith.h" /* For gfc_compare_expr(). */
28 #include "dependency.h"
30 /* Types used in equivalence statements. */
34 SEQ_NONDEFAULT
, SEQ_NUMERIC
, SEQ_CHARACTER
, SEQ_MIXED
38 /* Stack to push the current if we descend into a block during
39 resolution. See resolve_branch() and resolve_code(). */
41 typedef struct code_stack
43 struct gfc_code
*head
, *current
;
44 struct code_stack
*prev
;
48 static code_stack
*cs_base
= NULL
;
51 /* Nonzero if we're inside a FORALL block. */
53 static int forall_flag
;
55 /* Nonzero if we're inside a OpenMP WORKSHARE or PARALLEL WORKSHARE block. */
57 static int omp_workshare_flag
;
59 /* Nonzero if we are processing a formal arglist. The corresponding function
60 resets the flag each time that it is read. */
61 static int formal_arg_flag
= 0;
63 /* True if we are resolving a specification expression. */
64 static int specification_expr
= 0;
66 /* The id of the last entry seen. */
67 static int current_entry_id
;
70 gfc_is_formal_arg (void)
72 return formal_arg_flag
;
75 /* Resolve types of formal argument lists. These have to be done early so that
76 the formal argument lists of module procedures can be copied to the
77 containing module before the individual procedures are resolved
78 individually. We also resolve argument lists of procedures in interface
79 blocks because they are self-contained scoping units.
81 Since a dummy argument cannot be a non-dummy procedure, the only
82 resort left for untyped names are the IMPLICIT types. */
85 resolve_formal_arglist (gfc_symbol
*proc
)
87 gfc_formal_arglist
*f
;
91 if (proc
->result
!= NULL
)
96 if (gfc_elemental (proc
)
97 || sym
->attr
.pointer
|| sym
->attr
.allocatable
98 || (sym
->as
&& sym
->as
->rank
> 0))
99 proc
->attr
.always_explicit
= 1;
103 for (f
= proc
->formal
; f
; f
= f
->next
)
109 /* Alternate return placeholder. */
110 if (gfc_elemental (proc
))
111 gfc_error ("Alternate return specifier in elemental subroutine "
112 "'%s' at %L is not allowed", proc
->name
,
114 if (proc
->attr
.function
)
115 gfc_error ("Alternate return specifier in function "
116 "'%s' at %L is not allowed", proc
->name
,
121 if (sym
->attr
.if_source
!= IFSRC_UNKNOWN
)
122 resolve_formal_arglist (sym
);
124 if (sym
->attr
.subroutine
|| sym
->attr
.external
|| sym
->attr
.intrinsic
)
126 if (gfc_pure (proc
) && !gfc_pure (sym
))
128 gfc_error ("Dummy procedure '%s' of PURE procedure at %L must "
129 "also be PURE", sym
->name
, &sym
->declared_at
);
133 if (gfc_elemental (proc
))
135 gfc_error ("Dummy procedure at %L not allowed in ELEMENTAL "
136 "procedure", &sym
->declared_at
);
140 if (sym
->attr
.function
141 && sym
->ts
.type
== BT_UNKNOWN
142 && sym
->attr
.intrinsic
)
144 gfc_intrinsic_sym
*isym
;
145 isym
= gfc_find_function (sym
->name
);
146 if (isym
== NULL
|| !isym
->specific
)
148 gfc_error ("Unable to find a specific INTRINSIC procedure "
149 "for the reference '%s' at %L", sym
->name
,
158 if (sym
->ts
.type
== BT_UNKNOWN
)
160 if (!sym
->attr
.function
|| sym
->result
== sym
)
161 gfc_set_default_type (sym
, 1, sym
->ns
);
164 gfc_resolve_array_spec (sym
->as
, 0);
166 /* We can't tell if an array with dimension (:) is assumed or deferred
167 shape until we know if it has the pointer or allocatable attributes.
169 if (sym
->as
&& sym
->as
->rank
> 0 && sym
->as
->type
== AS_DEFERRED
170 && !(sym
->attr
.pointer
|| sym
->attr
.allocatable
))
172 sym
->as
->type
= AS_ASSUMED_SHAPE
;
173 for (i
= 0; i
< sym
->as
->rank
; i
++)
174 sym
->as
->lower
[i
] = gfc_int_expr (1);
177 if ((sym
->as
&& sym
->as
->rank
> 0 && sym
->as
->type
== AS_ASSUMED_SHAPE
)
178 || sym
->attr
.pointer
|| sym
->attr
.allocatable
|| sym
->attr
.target
179 || sym
->attr
.optional
)
180 proc
->attr
.always_explicit
= 1;
182 /* If the flavor is unknown at this point, it has to be a variable.
183 A procedure specification would have already set the type. */
185 if (sym
->attr
.flavor
== FL_UNKNOWN
)
186 gfc_add_flavor (&sym
->attr
, FL_VARIABLE
, sym
->name
, &sym
->declared_at
);
188 if (gfc_pure (proc
) && !sym
->attr
.pointer
189 && sym
->attr
.flavor
!= FL_PROCEDURE
)
191 if (proc
->attr
.function
&& sym
->attr
.intent
!= INTENT_IN
)
192 gfc_error ("Argument '%s' of pure function '%s' at %L must be "
193 "INTENT(IN)", sym
->name
, proc
->name
,
196 if (proc
->attr
.subroutine
&& sym
->attr
.intent
== INTENT_UNKNOWN
)
197 gfc_error ("Argument '%s' of pure subroutine '%s' at %L must "
198 "have its INTENT specified", sym
->name
, proc
->name
,
202 if (gfc_elemental (proc
))
206 gfc_error ("Argument '%s' of elemental procedure at %L must "
207 "be scalar", sym
->name
, &sym
->declared_at
);
211 if (sym
->attr
.pointer
)
213 gfc_error ("Argument '%s' of elemental procedure at %L cannot "
214 "have the POINTER attribute", sym
->name
,
220 /* Each dummy shall be specified to be scalar. */
221 if (proc
->attr
.proc
== PROC_ST_FUNCTION
)
225 gfc_error ("Argument '%s' of statement function at %L must "
226 "be scalar", sym
->name
, &sym
->declared_at
);
230 if (sym
->ts
.type
== BT_CHARACTER
)
232 gfc_charlen
*cl
= sym
->ts
.cl
;
233 if (!cl
|| !cl
->length
|| cl
->length
->expr_type
!= EXPR_CONSTANT
)
235 gfc_error ("Character-valued argument '%s' of statement "
236 "function at %L must have constant length",
237 sym
->name
, &sym
->declared_at
);
247 /* Work function called when searching for symbols that have argument lists
248 associated with them. */
251 find_arglists (gfc_symbol
*sym
)
253 if (sym
->attr
.if_source
== IFSRC_UNKNOWN
|| sym
->ns
!= gfc_current_ns
)
256 resolve_formal_arglist (sym
);
260 /* Given a namespace, resolve all formal argument lists within the namespace.
264 resolve_formal_arglists (gfc_namespace
*ns
)
269 gfc_traverse_ns (ns
, find_arglists
);
274 resolve_contained_fntype (gfc_symbol
*sym
, gfc_namespace
*ns
)
278 /* If this namespace is not a function, ignore it. */
279 if (! sym
|| !(sym
->attr
.function
|| sym
->attr
.flavor
== FL_VARIABLE
))
282 /* Try to find out of what the return type is. */
283 if (sym
->result
!= NULL
)
286 if (sym
->ts
.type
== BT_UNKNOWN
)
288 t
= gfc_set_default_type (sym
, 0, ns
);
290 if (t
== FAILURE
&& !sym
->attr
.untyped
)
292 gfc_error ("Contained function '%s' at %L has no IMPLICIT type",
293 sym
->name
, &sym
->declared_at
); /* FIXME */
294 sym
->attr
.untyped
= 1;
298 /* Fortran 95 Draft Standard, page 51, Section 5.1.1.5, on the Character
299 type, lists the only ways a character length value of * can be used:
300 dummy arguments of procedures, named constants, and function results
301 in external functions. Internal function results are not on that list;
302 ergo, not permitted. */
304 if (sym
->ts
.type
== BT_CHARACTER
)
306 gfc_charlen
*cl
= sym
->ts
.cl
;
307 if (!cl
|| !cl
->length
)
308 gfc_error ("Character-valued internal function '%s' at %L must "
309 "not be assumed length", sym
->name
, &sym
->declared_at
);
314 /* Add NEW_ARGS to the formal argument list of PROC, taking care not to
315 introduce duplicates. */
318 merge_argument_lists (gfc_symbol
*proc
, gfc_formal_arglist
*new_args
)
320 gfc_formal_arglist
*f
, *new_arglist
;
323 for (; new_args
!= NULL
; new_args
= new_args
->next
)
325 new_sym
= new_args
->sym
;
326 /* See if this arg is already in the formal argument list. */
327 for (f
= proc
->formal
; f
; f
= f
->next
)
329 if (new_sym
== f
->sym
)
336 /* Add a new argument. Argument order is not important. */
337 new_arglist
= gfc_get_formal_arglist ();
338 new_arglist
->sym
= new_sym
;
339 new_arglist
->next
= proc
->formal
;
340 proc
->formal
= new_arglist
;
345 /* Flag the arguments that are not present in all entries. */
348 check_argument_lists (gfc_symbol
*proc
, gfc_formal_arglist
*new_args
)
350 gfc_formal_arglist
*f
, *head
;
353 for (f
= proc
->formal
; f
; f
= f
->next
)
358 for (new_args
= head
; new_args
; new_args
= new_args
->next
)
360 if (new_args
->sym
== f
->sym
)
367 f
->sym
->attr
.not_always_present
= 1;
372 /* Resolve alternate entry points. If a symbol has multiple entry points we
373 create a new master symbol for the main routine, and turn the existing
374 symbol into an entry point. */
377 resolve_entries (gfc_namespace
*ns
)
379 gfc_namespace
*old_ns
;
383 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
384 static int master_count
= 0;
386 if (ns
->proc_name
== NULL
)
389 /* No need to do anything if this procedure doesn't have alternate entry
394 /* We may already have resolved alternate entry points. */
395 if (ns
->proc_name
->attr
.entry_master
)
398 /* If this isn't a procedure something has gone horribly wrong. */
399 gcc_assert (ns
->proc_name
->attr
.flavor
== FL_PROCEDURE
);
401 /* Remember the current namespace. */
402 old_ns
= gfc_current_ns
;
406 /* Add the main entry point to the list of entry points. */
407 el
= gfc_get_entry_list ();
408 el
->sym
= ns
->proc_name
;
410 el
->next
= ns
->entries
;
412 ns
->proc_name
->attr
.entry
= 1;
414 /* If it is a module function, it needs to be in the right namespace
415 so that gfc_get_fake_result_decl can gather up the results. The
416 need for this arose in get_proc_name, where these beasts were
417 left in their own namespace, to keep prior references linked to
418 the entry declaration.*/
419 if (ns
->proc_name
->attr
.function
420 && ns
->parent
&& ns
->parent
->proc_name
->attr
.flavor
== FL_MODULE
)
423 /* Add an entry statement for it. */
430 /* Create a new symbol for the master function. */
431 /* Give the internal function a unique name (within this file).
432 Also include the function name so the user has some hope of figuring
433 out what is going on. */
434 snprintf (name
, GFC_MAX_SYMBOL_LEN
, "master.%d.%s",
435 master_count
++, ns
->proc_name
->name
);
436 gfc_get_ha_symbol (name
, &proc
);
437 gcc_assert (proc
!= NULL
);
439 gfc_add_procedure (&proc
->attr
, PROC_INTERNAL
, proc
->name
, NULL
);
440 if (ns
->proc_name
->attr
.subroutine
)
441 gfc_add_subroutine (&proc
->attr
, proc
->name
, NULL
);
445 gfc_typespec
*ts
, *fts
;
446 gfc_array_spec
*as
, *fas
;
447 gfc_add_function (&proc
->attr
, proc
->name
, NULL
);
449 fas
= ns
->entries
->sym
->as
;
450 fas
= fas
? fas
: ns
->entries
->sym
->result
->as
;
451 fts
= &ns
->entries
->sym
->result
->ts
;
452 if (fts
->type
== BT_UNKNOWN
)
453 fts
= gfc_get_default_type (ns
->entries
->sym
->result
, NULL
);
454 for (el
= ns
->entries
->next
; el
; el
= el
->next
)
456 ts
= &el
->sym
->result
->ts
;
458 as
= as
? as
: el
->sym
->result
->as
;
459 if (ts
->type
== BT_UNKNOWN
)
460 ts
= gfc_get_default_type (el
->sym
->result
, NULL
);
462 if (! gfc_compare_types (ts
, fts
)
463 || (el
->sym
->result
->attr
.dimension
464 != ns
->entries
->sym
->result
->attr
.dimension
)
465 || (el
->sym
->result
->attr
.pointer
466 != ns
->entries
->sym
->result
->attr
.pointer
))
469 else if (as
&& fas
&& gfc_compare_array_spec (as
, fas
) == 0)
470 gfc_error ("Procedure %s at %L has entries with mismatched "
471 "array specifications", ns
->entries
->sym
->name
,
472 &ns
->entries
->sym
->declared_at
);
477 sym
= ns
->entries
->sym
->result
;
478 /* All result types the same. */
480 if (sym
->attr
.dimension
)
481 gfc_set_array_spec (proc
, gfc_copy_array_spec (sym
->as
), NULL
);
482 if (sym
->attr
.pointer
)
483 gfc_add_pointer (&proc
->attr
, NULL
);
487 /* Otherwise the result will be passed through a union by
489 proc
->attr
.mixed_entry_master
= 1;
490 for (el
= ns
->entries
; el
; el
= el
->next
)
492 sym
= el
->sym
->result
;
493 if (sym
->attr
.dimension
)
495 if (el
== ns
->entries
)
496 gfc_error ("FUNCTION result %s can't be an array in "
497 "FUNCTION %s at %L", sym
->name
,
498 ns
->entries
->sym
->name
, &sym
->declared_at
);
500 gfc_error ("ENTRY result %s can't be an array in "
501 "FUNCTION %s at %L", sym
->name
,
502 ns
->entries
->sym
->name
, &sym
->declared_at
);
504 else if (sym
->attr
.pointer
)
506 if (el
== ns
->entries
)
507 gfc_error ("FUNCTION result %s can't be a POINTER in "
508 "FUNCTION %s at %L", sym
->name
,
509 ns
->entries
->sym
->name
, &sym
->declared_at
);
511 gfc_error ("ENTRY result %s can't be a POINTER in "
512 "FUNCTION %s at %L", sym
->name
,
513 ns
->entries
->sym
->name
, &sym
->declared_at
);
518 if (ts
->type
== BT_UNKNOWN
)
519 ts
= gfc_get_default_type (sym
, NULL
);
523 if (ts
->kind
== gfc_default_integer_kind
)
527 if (ts
->kind
== gfc_default_real_kind
528 || ts
->kind
== gfc_default_double_kind
)
532 if (ts
->kind
== gfc_default_complex_kind
)
536 if (ts
->kind
== gfc_default_logical_kind
)
540 /* We will issue error elsewhere. */
548 if (el
== ns
->entries
)
549 gfc_error ("FUNCTION result %s can't be of type %s "
550 "in FUNCTION %s at %L", sym
->name
,
551 gfc_typename (ts
), ns
->entries
->sym
->name
,
554 gfc_error ("ENTRY result %s can't be of type %s "
555 "in FUNCTION %s at %L", sym
->name
,
556 gfc_typename (ts
), ns
->entries
->sym
->name
,
563 proc
->attr
.access
= ACCESS_PRIVATE
;
564 proc
->attr
.entry_master
= 1;
566 /* Merge all the entry point arguments. */
567 for (el
= ns
->entries
; el
; el
= el
->next
)
568 merge_argument_lists (proc
, el
->sym
->formal
);
570 /* Check the master formal arguments for any that are not
571 present in all entry points. */
572 for (el
= ns
->entries
; el
; el
= el
->next
)
573 check_argument_lists (proc
, el
->sym
->formal
);
575 /* Use the master function for the function body. */
576 ns
->proc_name
= proc
;
578 /* Finalize the new symbols. */
579 gfc_commit_symbols ();
581 /* Restore the original namespace. */
582 gfc_current_ns
= old_ns
;
586 /* Resolve contained function types. Because contained functions can call one
587 another, they have to be worked out before any of the contained procedures
590 The good news is that if a function doesn't already have a type, the only
591 way it can get one is through an IMPLICIT type or a RESULT variable, because
592 by definition contained functions are contained namespace they're contained
593 in, not in a sibling or parent namespace. */
596 resolve_contained_functions (gfc_namespace
*ns
)
598 gfc_namespace
*child
;
601 resolve_formal_arglists (ns
);
603 for (child
= ns
->contained
; child
; child
= child
->sibling
)
605 /* Resolve alternate entry points first. */
606 resolve_entries (child
);
608 /* Then check function return types. */
609 resolve_contained_fntype (child
->proc_name
, child
);
610 for (el
= child
->entries
; el
; el
= el
->next
)
611 resolve_contained_fntype (el
->sym
, child
);
616 /* Resolve all of the elements of a structure constructor and make sure that
617 the types are correct. */
620 resolve_structure_cons (gfc_expr
*expr
)
622 gfc_constructor
*cons
;
628 cons
= expr
->value
.constructor
;
629 /* A constructor may have references if it is the result of substituting a
630 parameter variable. In this case we just pull out the component we
633 comp
= expr
->ref
->u
.c
.sym
->components
;
635 comp
= expr
->ts
.derived
->components
;
637 for (; comp
; comp
= comp
->next
, cons
= cons
->next
)
642 if (gfc_resolve_expr (cons
->expr
) == FAILURE
)
648 if (cons
->expr
->expr_type
!= EXPR_NULL
649 && comp
->as
&& comp
->as
->rank
!= cons
->expr
->rank
650 && (comp
->allocatable
|| cons
->expr
->rank
))
652 gfc_error ("The rank of the element in the derived type "
653 "constructor at %L does not match that of the "
654 "component (%d/%d)", &cons
->expr
->where
,
655 cons
->expr
->rank
, comp
->as
? comp
->as
->rank
: 0);
659 /* If we don't have the right type, try to convert it. */
661 if (!gfc_compare_types (&cons
->expr
->ts
, &comp
->ts
))
664 if (comp
->pointer
&& cons
->expr
->ts
.type
!= BT_UNKNOWN
)
665 gfc_error ("The element in the derived type constructor at %L, "
666 "for pointer component '%s', is %s but should be %s",
667 &cons
->expr
->where
, comp
->name
,
668 gfc_basic_typename (cons
->expr
->ts
.type
),
669 gfc_basic_typename (comp
->ts
.type
));
671 t
= gfc_convert_type (cons
->expr
, &comp
->ts
, 1);
674 if (!comp
->pointer
|| cons
->expr
->expr_type
== EXPR_NULL
)
677 a
= gfc_expr_attr (cons
->expr
);
679 if (!a
.pointer
&& !a
.target
)
682 gfc_error ("The element in the derived type constructor at %L, "
683 "for pointer component '%s' should be a POINTER or "
684 "a TARGET", &cons
->expr
->where
, comp
->name
);
692 /****************** Expression name resolution ******************/
694 /* Returns 0 if a symbol was not declared with a type or
695 attribute declaration statement, nonzero otherwise. */
698 was_declared (gfc_symbol
*sym
)
704 if (!a
.implicit_type
&& sym
->ts
.type
!= BT_UNKNOWN
)
707 if (a
.allocatable
|| a
.dimension
|| a
.dummy
|| a
.external
|| a
.intrinsic
708 || a
.optional
|| a
.pointer
|| a
.save
|| a
.target
|| a
.volatile_
709 || a
.value
|| a
.access
!= ACCESS_UNKNOWN
|| a
.intent
!= INTENT_UNKNOWN
)
716 /* Determine if a symbol is generic or not. */
719 generic_sym (gfc_symbol
*sym
)
723 if (sym
->attr
.generic
||
724 (sym
->attr
.intrinsic
&& gfc_generic_intrinsic (sym
->name
)))
727 if (was_declared (sym
) || sym
->ns
->parent
== NULL
)
730 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &s
);
732 return (s
== NULL
) ? 0 : generic_sym (s
);
736 /* Determine if a symbol is specific or not. */
739 specific_sym (gfc_symbol
*sym
)
743 if (sym
->attr
.if_source
== IFSRC_IFBODY
744 || sym
->attr
.proc
== PROC_MODULE
745 || sym
->attr
.proc
== PROC_INTERNAL
746 || sym
->attr
.proc
== PROC_ST_FUNCTION
747 || (sym
->attr
.intrinsic
&& gfc_specific_intrinsic (sym
->name
))
748 || sym
->attr
.external
)
751 if (was_declared (sym
) || sym
->ns
->parent
== NULL
)
754 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &s
);
756 return (s
== NULL
) ? 0 : specific_sym (s
);
760 /* Figure out if the procedure is specific, generic or unknown. */
763 { PTYPE_GENERIC
= 1, PTYPE_SPECIFIC
, PTYPE_UNKNOWN
}
767 procedure_kind (gfc_symbol
*sym
)
769 if (generic_sym (sym
))
770 return PTYPE_GENERIC
;
772 if (specific_sym (sym
))
773 return PTYPE_SPECIFIC
;
775 return PTYPE_UNKNOWN
;
778 /* Check references to assumed size arrays. The flag need_full_assumed_size
779 is nonzero when matching actual arguments. */
781 static int need_full_assumed_size
= 0;
784 check_assumed_size_reference (gfc_symbol
*sym
, gfc_expr
*e
)
790 if (need_full_assumed_size
|| !(sym
->as
&& sym
->as
->type
== AS_ASSUMED_SIZE
))
793 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
794 if (ref
->type
== REF_ARRAY
)
795 for (dim
= 0; dim
< ref
->u
.ar
.as
->rank
; dim
++)
796 last
= (ref
->u
.ar
.end
[dim
] == NULL
)
797 && (ref
->u
.ar
.type
== DIMEN_ELEMENT
);
801 gfc_error ("The upper bound in the last dimension must "
802 "appear in the reference to the assumed size "
803 "array '%s' at %L", sym
->name
, &e
->where
);
810 /* Look for bad assumed size array references in argument expressions
811 of elemental and array valued intrinsic procedures. Since this is
812 called from procedure resolution functions, it only recurses at
816 resolve_assumed_size_actual (gfc_expr
*e
)
821 switch (e
->expr_type
)
824 if (e
->symtree
&& check_assumed_size_reference (e
->symtree
->n
.sym
, e
))
829 if (resolve_assumed_size_actual (e
->value
.op
.op1
)
830 || resolve_assumed_size_actual (e
->value
.op
.op2
))
841 /* Resolve an actual argument list. Most of the time, this is just
842 resolving the expressions in the list.
843 The exception is that we sometimes have to decide whether arguments
844 that look like procedure arguments are really simple variable
848 resolve_actual_arglist (gfc_actual_arglist
*arg
, procedure_type ptype
)
851 gfc_symtree
*parent_st
;
854 for (; arg
; arg
= arg
->next
)
859 /* Check the label is a valid branching target. */
862 if (arg
->label
->defined
== ST_LABEL_UNKNOWN
)
864 gfc_error ("Label %d referenced at %L is never defined",
865 arg
->label
->value
, &arg
->label
->where
);
872 if (e
->ts
.type
!= BT_PROCEDURE
)
874 if (gfc_resolve_expr (e
) != SUCCESS
)
879 /* See if the expression node should really be a variable reference. */
881 sym
= e
->symtree
->n
.sym
;
883 if (sym
->attr
.flavor
== FL_PROCEDURE
884 || sym
->attr
.intrinsic
885 || sym
->attr
.external
)
889 /* If a procedure is not already determined to be something else
890 check if it is intrinsic. */
891 if (!sym
->attr
.intrinsic
892 && !(sym
->attr
.external
|| sym
->attr
.use_assoc
893 || sym
->attr
.if_source
== IFSRC_IFBODY
)
894 && gfc_intrinsic_name (sym
->name
, sym
->attr
.subroutine
))
895 sym
->attr
.intrinsic
= 1;
897 if (sym
->attr
.proc
== PROC_ST_FUNCTION
)
899 gfc_error ("Statement function '%s' at %L is not allowed as an "
900 "actual argument", sym
->name
, &e
->where
);
903 actual_ok
= gfc_intrinsic_actual_ok (sym
->name
,
904 sym
->attr
.subroutine
);
905 if (sym
->attr
.intrinsic
&& actual_ok
== 0)
907 gfc_error ("Intrinsic '%s' at %L is not allowed as an "
908 "actual argument", sym
->name
, &e
->where
);
911 if (sym
->attr
.contained
&& !sym
->attr
.use_assoc
912 && sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
)
914 gfc_error ("Internal procedure '%s' is not allowed as an "
915 "actual argument at %L", sym
->name
, &e
->where
);
918 if (sym
->attr
.elemental
&& !sym
->attr
.intrinsic
)
920 gfc_error ("ELEMENTAL non-INTRINSIC procedure '%s' is not "
921 "allowed as an actual argument at %L", sym
->name
,
925 if (sym
->attr
.generic
)
927 gfc_error ("GENERIC non-INTRINSIC procedure '%s' is not "
928 "allowed as an actual argument at %L", sym
->name
,
932 /* If the symbol is the function that names the current (or
933 parent) scope, then we really have a variable reference. */
935 if (sym
->attr
.function
&& sym
->result
== sym
936 && (sym
->ns
->proc_name
== sym
937 || (sym
->ns
->parent
!= NULL
938 && sym
->ns
->parent
->proc_name
== sym
)))
941 /* If all else fails, see if we have a specific intrinsic. */
942 if (sym
->attr
.function
943 && sym
->ts
.type
== BT_UNKNOWN
&& sym
->attr
.intrinsic
)
945 gfc_intrinsic_sym
*isym
;
946 isym
= gfc_find_function (sym
->name
);
947 if (isym
== NULL
|| !isym
->specific
)
949 gfc_error ("Unable to find a specific INTRINSIC procedure "
950 "for the reference '%s' at %L", sym
->name
,
958 /* See if the name is a module procedure in a parent unit. */
960 if (was_declared (sym
) || sym
->ns
->parent
== NULL
)
963 if (gfc_find_sym_tree (sym
->name
, sym
->ns
->parent
, 1, &parent_st
))
965 gfc_error ("Symbol '%s' at %L is ambiguous", sym
->name
, &e
->where
);
969 if (parent_st
== NULL
)
972 sym
= parent_st
->n
.sym
;
973 e
->symtree
= parent_st
; /* Point to the right thing. */
975 if (sym
->attr
.flavor
== FL_PROCEDURE
976 || sym
->attr
.intrinsic
977 || sym
->attr
.external
)
983 e
->expr_type
= EXPR_VARIABLE
;
987 e
->rank
= sym
->as
->rank
;
988 e
->ref
= gfc_get_ref ();
989 e
->ref
->type
= REF_ARRAY
;
990 e
->ref
->u
.ar
.type
= AR_FULL
;
991 e
->ref
->u
.ar
.as
= sym
->as
;
995 /* Check argument list functions %VAL, %LOC and %REF. There is
996 nothing to do for %REF. */
997 if (arg
->name
&& arg
->name
[0] == '%')
999 if (strncmp ("%VAL", arg
->name
, 4) == 0)
1001 if (e
->ts
.type
== BT_CHARACTER
|| e
->ts
.type
== BT_DERIVED
)
1003 gfc_error ("By-value argument at %L is not of numeric "
1010 gfc_error ("By-value argument at %L cannot be an array or "
1011 "an array section", &e
->where
);
1015 /* Intrinsics are still PROC_UNKNOWN here. However,
1016 since same file external procedures are not resolvable
1017 in gfortran, it is a good deal easier to leave them to
1019 if (ptype
!= PROC_UNKNOWN
1020 && ptype
!= PROC_DUMMY
1021 && ptype
!= PROC_EXTERNAL
)
1023 gfc_error ("By-value argument at %L is not allowed "
1024 "in this context", &e
->where
);
1029 /* Statement functions have already been excluded above. */
1030 else if (strncmp ("%LOC", arg
->name
, 4) == 0
1031 && e
->ts
.type
== BT_PROCEDURE
)
1033 if (e
->symtree
->n
.sym
->attr
.proc
== PROC_INTERNAL
)
1035 gfc_error ("Passing internal procedure at %L by location "
1036 "not allowed", &e
->where
);
1047 /* Do the checks of the actual argument list that are specific to elemental
1048 procedures. If called with c == NULL, we have a function, otherwise if
1049 expr == NULL, we have a subroutine. */
1052 resolve_elemental_actual (gfc_expr
*expr
, gfc_code
*c
)
1054 gfc_actual_arglist
*arg0
;
1055 gfc_actual_arglist
*arg
;
1056 gfc_symbol
*esym
= NULL
;
1057 gfc_intrinsic_sym
*isym
= NULL
;
1059 gfc_intrinsic_arg
*iformal
= NULL
;
1060 gfc_formal_arglist
*eformal
= NULL
;
1061 bool formal_optional
= false;
1062 bool set_by_optional
= false;
1066 /* Is this an elemental procedure? */
1067 if (expr
&& expr
->value
.function
.actual
!= NULL
)
1069 if (expr
->value
.function
.esym
!= NULL
1070 && expr
->value
.function
.esym
->attr
.elemental
)
1072 arg0
= expr
->value
.function
.actual
;
1073 esym
= expr
->value
.function
.esym
;
1075 else if (expr
->value
.function
.isym
!= NULL
1076 && expr
->value
.function
.isym
->elemental
)
1078 arg0
= expr
->value
.function
.actual
;
1079 isym
= expr
->value
.function
.isym
;
1084 else if (c
&& c
->ext
.actual
!= NULL
&& c
->symtree
->n
.sym
->attr
.elemental
)
1086 arg0
= c
->ext
.actual
;
1087 esym
= c
->symtree
->n
.sym
;
1092 /* The rank of an elemental is the rank of its array argument(s). */
1093 for (arg
= arg0
; arg
; arg
= arg
->next
)
1095 if (arg
->expr
!= NULL
&& arg
->expr
->rank
> 0)
1097 rank
= arg
->expr
->rank
;
1098 if (arg
->expr
->expr_type
== EXPR_VARIABLE
1099 && arg
->expr
->symtree
->n
.sym
->attr
.optional
)
1100 set_by_optional
= true;
1102 /* Function specific; set the result rank and shape. */
1106 if (!expr
->shape
&& arg
->expr
->shape
)
1108 expr
->shape
= gfc_get_shape (rank
);
1109 for (i
= 0; i
< rank
; i
++)
1110 mpz_init_set (expr
->shape
[i
], arg
->expr
->shape
[i
]);
1117 /* If it is an array, it shall not be supplied as an actual argument
1118 to an elemental procedure unless an array of the same rank is supplied
1119 as an actual argument corresponding to a nonoptional dummy argument of
1120 that elemental procedure(12.4.1.5). */
1121 formal_optional
= false;
1123 iformal
= isym
->formal
;
1125 eformal
= esym
->formal
;
1127 for (arg
= arg0
; arg
; arg
= arg
->next
)
1131 if (eformal
->sym
&& eformal
->sym
->attr
.optional
)
1132 formal_optional
= true;
1133 eformal
= eformal
->next
;
1135 else if (isym
&& iformal
)
1137 if (iformal
->optional
)
1138 formal_optional
= true;
1139 iformal
= iformal
->next
;
1142 formal_optional
= true;
1144 if (pedantic
&& arg
->expr
!= NULL
1145 && arg
->expr
->expr_type
== EXPR_VARIABLE
1146 && arg
->expr
->symtree
->n
.sym
->attr
.optional
1149 && (set_by_optional
|| arg
->expr
->rank
!= rank
)
1150 && !(isym
&& isym
->generic_id
== GFC_ISYM_CONVERSION
))
1152 gfc_warning ("'%s' at %L is an array and OPTIONAL; IF IT IS "
1153 "MISSING, it cannot be the actual argument of an "
1154 "ELEMENTAL procedure unless there is a non-optional "
1155 "argument with the same rank (12.4.1.5)",
1156 arg
->expr
->symtree
->n
.sym
->name
, &arg
->expr
->where
);
1161 for (arg
= arg0
; arg
; arg
= arg
->next
)
1163 if (arg
->expr
== NULL
|| arg
->expr
->rank
== 0)
1166 /* Being elemental, the last upper bound of an assumed size array
1167 argument must be present. */
1168 if (resolve_assumed_size_actual (arg
->expr
))
1174 /* Elemental subroutine array actual arguments must conform. */
1177 if (gfc_check_conformance ("elemental subroutine", arg
->expr
, e
)
1189 /* Go through each actual argument in ACTUAL and see if it can be
1190 implemented as an inlined, non-copying intrinsic. FNSYM is the
1191 function being called, or NULL if not known. */
1194 find_noncopying_intrinsics (gfc_symbol
*fnsym
, gfc_actual_arglist
*actual
)
1196 gfc_actual_arglist
*ap
;
1199 for (ap
= actual
; ap
; ap
= ap
->next
)
1201 && (expr
= gfc_get_noncopying_intrinsic_argument (ap
->expr
))
1202 && !gfc_check_fncall_dependency (expr
, INTENT_IN
, fnsym
, actual
))
1203 ap
->expr
->inline_noncopying_intrinsic
= 1;
1207 /* This function does the checking of references to global procedures
1208 as defined in sections 18.1 and 14.1, respectively, of the Fortran
1209 77 and 95 standards. It checks for a gsymbol for the name, making
1210 one if it does not already exist. If it already exists, then the
1211 reference being resolved must correspond to the type of gsymbol.
1212 Otherwise, the new symbol is equipped with the attributes of the
1213 reference. The corresponding code that is called in creating
1214 global entities is parse.c. */
1217 resolve_global_procedure (gfc_symbol
*sym
, locus
*where
, int sub
)
1222 type
= sub
? GSYM_SUBROUTINE
: GSYM_FUNCTION
;
1224 gsym
= gfc_get_gsymbol (sym
->name
);
1226 if ((gsym
->type
!= GSYM_UNKNOWN
&& gsym
->type
!= type
))
1227 global_used (gsym
, where
);
1229 if (gsym
->type
== GSYM_UNKNOWN
)
1232 gsym
->where
= *where
;
1239 /************* Function resolution *************/
1241 /* Resolve a function call known to be generic.
1242 Section 14.1.2.4.1. */
1245 resolve_generic_f0 (gfc_expr
*expr
, gfc_symbol
*sym
)
1249 if (sym
->attr
.generic
)
1251 s
= gfc_search_interface (sym
->generic
, 0, &expr
->value
.function
.actual
);
1254 expr
->value
.function
.name
= s
->name
;
1255 expr
->value
.function
.esym
= s
;
1257 if (s
->ts
.type
!= BT_UNKNOWN
)
1259 else if (s
->result
!= NULL
&& s
->result
->ts
.type
!= BT_UNKNOWN
)
1260 expr
->ts
= s
->result
->ts
;
1263 expr
->rank
= s
->as
->rank
;
1264 else if (s
->result
!= NULL
&& s
->result
->as
!= NULL
)
1265 expr
->rank
= s
->result
->as
->rank
;
1270 /* TODO: Need to search for elemental references in generic
1274 if (sym
->attr
.intrinsic
)
1275 return gfc_intrinsic_func_interface (expr
, 0);
1282 resolve_generic_f (gfc_expr
*expr
)
1287 sym
= expr
->symtree
->n
.sym
;
1291 m
= resolve_generic_f0 (expr
, sym
);
1294 else if (m
== MATCH_ERROR
)
1298 if (sym
->ns
->parent
== NULL
)
1300 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &sym
);
1304 if (!generic_sym (sym
))
1308 /* Last ditch attempt. See if the reference is to an intrinsic
1309 that possesses a matching interface. 14.1.2.4 */
1310 if (sym
&& !gfc_intrinsic_name (sym
->name
, 0))
1312 gfc_error ("There is no specific function for the generic '%s' at %L",
1313 expr
->symtree
->n
.sym
->name
, &expr
->where
);
1317 m
= gfc_intrinsic_func_interface (expr
, 0);
1321 gfc_error ("Generic function '%s' at %L is not consistent with a "
1322 "specific intrinsic interface", expr
->symtree
->n
.sym
->name
,
1329 /* Resolve a function call known to be specific. */
1332 resolve_specific_f0 (gfc_symbol
*sym
, gfc_expr
*expr
)
1336 if (sym
->attr
.external
|| sym
->attr
.if_source
== IFSRC_IFBODY
)
1338 if (sym
->attr
.dummy
)
1340 sym
->attr
.proc
= PROC_DUMMY
;
1344 sym
->attr
.proc
= PROC_EXTERNAL
;
1348 if (sym
->attr
.proc
== PROC_MODULE
1349 || sym
->attr
.proc
== PROC_ST_FUNCTION
1350 || sym
->attr
.proc
== PROC_INTERNAL
)
1353 if (sym
->attr
.intrinsic
)
1355 m
= gfc_intrinsic_func_interface (expr
, 1);
1359 gfc_error ("Function '%s' at %L is INTRINSIC but is not compatible "
1360 "with an intrinsic", sym
->name
, &expr
->where
);
1368 gfc_procedure_use (sym
, &expr
->value
.function
.actual
, &expr
->where
);
1371 expr
->value
.function
.name
= sym
->name
;
1372 expr
->value
.function
.esym
= sym
;
1373 if (sym
->as
!= NULL
)
1374 expr
->rank
= sym
->as
->rank
;
1381 resolve_specific_f (gfc_expr
*expr
)
1386 sym
= expr
->symtree
->n
.sym
;
1390 m
= resolve_specific_f0 (sym
, expr
);
1393 if (m
== MATCH_ERROR
)
1396 if (sym
->ns
->parent
== NULL
)
1399 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &sym
);
1405 gfc_error ("Unable to resolve the specific function '%s' at %L",
1406 expr
->symtree
->n
.sym
->name
, &expr
->where
);
1412 /* Resolve a procedure call not known to be generic nor specific. */
1415 resolve_unknown_f (gfc_expr
*expr
)
1420 sym
= expr
->symtree
->n
.sym
;
1422 if (sym
->attr
.dummy
)
1424 sym
->attr
.proc
= PROC_DUMMY
;
1425 expr
->value
.function
.name
= sym
->name
;
1429 /* See if we have an intrinsic function reference. */
1431 if (gfc_intrinsic_name (sym
->name
, 0))
1433 if (gfc_intrinsic_func_interface (expr
, 1) == MATCH_YES
)
1438 /* The reference is to an external name. */
1440 sym
->attr
.proc
= PROC_EXTERNAL
;
1441 expr
->value
.function
.name
= sym
->name
;
1442 expr
->value
.function
.esym
= expr
->symtree
->n
.sym
;
1444 if (sym
->as
!= NULL
)
1445 expr
->rank
= sym
->as
->rank
;
1447 /* Type of the expression is either the type of the symbol or the
1448 default type of the symbol. */
1451 gfc_procedure_use (sym
, &expr
->value
.function
.actual
, &expr
->where
);
1453 if (sym
->ts
.type
!= BT_UNKNOWN
)
1457 ts
= gfc_get_default_type (sym
, sym
->ns
);
1459 if (ts
->type
== BT_UNKNOWN
)
1461 gfc_error ("Function '%s' at %L has no IMPLICIT type",
1462 sym
->name
, &expr
->where
);
1473 /* Figure out if a function reference is pure or not. Also set the name
1474 of the function for a potential error message. Return nonzero if the
1475 function is PURE, zero if not. */
1478 pure_function (gfc_expr
*e
, const char **name
)
1484 if (e
->symtree
!= NULL
1485 && e
->symtree
->n
.sym
!= NULL
1486 && e
->symtree
->n
.sym
->attr
.proc
== PROC_ST_FUNCTION
)
1489 if (e
->value
.function
.esym
)
1491 pure
= gfc_pure (e
->value
.function
.esym
);
1492 *name
= e
->value
.function
.esym
->name
;
1494 else if (e
->value
.function
.isym
)
1496 pure
= e
->value
.function
.isym
->pure
1497 || e
->value
.function
.isym
->elemental
;
1498 *name
= e
->value
.function
.isym
->name
;
1502 /* Implicit functions are not pure. */
1504 *name
= e
->value
.function
.name
;
1511 /* Resolve a function call, which means resolving the arguments, then figuring
1512 out which entity the name refers to. */
1513 /* TODO: Check procedure arguments so that an INTENT(IN) isn't passed
1514 to INTENT(OUT) or INTENT(INOUT). */
1517 resolve_function (gfc_expr
*expr
)
1519 gfc_actual_arglist
*arg
;
1524 procedure_type p
= PROC_INTRINSIC
;
1528 sym
= expr
->symtree
->n
.sym
;
1530 if (sym
&& sym
->attr
.flavor
== FL_VARIABLE
)
1532 gfc_error ("'%s' at %L is not a function", sym
->name
, &expr
->where
);
1536 /* If the procedure is not internal, a statement function or a module
1537 procedure,it must be external and should be checked for usage. */
1538 if (sym
&& !sym
->attr
.dummy
&& !sym
->attr
.contained
1539 && sym
->attr
.proc
!= PROC_ST_FUNCTION
1540 && !sym
->attr
.use_assoc
)
1541 resolve_global_procedure (sym
, &expr
->where
, 0);
1543 /* Switch off assumed size checking and do this again for certain kinds
1544 of procedure, once the procedure itself is resolved. */
1545 need_full_assumed_size
++;
1547 if (expr
->symtree
&& expr
->symtree
->n
.sym
)
1548 p
= expr
->symtree
->n
.sym
->attr
.proc
;
1550 if (resolve_actual_arglist (expr
->value
.function
.actual
, p
) == FAILURE
)
1553 /* Resume assumed_size checking. */
1554 need_full_assumed_size
--;
1556 if (sym
&& sym
->ts
.type
== BT_CHARACTER
1558 && sym
->ts
.cl
->length
== NULL
1560 && expr
->value
.function
.esym
== NULL
1561 && !sym
->attr
.contained
)
1563 /* Internal procedures are taken care of in resolve_contained_fntype. */
1564 gfc_error ("Function '%s' is declared CHARACTER(*) and cannot "
1565 "be used at %L since it is not a dummy argument",
1566 sym
->name
, &expr
->where
);
1570 /* See if function is already resolved. */
1572 if (expr
->value
.function
.name
!= NULL
)
1574 if (expr
->ts
.type
== BT_UNKNOWN
)
1580 /* Apply the rules of section 14.1.2. */
1582 switch (procedure_kind (sym
))
1585 t
= resolve_generic_f (expr
);
1588 case PTYPE_SPECIFIC
:
1589 t
= resolve_specific_f (expr
);
1593 t
= resolve_unknown_f (expr
);
1597 gfc_internal_error ("resolve_function(): bad function type");
1601 /* If the expression is still a function (it might have simplified),
1602 then we check to see if we are calling an elemental function. */
1604 if (expr
->expr_type
!= EXPR_FUNCTION
)
1607 temp
= need_full_assumed_size
;
1608 need_full_assumed_size
= 0;
1610 if (resolve_elemental_actual (expr
, NULL
) == FAILURE
)
1613 if (omp_workshare_flag
1614 && expr
->value
.function
.esym
1615 && ! gfc_elemental (expr
->value
.function
.esym
))
1617 gfc_error ("User defined non-ELEMENTAL function '%s' at %L not allowed "
1618 "in WORKSHARE construct", expr
->value
.function
.esym
->name
,
1623 #define GENERIC_ID expr->value.function.isym->generic_id
1624 else if (expr
->value
.function
.actual
!= NULL
1625 && expr
->value
.function
.isym
!= NULL
1626 && GENERIC_ID
!= GFC_ISYM_LBOUND
1627 && GENERIC_ID
!= GFC_ISYM_LEN
1628 && GENERIC_ID
!= GFC_ISYM_LOC
1629 && GENERIC_ID
!= GFC_ISYM_PRESENT
)
1631 /* Array intrinsics must also have the last upper bound of an
1632 assumed size array argument. UBOUND and SIZE have to be
1633 excluded from the check if the second argument is anything
1636 inquiry
= GENERIC_ID
== GFC_ISYM_UBOUND
1637 || GENERIC_ID
== GFC_ISYM_SIZE
;
1639 for (arg
= expr
->value
.function
.actual
; arg
; arg
= arg
->next
)
1641 if (inquiry
&& arg
->next
!= NULL
&& arg
->next
->expr
)
1643 if (arg
->next
->expr
->expr_type
!= EXPR_CONSTANT
)
1646 if ((int)mpz_get_si (arg
->next
->expr
->value
.integer
)
1651 if (arg
->expr
!= NULL
1652 && arg
->expr
->rank
> 0
1653 && resolve_assumed_size_actual (arg
->expr
))
1659 need_full_assumed_size
= temp
;
1662 if (!pure_function (expr
, &name
) && name
)
1666 gfc_error ("reference to non-PURE function '%s' at %L inside a "
1667 "FORALL %s", name
, &expr
->where
,
1668 forall_flag
== 2 ? "mask" : "block");
1671 else if (gfc_pure (NULL
))
1673 gfc_error ("Function reference to '%s' at %L is to a non-PURE "
1674 "procedure within a PURE procedure", name
, &expr
->where
);
1679 /* Functions without the RECURSIVE attribution are not allowed to
1680 * call themselves. */
1681 if (expr
->value
.function
.esym
&& !expr
->value
.function
.esym
->attr
.recursive
)
1683 gfc_symbol
*esym
, *proc
;
1684 esym
= expr
->value
.function
.esym
;
1685 proc
= gfc_current_ns
->proc_name
;
1688 gfc_error ("Function '%s' at %L cannot call itself, as it is not "
1689 "RECURSIVE", name
, &expr
->where
);
1693 if (esym
->attr
.entry
&& esym
->ns
->entries
&& proc
->ns
->entries
1694 && esym
->ns
->entries
->sym
== proc
->ns
->entries
->sym
)
1696 gfc_error ("Call to ENTRY '%s' at %L is recursive, but function "
1697 "'%s' is not declared as RECURSIVE",
1698 esym
->name
, &expr
->where
, esym
->ns
->entries
->sym
->name
);
1703 /* Character lengths of use associated functions may contains references to
1704 symbols not referenced from the current program unit otherwise. Make sure
1705 those symbols are marked as referenced. */
1707 if (expr
->ts
.type
== BT_CHARACTER
&& expr
->value
.function
.esym
1708 && expr
->value
.function
.esym
->attr
.use_assoc
)
1710 gfc_expr_set_symbols_referenced (expr
->ts
.cl
->length
);
1714 find_noncopying_intrinsics (expr
->value
.function
.esym
,
1715 expr
->value
.function
.actual
);
1717 /* Make sure that the expression has a typespec that works. */
1718 if (expr
->ts
.type
== BT_UNKNOWN
)
1720 if (expr
->symtree
->n
.sym
->result
1721 && expr
->symtree
->n
.sym
->result
->ts
.type
!= BT_UNKNOWN
)
1722 expr
->ts
= expr
->symtree
->n
.sym
->result
->ts
;
1724 expr
->ts
= expr
->symtree
->n
.sym
->result
->ts
;
1731 /************* Subroutine resolution *************/
1734 pure_subroutine (gfc_code
*c
, gfc_symbol
*sym
)
1740 gfc_error ("Subroutine call to '%s' in FORALL block at %L is not PURE",
1741 sym
->name
, &c
->loc
);
1742 else if (gfc_pure (NULL
))
1743 gfc_error ("Subroutine call to '%s' at %L is not PURE", sym
->name
,
1749 resolve_generic_s0 (gfc_code
*c
, gfc_symbol
*sym
)
1753 if (sym
->attr
.generic
)
1755 s
= gfc_search_interface (sym
->generic
, 1, &c
->ext
.actual
);
1758 c
->resolved_sym
= s
;
1759 pure_subroutine (c
, s
);
1763 /* TODO: Need to search for elemental references in generic interface. */
1766 if (sym
->attr
.intrinsic
)
1767 return gfc_intrinsic_sub_interface (c
, 0);
1774 resolve_generic_s (gfc_code
*c
)
1779 sym
= c
->symtree
->n
.sym
;
1783 m
= resolve_generic_s0 (c
, sym
);
1786 else if (m
== MATCH_ERROR
)
1790 if (sym
->ns
->parent
== NULL
)
1792 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &sym
);
1796 if (!generic_sym (sym
))
1800 /* Last ditch attempt. See if the reference is to an intrinsic
1801 that possesses a matching interface. 14.1.2.4 */
1802 sym
= c
->symtree
->n
.sym
;
1804 if (!gfc_intrinsic_name (sym
->name
, 1))
1806 gfc_error ("There is no specific subroutine for the generic '%s' at %L",
1807 sym
->name
, &c
->loc
);
1811 m
= gfc_intrinsic_sub_interface (c
, 0);
1815 gfc_error ("Generic subroutine '%s' at %L is not consistent with an "
1816 "intrinsic subroutine interface", sym
->name
, &c
->loc
);
1822 /* Resolve a subroutine call known to be specific. */
1825 resolve_specific_s0 (gfc_code
*c
, gfc_symbol
*sym
)
1829 if (sym
->attr
.external
|| sym
->attr
.if_source
== IFSRC_IFBODY
)
1831 if (sym
->attr
.dummy
)
1833 sym
->attr
.proc
= PROC_DUMMY
;
1837 sym
->attr
.proc
= PROC_EXTERNAL
;
1841 if (sym
->attr
.proc
== PROC_MODULE
|| sym
->attr
.proc
== PROC_INTERNAL
)
1844 if (sym
->attr
.intrinsic
)
1846 m
= gfc_intrinsic_sub_interface (c
, 1);
1850 gfc_error ("Subroutine '%s' at %L is INTRINSIC but is not compatible "
1851 "with an intrinsic", sym
->name
, &c
->loc
);
1859 gfc_procedure_use (sym
, &c
->ext
.actual
, &c
->loc
);
1861 c
->resolved_sym
= sym
;
1862 pure_subroutine (c
, sym
);
1869 resolve_specific_s (gfc_code
*c
)
1874 sym
= c
->symtree
->n
.sym
;
1878 m
= resolve_specific_s0 (c
, sym
);
1881 if (m
== MATCH_ERROR
)
1884 if (sym
->ns
->parent
== NULL
)
1887 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &sym
);
1893 sym
= c
->symtree
->n
.sym
;
1894 gfc_error ("Unable to resolve the specific subroutine '%s' at %L",
1895 sym
->name
, &c
->loc
);
1901 /* Resolve a subroutine call not known to be generic nor specific. */
1904 resolve_unknown_s (gfc_code
*c
)
1908 sym
= c
->symtree
->n
.sym
;
1910 if (sym
->attr
.dummy
)
1912 sym
->attr
.proc
= PROC_DUMMY
;
1916 /* See if we have an intrinsic function reference. */
1918 if (gfc_intrinsic_name (sym
->name
, 1))
1920 if (gfc_intrinsic_sub_interface (c
, 1) == MATCH_YES
)
1925 /* The reference is to an external name. */
1928 gfc_procedure_use (sym
, &c
->ext
.actual
, &c
->loc
);
1930 c
->resolved_sym
= sym
;
1932 pure_subroutine (c
, sym
);
1938 /* Resolve a subroutine call. Although it was tempting to use the same code
1939 for functions, subroutines and functions are stored differently and this
1940 makes things awkward. */
1943 resolve_call (gfc_code
*c
)
1946 procedure_type ptype
= PROC_INTRINSIC
;
1948 if (c
->symtree
&& c
->symtree
->n
.sym
1949 && c
->symtree
->n
.sym
->ts
.type
!= BT_UNKNOWN
)
1951 gfc_error ("'%s' at %L has a type, which is not consistent with "
1952 "the CALL at %L", c
->symtree
->n
.sym
->name
,
1953 &c
->symtree
->n
.sym
->declared_at
, &c
->loc
);
1957 /* If the procedure is not internal or module, it must be external and
1958 should be checked for usage. */
1959 if (c
->symtree
&& c
->symtree
->n
.sym
1960 && !c
->symtree
->n
.sym
->attr
.dummy
1961 && !c
->symtree
->n
.sym
->attr
.contained
1962 && !c
->symtree
->n
.sym
->attr
.use_assoc
)
1963 resolve_global_procedure (c
->symtree
->n
.sym
, &c
->loc
, 1);
1965 /* Subroutines without the RECURSIVE attribution are not allowed to
1966 * call themselves. */
1967 if (c
->symtree
&& c
->symtree
->n
.sym
&& !c
->symtree
->n
.sym
->attr
.recursive
)
1969 gfc_symbol
*csym
, *proc
;
1970 csym
= c
->symtree
->n
.sym
;
1971 proc
= gfc_current_ns
->proc_name
;
1974 gfc_error ("SUBROUTINE '%s' at %L cannot call itself, as it is not "
1975 "RECURSIVE", csym
->name
, &c
->loc
);
1979 if (csym
->attr
.entry
&& csym
->ns
->entries
&& proc
->ns
->entries
1980 && csym
->ns
->entries
->sym
== proc
->ns
->entries
->sym
)
1982 gfc_error ("Call to ENTRY '%s' at %L is recursive, but subroutine "
1983 "'%s' is not declared as RECURSIVE",
1984 csym
->name
, &c
->loc
, csym
->ns
->entries
->sym
->name
);
1989 /* Switch off assumed size checking and do this again for certain kinds
1990 of procedure, once the procedure itself is resolved. */
1991 need_full_assumed_size
++;
1993 if (c
->symtree
&& c
->symtree
->n
.sym
)
1994 ptype
= c
->symtree
->n
.sym
->attr
.proc
;
1996 if (resolve_actual_arglist (c
->ext
.actual
, ptype
) == FAILURE
)
1999 /* Resume assumed_size checking. */
2000 need_full_assumed_size
--;
2003 if (c
->resolved_sym
== NULL
)
2004 switch (procedure_kind (c
->symtree
->n
.sym
))
2007 t
= resolve_generic_s (c
);
2010 case PTYPE_SPECIFIC
:
2011 t
= resolve_specific_s (c
);
2015 t
= resolve_unknown_s (c
);
2019 gfc_internal_error ("resolve_subroutine(): bad function type");
2022 /* Some checks of elemental subroutine actual arguments. */
2023 if (resolve_elemental_actual (NULL
, c
) == FAILURE
)
2027 find_noncopying_intrinsics (c
->resolved_sym
, c
->ext
.actual
);
2032 /* Compare the shapes of two arrays that have non-NULL shapes. If both
2033 op1->shape and op2->shape are non-NULL return SUCCESS if their shapes
2034 match. If both op1->shape and op2->shape are non-NULL return FAILURE
2035 if their shapes do not match. If either op1->shape or op2->shape is
2036 NULL, return SUCCESS. */
2039 compare_shapes (gfc_expr
*op1
, gfc_expr
*op2
)
2046 if (op1
->shape
!= NULL
&& op2
->shape
!= NULL
)
2048 for (i
= 0; i
< op1
->rank
; i
++)
2050 if (mpz_cmp (op1
->shape
[i
], op2
->shape
[i
]) != 0)
2052 gfc_error ("Shapes for operands at %L and %L are not conformable",
2053 &op1
->where
, &op2
->where
);
2064 /* Resolve an operator expression node. This can involve replacing the
2065 operation with a user defined function call. */
2068 resolve_operator (gfc_expr
*e
)
2070 gfc_expr
*op1
, *op2
;
2074 /* Resolve all subnodes-- give them types. */
2076 switch (e
->value
.op
.operator)
2079 if (gfc_resolve_expr (e
->value
.op
.op2
) == FAILURE
)
2082 /* Fall through... */
2085 case INTRINSIC_UPLUS
:
2086 case INTRINSIC_UMINUS
:
2087 case INTRINSIC_PARENTHESES
:
2088 if (gfc_resolve_expr (e
->value
.op
.op1
) == FAILURE
)
2093 /* Typecheck the new node. */
2095 op1
= e
->value
.op
.op1
;
2096 op2
= e
->value
.op
.op2
;
2098 switch (e
->value
.op
.operator)
2100 case INTRINSIC_UPLUS
:
2101 case INTRINSIC_UMINUS
:
2102 if (op1
->ts
.type
== BT_INTEGER
2103 || op1
->ts
.type
== BT_REAL
2104 || op1
->ts
.type
== BT_COMPLEX
)
2110 sprintf (msg
, _("Operand of unary numeric operator '%s' at %%L is %s"),
2111 gfc_op2string (e
->value
.op
.operator), gfc_typename (&e
->ts
));
2114 case INTRINSIC_PLUS
:
2115 case INTRINSIC_MINUS
:
2116 case INTRINSIC_TIMES
:
2117 case INTRINSIC_DIVIDE
:
2118 case INTRINSIC_POWER
:
2119 if (gfc_numeric_ts (&op1
->ts
) && gfc_numeric_ts (&op2
->ts
))
2121 gfc_type_convert_binary (e
);
2126 _("Operands of binary numeric operator '%s' at %%L are %s/%s"),
2127 gfc_op2string (e
->value
.op
.operator), gfc_typename (&op1
->ts
),
2128 gfc_typename (&op2
->ts
));
2131 case INTRINSIC_CONCAT
:
2132 if (op1
->ts
.type
== BT_CHARACTER
&& op2
->ts
.type
== BT_CHARACTER
)
2134 e
->ts
.type
= BT_CHARACTER
;
2135 e
->ts
.kind
= op1
->ts
.kind
;
2140 _("Operands of string concatenation operator at %%L are %s/%s"),
2141 gfc_typename (&op1
->ts
), gfc_typename (&op2
->ts
));
2147 case INTRINSIC_NEQV
:
2148 if (op1
->ts
.type
== BT_LOGICAL
&& op2
->ts
.type
== BT_LOGICAL
)
2150 e
->ts
.type
= BT_LOGICAL
;
2151 e
->ts
.kind
= gfc_kind_max (op1
, op2
);
2152 if (op1
->ts
.kind
< e
->ts
.kind
)
2153 gfc_convert_type (op1
, &e
->ts
, 2);
2154 else if (op2
->ts
.kind
< e
->ts
.kind
)
2155 gfc_convert_type (op2
, &e
->ts
, 2);
2159 sprintf (msg
, _("Operands of logical operator '%s' at %%L are %s/%s"),
2160 gfc_op2string (e
->value
.op
.operator), gfc_typename (&op1
->ts
),
2161 gfc_typename (&op2
->ts
));
2166 if (op1
->ts
.type
== BT_LOGICAL
)
2168 e
->ts
.type
= BT_LOGICAL
;
2169 e
->ts
.kind
= op1
->ts
.kind
;
2173 sprintf (msg
, _("Operand of .NOT. operator at %%L is %s"),
2174 gfc_typename (&op1
->ts
));
2181 if (op1
->ts
.type
== BT_COMPLEX
|| op2
->ts
.type
== BT_COMPLEX
)
2183 strcpy (msg
, _("COMPLEX quantities cannot be compared at %L"));
2187 /* Fall through... */
2191 if (op1
->ts
.type
== BT_CHARACTER
&& op2
->ts
.type
== BT_CHARACTER
)
2193 e
->ts
.type
= BT_LOGICAL
;
2194 e
->ts
.kind
= gfc_default_logical_kind
;
2198 if (gfc_numeric_ts (&op1
->ts
) && gfc_numeric_ts (&op2
->ts
))
2200 gfc_type_convert_binary (e
);
2202 e
->ts
.type
= BT_LOGICAL
;
2203 e
->ts
.kind
= gfc_default_logical_kind
;
2207 if (op1
->ts
.type
== BT_LOGICAL
&& op2
->ts
.type
== BT_LOGICAL
)
2209 _("Logicals at %%L must be compared with %s instead of %s"),
2210 e
->value
.op
.operator == INTRINSIC_EQ
? ".EQV." : ".NEQV.",
2211 gfc_op2string (e
->value
.op
.operator));
2214 _("Operands of comparison operator '%s' at %%L are %s/%s"),
2215 gfc_op2string (e
->value
.op
.operator), gfc_typename (&op1
->ts
),
2216 gfc_typename (&op2
->ts
));
2220 case INTRINSIC_USER
:
2222 sprintf (msg
, _("Operand of user operator '%s' at %%L is %s"),
2223 e
->value
.op
.uop
->name
, gfc_typename (&op1
->ts
));
2225 sprintf (msg
, _("Operands of user operator '%s' at %%L are %s/%s"),
2226 e
->value
.op
.uop
->name
, gfc_typename (&op1
->ts
),
2227 gfc_typename (&op2
->ts
));
2231 case INTRINSIC_PARENTHESES
:
2235 gfc_internal_error ("resolve_operator(): Bad intrinsic");
2238 /* Deal with arrayness of an operand through an operator. */
2242 switch (e
->value
.op
.operator)
2244 case INTRINSIC_PLUS
:
2245 case INTRINSIC_MINUS
:
2246 case INTRINSIC_TIMES
:
2247 case INTRINSIC_DIVIDE
:
2248 case INTRINSIC_POWER
:
2249 case INTRINSIC_CONCAT
:
2253 case INTRINSIC_NEQV
:
2261 if (op1
->rank
== 0 && op2
->rank
== 0)
2264 if (op1
->rank
== 0 && op2
->rank
!= 0)
2266 e
->rank
= op2
->rank
;
2268 if (e
->shape
== NULL
)
2269 e
->shape
= gfc_copy_shape (op2
->shape
, op2
->rank
);
2272 if (op1
->rank
!= 0 && op2
->rank
== 0)
2274 e
->rank
= op1
->rank
;
2276 if (e
->shape
== NULL
)
2277 e
->shape
= gfc_copy_shape (op1
->shape
, op1
->rank
);
2280 if (op1
->rank
!= 0 && op2
->rank
!= 0)
2282 if (op1
->rank
== op2
->rank
)
2284 e
->rank
= op1
->rank
;
2285 if (e
->shape
== NULL
)
2287 t
= compare_shapes(op1
, op2
);
2291 e
->shape
= gfc_copy_shape (op1
->shape
, op1
->rank
);
2296 gfc_error ("Inconsistent ranks for operator at %L and %L",
2297 &op1
->where
, &op2
->where
);
2300 /* Allow higher level expressions to work. */
2308 case INTRINSIC_UPLUS
:
2309 case INTRINSIC_UMINUS
:
2310 case INTRINSIC_PARENTHESES
:
2311 e
->rank
= op1
->rank
;
2313 if (e
->shape
== NULL
)
2314 e
->shape
= gfc_copy_shape (op1
->shape
, op1
->rank
);
2316 /* Simply copy arrayness attribute */
2323 /* Attempt to simplify the expression. */
2326 t
= gfc_simplify_expr (e
, 0);
2327 /* Some calls do not succeed in simplification and return FAILURE
2328 even though there is no error; eg. variable references to
2329 PARAMETER arrays. */
2330 if (!gfc_is_constant_expr (e
))
2337 if (gfc_extend_expr (e
) == SUCCESS
)
2340 gfc_error (msg
, &e
->where
);
2346 /************** Array resolution subroutines **************/
2349 { CMP_LT
, CMP_EQ
, CMP_GT
, CMP_UNKNOWN
}
2352 /* Compare two integer expressions. */
2355 compare_bound (gfc_expr
*a
, gfc_expr
*b
)
2359 if (a
== NULL
|| a
->expr_type
!= EXPR_CONSTANT
2360 || b
== NULL
|| b
->expr_type
!= EXPR_CONSTANT
)
2363 if (a
->ts
.type
!= BT_INTEGER
|| b
->ts
.type
!= BT_INTEGER
)
2364 gfc_internal_error ("compare_bound(): Bad expression");
2366 i
= mpz_cmp (a
->value
.integer
, b
->value
.integer
);
2376 /* Compare an integer expression with an integer. */
2379 compare_bound_int (gfc_expr
*a
, int b
)
2383 if (a
== NULL
|| a
->expr_type
!= EXPR_CONSTANT
)
2386 if (a
->ts
.type
!= BT_INTEGER
)
2387 gfc_internal_error ("compare_bound_int(): Bad expression");
2389 i
= mpz_cmp_si (a
->value
.integer
, b
);
2399 /* Compare an integer expression with a mpz_t. */
2402 compare_bound_mpz_t (gfc_expr
*a
, mpz_t b
)
2406 if (a
== NULL
|| a
->expr_type
!= EXPR_CONSTANT
)
2409 if (a
->ts
.type
!= BT_INTEGER
)
2410 gfc_internal_error ("compare_bound_int(): Bad expression");
2412 i
= mpz_cmp (a
->value
.integer
, b
);
2422 /* Compute the last value of a sequence given by a triplet.
2423 Return 0 if it wasn't able to compute the last value, or if the
2424 sequence if empty, and 1 otherwise. */
2427 compute_last_value_for_triplet (gfc_expr
*start
, gfc_expr
*end
,
2428 gfc_expr
*stride
, mpz_t last
)
2432 if (start
== NULL
|| start
->expr_type
!= EXPR_CONSTANT
2433 || end
== NULL
|| end
->expr_type
!= EXPR_CONSTANT
2434 || (stride
!= NULL
&& stride
->expr_type
!= EXPR_CONSTANT
))
2437 if (start
->ts
.type
!= BT_INTEGER
|| end
->ts
.type
!= BT_INTEGER
2438 || (stride
!= NULL
&& stride
->ts
.type
!= BT_INTEGER
))
2441 if (stride
== NULL
|| compare_bound_int(stride
, 1) == CMP_EQ
)
2443 if (compare_bound (start
, end
) == CMP_GT
)
2445 mpz_set (last
, end
->value
.integer
);
2449 if (compare_bound_int (stride
, 0) == CMP_GT
)
2451 /* Stride is positive */
2452 if (mpz_cmp (start
->value
.integer
, end
->value
.integer
) > 0)
2457 /* Stride is negative */
2458 if (mpz_cmp (start
->value
.integer
, end
->value
.integer
) < 0)
2463 mpz_sub (rem
, end
->value
.integer
, start
->value
.integer
);
2464 mpz_tdiv_r (rem
, rem
, stride
->value
.integer
);
2465 mpz_sub (last
, end
->value
.integer
, rem
);
2472 /* Compare a single dimension of an array reference to the array
2476 check_dimension (int i
, gfc_array_ref
*ar
, gfc_array_spec
*as
)
2480 /* Given start, end and stride values, calculate the minimum and
2481 maximum referenced indexes. */
2489 if (compare_bound (ar
->start
[i
], as
->lower
[i
]) == CMP_LT
)
2491 if (compare_bound (ar
->start
[i
], as
->upper
[i
]) == CMP_GT
)
2497 if (compare_bound_int (ar
->stride
[i
], 0) == CMP_EQ
)
2499 gfc_error ("Illegal stride of zero at %L", &ar
->c_where
[i
]);
2503 #define AR_START (ar->start[i] ? ar->start[i] : as->lower[i])
2504 #define AR_END (ar->end[i] ? ar->end[i] : as->upper[i])
2506 if (compare_bound (AR_START
, AR_END
) == CMP_EQ
2507 && (compare_bound (AR_START
, as
->lower
[i
]) == CMP_LT
2508 || compare_bound (AR_START
, as
->upper
[i
]) == CMP_GT
))
2511 if (((compare_bound_int (ar
->stride
[i
], 0) == CMP_GT
2512 || ar
->stride
[i
] == NULL
)
2513 && compare_bound (AR_START
, AR_END
) != CMP_GT
)
2514 || (compare_bound_int (ar
->stride
[i
], 0) == CMP_LT
2515 && compare_bound (AR_START
, AR_END
) != CMP_LT
))
2517 if (compare_bound (AR_START
, as
->lower
[i
]) == CMP_LT
)
2519 if (compare_bound (AR_START
, as
->upper
[i
]) == CMP_GT
)
2523 mpz_init (last_value
);
2524 if (compute_last_value_for_triplet (AR_START
, AR_END
, ar
->stride
[i
],
2527 if (compare_bound_mpz_t (as
->lower
[i
], last_value
) == CMP_GT
2528 || compare_bound_mpz_t (as
->upper
[i
], last_value
) == CMP_LT
)
2530 mpz_clear (last_value
);
2534 mpz_clear (last_value
);
2542 gfc_internal_error ("check_dimension(): Bad array reference");
2548 gfc_warning ("Array reference at %L is out of bounds", &ar
->c_where
[i
]);
2553 /* Compare an array reference with an array specification. */
2556 compare_spec_to_ref (gfc_array_ref
*ar
)
2563 /* TODO: Full array sections are only allowed as actual parameters. */
2564 if (as
->type
== AS_ASSUMED_SIZE
2565 && (/*ar->type == AR_FULL
2566 ||*/ (ar
->type
== AR_SECTION
2567 && ar
->dimen_type
[i
] == DIMEN_RANGE
&& ar
->end
[i
] == NULL
)))
2569 gfc_error ("Rightmost upper bound of assumed size array section "
2570 "not specified at %L", &ar
->where
);
2574 if (ar
->type
== AR_FULL
)
2577 if (as
->rank
!= ar
->dimen
)
2579 gfc_error ("Rank mismatch in array reference at %L (%d/%d)",
2580 &ar
->where
, ar
->dimen
, as
->rank
);
2584 for (i
= 0; i
< as
->rank
; i
++)
2585 if (check_dimension (i
, ar
, as
) == FAILURE
)
2592 /* Resolve one part of an array index. */
2595 gfc_resolve_index (gfc_expr
*index
, int check_scalar
)
2602 if (gfc_resolve_expr (index
) == FAILURE
)
2605 if (check_scalar
&& index
->rank
!= 0)
2607 gfc_error ("Array index at %L must be scalar", &index
->where
);
2611 if (index
->ts
.type
!= BT_INTEGER
&& index
->ts
.type
!= BT_REAL
)
2613 gfc_error ("Array index at %L must be of INTEGER type",
2618 if (index
->ts
.type
== BT_REAL
)
2619 if (gfc_notify_std (GFC_STD_LEGACY
, "Extension: REAL array index at %L",
2620 &index
->where
) == FAILURE
)
2623 if (index
->ts
.kind
!= gfc_index_integer_kind
2624 || index
->ts
.type
!= BT_INTEGER
)
2627 ts
.type
= BT_INTEGER
;
2628 ts
.kind
= gfc_index_integer_kind
;
2630 gfc_convert_type_warn (index
, &ts
, 2, 0);
2636 /* Resolve a dim argument to an intrinsic function. */
2639 gfc_resolve_dim_arg (gfc_expr
*dim
)
2644 if (gfc_resolve_expr (dim
) == FAILURE
)
2649 gfc_error ("Argument dim at %L must be scalar", &dim
->where
);
2653 if (dim
->ts
.type
!= BT_INTEGER
)
2655 gfc_error ("Argument dim at %L must be of INTEGER type", &dim
->where
);
2658 if (dim
->ts
.kind
!= gfc_index_integer_kind
)
2662 ts
.type
= BT_INTEGER
;
2663 ts
.kind
= gfc_index_integer_kind
;
2665 gfc_convert_type_warn (dim
, &ts
, 2, 0);
2671 /* Given an expression that contains array references, update those array
2672 references to point to the right array specifications. While this is
2673 filled in during matching, this information is difficult to save and load
2674 in a module, so we take care of it here.
2676 The idea here is that the original array reference comes from the
2677 base symbol. We traverse the list of reference structures, setting
2678 the stored reference to references. Component references can
2679 provide an additional array specification. */
2682 find_array_spec (gfc_expr
*e
)
2686 gfc_symbol
*derived
;
2689 as
= e
->symtree
->n
.sym
->as
;
2692 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
2697 gfc_internal_error ("find_array_spec(): Missing spec");
2704 if (derived
== NULL
)
2705 derived
= e
->symtree
->n
.sym
->ts
.derived
;
2707 c
= derived
->components
;
2709 for (; c
; c
= c
->next
)
2710 if (c
== ref
->u
.c
.component
)
2712 /* Track the sequence of component references. */
2713 if (c
->ts
.type
== BT_DERIVED
)
2714 derived
= c
->ts
.derived
;
2719 gfc_internal_error ("find_array_spec(): Component not found");
2724 gfc_internal_error ("find_array_spec(): unused as(1)");
2735 gfc_internal_error ("find_array_spec(): unused as(2)");
2739 /* Resolve an array reference. */
2742 resolve_array_ref (gfc_array_ref
*ar
)
2744 int i
, check_scalar
;
2747 for (i
= 0; i
< ar
->dimen
; i
++)
2749 check_scalar
= ar
->dimen_type
[i
] == DIMEN_RANGE
;
2751 if (gfc_resolve_index (ar
->start
[i
], check_scalar
) == FAILURE
)
2753 if (gfc_resolve_index (ar
->end
[i
], check_scalar
) == FAILURE
)
2755 if (gfc_resolve_index (ar
->stride
[i
], check_scalar
) == FAILURE
)
2760 if (ar
->dimen_type
[i
] == DIMEN_UNKNOWN
)
2764 ar
->dimen_type
[i
] = DIMEN_ELEMENT
;
2768 ar
->dimen_type
[i
] = DIMEN_VECTOR
;
2769 if (e
->expr_type
== EXPR_VARIABLE
2770 && e
->symtree
->n
.sym
->ts
.type
== BT_DERIVED
)
2771 ar
->start
[i
] = gfc_get_parentheses (e
);
2775 gfc_error ("Array index at %L is an array of rank %d",
2776 &ar
->c_where
[i
], e
->rank
);
2781 /* If the reference type is unknown, figure out what kind it is. */
2783 if (ar
->type
== AR_UNKNOWN
)
2785 ar
->type
= AR_ELEMENT
;
2786 for (i
= 0; i
< ar
->dimen
; i
++)
2787 if (ar
->dimen_type
[i
] == DIMEN_RANGE
2788 || ar
->dimen_type
[i
] == DIMEN_VECTOR
)
2790 ar
->type
= AR_SECTION
;
2795 if (!ar
->as
->cray_pointee
&& compare_spec_to_ref (ar
) == FAILURE
)
2803 resolve_substring (gfc_ref
*ref
)
2805 if (ref
->u
.ss
.start
!= NULL
)
2807 if (gfc_resolve_expr (ref
->u
.ss
.start
) == FAILURE
)
2810 if (ref
->u
.ss
.start
->ts
.type
!= BT_INTEGER
)
2812 gfc_error ("Substring start index at %L must be of type INTEGER",
2813 &ref
->u
.ss
.start
->where
);
2817 if (ref
->u
.ss
.start
->rank
!= 0)
2819 gfc_error ("Substring start index at %L must be scalar",
2820 &ref
->u
.ss
.start
->where
);
2824 if (compare_bound_int (ref
->u
.ss
.start
, 1) == CMP_LT
2825 && (compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_EQ
2826 || compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_GT
))
2828 gfc_error ("Substring start index at %L is less than one",
2829 &ref
->u
.ss
.start
->where
);
2834 if (ref
->u
.ss
.end
!= NULL
)
2836 if (gfc_resolve_expr (ref
->u
.ss
.end
) == FAILURE
)
2839 if (ref
->u
.ss
.end
->ts
.type
!= BT_INTEGER
)
2841 gfc_error ("Substring end index at %L must be of type INTEGER",
2842 &ref
->u
.ss
.end
->where
);
2846 if (ref
->u
.ss
.end
->rank
!= 0)
2848 gfc_error ("Substring end index at %L must be scalar",
2849 &ref
->u
.ss
.end
->where
);
2853 if (ref
->u
.ss
.length
!= NULL
2854 && compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.length
->length
) == CMP_GT
2855 && (compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_EQ
2856 || compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_GT
))
2858 gfc_error ("Substring end index at %L exceeds the string length",
2859 &ref
->u
.ss
.start
->where
);
2868 /* Resolve subtype references. */
2871 resolve_ref (gfc_expr
*expr
)
2873 int current_part_dimension
, n_components
, seen_part_dimension
;
2876 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
2877 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.as
== NULL
)
2879 find_array_spec (expr
);
2883 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
2887 if (resolve_array_ref (&ref
->u
.ar
) == FAILURE
)
2895 resolve_substring (ref
);
2899 /* Check constraints on part references. */
2901 current_part_dimension
= 0;
2902 seen_part_dimension
= 0;
2905 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
2910 switch (ref
->u
.ar
.type
)
2914 current_part_dimension
= 1;
2918 current_part_dimension
= 0;
2922 gfc_internal_error ("resolve_ref(): Bad array reference");
2928 if (current_part_dimension
|| seen_part_dimension
)
2930 if (ref
->u
.c
.component
->pointer
)
2932 gfc_error ("Component to the right of a part reference "
2933 "with nonzero rank must not have the POINTER "
2934 "attribute at %L", &expr
->where
);
2937 else if (ref
->u
.c
.component
->allocatable
)
2939 gfc_error ("Component to the right of a part reference "
2940 "with nonzero rank must not have the ALLOCATABLE "
2941 "attribute at %L", &expr
->where
);
2953 if (((ref
->type
== REF_COMPONENT
&& n_components
> 1)
2954 || ref
->next
== NULL
)
2955 && current_part_dimension
2956 && seen_part_dimension
)
2958 gfc_error ("Two or more part references with nonzero rank must "
2959 "not be specified at %L", &expr
->where
);
2963 if (ref
->type
== REF_COMPONENT
)
2965 if (current_part_dimension
)
2966 seen_part_dimension
= 1;
2968 /* reset to make sure */
2969 current_part_dimension
= 0;
2977 /* Given an expression, determine its shape. This is easier than it sounds.
2978 Leaves the shape array NULL if it is not possible to determine the shape. */
2981 expression_shape (gfc_expr
*e
)
2983 mpz_t array
[GFC_MAX_DIMENSIONS
];
2986 if (e
->rank
== 0 || e
->shape
!= NULL
)
2989 for (i
= 0; i
< e
->rank
; i
++)
2990 if (gfc_array_dimen_size (e
, i
, &array
[i
]) == FAILURE
)
2993 e
->shape
= gfc_get_shape (e
->rank
);
2995 memcpy (e
->shape
, array
, e
->rank
* sizeof (mpz_t
));
3000 for (i
--; i
>= 0; i
--)
3001 mpz_clear (array
[i
]);
3005 /* Given a variable expression node, compute the rank of the expression by
3006 examining the base symbol and any reference structures it may have. */
3009 expression_rank (gfc_expr
*e
)
3016 if (e
->expr_type
== EXPR_ARRAY
)
3018 /* Constructors can have a rank different from one via RESHAPE(). */
3020 if (e
->symtree
== NULL
)
3026 e
->rank
= (e
->symtree
->n
.sym
->as
== NULL
)
3027 ? 0 : e
->symtree
->n
.sym
->as
->rank
;
3033 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
3035 if (ref
->type
!= REF_ARRAY
)
3038 if (ref
->u
.ar
.type
== AR_FULL
)
3040 rank
= ref
->u
.ar
.as
->rank
;
3044 if (ref
->u
.ar
.type
== AR_SECTION
)
3046 /* Figure out the rank of the section. */
3048 gfc_internal_error ("expression_rank(): Two array specs");
3050 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
3051 if (ref
->u
.ar
.dimen_type
[i
] == DIMEN_RANGE
3052 || ref
->u
.ar
.dimen_type
[i
] == DIMEN_VECTOR
)
3062 expression_shape (e
);
3066 /* Resolve a variable expression. */
3069 resolve_variable (gfc_expr
*e
)
3076 if (e
->symtree
== NULL
)
3079 if (e
->ref
&& resolve_ref (e
) == FAILURE
)
3082 sym
= e
->symtree
->n
.sym
;
3083 if (sym
->attr
.flavor
== FL_PROCEDURE
&& !sym
->attr
.function
)
3085 e
->ts
.type
= BT_PROCEDURE
;
3089 if (sym
->ts
.type
!= BT_UNKNOWN
)
3090 gfc_variable_attr (e
, &e
->ts
);
3093 /* Must be a simple variable reference. */
3094 if (gfc_set_default_type (sym
, 1, sym
->ns
) == FAILURE
)
3099 if (check_assumed_size_reference (sym
, e
))
3102 /* Deal with forward references to entries during resolve_code, to
3103 satisfy, at least partially, 12.5.2.5. */
3104 if (gfc_current_ns
->entries
3105 && current_entry_id
== sym
->entry_id
3108 && cs_base
->current
->op
!= EXEC_ENTRY
)
3110 gfc_entry_list
*entry
;
3111 gfc_formal_arglist
*formal
;
3115 /* If the symbol is a dummy... */
3116 if (sym
->attr
.dummy
)
3118 entry
= gfc_current_ns
->entries
;
3121 /* ...test if the symbol is a parameter of previous entries. */
3122 for (; entry
&& entry
->id
<= current_entry_id
; entry
= entry
->next
)
3123 for (formal
= entry
->sym
->formal
; formal
; formal
= formal
->next
)
3125 if (formal
->sym
&& sym
->name
== formal
->sym
->name
)
3129 /* If it has not been seen as a dummy, this is an error. */
3132 if (specification_expr
)
3133 gfc_error ("Variable '%s',used in a specification expression, "
3134 "is referenced at %L before the ENTRY statement "
3135 "in which it is a parameter",
3136 sym
->name
, &cs_base
->current
->loc
);
3138 gfc_error ("Variable '%s' is used at %L before the ENTRY "
3139 "statement in which it is a parameter",
3140 sym
->name
, &cs_base
->current
->loc
);
3145 /* Now do the same check on the specification expressions. */
3146 specification_expr
= 1;
3147 if (sym
->ts
.type
== BT_CHARACTER
3148 && gfc_resolve_expr (sym
->ts
.cl
->length
) == FAILURE
)
3152 for (n
= 0; n
< sym
->as
->rank
; n
++)
3154 specification_expr
= 1;
3155 if (gfc_resolve_expr (sym
->as
->lower
[n
]) == FAILURE
)
3157 specification_expr
= 1;
3158 if (gfc_resolve_expr (sym
->as
->upper
[n
]) == FAILURE
)
3161 specification_expr
= 0;
3164 /* Update the symbol's entry level. */
3165 sym
->entry_id
= current_entry_id
+ 1;
3172 /* Resolve an expression. That is, make sure that types of operands agree
3173 with their operators, intrinsic operators are converted to function calls
3174 for overloaded types and unresolved function references are resolved. */
3177 gfc_resolve_expr (gfc_expr
*e
)
3184 switch (e
->expr_type
)
3187 t
= resolve_operator (e
);
3191 t
= resolve_function (e
);
3195 t
= resolve_variable (e
);
3197 expression_rank (e
);
3200 case EXPR_SUBSTRING
:
3201 t
= resolve_ref (e
);
3211 if (resolve_ref (e
) == FAILURE
)
3214 t
= gfc_resolve_array_constructor (e
);
3215 /* Also try to expand a constructor. */
3218 expression_rank (e
);
3219 gfc_expand_constructor (e
);
3222 /* This provides the opportunity for the length of constructors with
3223 character valued function elements to propogate the string length
3224 to the expression. */
3225 if (e
->ts
.type
== BT_CHARACTER
)
3226 gfc_resolve_character_array_constructor (e
);
3230 case EXPR_STRUCTURE
:
3231 t
= resolve_ref (e
);
3235 t
= resolve_structure_cons (e
);
3239 t
= gfc_simplify_expr (e
, 0);
3243 gfc_internal_error ("gfc_resolve_expr(): Bad expression type");
3250 /* Resolve an expression from an iterator. They must be scalar and have
3251 INTEGER or (optionally) REAL type. */
3254 gfc_resolve_iterator_expr (gfc_expr
*expr
, bool real_ok
,
3255 const char *name_msgid
)
3257 if (gfc_resolve_expr (expr
) == FAILURE
)
3260 if (expr
->rank
!= 0)
3262 gfc_error ("%s at %L must be a scalar", _(name_msgid
), &expr
->where
);
3266 if (!(expr
->ts
.type
== BT_INTEGER
3267 || (expr
->ts
.type
== BT_REAL
&& real_ok
)))
3270 gfc_error ("%s at %L must be INTEGER or REAL", _(name_msgid
),
3273 gfc_error ("%s at %L must be INTEGER", _(name_msgid
), &expr
->where
);
3280 /* Resolve the expressions in an iterator structure. If REAL_OK is
3281 false allow only INTEGER type iterators, otherwise allow REAL types. */
3284 gfc_resolve_iterator (gfc_iterator
*iter
, bool real_ok
)
3287 if (iter
->var
->ts
.type
== BT_REAL
)
3288 gfc_notify_std (GFC_STD_F95_DEL
, "Obsolete: REAL DO loop iterator at %L",
3291 if (gfc_resolve_iterator_expr (iter
->var
, real_ok
, "Loop variable")
3295 if (gfc_pure (NULL
) && gfc_impure_variable (iter
->var
->symtree
->n
.sym
))
3297 gfc_error ("Cannot assign to loop variable in PURE procedure at %L",
3302 if (gfc_resolve_iterator_expr (iter
->start
, real_ok
,
3303 "Start expression in DO loop") == FAILURE
)
3306 if (gfc_resolve_iterator_expr (iter
->end
, real_ok
,
3307 "End expression in DO loop") == FAILURE
)
3310 if (gfc_resolve_iterator_expr (iter
->step
, real_ok
,
3311 "Step expression in DO loop") == FAILURE
)
3314 if (iter
->step
->expr_type
== EXPR_CONSTANT
)
3316 if ((iter
->step
->ts
.type
== BT_INTEGER
3317 && mpz_cmp_ui (iter
->step
->value
.integer
, 0) == 0)
3318 || (iter
->step
->ts
.type
== BT_REAL
3319 && mpfr_sgn (iter
->step
->value
.real
) == 0))
3321 gfc_error ("Step expression in DO loop at %L cannot be zero",
3322 &iter
->step
->where
);
3327 /* Convert start, end, and step to the same type as var. */
3328 if (iter
->start
->ts
.kind
!= iter
->var
->ts
.kind
3329 || iter
->start
->ts
.type
!= iter
->var
->ts
.type
)
3330 gfc_convert_type (iter
->start
, &iter
->var
->ts
, 2);
3332 if (iter
->end
->ts
.kind
!= iter
->var
->ts
.kind
3333 || iter
->end
->ts
.type
!= iter
->var
->ts
.type
)
3334 gfc_convert_type (iter
->end
, &iter
->var
->ts
, 2);
3336 if (iter
->step
->ts
.kind
!= iter
->var
->ts
.kind
3337 || iter
->step
->ts
.type
!= iter
->var
->ts
.type
)
3338 gfc_convert_type (iter
->step
, &iter
->var
->ts
, 2);
3344 /* Resolve a list of FORALL iterators. The FORALL index-name is constrained
3345 to be a scalar INTEGER variable. The subscripts and stride are scalar
3346 INTEGERs, and if stride is a constant it must be nonzero. */
3349 resolve_forall_iterators (gfc_forall_iterator
*iter
)
3353 if (gfc_resolve_expr (iter
->var
) == SUCCESS
3354 && (iter
->var
->ts
.type
!= BT_INTEGER
|| iter
->var
->rank
!= 0))
3355 gfc_error ("FORALL index-name at %L must be a scalar INTEGER",
3358 if (gfc_resolve_expr (iter
->start
) == SUCCESS
3359 && (iter
->start
->ts
.type
!= BT_INTEGER
|| iter
->start
->rank
!= 0))
3360 gfc_error ("FORALL start expression at %L must be a scalar INTEGER",
3361 &iter
->start
->where
);
3362 if (iter
->var
->ts
.kind
!= iter
->start
->ts
.kind
)
3363 gfc_convert_type (iter
->start
, &iter
->var
->ts
, 2);
3365 if (gfc_resolve_expr (iter
->end
) == SUCCESS
3366 && (iter
->end
->ts
.type
!= BT_INTEGER
|| iter
->end
->rank
!= 0))
3367 gfc_error ("FORALL end expression at %L must be a scalar INTEGER",
3369 if (iter
->var
->ts
.kind
!= iter
->end
->ts
.kind
)
3370 gfc_convert_type (iter
->end
, &iter
->var
->ts
, 2);
3372 if (gfc_resolve_expr (iter
->stride
) == SUCCESS
)
3374 if (iter
->stride
->ts
.type
!= BT_INTEGER
|| iter
->stride
->rank
!= 0)
3375 gfc_error ("FORALL stride expression at %L must be a scalar %s",
3376 &iter
->stride
->where
, "INTEGER");
3378 if (iter
->stride
->expr_type
== EXPR_CONSTANT
3379 && mpz_cmp_ui(iter
->stride
->value
.integer
, 0) == 0)
3380 gfc_error ("FORALL stride expression at %L cannot be zero",
3381 &iter
->stride
->where
);
3383 if (iter
->var
->ts
.kind
!= iter
->stride
->ts
.kind
)
3384 gfc_convert_type (iter
->stride
, &iter
->var
->ts
, 2);
3391 /* Given a pointer to a symbol that is a derived type, see if any components
3392 have the POINTER attribute. The search is recursive if necessary.
3393 Returns zero if no pointer components are found, nonzero otherwise. */
3396 derived_pointer (gfc_symbol
*sym
)
3400 for (c
= sym
->components
; c
; c
= c
->next
)
3405 if (c
->ts
.type
== BT_DERIVED
&& derived_pointer (c
->ts
.derived
))
3413 /* Given a pointer to a symbol that is a derived type, see if it's
3414 inaccessible, i.e. if it's defined in another module and the components are
3415 PRIVATE. The search is recursive if necessary. Returns zero if no
3416 inaccessible components are found, nonzero otherwise. */
3419 derived_inaccessible (gfc_symbol
*sym
)
3423 if (sym
->attr
.use_assoc
&& sym
->component_access
== ACCESS_PRIVATE
)
3426 for (c
= sym
->components
; c
; c
= c
->next
)
3428 if (c
->ts
.type
== BT_DERIVED
&& derived_inaccessible (c
->ts
.derived
))
3436 /* Resolve the argument of a deallocate expression. The expression must be
3437 a pointer or a full array. */
3440 resolve_deallocate_expr (gfc_expr
*e
)
3442 symbol_attribute attr
;
3443 int allocatable
, pointer
, check_intent_in
;
3446 /* Check INTENT(IN), unless the object is a sub-component of a pointer. */
3447 check_intent_in
= 1;
3449 if (gfc_resolve_expr (e
) == FAILURE
)
3452 if (e
->expr_type
!= EXPR_VARIABLE
)
3455 allocatable
= e
->symtree
->n
.sym
->attr
.allocatable
;
3456 pointer
= e
->symtree
->n
.sym
->attr
.pointer
;
3457 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
3460 check_intent_in
= 0;
3465 if (ref
->u
.ar
.type
!= AR_FULL
)
3470 allocatable
= (ref
->u
.c
.component
->as
!= NULL
3471 && ref
->u
.c
.component
->as
->type
== AS_DEFERRED
);
3472 pointer
= ref
->u
.c
.component
->pointer
;
3481 attr
= gfc_expr_attr (e
);
3483 if (allocatable
== 0 && attr
.pointer
== 0)
3486 gfc_error ("Expression in DEALLOCATE statement at %L must be "
3487 "ALLOCATABLE or a POINTER", &e
->where
);
3491 && e
->symtree
->n
.sym
->attr
.intent
== INTENT_IN
)
3493 gfc_error ("Cannot deallocate INTENT(IN) variable '%s' at %L",
3494 e
->symtree
->n
.sym
->name
, &e
->where
);
3502 /* Returns true if the expression e contains a reference the symbol sym. */
3504 find_sym_in_expr (gfc_symbol
*sym
, gfc_expr
*e
)
3506 gfc_actual_arglist
*arg
;
3514 switch (e
->expr_type
)
3517 for (arg
= e
->value
.function
.actual
; arg
; arg
= arg
->next
)
3518 rv
= rv
|| find_sym_in_expr (sym
, arg
->expr
);
3521 /* If the variable is not the same as the dependent, 'sym', and
3522 it is not marked as being declared and it is in the same
3523 namespace as 'sym', add it to the local declarations. */
3525 if (sym
== e
->symtree
->n
.sym
)
3530 rv
= rv
|| find_sym_in_expr (sym
, e
->value
.op
.op1
);
3531 rv
= rv
|| find_sym_in_expr (sym
, e
->value
.op
.op2
);
3540 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
3545 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
3547 rv
= rv
|| find_sym_in_expr (sym
, ref
->u
.ar
.start
[i
]);
3548 rv
= rv
|| find_sym_in_expr (sym
, ref
->u
.ar
.end
[i
]);
3549 rv
= rv
|| find_sym_in_expr (sym
, ref
->u
.ar
.stride
[i
]);
3554 rv
= rv
|| find_sym_in_expr (sym
, ref
->u
.ss
.start
);
3555 rv
= rv
|| find_sym_in_expr (sym
, ref
->u
.ss
.end
);
3559 if (ref
->u
.c
.component
->ts
.type
== BT_CHARACTER
3560 && ref
->u
.c
.component
->ts
.cl
->length
->expr_type
3563 || find_sym_in_expr (sym
,
3564 ref
->u
.c
.component
->ts
.cl
->length
);
3566 if (ref
->u
.c
.component
->as
)
3567 for (i
= 0; i
< ref
->u
.c
.component
->as
->rank
; i
++)
3570 || find_sym_in_expr (sym
,
3571 ref
->u
.c
.component
->as
->lower
[i
]);
3573 || find_sym_in_expr (sym
,
3574 ref
->u
.c
.component
->as
->upper
[i
]);
3584 /* Given the expression node e for an allocatable/pointer of derived type to be
3585 allocated, get the expression node to be initialized afterwards (needed for
3586 derived types with default initializers, and derived types with allocatable
3587 components that need nullification.) */
3590 expr_to_initialize (gfc_expr
*e
)
3596 result
= gfc_copy_expr (e
);
3598 /* Change the last array reference from AR_ELEMENT to AR_FULL. */
3599 for (ref
= result
->ref
; ref
; ref
= ref
->next
)
3600 if (ref
->type
== REF_ARRAY
&& ref
->next
== NULL
)
3602 ref
->u
.ar
.type
= AR_FULL
;
3604 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
3605 ref
->u
.ar
.start
[i
] = ref
->u
.ar
.end
[i
] = ref
->u
.ar
.stride
[i
] = NULL
;
3607 result
->rank
= ref
->u
.ar
.dimen
;
3615 /* Resolve the expression in an ALLOCATE statement, doing the additional
3616 checks to see whether the expression is OK or not. The expression must
3617 have a trailing array reference that gives the size of the array. */
3620 resolve_allocate_expr (gfc_expr
*e
, gfc_code
*code
)
3622 int i
, pointer
, allocatable
, dimension
, check_intent_in
;
3623 symbol_attribute attr
;
3624 gfc_ref
*ref
, *ref2
;
3631 /* Check INTENT(IN), unless the object is a sub-component of a pointer. */
3632 check_intent_in
= 1;
3634 if (gfc_resolve_expr (e
) == FAILURE
)
3637 if (code
->expr
&& code
->expr
->expr_type
== EXPR_VARIABLE
)
3638 sym
= code
->expr
->symtree
->n
.sym
;
3642 /* Make sure the expression is allocatable or a pointer. If it is
3643 pointer, the next-to-last reference must be a pointer. */
3647 if (e
->expr_type
!= EXPR_VARIABLE
)
3650 attr
= gfc_expr_attr (e
);
3651 pointer
= attr
.pointer
;
3652 dimension
= attr
.dimension
;
3656 allocatable
= e
->symtree
->n
.sym
->attr
.allocatable
;
3657 pointer
= e
->symtree
->n
.sym
->attr
.pointer
;
3658 dimension
= e
->symtree
->n
.sym
->attr
.dimension
;
3660 if (sym
== e
->symtree
->n
.sym
&& sym
->ts
.type
!= BT_DERIVED
)
3662 gfc_error ("The STAT variable '%s' in an ALLOCATE statement must "
3663 "not be allocated in the same statement at %L",
3664 sym
->name
, &e
->where
);
3668 for (ref
= e
->ref
; ref
; ref2
= ref
, ref
= ref
->next
)
3671 check_intent_in
= 0;
3676 if (ref
->next
!= NULL
)
3681 allocatable
= (ref
->u
.c
.component
->as
!= NULL
3682 && ref
->u
.c
.component
->as
->type
== AS_DEFERRED
);
3684 pointer
= ref
->u
.c
.component
->pointer
;
3685 dimension
= ref
->u
.c
.component
->dimension
;
3696 if (allocatable
== 0 && pointer
== 0)
3698 gfc_error ("Expression in ALLOCATE statement at %L must be "
3699 "ALLOCATABLE or a POINTER", &e
->where
);
3704 && e
->symtree
->n
.sym
->attr
.intent
== INTENT_IN
)
3706 gfc_error ("Cannot allocate INTENT(IN) variable '%s' at %L",
3707 e
->symtree
->n
.sym
->name
, &e
->where
);
3711 /* Add default initializer for those derived types that need them. */
3712 if (e
->ts
.type
== BT_DERIVED
&& (init_e
= gfc_default_initializer (&e
->ts
)))
3714 init_st
= gfc_get_code ();
3715 init_st
->loc
= code
->loc
;
3716 init_st
->op
= EXEC_INIT_ASSIGN
;
3717 init_st
->expr
= expr_to_initialize (e
);
3718 init_st
->expr2
= init_e
;
3719 init_st
->next
= code
->next
;
3720 code
->next
= init_st
;
3723 if (pointer
&& dimension
== 0)
3726 /* Make sure the next-to-last reference node is an array specification. */
3728 if (ref2
== NULL
|| ref2
->type
!= REF_ARRAY
|| ref2
->u
.ar
.type
== AR_FULL
)
3730 gfc_error ("Array specification required in ALLOCATE statement "
3731 "at %L", &e
->where
);
3735 /* Make sure that the array section reference makes sense in the
3736 context of an ALLOCATE specification. */
3740 for (i
= 0; i
< ar
->dimen
; i
++)
3742 if (ref2
->u
.ar
.type
== AR_ELEMENT
)
3745 switch (ar
->dimen_type
[i
])
3751 if (ar
->start
[i
] != NULL
3752 && ar
->end
[i
] != NULL
3753 && ar
->stride
[i
] == NULL
)
3756 /* Fall Through... */
3760 gfc_error ("Bad array specification in ALLOCATE statement at %L",
3767 for (a
= code
->ext
.alloc_list
; a
; a
= a
->next
)
3769 sym
= a
->expr
->symtree
->n
.sym
;
3771 /* TODO - check derived type components. */
3772 if (sym
->ts
.type
== BT_DERIVED
)
3775 if ((ar
->start
[i
] != NULL
&& find_sym_in_expr (sym
, ar
->start
[i
]))
3776 || (ar
->end
[i
] != NULL
&& find_sym_in_expr (sym
, ar
->end
[i
])))
3778 gfc_error ("'%s' must not appear an the array specification at "
3779 "%L in the same ALLOCATE statement where it is "
3780 "itself allocated", sym
->name
, &ar
->where
);
3790 /************ SELECT CASE resolution subroutines ************/
3792 /* Callback function for our mergesort variant. Determines interval
3793 overlaps for CASEs. Return <0 if op1 < op2, 0 for overlap, >0 for
3794 op1 > op2. Assumes we're not dealing with the default case.
3795 We have op1 = (:L), (K:L) or (K:) and op2 = (:N), (M:N) or (M:).
3796 There are nine situations to check. */
3799 compare_cases (const gfc_case
*op1
, const gfc_case
*op2
)
3803 if (op1
->low
== NULL
) /* op1 = (:L) */
3805 /* op2 = (:N), so overlap. */
3807 /* op2 = (M:) or (M:N), L < M */
3808 if (op2
->low
!= NULL
3809 && gfc_compare_expr (op1
->high
, op2
->low
) < 0)
3812 else if (op1
->high
== NULL
) /* op1 = (K:) */
3814 /* op2 = (M:), so overlap. */
3816 /* op2 = (:N) or (M:N), K > N */
3817 if (op2
->high
!= NULL
3818 && gfc_compare_expr (op1
->low
, op2
->high
) > 0)
3821 else /* op1 = (K:L) */
3823 if (op2
->low
== NULL
) /* op2 = (:N), K > N */
3824 retval
= (gfc_compare_expr (op1
->low
, op2
->high
) > 0) ? 1 : 0;
3825 else if (op2
->high
== NULL
) /* op2 = (M:), L < M */
3826 retval
= (gfc_compare_expr (op1
->high
, op2
->low
) < 0) ? -1 : 0;
3827 else /* op2 = (M:N) */
3831 if (gfc_compare_expr (op1
->high
, op2
->low
) < 0)
3834 else if (gfc_compare_expr (op1
->low
, op2
->high
) > 0)
3843 /* Merge-sort a double linked case list, detecting overlap in the
3844 process. LIST is the head of the double linked case list before it
3845 is sorted. Returns the head of the sorted list if we don't see any
3846 overlap, or NULL otherwise. */
3849 check_case_overlap (gfc_case
*list
)
3851 gfc_case
*p
, *q
, *e
, *tail
;
3852 int insize
, nmerges
, psize
, qsize
, cmp
, overlap_seen
;
3854 /* If the passed list was empty, return immediately. */
3861 /* Loop unconditionally. The only exit from this loop is a return
3862 statement, when we've finished sorting the case list. */
3869 /* Count the number of merges we do in this pass. */
3872 /* Loop while there exists a merge to be done. */
3877 /* Count this merge. */
3880 /* Cut the list in two pieces by stepping INSIZE places
3881 forward in the list, starting from P. */
3884 for (i
= 0; i
< insize
; i
++)
3893 /* Now we have two lists. Merge them! */
3894 while (psize
> 0 || (qsize
> 0 && q
!= NULL
))
3896 /* See from which the next case to merge comes from. */
3899 /* P is empty so the next case must come from Q. */
3904 else if (qsize
== 0 || q
== NULL
)
3913 cmp
= compare_cases (p
, q
);
3916 /* The whole case range for P is less than the
3924 /* The whole case range for Q is greater than
3925 the case range for P. */
3932 /* The cases overlap, or they are the same
3933 element in the list. Either way, we must
3934 issue an error and get the next case from P. */
3935 /* FIXME: Sort P and Q by line number. */
3936 gfc_error ("CASE label at %L overlaps with CASE "
3937 "label at %L", &p
->where
, &q
->where
);
3945 /* Add the next element to the merged list. */
3954 /* P has now stepped INSIZE places along, and so has Q. So
3955 they're the same. */
3960 /* If we have done only one merge or none at all, we've
3961 finished sorting the cases. */
3970 /* Otherwise repeat, merging lists twice the size. */
3976 /* Check to see if an expression is suitable for use in a CASE statement.
3977 Makes sure that all case expressions are scalar constants of the same
3978 type. Return FAILURE if anything is wrong. */
3981 validate_case_label_expr (gfc_expr
*e
, gfc_expr
*case_expr
)
3983 if (e
== NULL
) return SUCCESS
;
3985 if (e
->ts
.type
!= case_expr
->ts
.type
)
3987 gfc_error ("Expression in CASE statement at %L must be of type %s",
3988 &e
->where
, gfc_basic_typename (case_expr
->ts
.type
));
3992 /* C805 (R808) For a given case-construct, each case-value shall be of
3993 the same type as case-expr. For character type, length differences
3994 are allowed, but the kind type parameters shall be the same. */
3996 if (case_expr
->ts
.type
== BT_CHARACTER
&& e
->ts
.kind
!= case_expr
->ts
.kind
)
3998 gfc_error("Expression in CASE statement at %L must be kind %d",
3999 &e
->where
, case_expr
->ts
.kind
);
4003 /* Convert the case value kind to that of case expression kind, if needed.
4004 FIXME: Should a warning be issued? */
4005 if (e
->ts
.kind
!= case_expr
->ts
.kind
)
4006 gfc_convert_type_warn (e
, &case_expr
->ts
, 2, 0);
4010 gfc_error ("Expression in CASE statement at %L must be scalar",
4019 /* Given a completely parsed select statement, we:
4021 - Validate all expressions and code within the SELECT.
4022 - Make sure that the selection expression is not of the wrong type.
4023 - Make sure that no case ranges overlap.
4024 - Eliminate unreachable cases and unreachable code resulting from
4025 removing case labels.
4027 The standard does allow unreachable cases, e.g. CASE (5:3). But
4028 they are a hassle for code generation, and to prevent that, we just
4029 cut them out here. This is not necessary for overlapping cases
4030 because they are illegal and we never even try to generate code.
4032 We have the additional caveat that a SELECT construct could have
4033 been a computed GOTO in the source code. Fortunately we can fairly
4034 easily work around that here: The case_expr for a "real" SELECT CASE
4035 is in code->expr1, but for a computed GOTO it is in code->expr2. All
4036 we have to do is make sure that the case_expr is a scalar integer
4040 resolve_select (gfc_code
*code
)
4043 gfc_expr
*case_expr
;
4044 gfc_case
*cp
, *default_case
, *tail
, *head
;
4045 int seen_unreachable
;
4051 if (code
->expr
== NULL
)
4053 /* This was actually a computed GOTO statement. */
4054 case_expr
= code
->expr2
;
4055 if (case_expr
->ts
.type
!= BT_INTEGER
|| case_expr
->rank
!= 0)
4056 gfc_error ("Selection expression in computed GOTO statement "
4057 "at %L must be a scalar integer expression",
4060 /* Further checking is not necessary because this SELECT was built
4061 by the compiler, so it should always be OK. Just move the
4062 case_expr from expr2 to expr so that we can handle computed
4063 GOTOs as normal SELECTs from here on. */
4064 code
->expr
= code
->expr2
;
4069 case_expr
= code
->expr
;
4071 type
= case_expr
->ts
.type
;
4072 if (type
!= BT_LOGICAL
&& type
!= BT_INTEGER
&& type
!= BT_CHARACTER
)
4074 gfc_error ("Argument of SELECT statement at %L cannot be %s",
4075 &case_expr
->where
, gfc_typename (&case_expr
->ts
));
4077 /* Punt. Going on here just produce more garbage error messages. */
4081 if (case_expr
->rank
!= 0)
4083 gfc_error ("Argument of SELECT statement at %L must be a scalar "
4084 "expression", &case_expr
->where
);
4090 /* PR 19168 has a long discussion concerning a mismatch of the kinds
4091 of the SELECT CASE expression and its CASE values. Walk the lists
4092 of case values, and if we find a mismatch, promote case_expr to
4093 the appropriate kind. */
4095 if (type
== BT_LOGICAL
|| type
== BT_INTEGER
)
4097 for (body
= code
->block
; body
; body
= body
->block
)
4099 /* Walk the case label list. */
4100 for (cp
= body
->ext
.case_list
; cp
; cp
= cp
->next
)
4102 /* Intercept the DEFAULT case. It does not have a kind. */
4103 if (cp
->low
== NULL
&& cp
->high
== NULL
)
4106 /* Unreachable case ranges are discarded, so ignore. */
4107 if (cp
->low
!= NULL
&& cp
->high
!= NULL
4108 && cp
->low
!= cp
->high
4109 && gfc_compare_expr (cp
->low
, cp
->high
) > 0)
4112 /* FIXME: Should a warning be issued? */
4114 && case_expr
->ts
.kind
!= gfc_kind_max(case_expr
, cp
->low
))
4115 gfc_convert_type_warn (case_expr
, &cp
->low
->ts
, 2, 0);
4117 if (cp
->high
!= NULL
4118 && case_expr
->ts
.kind
!= gfc_kind_max(case_expr
, cp
->high
))
4119 gfc_convert_type_warn (case_expr
, &cp
->high
->ts
, 2, 0);
4124 /* Assume there is no DEFAULT case. */
4125 default_case
= NULL
;
4130 for (body
= code
->block
; body
; body
= body
->block
)
4132 /* Assume the CASE list is OK, and all CASE labels can be matched. */
4134 seen_unreachable
= 0;
4136 /* Walk the case label list, making sure that all case labels
4138 for (cp
= body
->ext
.case_list
; cp
; cp
= cp
->next
)
4140 /* Count the number of cases in the whole construct. */
4143 /* Intercept the DEFAULT case. */
4144 if (cp
->low
== NULL
&& cp
->high
== NULL
)
4146 if (default_case
!= NULL
)
4148 gfc_error ("The DEFAULT CASE at %L cannot be followed "
4149 "by a second DEFAULT CASE at %L",
4150 &default_case
->where
, &cp
->where
);
4161 /* Deal with single value cases and case ranges. Errors are
4162 issued from the validation function. */
4163 if(validate_case_label_expr (cp
->low
, case_expr
) != SUCCESS
4164 || validate_case_label_expr (cp
->high
, case_expr
) != SUCCESS
)
4170 if (type
== BT_LOGICAL
4171 && ((cp
->low
== NULL
|| cp
->high
== NULL
)
4172 || cp
->low
!= cp
->high
))
4174 gfc_error ("Logical range in CASE statement at %L is not "
4175 "allowed", &cp
->low
->where
);
4180 if (type
== BT_LOGICAL
&& cp
->low
->expr_type
== EXPR_CONSTANT
)
4183 value
= cp
->low
->value
.logical
== 0 ? 2 : 1;
4184 if (value
& seen_logical
)
4186 gfc_error ("constant logical value in CASE statement "
4187 "is repeated at %L",
4192 seen_logical
|= value
;
4195 if (cp
->low
!= NULL
&& cp
->high
!= NULL
4196 && cp
->low
!= cp
->high
4197 && gfc_compare_expr (cp
->low
, cp
->high
) > 0)
4199 if (gfc_option
.warn_surprising
)
4200 gfc_warning ("Range specification at %L can never "
4201 "be matched", &cp
->where
);
4203 cp
->unreachable
= 1;
4204 seen_unreachable
= 1;
4208 /* If the case range can be matched, it can also overlap with
4209 other cases. To make sure it does not, we put it in a
4210 double linked list here. We sort that with a merge sort
4211 later on to detect any overlapping cases. */
4215 head
->right
= head
->left
= NULL
;
4220 tail
->right
->left
= tail
;
4227 /* It there was a failure in the previous case label, give up
4228 for this case label list. Continue with the next block. */
4232 /* See if any case labels that are unreachable have been seen.
4233 If so, we eliminate them. This is a bit of a kludge because
4234 the case lists for a single case statement (label) is a
4235 single forward linked lists. */
4236 if (seen_unreachable
)
4238 /* Advance until the first case in the list is reachable. */
4239 while (body
->ext
.case_list
!= NULL
4240 && body
->ext
.case_list
->unreachable
)
4242 gfc_case
*n
= body
->ext
.case_list
;
4243 body
->ext
.case_list
= body
->ext
.case_list
->next
;
4245 gfc_free_case_list (n
);
4248 /* Strip all other unreachable cases. */
4249 if (body
->ext
.case_list
)
4251 for (cp
= body
->ext
.case_list
; cp
->next
; cp
= cp
->next
)
4253 if (cp
->next
->unreachable
)
4255 gfc_case
*n
= cp
->next
;
4256 cp
->next
= cp
->next
->next
;
4258 gfc_free_case_list (n
);
4265 /* See if there were overlapping cases. If the check returns NULL,
4266 there was overlap. In that case we don't do anything. If head
4267 is non-NULL, we prepend the DEFAULT case. The sorted list can
4268 then used during code generation for SELECT CASE constructs with
4269 a case expression of a CHARACTER type. */
4272 head
= check_case_overlap (head
);
4274 /* Prepend the default_case if it is there. */
4275 if (head
!= NULL
&& default_case
)
4277 default_case
->left
= NULL
;
4278 default_case
->right
= head
;
4279 head
->left
= default_case
;
4283 /* Eliminate dead blocks that may be the result if we've seen
4284 unreachable case labels for a block. */
4285 for (body
= code
; body
&& body
->block
; body
= body
->block
)
4287 if (body
->block
->ext
.case_list
== NULL
)
4289 /* Cut the unreachable block from the code chain. */
4290 gfc_code
*c
= body
->block
;
4291 body
->block
= c
->block
;
4293 /* Kill the dead block, but not the blocks below it. */
4295 gfc_free_statements (c
);
4299 /* More than two cases is legal but insane for logical selects.
4300 Issue a warning for it. */
4301 if (gfc_option
.warn_surprising
&& type
== BT_LOGICAL
4303 gfc_warning ("Logical SELECT CASE block at %L has more that two cases",
4308 /* Resolve a transfer statement. This is making sure that:
4309 -- a derived type being transferred has only non-pointer components
4310 -- a derived type being transferred doesn't have private components, unless
4311 it's being transferred from the module where the type was defined
4312 -- we're not trying to transfer a whole assumed size array. */
4315 resolve_transfer (gfc_code
*code
)
4324 if (exp
->expr_type
!= EXPR_VARIABLE
&& exp
->expr_type
!= EXPR_FUNCTION
)
4327 sym
= exp
->symtree
->n
.sym
;
4330 /* Go to actual component transferred. */
4331 for (ref
= code
->expr
->ref
; ref
; ref
= ref
->next
)
4332 if (ref
->type
== REF_COMPONENT
)
4333 ts
= &ref
->u
.c
.component
->ts
;
4335 if (ts
->type
== BT_DERIVED
)
4337 /* Check that transferred derived type doesn't contain POINTER
4339 if (derived_pointer (ts
->derived
))
4341 gfc_error ("Data transfer element at %L cannot have "
4342 "POINTER components", &code
->loc
);
4346 if (ts
->derived
->attr
.alloc_comp
)
4348 gfc_error ("Data transfer element at %L cannot have "
4349 "ALLOCATABLE components", &code
->loc
);
4353 if (derived_inaccessible (ts
->derived
))
4355 gfc_error ("Data transfer element at %L cannot have "
4356 "PRIVATE components",&code
->loc
);
4361 if (sym
->as
!= NULL
&& sym
->as
->type
== AS_ASSUMED_SIZE
4362 && exp
->ref
->type
== REF_ARRAY
&& exp
->ref
->u
.ar
.type
== AR_FULL
)
4364 gfc_error ("Data transfer element at %L cannot be a full reference to "
4365 "an assumed-size array", &code
->loc
);
4371 /*********** Toplevel code resolution subroutines ***********/
4373 /* Given a branch to a label and a namespace, if the branch is conforming.
4374 The code node described where the branch is located. */
4377 resolve_branch (gfc_st_label
*label
, gfc_code
*code
)
4379 gfc_code
*block
, *found
;
4387 /* Step one: is this a valid branching target? */
4389 if (lp
->defined
== ST_LABEL_UNKNOWN
)
4391 gfc_error ("Label %d referenced at %L is never defined", lp
->value
,
4396 if (lp
->defined
!= ST_LABEL_TARGET
)
4398 gfc_error ("Statement at %L is not a valid branch target statement "
4399 "for the branch statement at %L", &lp
->where
, &code
->loc
);
4403 /* Step two: make sure this branch is not a branch to itself ;-) */
4405 if (code
->here
== label
)
4407 gfc_warning ("Branch at %L causes an infinite loop", &code
->loc
);
4411 /* Step three: Try to find the label in the parse tree. To do this,
4412 we traverse the tree block-by-block: first the block that
4413 contains this GOTO, then the block that it is nested in, etc. We
4414 can ignore other blocks because branching into another block is
4419 for (stack
= cs_base
; stack
; stack
= stack
->prev
)
4421 for (block
= stack
->head
; block
; block
= block
->next
)
4423 if (block
->here
== label
)
4436 /* The label is not in an enclosing block, so illegal. This was
4437 allowed in Fortran 66, so we allow it as extension. We also
4438 forego further checks if we run into this. */
4439 gfc_notify_std (GFC_STD_LEGACY
, "Label at %L is not in the same block "
4440 "as the GOTO statement at %L", &lp
->where
, &code
->loc
);
4444 /* Step four: Make sure that the branching target is legal if
4445 the statement is an END {SELECT,DO,IF}. */
4447 if (found
->op
== EXEC_NOP
)
4449 for (stack
= cs_base
; stack
; stack
= stack
->prev
)
4450 if (stack
->current
->next
== found
)
4454 gfc_notify_std (GFC_STD_F95_DEL
, "Obsolete: GOTO at %L jumps to END "
4455 "of construct at %L", &code
->loc
, &found
->loc
);
4460 /* Check whether EXPR1 has the same shape as EXPR2. */
4463 resolve_where_shape (gfc_expr
*expr1
, gfc_expr
*expr2
)
4465 mpz_t shape
[GFC_MAX_DIMENSIONS
];
4466 mpz_t shape2
[GFC_MAX_DIMENSIONS
];
4467 try result
= FAILURE
;
4470 /* Compare the rank. */
4471 if (expr1
->rank
!= expr2
->rank
)
4474 /* Compare the size of each dimension. */
4475 for (i
=0; i
<expr1
->rank
; i
++)
4477 if (gfc_array_dimen_size (expr1
, i
, &shape
[i
]) == FAILURE
)
4480 if (gfc_array_dimen_size (expr2
, i
, &shape2
[i
]) == FAILURE
)
4483 if (mpz_cmp (shape
[i
], shape2
[i
]))
4487 /* When either of the two expression is an assumed size array, we
4488 ignore the comparison of dimension sizes. */
4493 for (i
--; i
>= 0; i
--)
4495 mpz_clear (shape
[i
]);
4496 mpz_clear (shape2
[i
]);
4502 /* Check whether a WHERE assignment target or a WHERE mask expression
4503 has the same shape as the outmost WHERE mask expression. */
4506 resolve_where (gfc_code
*code
, gfc_expr
*mask
)
4512 cblock
= code
->block
;
4514 /* Store the first WHERE mask-expr of the WHERE statement or construct.
4515 In case of nested WHERE, only the outmost one is stored. */
4516 if (mask
== NULL
) /* outmost WHERE */
4518 else /* inner WHERE */
4525 /* Check if the mask-expr has a consistent shape with the
4526 outmost WHERE mask-expr. */
4527 if (resolve_where_shape (cblock
->expr
, e
) == FAILURE
)
4528 gfc_error ("WHERE mask at %L has inconsistent shape",
4529 &cblock
->expr
->where
);
4532 /* the assignment statement of a WHERE statement, or the first
4533 statement in where-body-construct of a WHERE construct */
4534 cnext
= cblock
->next
;
4539 /* WHERE assignment statement */
4542 /* Check shape consistent for WHERE assignment target. */
4543 if (e
&& resolve_where_shape (cnext
->expr
, e
) == FAILURE
)
4544 gfc_error ("WHERE assignment target at %L has "
4545 "inconsistent shape", &cnext
->expr
->where
);
4549 case EXEC_ASSIGN_CALL
:
4550 resolve_call (cnext
);
4553 /* WHERE or WHERE construct is part of a where-body-construct */
4555 resolve_where (cnext
, e
);
4559 gfc_error ("Unsupported statement inside WHERE at %L",
4562 /* the next statement within the same where-body-construct */
4563 cnext
= cnext
->next
;
4565 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
4566 cblock
= cblock
->block
;
4571 /* Check whether the FORALL index appears in the expression or not. */
4574 gfc_find_forall_index (gfc_expr
*expr
, gfc_symbol
*symbol
)
4578 gfc_actual_arglist
*args
;
4581 switch (expr
->expr_type
)
4584 gcc_assert (expr
->symtree
->n
.sym
);
4586 /* A scalar assignment */
4589 if (expr
->symtree
->n
.sym
== symbol
)
4595 /* the expr is array ref, substring or struct component. */
4602 /* Check if the symbol appears in the array subscript. */
4604 for (i
= 0; i
< GFC_MAX_DIMENSIONS
; i
++)
4607 if (gfc_find_forall_index (ar
.start
[i
], symbol
) == SUCCESS
)
4611 if (gfc_find_forall_index (ar
.end
[i
], symbol
) == SUCCESS
)
4615 if (gfc_find_forall_index (ar
.stride
[i
], symbol
) == SUCCESS
)
4621 if (expr
->symtree
->n
.sym
== symbol
)
4624 /* Check if the symbol appears in the substring section. */
4625 if (gfc_find_forall_index (tmp
->u
.ss
.start
, symbol
) == SUCCESS
)
4627 if (gfc_find_forall_index (tmp
->u
.ss
.end
, symbol
) == SUCCESS
)
4635 gfc_error("expression reference type error at %L", &expr
->where
);
4641 /* If the expression is a function call, then check if the symbol
4642 appears in the actual arglist of the function. */
4644 for (args
= expr
->value
.function
.actual
; args
; args
= args
->next
)
4646 if (gfc_find_forall_index(args
->expr
,symbol
) == SUCCESS
)
4651 /* It seems not to happen. */
4652 case EXPR_SUBSTRING
:
4656 gcc_assert (expr
->ref
->type
== REF_SUBSTRING
);
4657 if (gfc_find_forall_index (tmp
->u
.ss
.start
, symbol
) == SUCCESS
)
4659 if (gfc_find_forall_index (tmp
->u
.ss
.end
, symbol
) == SUCCESS
)
4664 /* It seems not to happen. */
4665 case EXPR_STRUCTURE
:
4667 gfc_error ("Unsupported statement while finding forall index in "
4672 /* Find the FORALL index in the first operand. */
4673 if (expr
->value
.op
.op1
)
4675 if (gfc_find_forall_index (expr
->value
.op
.op1
, symbol
) == SUCCESS
)
4679 /* Find the FORALL index in the second operand. */
4680 if (expr
->value
.op
.op2
)
4682 if (gfc_find_forall_index (expr
->value
.op
.op2
, symbol
) == SUCCESS
)
4695 /* Resolve assignment in FORALL construct.
4696 NVAR is the number of FORALL index variables, and VAR_EXPR records the
4697 FORALL index variables. */
4700 gfc_resolve_assign_in_forall (gfc_code
*code
, int nvar
, gfc_expr
**var_expr
)
4704 for (n
= 0; n
< nvar
; n
++)
4706 gfc_symbol
*forall_index
;
4708 forall_index
= var_expr
[n
]->symtree
->n
.sym
;
4710 /* Check whether the assignment target is one of the FORALL index
4712 if ((code
->expr
->expr_type
== EXPR_VARIABLE
)
4713 && (code
->expr
->symtree
->n
.sym
== forall_index
))
4714 gfc_error ("Assignment to a FORALL index variable at %L",
4715 &code
->expr
->where
);
4718 /* If one of the FORALL index variables doesn't appear in the
4719 assignment target, then there will be a many-to-one
4721 if (gfc_find_forall_index (code
->expr
, forall_index
) == FAILURE
)
4722 gfc_error ("The FORALL with index '%s' cause more than one "
4723 "assignment to this object at %L",
4724 var_expr
[n
]->symtree
->name
, &code
->expr
->where
);
4730 /* Resolve WHERE statement in FORALL construct. */
4733 gfc_resolve_where_code_in_forall (gfc_code
*code
, int nvar
,
4734 gfc_expr
**var_expr
)
4739 cblock
= code
->block
;
4742 /* the assignment statement of a WHERE statement, or the first
4743 statement in where-body-construct of a WHERE construct */
4744 cnext
= cblock
->next
;
4749 /* WHERE assignment statement */
4751 gfc_resolve_assign_in_forall (cnext
, nvar
, var_expr
);
4754 /* WHERE operator assignment statement */
4755 case EXEC_ASSIGN_CALL
:
4756 resolve_call (cnext
);
4759 /* WHERE or WHERE construct is part of a where-body-construct */
4761 gfc_resolve_where_code_in_forall (cnext
, nvar
, var_expr
);
4765 gfc_error ("Unsupported statement inside WHERE at %L",
4768 /* the next statement within the same where-body-construct */
4769 cnext
= cnext
->next
;
4771 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
4772 cblock
= cblock
->block
;
4777 /* Traverse the FORALL body to check whether the following errors exist:
4778 1. For assignment, check if a many-to-one assignment happens.
4779 2. For WHERE statement, check the WHERE body to see if there is any
4780 many-to-one assignment. */
4783 gfc_resolve_forall_body (gfc_code
*code
, int nvar
, gfc_expr
**var_expr
)
4787 c
= code
->block
->next
;
4793 case EXEC_POINTER_ASSIGN
:
4794 gfc_resolve_assign_in_forall (c
, nvar
, var_expr
);
4797 case EXEC_ASSIGN_CALL
:
4801 /* Because the gfc_resolve_blocks() will handle the nested FORALL,
4802 there is no need to handle it here. */
4806 gfc_resolve_where_code_in_forall(c
, nvar
, var_expr
);
4811 /* The next statement in the FORALL body. */
4817 /* Given a FORALL construct, first resolve the FORALL iterator, then call
4818 gfc_resolve_forall_body to resolve the FORALL body. */
4821 gfc_resolve_forall (gfc_code
*code
, gfc_namespace
*ns
, int forall_save
)
4823 static gfc_expr
**var_expr
;
4824 static int total_var
= 0;
4825 static int nvar
= 0;
4826 gfc_forall_iterator
*fa
;
4827 gfc_symbol
*forall_index
;
4831 /* Start to resolve a FORALL construct */
4832 if (forall_save
== 0)
4834 /* Count the total number of FORALL index in the nested FORALL
4835 construct in order to allocate the VAR_EXPR with proper size. */
4837 while ((next
!= NULL
) && (next
->op
== EXEC_FORALL
))
4839 for (fa
= next
->ext
.forall_iterator
; fa
; fa
= fa
->next
)
4841 next
= next
->block
->next
;
4844 /* Allocate VAR_EXPR with NUMBER_OF_FORALL_INDEX elements. */
4845 var_expr
= (gfc_expr
**) gfc_getmem (total_var
* sizeof (gfc_expr
*));
4848 /* The information about FORALL iterator, including FORALL index start, end
4849 and stride. The FORALL index can not appear in start, end or stride. */
4850 for (fa
= code
->ext
.forall_iterator
; fa
; fa
= fa
->next
)
4852 /* Check if any outer FORALL index name is the same as the current
4854 for (i
= 0; i
< nvar
; i
++)
4856 if (fa
->var
->symtree
->n
.sym
== var_expr
[i
]->symtree
->n
.sym
)
4858 gfc_error ("An outer FORALL construct already has an index "
4859 "with this name %L", &fa
->var
->where
);
4863 /* Record the current FORALL index. */
4864 var_expr
[nvar
] = gfc_copy_expr (fa
->var
);
4866 forall_index
= fa
->var
->symtree
->n
.sym
;
4868 /* Check if the FORALL index appears in start, end or stride. */
4869 if (gfc_find_forall_index (fa
->start
, forall_index
) == SUCCESS
)
4870 gfc_error ("A FORALL index must not appear in a limit or stride "
4871 "expression in the same FORALL at %L", &fa
->start
->where
);
4872 if (gfc_find_forall_index (fa
->end
, forall_index
) == SUCCESS
)
4873 gfc_error ("A FORALL index must not appear in a limit or stride "
4874 "expression in the same FORALL at %L", &fa
->end
->where
);
4875 if (gfc_find_forall_index (fa
->stride
, forall_index
) == SUCCESS
)
4876 gfc_error ("A FORALL index must not appear in a limit or stride "
4877 "expression in the same FORALL at %L", &fa
->stride
->where
);
4881 /* Resolve the FORALL body. */
4882 gfc_resolve_forall_body (code
, nvar
, var_expr
);
4884 /* May call gfc_resolve_forall to resolve the inner FORALL loop. */
4885 gfc_resolve_blocks (code
->block
, ns
);
4887 /* Free VAR_EXPR after the whole FORALL construct resolved. */
4888 for (i
= 0; i
< total_var
; i
++)
4889 gfc_free_expr (var_expr
[i
]);
4891 /* Reset the counters. */
4897 /* Resolve lists of blocks found in IF, SELECT CASE, WHERE, FORALL ,GOTO and
4900 static void resolve_code (gfc_code
*, gfc_namespace
*);
4903 gfc_resolve_blocks (gfc_code
*b
, gfc_namespace
*ns
)
4907 for (; b
; b
= b
->block
)
4909 t
= gfc_resolve_expr (b
->expr
);
4910 if (gfc_resolve_expr (b
->expr2
) == FAILURE
)
4916 if (t
== SUCCESS
&& b
->expr
!= NULL
4917 && (b
->expr
->ts
.type
!= BT_LOGICAL
|| b
->expr
->rank
!= 0))
4918 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
4925 && (b
->expr
->ts
.type
!= BT_LOGICAL
|| b
->expr
->rank
== 0))
4926 gfc_error ("WHERE/ELSEWHERE clause at %L requires a LOGICAL array",
4931 resolve_branch (b
->label
, b
);
4943 case EXEC_OMP_ATOMIC
:
4944 case EXEC_OMP_CRITICAL
:
4946 case EXEC_OMP_MASTER
:
4947 case EXEC_OMP_ORDERED
:
4948 case EXEC_OMP_PARALLEL
:
4949 case EXEC_OMP_PARALLEL_DO
:
4950 case EXEC_OMP_PARALLEL_SECTIONS
:
4951 case EXEC_OMP_PARALLEL_WORKSHARE
:
4952 case EXEC_OMP_SECTIONS
:
4953 case EXEC_OMP_SINGLE
:
4954 case EXEC_OMP_WORKSHARE
:
4958 gfc_internal_error ("resolve_block(): Bad block type");
4961 resolve_code (b
->next
, ns
);
4966 /* Given a block of code, recursively resolve everything pointed to by this
4970 resolve_code (gfc_code
*code
, gfc_namespace
*ns
)
4972 int omp_workshare_save
;
4978 frame
.prev
= cs_base
;
4982 for (; code
; code
= code
->next
)
4984 frame
.current
= code
;
4985 forall_save
= forall_flag
;
4987 if (code
->op
== EXEC_FORALL
)
4990 gfc_resolve_forall (code
, ns
, forall_save
);
4993 else if (code
->block
)
4995 omp_workshare_save
= -1;
4998 case EXEC_OMP_PARALLEL_WORKSHARE
:
4999 omp_workshare_save
= omp_workshare_flag
;
5000 omp_workshare_flag
= 1;
5001 gfc_resolve_omp_parallel_blocks (code
, ns
);
5003 case EXEC_OMP_PARALLEL
:
5004 case EXEC_OMP_PARALLEL_DO
:
5005 case EXEC_OMP_PARALLEL_SECTIONS
:
5006 omp_workshare_save
= omp_workshare_flag
;
5007 omp_workshare_flag
= 0;
5008 gfc_resolve_omp_parallel_blocks (code
, ns
);
5011 gfc_resolve_omp_do_blocks (code
, ns
);
5013 case EXEC_OMP_WORKSHARE
:
5014 omp_workshare_save
= omp_workshare_flag
;
5015 omp_workshare_flag
= 1;
5018 gfc_resolve_blocks (code
->block
, ns
);
5022 if (omp_workshare_save
!= -1)
5023 omp_workshare_flag
= omp_workshare_save
;
5026 t
= gfc_resolve_expr (code
->expr
);
5027 forall_flag
= forall_save
;
5029 if (gfc_resolve_expr (code
->expr2
) == FAILURE
)
5044 /* Keep track of which entry we are up to. */
5045 current_entry_id
= code
->ext
.entry
->id
;
5049 resolve_where (code
, NULL
);
5053 if (code
->expr
!= NULL
)
5055 if (code
->expr
->ts
.type
!= BT_INTEGER
)
5056 gfc_error ("ASSIGNED GOTO statement at %L requires an "
5057 "INTEGER variable", &code
->expr
->where
);
5058 else if (code
->expr
->symtree
->n
.sym
->attr
.assign
!= 1)
5059 gfc_error ("Variable '%s' has not been assigned a target "
5060 "label at %L", code
->expr
->symtree
->n
.sym
->name
,
5061 &code
->expr
->where
);
5064 resolve_branch (code
->label
, code
);
5068 if (code
->expr
!= NULL
5069 && (code
->expr
->ts
.type
!= BT_INTEGER
|| code
->expr
->rank
))
5070 gfc_error ("Alternate RETURN statement at %L requires a SCALAR-"
5071 "INTEGER return specifier", &code
->expr
->where
);
5074 case EXEC_INIT_ASSIGN
:
5081 if (gfc_extend_assign (code
, ns
) == SUCCESS
)
5083 if (gfc_pure (NULL
) && !gfc_pure (code
->symtree
->n
.sym
))
5085 gfc_error ("Subroutine '%s' called instead of assignment at "
5086 "%L must be PURE", code
->symtree
->n
.sym
->name
,
5093 if (code
->expr
->ts
.type
== BT_CHARACTER
5094 && gfc_option
.warn_character_truncation
)
5096 int llen
= 0, rlen
= 0;
5098 if (code
->expr
->ts
.cl
!= NULL
5099 && code
->expr
->ts
.cl
->length
!= NULL
5100 && code
->expr
->ts
.cl
->length
->expr_type
== EXPR_CONSTANT
)
5101 llen
= mpz_get_si (code
->expr
->ts
.cl
->length
->value
.integer
);
5103 if (code
->expr2
->expr_type
== EXPR_CONSTANT
)
5104 rlen
= code
->expr2
->value
.character
.length
;
5106 else if (code
->expr2
->ts
.cl
!= NULL
5107 && code
->expr2
->ts
.cl
->length
!= NULL
5108 && code
->expr2
->ts
.cl
->length
->expr_type
5110 rlen
= mpz_get_si (code
->expr2
->ts
.cl
->length
->value
.integer
);
5112 if (rlen
&& llen
&& rlen
> llen
)
5113 gfc_warning_now ("rhs of CHARACTER assignment at %L will be "
5114 "truncated (%d/%d)", &code
->loc
, rlen
, llen
);
5117 if (gfc_pure (NULL
))
5119 if (gfc_impure_variable (code
->expr
->symtree
->n
.sym
))
5121 gfc_error ("Cannot assign to variable '%s' in PURE "
5123 code
->expr
->symtree
->n
.sym
->name
,
5124 &code
->expr
->where
);
5128 if (code
->expr2
->ts
.type
== BT_DERIVED
5129 && derived_pointer (code
->expr2
->ts
.derived
))
5131 gfc_error ("Right side of assignment at %L is a derived "
5132 "type containing a POINTER in a PURE procedure",
5133 &code
->expr2
->where
);
5138 gfc_check_assign (code
->expr
, code
->expr2
, 1);
5141 case EXEC_LABEL_ASSIGN
:
5142 if (code
->label
->defined
== ST_LABEL_UNKNOWN
)
5143 gfc_error ("Label %d referenced at %L is never defined",
5144 code
->label
->value
, &code
->label
->where
);
5146 && (code
->expr
->expr_type
!= EXPR_VARIABLE
5147 || code
->expr
->symtree
->n
.sym
->ts
.type
!= BT_INTEGER
5148 || code
->expr
->symtree
->n
.sym
->ts
.kind
5149 != gfc_default_integer_kind
5150 || code
->expr
->symtree
->n
.sym
->as
!= NULL
))
5151 gfc_error ("ASSIGN statement at %L requires a scalar "
5152 "default INTEGER variable", &code
->expr
->where
);
5155 case EXEC_POINTER_ASSIGN
:
5159 gfc_check_pointer_assign (code
->expr
, code
->expr2
);
5162 case EXEC_ARITHMETIC_IF
:
5164 && code
->expr
->ts
.type
!= BT_INTEGER
5165 && code
->expr
->ts
.type
!= BT_REAL
)
5166 gfc_error ("Arithmetic IF statement at %L requires a numeric "
5167 "expression", &code
->expr
->where
);
5169 resolve_branch (code
->label
, code
);
5170 resolve_branch (code
->label2
, code
);
5171 resolve_branch (code
->label3
, code
);
5175 if (t
== SUCCESS
&& code
->expr
!= NULL
5176 && (code
->expr
->ts
.type
!= BT_LOGICAL
5177 || code
->expr
->rank
!= 0))
5178 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
5179 &code
->expr
->where
);
5184 resolve_call (code
);
5188 /* Select is complicated. Also, a SELECT construct could be
5189 a transformed computed GOTO. */
5190 resolve_select (code
);
5194 if (code
->ext
.iterator
!= NULL
)
5196 gfc_iterator
*iter
= code
->ext
.iterator
;
5197 if (gfc_resolve_iterator (iter
, true) != FAILURE
)
5198 gfc_resolve_do_iterator (code
, iter
->var
->symtree
->n
.sym
);
5203 if (code
->expr
== NULL
)
5204 gfc_internal_error ("resolve_code(): No expression on DO WHILE");
5206 && (code
->expr
->rank
!= 0
5207 || code
->expr
->ts
.type
!= BT_LOGICAL
))
5208 gfc_error ("Exit condition of DO WHILE loop at %L must be "
5209 "a scalar LOGICAL expression", &code
->expr
->where
);
5213 if (t
== SUCCESS
&& code
->expr
!= NULL
5214 && code
->expr
->ts
.type
!= BT_INTEGER
)
5215 gfc_error ("STAT tag in ALLOCATE statement at %L must be "
5216 "of type INTEGER", &code
->expr
->where
);
5218 for (a
= code
->ext
.alloc_list
; a
; a
= a
->next
)
5219 resolve_allocate_expr (a
->expr
, code
);
5223 case EXEC_DEALLOCATE
:
5224 if (t
== SUCCESS
&& code
->expr
!= NULL
5225 && code
->expr
->ts
.type
!= BT_INTEGER
)
5227 ("STAT tag in DEALLOCATE statement at %L must be of type "
5228 "INTEGER", &code
->expr
->where
);
5230 for (a
= code
->ext
.alloc_list
; a
; a
= a
->next
)
5231 resolve_deallocate_expr (a
->expr
);
5236 if (gfc_resolve_open (code
->ext
.open
) == FAILURE
)
5239 resolve_branch (code
->ext
.open
->err
, code
);
5243 if (gfc_resolve_close (code
->ext
.close
) == FAILURE
)
5246 resolve_branch (code
->ext
.close
->err
, code
);
5249 case EXEC_BACKSPACE
:
5253 if (gfc_resolve_filepos (code
->ext
.filepos
) == FAILURE
)
5256 resolve_branch (code
->ext
.filepos
->err
, code
);
5260 if (gfc_resolve_inquire (code
->ext
.inquire
) == FAILURE
)
5263 resolve_branch (code
->ext
.inquire
->err
, code
);
5267 gcc_assert (code
->ext
.inquire
!= NULL
);
5268 if (gfc_resolve_inquire (code
->ext
.inquire
) == FAILURE
)
5271 resolve_branch (code
->ext
.inquire
->err
, code
);
5276 if (gfc_resolve_dt (code
->ext
.dt
) == FAILURE
)
5279 resolve_branch (code
->ext
.dt
->err
, code
);
5280 resolve_branch (code
->ext
.dt
->end
, code
);
5281 resolve_branch (code
->ext
.dt
->eor
, code
);
5285 resolve_transfer (code
);
5289 resolve_forall_iterators (code
->ext
.forall_iterator
);
5291 if (code
->expr
!= NULL
&& code
->expr
->ts
.type
!= BT_LOGICAL
)
5292 gfc_error ("FORALL mask clause at %L requires a LOGICAL "
5293 "expression", &code
->expr
->where
);
5296 case EXEC_OMP_ATOMIC
:
5297 case EXEC_OMP_BARRIER
:
5298 case EXEC_OMP_CRITICAL
:
5299 case EXEC_OMP_FLUSH
:
5301 case EXEC_OMP_MASTER
:
5302 case EXEC_OMP_ORDERED
:
5303 case EXEC_OMP_SECTIONS
:
5304 case EXEC_OMP_SINGLE
:
5305 case EXEC_OMP_WORKSHARE
:
5306 gfc_resolve_omp_directive (code
, ns
);
5309 case EXEC_OMP_PARALLEL
:
5310 case EXEC_OMP_PARALLEL_DO
:
5311 case EXEC_OMP_PARALLEL_SECTIONS
:
5312 case EXEC_OMP_PARALLEL_WORKSHARE
:
5313 omp_workshare_save
= omp_workshare_flag
;
5314 omp_workshare_flag
= 0;
5315 gfc_resolve_omp_directive (code
, ns
);
5316 omp_workshare_flag
= omp_workshare_save
;
5320 gfc_internal_error ("resolve_code(): Bad statement code");
5324 cs_base
= frame
.prev
;
5328 /* Resolve initial values and make sure they are compatible with
5332 resolve_values (gfc_symbol
*sym
)
5334 if (sym
->value
== NULL
)
5337 if (gfc_resolve_expr (sym
->value
) == FAILURE
)
5340 gfc_check_assign_symbol (sym
, sym
->value
);
5344 /* Resolve an index expression. */
5347 resolve_index_expr (gfc_expr
*e
)
5349 if (gfc_resolve_expr (e
) == FAILURE
)
5352 if (gfc_simplify_expr (e
, 0) == FAILURE
)
5355 if (gfc_specification_expr (e
) == FAILURE
)
5361 /* Resolve a charlen structure. */
5364 resolve_charlen (gfc_charlen
*cl
)
5371 specification_expr
= 1;
5373 if (resolve_index_expr (cl
->length
) == FAILURE
)
5375 specification_expr
= 0;
5383 /* Test for non-constant shape arrays. */
5386 is_non_constant_shape_array (gfc_symbol
*sym
)
5392 not_constant
= false;
5393 if (sym
->as
!= NULL
)
5395 /* Unfortunately, !gfc_is_compile_time_shape hits a legal case that
5396 has not been simplified; parameter array references. Do the
5397 simplification now. */
5398 for (i
= 0; i
< sym
->as
->rank
; i
++)
5400 e
= sym
->as
->lower
[i
];
5401 if (e
&& (resolve_index_expr (e
) == FAILURE
5402 || !gfc_is_constant_expr (e
)))
5403 not_constant
= true;
5405 e
= sym
->as
->upper
[i
];
5406 if (e
&& (resolve_index_expr (e
) == FAILURE
5407 || !gfc_is_constant_expr (e
)))
5408 not_constant
= true;
5411 return not_constant
;
5415 /* Assign the default initializer to a derived type variable or result. */
5418 apply_default_init (gfc_symbol
*sym
)
5421 gfc_expr
*init
= NULL
;
5423 gfc_namespace
*ns
= sym
->ns
;
5425 if (sym
->attr
.flavor
!= FL_VARIABLE
&& !sym
->attr
.function
)
5428 if (sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.derived
)
5429 init
= gfc_default_initializer (&sym
->ts
);
5434 /* Search for the function namespace if this is a contained
5435 function without an explicit result. */
5436 if (sym
->attr
.function
&& sym
== sym
->result
5437 && sym
->name
!= sym
->ns
->proc_name
->name
)
5440 for (;ns
; ns
= ns
->sibling
)
5441 if (strcmp (ns
->proc_name
->name
, sym
->name
) == 0)
5447 gfc_free_expr (init
);
5451 /* Build an l-value expression for the result. */
5452 lval
= gfc_get_expr ();
5453 lval
->expr_type
= EXPR_VARIABLE
;
5454 lval
->where
= sym
->declared_at
;
5456 lval
->symtree
= gfc_find_symtree (sym
->ns
->sym_root
, sym
->name
);
5458 /* It will always be a full array. */
5459 lval
->rank
= sym
->as
? sym
->as
->rank
: 0;
5462 lval
->ref
= gfc_get_ref ();
5463 lval
->ref
->type
= REF_ARRAY
;
5464 lval
->ref
->u
.ar
.type
= AR_FULL
;
5465 lval
->ref
->u
.ar
.dimen
= lval
->rank
;
5466 lval
->ref
->u
.ar
.where
= sym
->declared_at
;
5467 lval
->ref
->u
.ar
.as
= sym
->as
;
5470 /* Add the code at scope entry. */
5471 init_st
= gfc_get_code ();
5472 init_st
->next
= ns
->code
;
5475 /* Assign the default initializer to the l-value. */
5476 init_st
->loc
= sym
->declared_at
;
5477 init_st
->op
= EXEC_INIT_ASSIGN
;
5478 init_st
->expr
= lval
;
5479 init_st
->expr2
= init
;
5483 /* Resolution of common features of flavors variable and procedure. */
5486 resolve_fl_var_and_proc (gfc_symbol
*sym
, int mp_flag
)
5488 /* Constraints on deferred shape variable. */
5489 if (sym
->as
== NULL
|| sym
->as
->type
!= AS_DEFERRED
)
5491 if (sym
->attr
.allocatable
)
5493 if (sym
->attr
.dimension
)
5494 gfc_error ("Allocatable array '%s' at %L must have "
5495 "a deferred shape", sym
->name
, &sym
->declared_at
);
5497 gfc_error ("Scalar object '%s' at %L may not be ALLOCATABLE",
5498 sym
->name
, &sym
->declared_at
);
5502 if (sym
->attr
.pointer
&& sym
->attr
.dimension
)
5504 gfc_error ("Array pointer '%s' at %L must have a deferred shape",
5505 sym
->name
, &sym
->declared_at
);
5512 if (!mp_flag
&& !sym
->attr
.allocatable
5513 && !sym
->attr
.pointer
&& !sym
->attr
.dummy
)
5515 gfc_error ("Array '%s' at %L cannot have a deferred shape",
5516 sym
->name
, &sym
->declared_at
);
5524 static gfc_component
*
5525 has_default_initializer (gfc_symbol
*der
)
5528 for (c
= der
->components
; c
; c
= c
->next
)
5529 if ((c
->ts
.type
!= BT_DERIVED
&& c
->initializer
)
5530 || (c
->ts
.type
== BT_DERIVED
5532 && has_default_initializer (c
->ts
.derived
)))
5539 /* Resolve symbols with flavor variable. */
5542 resolve_fl_variable (gfc_symbol
*sym
, int mp_flag
)
5548 const char *auto_save_msg
;
5550 auto_save_msg
= "automatic object '%s' at %L cannot have the "
5553 if (resolve_fl_var_and_proc (sym
, mp_flag
) == FAILURE
)
5556 /* Set this flag to check that variables are parameters of all entries.
5557 This check is effected by the call to gfc_resolve_expr through
5558 is_non_constant_shape_array. */
5559 specification_expr
= 1;
5561 if (!sym
->attr
.use_assoc
5562 && !sym
->attr
.allocatable
5563 && !sym
->attr
.pointer
5564 && is_non_constant_shape_array (sym
))
5566 /* The shape of a main program or module array needs to be
5568 if (sym
->ns
->proc_name
5569 && (sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
5570 || sym
->ns
->proc_name
->attr
.is_main_program
))
5572 gfc_error ("The module or main program array '%s' at %L must "
5573 "have constant shape", sym
->name
, &sym
->declared_at
);
5574 specification_expr
= 0;
5579 if (sym
->ts
.type
== BT_CHARACTER
)
5581 /* Make sure that character string variables with assumed length are
5583 e
= sym
->ts
.cl
->length
;
5584 if (e
== NULL
&& !sym
->attr
.dummy
&& !sym
->attr
.result
)
5586 gfc_error ("Entity with assumed character length at %L must be a "
5587 "dummy argument or a PARAMETER", &sym
->declared_at
);
5591 if (e
&& sym
->attr
.save
&& !gfc_is_constant_expr (e
))
5593 gfc_error (auto_save_msg
, sym
->name
, &sym
->declared_at
);
5597 if (!gfc_is_constant_expr (e
)
5598 && !(e
->expr_type
== EXPR_VARIABLE
5599 && e
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
)
5600 && sym
->ns
->proc_name
5601 && (sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
5602 || sym
->ns
->proc_name
->attr
.is_main_program
)
5603 && !sym
->attr
.use_assoc
)
5605 gfc_error ("'%s' at %L must have constant character length "
5606 "in this context", sym
->name
, &sym
->declared_at
);
5611 /* Can the symbol have an initializer? */
5613 if (sym
->attr
.allocatable
|| sym
->attr
.external
|| sym
->attr
.dummy
5614 || sym
->attr
.intrinsic
|| sym
->attr
.result
)
5616 else if (sym
->attr
.dimension
&& !sym
->attr
.pointer
)
5618 /* Don't allow initialization of automatic arrays. */
5619 for (i
= 0; i
< sym
->as
->rank
; i
++)
5621 if (sym
->as
->lower
[i
] == NULL
5622 || sym
->as
->lower
[i
]->expr_type
!= EXPR_CONSTANT
5623 || sym
->as
->upper
[i
] == NULL
5624 || sym
->as
->upper
[i
]->expr_type
!= EXPR_CONSTANT
)
5631 /* Also, they must not have the SAVE attribute. */
5632 if (flag
&& sym
->attr
.save
)
5634 gfc_error (auto_save_msg
, sym
->name
, &sym
->declared_at
);
5639 /* Reject illegal initializers. */
5640 if (sym
->value
&& flag
)
5642 if (sym
->attr
.allocatable
)
5643 gfc_error ("Allocatable '%s' at %L cannot have an initializer",
5644 sym
->name
, &sym
->declared_at
);
5645 else if (sym
->attr
.external
)
5646 gfc_error ("External '%s' at %L cannot have an initializer",
5647 sym
->name
, &sym
->declared_at
);
5648 else if (sym
->attr
.dummy
)
5649 gfc_error ("Dummy '%s' at %L cannot have an initializer",
5650 sym
->name
, &sym
->declared_at
);
5651 else if (sym
->attr
.intrinsic
)
5652 gfc_error ("Intrinsic '%s' at %L cannot have an initializer",
5653 sym
->name
, &sym
->declared_at
);
5654 else if (sym
->attr
.result
)
5655 gfc_error ("Function result '%s' at %L cannot have an initializer",
5656 sym
->name
, &sym
->declared_at
);
5658 gfc_error ("Automatic array '%s' at %L cannot have an initializer",
5659 sym
->name
, &sym
->declared_at
);
5663 /* Check to see if a derived type is blocked from being host associated
5664 by the presence of another class I symbol in the same namespace.
5665 14.6.1.3 of the standard and the discussion on comp.lang.fortran. */
5666 if (sym
->ts
.type
== BT_DERIVED
&& sym
->ns
!= sym
->ts
.derived
->ns
)
5669 gfc_find_symbol (sym
->ts
.derived
->name
, sym
->ns
, 0, &s
);
5670 if (s
&& (s
->attr
.flavor
!= FL_DERIVED
5671 || !gfc_compare_derived_types (s
, sym
->ts
.derived
)))
5673 gfc_error ("The type %s cannot be host associated at %L because "
5674 "it is blocked by an incompatible object of the same "
5675 "name at %L", sym
->ts
.derived
->name
, &sym
->declared_at
,
5681 /* Do not use gfc_default_initializer to test for a default initializer
5682 in the fortran because it generates a hidden default for allocatable
5685 if (sym
->ts
.type
== BT_DERIVED
&& !(sym
->value
|| flag
))
5686 c
= has_default_initializer (sym
->ts
.derived
);
5688 /* 4th constraint in section 11.3: "If an object of a type for which
5689 component-initialization is specified (R429) appears in the
5690 specification-part of a module and does not have the ALLOCATABLE
5691 or POINTER attribute, the object shall have the SAVE attribute." */
5692 if (c
&& sym
->ns
->proc_name
5693 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
5694 && !sym
->ns
->save_all
&& !sym
->attr
.save
5695 && !sym
->attr
.pointer
&& !sym
->attr
.allocatable
)
5697 gfc_error("Object '%s' at %L must have the SAVE attribute %s",
5698 sym
->name
, &sym
->declared_at
,
5699 "for default initialization of a component");
5703 /* Assign default initializer. */
5704 if (sym
->ts
.type
== BT_DERIVED
5706 && !sym
->attr
.pointer
5707 && !sym
->attr
.allocatable
5708 && (!flag
|| sym
->attr
.intent
== INTENT_OUT
))
5709 sym
->value
= gfc_default_initializer (&sym
->ts
);
5715 /* Resolve a procedure. */
5718 resolve_fl_procedure (gfc_symbol
*sym
, int mp_flag
)
5720 gfc_formal_arglist
*arg
;
5722 if (sym
->attr
.ambiguous_interfaces
&& !sym
->attr
.referenced
)
5723 gfc_warning ("Although not referenced, '%s' at %L has ambiguous "
5724 "interfaces", sym
->name
, &sym
->declared_at
);
5726 if (sym
->attr
.function
5727 && resolve_fl_var_and_proc (sym
, mp_flag
) == FAILURE
)
5730 if (sym
->ts
.type
== BT_CHARACTER
)
5732 gfc_charlen
*cl
= sym
->ts
.cl
;
5733 if (!cl
|| !cl
->length
|| cl
->length
->expr_type
!= EXPR_CONSTANT
)
5735 if (sym
->attr
.proc
== PROC_ST_FUNCTION
)
5737 gfc_error ("Character-valued statement function '%s' at %L must "
5738 "have constant length", sym
->name
, &sym
->declared_at
);
5742 if (sym
->attr
.external
&& sym
->formal
== NULL
5743 && cl
&& cl
->length
&& cl
->length
->expr_type
!= EXPR_CONSTANT
)
5745 gfc_error ("Automatic character length function '%s' at %L must "
5746 "have an explicit interface", sym
->name
,
5753 /* Ensure that derived type for are not of a private type. Internal
5754 module procedures are excluded by 2.2.3.3 - ie. they are not
5755 externally accessible and can access all the objects accessible in
5757 if (!(sym
->ns
->parent
5758 && sym
->ns
->parent
->proc_name
->attr
.flavor
== FL_MODULE
)
5759 && gfc_check_access(sym
->attr
.access
, sym
->ns
->default_access
))
5761 for (arg
= sym
->formal
; arg
; arg
= arg
->next
)
5764 && arg
->sym
->ts
.type
== BT_DERIVED
5765 && !arg
->sym
->ts
.derived
->attr
.use_assoc
5766 && !gfc_check_access (arg
->sym
->ts
.derived
->attr
.access
,
5767 arg
->sym
->ts
.derived
->ns
->default_access
))
5769 gfc_error_now ("'%s' is of a PRIVATE type and cannot be "
5770 "a dummy argument of '%s', which is "
5771 "PUBLIC at %L", arg
->sym
->name
, sym
->name
,
5773 /* Stop this message from recurring. */
5774 arg
->sym
->ts
.derived
->attr
.access
= ACCESS_PUBLIC
;
5780 /* An external symbol may not have an initializer because it is taken to be
5782 if (sym
->attr
.external
&& sym
->value
)
5784 gfc_error ("External object '%s' at %L may not have an initializer",
5785 sym
->name
, &sym
->declared_at
);
5789 /* An elemental function is required to return a scalar 12.7.1 */
5790 if (sym
->attr
.elemental
&& sym
->attr
.function
&& sym
->as
)
5792 gfc_error ("ELEMENTAL function '%s' at %L must have a scalar "
5793 "result", sym
->name
, &sym
->declared_at
);
5794 /* Reset so that the error only occurs once. */
5795 sym
->attr
.elemental
= 0;
5799 /* 5.1.1.5 of the Standard: A function name declared with an asterisk
5800 char-len-param shall not be array-valued, pointer-valued, recursive
5801 or pure. ....snip... A character value of * may only be used in the
5802 following ways: (i) Dummy arg of procedure - dummy associates with
5803 actual length; (ii) To declare a named constant; or (iii) External
5804 function - but length must be declared in calling scoping unit. */
5805 if (sym
->attr
.function
5806 && sym
->ts
.type
== BT_CHARACTER
5807 && sym
->ts
.cl
&& sym
->ts
.cl
->length
== NULL
)
5809 if ((sym
->as
&& sym
->as
->rank
) || (sym
->attr
.pointer
)
5810 || (sym
->attr
.recursive
) || (sym
->attr
.pure
))
5812 if (sym
->as
&& sym
->as
->rank
)
5813 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
5814 "array-valued", sym
->name
, &sym
->declared_at
);
5816 if (sym
->attr
.pointer
)
5817 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
5818 "pointer-valued", sym
->name
, &sym
->declared_at
);
5821 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
5822 "pure", sym
->name
, &sym
->declared_at
);
5824 if (sym
->attr
.recursive
)
5825 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
5826 "recursive", sym
->name
, &sym
->declared_at
);
5831 /* Appendix B.2 of the standard. Contained functions give an
5832 error anyway. Fixed-form is likely to be F77/legacy. */
5833 if (!sym
->attr
.contained
&& gfc_current_form
!= FORM_FIXED
)
5834 gfc_notify_std (GFC_STD_F95_OBS
, "CHARACTER(*) function "
5835 "'%s' at %L is obsolescent in fortran 95",
5836 sym
->name
, &sym
->declared_at
);
5842 /* Resolve the components of a derived type. */
5845 resolve_fl_derived (gfc_symbol
*sym
)
5848 gfc_dt_list
* dt_list
;
5851 for (c
= sym
->components
; c
!= NULL
; c
= c
->next
)
5853 if (c
->ts
.type
== BT_CHARACTER
)
5855 if (c
->ts
.cl
->length
== NULL
5856 || (resolve_charlen (c
->ts
.cl
) == FAILURE
)
5857 || !gfc_is_constant_expr (c
->ts
.cl
->length
))
5859 gfc_error ("Character length of component '%s' needs to "
5860 "be a constant specification expression at %L",
5862 c
->ts
.cl
->length
? &c
->ts
.cl
->length
->where
: &c
->loc
);
5867 if (c
->ts
.type
== BT_DERIVED
5868 && sym
->component_access
!= ACCESS_PRIVATE
5869 && gfc_check_access (sym
->attr
.access
, sym
->ns
->default_access
)
5870 && !c
->ts
.derived
->attr
.use_assoc
5871 && !gfc_check_access (c
->ts
.derived
->attr
.access
,
5872 c
->ts
.derived
->ns
->default_access
))
5874 gfc_error ("The component '%s' is a PRIVATE type and cannot be "
5875 "a component of '%s', which is PUBLIC at %L",
5876 c
->name
, sym
->name
, &sym
->declared_at
);
5880 if (sym
->attr
.sequence
)
5882 if (c
->ts
.type
== BT_DERIVED
&& c
->ts
.derived
->attr
.sequence
== 0)
5884 gfc_error ("Component %s of SEQUENCE type declared at %L does "
5885 "not have the SEQUENCE attribute",
5886 c
->ts
.derived
->name
, &sym
->declared_at
);
5891 if (c
->ts
.type
== BT_DERIVED
&& c
->pointer
5892 && c
->ts
.derived
->components
== NULL
)
5894 gfc_error ("The pointer component '%s' of '%s' at %L is a type "
5895 "that has not been declared", c
->name
, sym
->name
,
5900 if (c
->pointer
|| c
->allocatable
|| c
->as
== NULL
)
5903 for (i
= 0; i
< c
->as
->rank
; i
++)
5905 if (c
->as
->lower
[i
] == NULL
5906 || !gfc_is_constant_expr (c
->as
->lower
[i
])
5907 || (resolve_index_expr (c
->as
->lower
[i
]) == FAILURE
)
5908 || c
->as
->upper
[i
] == NULL
5909 || (resolve_index_expr (c
->as
->upper
[i
]) == FAILURE
)
5910 || !gfc_is_constant_expr (c
->as
->upper
[i
]))
5912 gfc_error ("Component '%s' of '%s' at %L must have "
5913 "constant array bounds",
5914 c
->name
, sym
->name
, &c
->loc
);
5920 /* Add derived type to the derived type list. */
5921 for (dt_list
= sym
->ns
->derived_types
; dt_list
; dt_list
= dt_list
->next
)
5922 if (sym
== dt_list
->derived
)
5925 if (dt_list
== NULL
)
5927 dt_list
= gfc_get_dt_list ();
5928 dt_list
->next
= sym
->ns
->derived_types
;
5929 dt_list
->derived
= sym
;
5930 sym
->ns
->derived_types
= dt_list
;
5938 resolve_fl_namelist (gfc_symbol
*sym
)
5943 /* Reject PRIVATE objects in a PUBLIC namelist. */
5944 if (gfc_check_access(sym
->attr
.access
, sym
->ns
->default_access
))
5946 for (nl
= sym
->namelist
; nl
; nl
= nl
->next
)
5948 if (!nl
->sym
->attr
.use_assoc
5949 && !(sym
->ns
->parent
== nl
->sym
->ns
)
5950 && !gfc_check_access(nl
->sym
->attr
.access
,
5951 nl
->sym
->ns
->default_access
))
5953 gfc_error ("PRIVATE symbol '%s' cannot be member of "
5954 "PUBLIC namelist at %L", nl
->sym
->name
,
5961 /* Reject namelist arrays that are not constant shape. */
5962 for (nl
= sym
->namelist
; nl
; nl
= nl
->next
)
5964 if (is_non_constant_shape_array (nl
->sym
))
5966 gfc_error ("The array '%s' must have constant shape to be "
5967 "a NAMELIST object at %L", nl
->sym
->name
,
5973 /* Namelist objects cannot have allocatable components. */
5974 for (nl
= sym
->namelist
; nl
; nl
= nl
->next
)
5976 if (nl
->sym
->ts
.type
== BT_DERIVED
5977 && nl
->sym
->ts
.derived
->attr
.alloc_comp
)
5979 gfc_error ("NAMELIST object '%s' at %L cannot have ALLOCATABLE "
5980 "components", nl
->sym
->name
, &sym
->declared_at
);
5985 /* 14.1.2 A module or internal procedure represent local entities
5986 of the same type as a namelist member and so are not allowed.
5987 Note that this is sometimes caught by check_conflict so the
5988 same message has been used. */
5989 for (nl
= sym
->namelist
; nl
; nl
= nl
->next
)
5991 if (nl
->sym
->ts
.kind
!= 0 && nl
->sym
->attr
.flavor
== FL_VARIABLE
)
5994 if (sym
->ns
->parent
&& nl
->sym
&& nl
->sym
->name
)
5995 gfc_find_symbol (nl
->sym
->name
, sym
->ns
->parent
, 0, &nlsym
);
5996 if (nlsym
&& nlsym
->attr
.flavor
== FL_PROCEDURE
)
5998 gfc_error ("PROCEDURE attribute conflicts with NAMELIST "
5999 "attribute in '%s' at %L", nlsym
->name
,
6010 resolve_fl_parameter (gfc_symbol
*sym
)
6012 /* A parameter array's shape needs to be constant. */
6013 if (sym
->as
!= NULL
&& !gfc_is_compile_time_shape (sym
->as
))
6015 gfc_error ("Parameter array '%s' at %L cannot be automatic "
6016 "or assumed shape", sym
->name
, &sym
->declared_at
);
6020 /* Make sure a parameter that has been implicitly typed still
6021 matches the implicit type, since PARAMETER statements can precede
6022 IMPLICIT statements. */
6023 if (sym
->attr
.implicit_type
6024 && !gfc_compare_types (&sym
->ts
, gfc_get_default_type (sym
, sym
->ns
)))
6026 gfc_error ("Implicitly typed PARAMETER '%s' at %L doesn't match a "
6027 "later IMPLICIT type", sym
->name
, &sym
->declared_at
);
6031 /* Make sure the types of derived parameters are consistent. This
6032 type checking is deferred until resolution because the type may
6033 refer to a derived type from the host. */
6034 if (sym
->ts
.type
== BT_DERIVED
6035 && !gfc_compare_types (&sym
->ts
, &sym
->value
->ts
))
6037 gfc_error ("Incompatible derived type in PARAMETER at %L",
6038 &sym
->value
->where
);
6045 /* Do anything necessary to resolve a symbol. Right now, we just
6046 assume that an otherwise unknown symbol is a variable. This sort
6047 of thing commonly happens for symbols in module. */
6050 resolve_symbol (gfc_symbol
*sym
)
6052 /* Zero if we are checking a formal namespace. */
6053 static int formal_ns_flag
= 1;
6054 int formal_ns_save
, check_constant
, mp_flag
;
6055 gfc_symtree
*symtree
;
6056 gfc_symtree
*this_symtree
;
6060 if (sym
->attr
.flavor
== FL_UNKNOWN
)
6063 /* If we find that a flavorless symbol is an interface in one of the
6064 parent namespaces, find its symtree in this namespace, free the
6065 symbol and set the symtree to point to the interface symbol. */
6066 for (ns
= gfc_current_ns
->parent
; ns
; ns
= ns
->parent
)
6068 symtree
= gfc_find_symtree (ns
->sym_root
, sym
->name
);
6069 if (symtree
&& symtree
->n
.sym
->generic
)
6071 this_symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
,
6075 gfc_free_symbol (sym
);
6076 symtree
->n
.sym
->refs
++;
6077 this_symtree
->n
.sym
= symtree
->n
.sym
;
6082 /* Otherwise give it a flavor according to such attributes as
6084 if (sym
->attr
.external
== 0 && sym
->attr
.intrinsic
== 0)
6085 sym
->attr
.flavor
= FL_VARIABLE
;
6088 sym
->attr
.flavor
= FL_PROCEDURE
;
6089 if (sym
->attr
.dimension
)
6090 sym
->attr
.function
= 1;
6094 if (sym
->attr
.flavor
== FL_DERIVED
&& resolve_fl_derived (sym
) == FAILURE
)
6097 /* Symbols that are module procedures with results (functions) have
6098 the types and array specification copied for type checking in
6099 procedures that call them, as well as for saving to a module
6100 file. These symbols can't stand the scrutiny that their results
6102 mp_flag
= (sym
->result
!= NULL
&& sym
->result
!= sym
);
6104 /* Assign default type to symbols that need one and don't have one. */
6105 if (sym
->ts
.type
== BT_UNKNOWN
)
6107 if (sym
->attr
.flavor
== FL_VARIABLE
|| sym
->attr
.flavor
== FL_PARAMETER
)
6108 gfc_set_default_type (sym
, 1, NULL
);
6110 if (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.function
)
6112 /* The specific case of an external procedure should emit an error
6113 in the case that there is no implicit type. */
6115 gfc_set_default_type (sym
, sym
->attr
.external
, NULL
);
6118 /* Result may be in another namespace. */
6119 resolve_symbol (sym
->result
);
6121 sym
->ts
= sym
->result
->ts
;
6122 sym
->as
= gfc_copy_array_spec (sym
->result
->as
);
6123 sym
->attr
.dimension
= sym
->result
->attr
.dimension
;
6124 sym
->attr
.pointer
= sym
->result
->attr
.pointer
;
6125 sym
->attr
.allocatable
= sym
->result
->attr
.allocatable
;
6130 /* Assumed size arrays and assumed shape arrays must be dummy
6134 && (sym
->as
->type
== AS_ASSUMED_SIZE
6135 || sym
->as
->type
== AS_ASSUMED_SHAPE
)
6136 && sym
->attr
.dummy
== 0)
6138 if (sym
->as
->type
== AS_ASSUMED_SIZE
)
6139 gfc_error ("Assumed size array at %L must be a dummy argument",
6142 gfc_error ("Assumed shape array at %L must be a dummy argument",
6147 /* Make sure symbols with known intent or optional are really dummy
6148 variable. Because of ENTRY statement, this has to be deferred
6149 until resolution time. */
6151 if (!sym
->attr
.dummy
6152 && (sym
->attr
.optional
|| sym
->attr
.intent
!= INTENT_UNKNOWN
))
6154 gfc_error ("Symbol at %L is not a DUMMY variable", &sym
->declared_at
);
6158 if (sym
->attr
.value
&& !sym
->attr
.dummy
)
6160 gfc_error ("'%s' at %L cannot have the VALUE attribute because "
6161 "it is not a dummy argument", sym
->name
, &sym
->declared_at
);
6165 if (sym
->attr
.value
&& sym
->ts
.type
== BT_CHARACTER
)
6167 gfc_charlen
*cl
= sym
->ts
.cl
;
6168 if (!cl
|| !cl
->length
|| cl
->length
->expr_type
!= EXPR_CONSTANT
)
6170 gfc_error ("Character dummy variable '%s' at %L with VALUE "
6171 "attribute must have constant length",
6172 sym
->name
, &sym
->declared_at
);
6177 /* If a derived type symbol has reached this point, without its
6178 type being declared, we have an error. Notice that most
6179 conditions that produce undefined derived types have already
6180 been dealt with. However, the likes of:
6181 implicit type(t) (t) ..... call foo (t) will get us here if
6182 the type is not declared in the scope of the implicit
6183 statement. Change the type to BT_UNKNOWN, both because it is so
6184 and to prevent an ICE. */
6185 if (sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.derived
->components
== NULL
)
6187 gfc_error ("The derived type '%s' at %L is of type '%s', "
6188 "which has not been defined", sym
->name
,
6189 &sym
->declared_at
, sym
->ts
.derived
->name
);
6190 sym
->ts
.type
= BT_UNKNOWN
;
6194 /* An assumed-size array with INTENT(OUT) shall not be of a type for which
6195 default initialization is defined (5.1.2.4.4). */
6196 if (sym
->ts
.type
== BT_DERIVED
6198 && sym
->attr
.intent
== INTENT_OUT
6200 && sym
->as
->type
== AS_ASSUMED_SIZE
)
6202 for (c
= sym
->ts
.derived
->components
; c
; c
= c
->next
)
6206 gfc_error ("The INTENT(OUT) dummy argument '%s' at %L is "
6207 "ASSUMED SIZE and so cannot have a default initializer",
6208 sym
->name
, &sym
->declared_at
);
6214 switch (sym
->attr
.flavor
)
6217 if (resolve_fl_variable (sym
, mp_flag
) == FAILURE
)
6222 if (resolve_fl_procedure (sym
, mp_flag
) == FAILURE
)
6227 if (resolve_fl_namelist (sym
) == FAILURE
)
6232 if (resolve_fl_parameter (sym
) == FAILURE
)
6240 /* Make sure that intrinsic exist */
6241 if (sym
->attr
.flavor
!= FL_MODULE
&& sym
->attr
.intrinsic
6242 && !gfc_intrinsic_name(sym
->name
, 0)
6243 && !gfc_intrinsic_name(sym
->name
, 1))
6244 gfc_error("Intrinsic at %L does not exist", &sym
->declared_at
);
6246 /* Resolve array specifier. Check as well some constraints
6247 on COMMON blocks. */
6249 check_constant
= sym
->attr
.in_common
&& !sym
->attr
.pointer
;
6251 /* Set the formal_arg_flag so that check_conflict will not throw
6252 an error for host associated variables in the specification
6253 expression for an array_valued function. */
6254 if (sym
->attr
.function
&& sym
->as
)
6255 formal_arg_flag
= 1;
6257 gfc_resolve_array_spec (sym
->as
, check_constant
);
6259 formal_arg_flag
= 0;
6261 /* Resolve formal namespaces. */
6263 if (formal_ns_flag
&& sym
!= NULL
&& sym
->formal_ns
!= NULL
)
6265 formal_ns_save
= formal_ns_flag
;
6267 gfc_resolve (sym
->formal_ns
);
6268 formal_ns_flag
= formal_ns_save
;
6271 /* Check threadprivate restrictions. */
6272 if (sym
->attr
.threadprivate
&& !sym
->attr
.save
6273 && (!sym
->attr
.in_common
6274 && sym
->module
== NULL
6275 && (sym
->ns
->proc_name
== NULL
6276 || sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
)))
6277 gfc_error ("Threadprivate at %L isn't SAVEd", &sym
->declared_at
);
6279 /* If we have come this far we can apply default-initializers, as
6280 described in 14.7.5, to those variables that have not already
6281 been assigned one. */
6282 if (sym
->ts
.type
== BT_DERIVED
6283 && sym
->attr
.referenced
6284 && sym
->ns
== gfc_current_ns
6286 && !sym
->attr
.allocatable
6287 && !sym
->attr
.alloc_comp
)
6289 symbol_attribute
*a
= &sym
->attr
;
6291 if ((!a
->save
&& !a
->dummy
&& !a
->pointer
6292 && !a
->in_common
&& !a
->use_assoc
6293 && !(a
->function
&& sym
!= sym
->result
))
6294 || (a
->dummy
&& a
->intent
== INTENT_OUT
))
6295 apply_default_init (sym
);
6300 /************* Resolve DATA statements *************/
6304 gfc_data_value
*vnode
;
6310 /* Advance the values structure to point to the next value in the data list. */
6313 next_data_value (void)
6315 while (values
.left
== 0)
6317 if (values
.vnode
->next
== NULL
)
6320 values
.vnode
= values
.vnode
->next
;
6321 values
.left
= values
.vnode
->repeat
;
6329 check_data_variable (gfc_data_variable
*var
, locus
*where
)
6335 ar_type mark
= AR_UNKNOWN
;
6337 mpz_t section_index
[GFC_MAX_DIMENSIONS
];
6341 if (gfc_resolve_expr (var
->expr
) == FAILURE
)
6345 mpz_init_set_si (offset
, 0);
6348 if (e
->expr_type
!= EXPR_VARIABLE
)
6349 gfc_internal_error ("check_data_variable(): Bad expression");
6351 if (e
->symtree
->n
.sym
->ns
->is_block_data
6352 && !e
->symtree
->n
.sym
->attr
.in_common
)
6354 gfc_error ("BLOCK DATA element '%s' at %L must be in COMMON",
6355 e
->symtree
->n
.sym
->name
, &e
->symtree
->n
.sym
->declared_at
);
6360 mpz_init_set_ui (size
, 1);
6367 /* Find the array section reference. */
6368 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
6370 if (ref
->type
!= REF_ARRAY
)
6372 if (ref
->u
.ar
.type
== AR_ELEMENT
)
6378 /* Set marks according to the reference pattern. */
6379 switch (ref
->u
.ar
.type
)
6387 /* Get the start position of array section. */
6388 gfc_get_section_index (ar
, section_index
, &offset
);
6396 if (gfc_array_size (e
, &size
) == FAILURE
)
6398 gfc_error ("Nonconstant array section at %L in DATA statement",
6407 while (mpz_cmp_ui (size
, 0) > 0)
6409 if (next_data_value () == FAILURE
)
6411 gfc_error ("DATA statement at %L has more variables than values",
6417 t
= gfc_check_assign (var
->expr
, values
.vnode
->expr
, 0);
6421 /* If we have more than one element left in the repeat count,
6422 and we have more than one element left in the target variable,
6423 then create a range assignment. */
6424 /* ??? Only done for full arrays for now, since array sections
6426 if (mark
== AR_FULL
&& ref
&& ref
->next
== NULL
6427 && values
.left
> 1 && mpz_cmp_ui (size
, 1) > 0)
6431 if (mpz_cmp_ui (size
, values
.left
) >= 0)
6433 mpz_init_set_ui (range
, values
.left
);
6434 mpz_sub_ui (size
, size
, values
.left
);
6439 mpz_init_set (range
, size
);
6440 values
.left
-= mpz_get_ui (size
);
6441 mpz_set_ui (size
, 0);
6444 gfc_assign_data_value_range (var
->expr
, values
.vnode
->expr
,
6447 mpz_add (offset
, offset
, range
);
6451 /* Assign initial value to symbol. */
6455 mpz_sub_ui (size
, size
, 1);
6457 gfc_assign_data_value (var
->expr
, values
.vnode
->expr
, offset
);
6459 if (mark
== AR_FULL
)
6460 mpz_add_ui (offset
, offset
, 1);
6462 /* Modify the array section indexes and recalculate the offset
6463 for next element. */
6464 else if (mark
== AR_SECTION
)
6465 gfc_advance_section (section_index
, ar
, &offset
);
6469 if (mark
== AR_SECTION
)
6471 for (i
= 0; i
< ar
->dimen
; i
++)
6472 mpz_clear (section_index
[i
]);
6482 static try traverse_data_var (gfc_data_variable
*, locus
*);
6484 /* Iterate over a list of elements in a DATA statement. */
6487 traverse_data_list (gfc_data_variable
*var
, locus
*where
)
6490 iterator_stack frame
;
6491 gfc_expr
*e
, *start
, *end
, *step
;
6492 try retval
= SUCCESS
;
6494 mpz_init (frame
.value
);
6496 start
= gfc_copy_expr (var
->iter
.start
);
6497 end
= gfc_copy_expr (var
->iter
.end
);
6498 step
= gfc_copy_expr (var
->iter
.step
);
6500 if (gfc_simplify_expr (start
, 1) == FAILURE
6501 || start
->expr_type
!= EXPR_CONSTANT
)
6503 gfc_error ("iterator start at %L does not simplify", &start
->where
);
6507 if (gfc_simplify_expr (end
, 1) == FAILURE
6508 || end
->expr_type
!= EXPR_CONSTANT
)
6510 gfc_error ("iterator end at %L does not simplify", &end
->where
);
6514 if (gfc_simplify_expr (step
, 1) == FAILURE
6515 || step
->expr_type
!= EXPR_CONSTANT
)
6517 gfc_error ("iterator step at %L does not simplify", &step
->where
);
6522 mpz_init_set (trip
, end
->value
.integer
);
6523 mpz_sub (trip
, trip
, start
->value
.integer
);
6524 mpz_add (trip
, trip
, step
->value
.integer
);
6526 mpz_div (trip
, trip
, step
->value
.integer
);
6528 mpz_set (frame
.value
, start
->value
.integer
);
6530 frame
.prev
= iter_stack
;
6531 frame
.variable
= var
->iter
.var
->symtree
;
6532 iter_stack
= &frame
;
6534 while (mpz_cmp_ui (trip
, 0) > 0)
6536 if (traverse_data_var (var
->list
, where
) == FAILURE
)
6543 e
= gfc_copy_expr (var
->expr
);
6544 if (gfc_simplify_expr (e
, 1) == FAILURE
)
6552 mpz_add (frame
.value
, frame
.value
, step
->value
.integer
);
6554 mpz_sub_ui (trip
, trip
, 1);
6559 mpz_clear (frame
.value
);
6561 gfc_free_expr (start
);
6562 gfc_free_expr (end
);
6563 gfc_free_expr (step
);
6565 iter_stack
= frame
.prev
;
6570 /* Type resolve variables in the variable list of a DATA statement. */
6573 traverse_data_var (gfc_data_variable
*var
, locus
*where
)
6577 for (; var
; var
= var
->next
)
6579 if (var
->expr
== NULL
)
6580 t
= traverse_data_list (var
, where
);
6582 t
= check_data_variable (var
, where
);
6592 /* Resolve the expressions and iterators associated with a data statement.
6593 This is separate from the assignment checking because data lists should
6594 only be resolved once. */
6597 resolve_data_variables (gfc_data_variable
*d
)
6599 for (; d
; d
= d
->next
)
6601 if (d
->list
== NULL
)
6603 if (gfc_resolve_expr (d
->expr
) == FAILURE
)
6608 if (gfc_resolve_iterator (&d
->iter
, false) == FAILURE
)
6611 if (resolve_data_variables (d
->list
) == FAILURE
)
6620 /* Resolve a single DATA statement. We implement this by storing a pointer to
6621 the value list into static variables, and then recursively traversing the
6622 variables list, expanding iterators and such. */
6625 resolve_data (gfc_data
* d
)
6627 if (resolve_data_variables (d
->var
) == FAILURE
)
6630 values
.vnode
= d
->value
;
6631 values
.left
= (d
->value
== NULL
) ? 0 : d
->value
->repeat
;
6633 if (traverse_data_var (d
->var
, &d
->where
) == FAILURE
)
6636 /* At this point, we better not have any values left. */
6638 if (next_data_value () == SUCCESS
)
6639 gfc_error ("DATA statement at %L has more values than variables",
6644 /* Determines if a variable is not 'pure', ie not assignable within a pure
6645 procedure. Returns zero if assignment is OK, nonzero if there is a
6649 gfc_impure_variable (gfc_symbol
*sym
)
6651 if (sym
->attr
.use_assoc
|| sym
->attr
.in_common
)
6654 if (sym
->ns
!= gfc_current_ns
)
6655 return !sym
->attr
.function
;
6657 /* TODO: Check storage association through EQUIVALENCE statements */
6663 /* Test whether a symbol is pure or not. For a NULL pointer, checks the
6664 symbol of the current procedure. */
6667 gfc_pure (gfc_symbol
*sym
)
6669 symbol_attribute attr
;
6672 sym
= gfc_current_ns
->proc_name
;
6678 return attr
.flavor
== FL_PROCEDURE
&& (attr
.pure
|| attr
.elemental
);
6682 /* Test whether the current procedure is elemental or not. */
6685 gfc_elemental (gfc_symbol
*sym
)
6687 symbol_attribute attr
;
6690 sym
= gfc_current_ns
->proc_name
;
6695 return attr
.flavor
== FL_PROCEDURE
&& attr
.elemental
;
6699 /* Warn about unused labels. */
6702 warn_unused_fortran_label (gfc_st_label
*label
)
6707 warn_unused_fortran_label (label
->left
);
6709 if (label
->defined
== ST_LABEL_UNKNOWN
)
6712 switch (label
->referenced
)
6714 case ST_LABEL_UNKNOWN
:
6715 gfc_warning ("Label %d at %L defined but not used", label
->value
,
6719 case ST_LABEL_BAD_TARGET
:
6720 gfc_warning ("Label %d at %L defined but cannot be used",
6721 label
->value
, &label
->where
);
6728 warn_unused_fortran_label (label
->right
);
6732 /* Returns the sequence type of a symbol or sequence. */
6735 sequence_type (gfc_typespec ts
)
6744 if (ts
.derived
->components
== NULL
)
6745 return SEQ_NONDEFAULT
;
6747 result
= sequence_type (ts
.derived
->components
->ts
);
6748 for (c
= ts
.derived
->components
->next
; c
; c
= c
->next
)
6749 if (sequence_type (c
->ts
) != result
)
6755 if (ts
.kind
!= gfc_default_character_kind
)
6756 return SEQ_NONDEFAULT
;
6758 return SEQ_CHARACTER
;
6761 if (ts
.kind
!= gfc_default_integer_kind
)
6762 return SEQ_NONDEFAULT
;
6767 if (!(ts
.kind
== gfc_default_real_kind
6768 || ts
.kind
== gfc_default_double_kind
))
6769 return SEQ_NONDEFAULT
;
6774 if (ts
.kind
!= gfc_default_complex_kind
)
6775 return SEQ_NONDEFAULT
;
6780 if (ts
.kind
!= gfc_default_logical_kind
)
6781 return SEQ_NONDEFAULT
;
6786 return SEQ_NONDEFAULT
;
6791 /* Resolve derived type EQUIVALENCE object. */
6794 resolve_equivalence_derived (gfc_symbol
*derived
, gfc_symbol
*sym
, gfc_expr
*e
)
6797 gfc_component
*c
= derived
->components
;
6802 /* Shall not be an object of nonsequence derived type. */
6803 if (!derived
->attr
.sequence
)
6805 gfc_error ("Derived type variable '%s' at %L must have SEQUENCE "
6806 "attribute to be an EQUIVALENCE object", sym
->name
,
6811 /* Shall not have allocatable components. */
6812 if (derived
->attr
.alloc_comp
)
6814 gfc_error ("Derived type variable '%s' at %L cannot have ALLOCATABLE "
6815 "components to be an EQUIVALENCE object",sym
->name
,
6820 for (; c
; c
= c
->next
)
6824 && (resolve_equivalence_derived (c
->ts
.derived
, sym
, e
) == FAILURE
))
6827 /* Shall not be an object of sequence derived type containing a pointer
6828 in the structure. */
6831 gfc_error ("Derived type variable '%s' at %L with pointer "
6832 "component(s) cannot be an EQUIVALENCE object",
6833 sym
->name
, &e
->where
);
6839 gfc_error ("Derived type variable '%s' at %L with default "
6840 "initializer cannot be an EQUIVALENCE object",
6841 sym
->name
, &e
->where
);
6849 /* Resolve equivalence object.
6850 An EQUIVALENCE object shall not be a dummy argument, a pointer, a target,
6851 an allocatable array, an object of nonsequence derived type, an object of
6852 sequence derived type containing a pointer at any level of component
6853 selection, an automatic object, a function name, an entry name, a result
6854 name, a named constant, a structure component, or a subobject of any of
6855 the preceding objects. A substring shall not have length zero. A
6856 derived type shall not have components with default initialization nor
6857 shall two objects of an equivalence group be initialized.
6858 Either all or none of the objects shall have an protected attribute.
6859 The simple constraints are done in symbol.c(check_conflict) and the rest
6860 are implemented here. */
6863 resolve_equivalence (gfc_equiv
*eq
)
6866 gfc_symbol
*derived
;
6867 gfc_symbol
*first_sym
;
6870 locus
*last_where
= NULL
;
6871 seq_type eq_type
, last_eq_type
;
6872 gfc_typespec
*last_ts
;
6873 int object
, cnt_protected
;
6874 const char *value_name
;
6878 last_ts
= &eq
->expr
->symtree
->n
.sym
->ts
;
6880 first_sym
= eq
->expr
->symtree
->n
.sym
;
6884 for (object
= 1; eq
; eq
= eq
->eq
, object
++)
6888 e
->ts
= e
->symtree
->n
.sym
->ts
;
6889 /* match_varspec might not know yet if it is seeing
6890 array reference or substring reference, as it doesn't
6892 if (e
->ref
&& e
->ref
->type
== REF_ARRAY
)
6894 gfc_ref
*ref
= e
->ref
;
6895 sym
= e
->symtree
->n
.sym
;
6897 if (sym
->attr
.dimension
)
6899 ref
->u
.ar
.as
= sym
->as
;
6903 /* For substrings, convert REF_ARRAY into REF_SUBSTRING. */
6904 if (e
->ts
.type
== BT_CHARACTER
6906 && ref
->type
== REF_ARRAY
6907 && ref
->u
.ar
.dimen
== 1
6908 && ref
->u
.ar
.dimen_type
[0] == DIMEN_RANGE
6909 && ref
->u
.ar
.stride
[0] == NULL
)
6911 gfc_expr
*start
= ref
->u
.ar
.start
[0];
6912 gfc_expr
*end
= ref
->u
.ar
.end
[0];
6915 /* Optimize away the (:) reference. */
6916 if (start
== NULL
&& end
== NULL
)
6921 e
->ref
->next
= ref
->next
;
6926 ref
->type
= REF_SUBSTRING
;
6928 start
= gfc_int_expr (1);
6929 ref
->u
.ss
.start
= start
;
6930 if (end
== NULL
&& e
->ts
.cl
)
6931 end
= gfc_copy_expr (e
->ts
.cl
->length
);
6932 ref
->u
.ss
.end
= end
;
6933 ref
->u
.ss
.length
= e
->ts
.cl
;
6940 /* Any further ref is an error. */
6943 gcc_assert (ref
->type
== REF_ARRAY
);
6944 gfc_error ("Syntax error in EQUIVALENCE statement at %L",
6950 if (gfc_resolve_expr (e
) == FAILURE
)
6953 sym
= e
->symtree
->n
.sym
;
6955 if (sym
->attr
.protected)
6957 if (cnt_protected
> 0 && cnt_protected
!= object
)
6959 gfc_error ("Either all or none of the objects in the "
6960 "EQUIVALENCE set at %L shall have the "
6961 "PROTECTED attribute",
6966 /* An equivalence statement cannot have more than one initialized
6970 if (value_name
!= NULL
)
6972 gfc_error ("Initialized objects '%s' and '%s' cannot both "
6973 "be in the EQUIVALENCE statement at %L",
6974 value_name
, sym
->name
, &e
->where
);
6978 value_name
= sym
->name
;
6981 /* Shall not equivalence common block variables in a PURE procedure. */
6982 if (sym
->ns
->proc_name
6983 && sym
->ns
->proc_name
->attr
.pure
6984 && sym
->attr
.in_common
)
6986 gfc_error ("Common block member '%s' at %L cannot be an EQUIVALENCE "
6987 "object in the pure procedure '%s'",
6988 sym
->name
, &e
->where
, sym
->ns
->proc_name
->name
);
6992 /* Shall not be a named constant. */
6993 if (e
->expr_type
== EXPR_CONSTANT
)
6995 gfc_error ("Named constant '%s' at %L cannot be an EQUIVALENCE "
6996 "object", sym
->name
, &e
->where
);
7000 derived
= e
->ts
.derived
;
7001 if (derived
&& resolve_equivalence_derived (derived
, sym
, e
) == FAILURE
)
7004 /* Check that the types correspond correctly:
7006 A numeric sequence structure may be equivalenced to another sequence
7007 structure, an object of default integer type, default real type, double
7008 precision real type, default logical type such that components of the
7009 structure ultimately only become associated to objects of the same
7010 kind. A character sequence structure may be equivalenced to an object
7011 of default character kind or another character sequence structure.
7012 Other objects may be equivalenced only to objects of the same type and
7015 /* Identical types are unconditionally OK. */
7016 if (object
== 1 || gfc_compare_types (last_ts
, &sym
->ts
))
7017 goto identical_types
;
7019 last_eq_type
= sequence_type (*last_ts
);
7020 eq_type
= sequence_type (sym
->ts
);
7022 /* Since the pair of objects is not of the same type, mixed or
7023 non-default sequences can be rejected. */
7025 msg
= "Sequence %s with mixed components in EQUIVALENCE "
7026 "statement at %L with different type objects";
7028 && last_eq_type
== SEQ_MIXED
7029 && gfc_notify_std (GFC_STD_GNU
, msg
, first_sym
->name
, last_where
)
7031 || (eq_type
== SEQ_MIXED
7032 && gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
,
7033 &e
->where
) == FAILURE
))
7036 msg
= "Non-default type object or sequence %s in EQUIVALENCE "
7037 "statement at %L with objects of different type";
7039 && last_eq_type
== SEQ_NONDEFAULT
7040 && gfc_notify_std (GFC_STD_GNU
, msg
, first_sym
->name
,
7041 last_where
) == FAILURE
)
7042 || (eq_type
== SEQ_NONDEFAULT
7043 && gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
,
7044 &e
->where
) == FAILURE
))
7047 msg
="Non-CHARACTER object '%s' in default CHARACTER "
7048 "EQUIVALENCE statement at %L";
7049 if (last_eq_type
== SEQ_CHARACTER
7050 && eq_type
!= SEQ_CHARACTER
7051 && gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
,
7052 &e
->where
) == FAILURE
)
7055 msg
="Non-NUMERIC object '%s' in default NUMERIC "
7056 "EQUIVALENCE statement at %L";
7057 if (last_eq_type
== SEQ_NUMERIC
7058 && eq_type
!= SEQ_NUMERIC
7059 && gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
,
7060 &e
->where
) == FAILURE
)
7065 last_where
= &e
->where
;
7070 /* Shall not be an automatic array. */
7071 if (e
->ref
->type
== REF_ARRAY
7072 && gfc_resolve_array_spec (e
->ref
->u
.ar
.as
, 1) == FAILURE
)
7074 gfc_error ("Array '%s' at %L with non-constant bounds cannot be "
7075 "an EQUIVALENCE object", sym
->name
, &e
->where
);
7082 /* Shall not be a structure component. */
7083 if (r
->type
== REF_COMPONENT
)
7085 gfc_error ("Structure component '%s' at %L cannot be an "
7086 "EQUIVALENCE object",
7087 r
->u
.c
.component
->name
, &e
->where
);
7091 /* A substring shall not have length zero. */
7092 if (r
->type
== REF_SUBSTRING
)
7094 if (compare_bound (r
->u
.ss
.start
, r
->u
.ss
.end
) == CMP_GT
)
7096 gfc_error ("Substring at %L has length zero",
7097 &r
->u
.ss
.start
->where
);
7107 /* Resolve function and ENTRY types, issue diagnostics if needed. */
7110 resolve_fntype (gfc_namespace
*ns
)
7115 if (ns
->proc_name
== NULL
|| !ns
->proc_name
->attr
.function
)
7118 /* If there are any entries, ns->proc_name is the entry master
7119 synthetic symbol and ns->entries->sym actual FUNCTION symbol. */
7121 sym
= ns
->entries
->sym
;
7123 sym
= ns
->proc_name
;
7124 if (sym
->result
== sym
7125 && sym
->ts
.type
== BT_UNKNOWN
7126 && gfc_set_default_type (sym
, 0, NULL
) == FAILURE
7127 && !sym
->attr
.untyped
)
7129 gfc_error ("Function '%s' at %L has no IMPLICIT type",
7130 sym
->name
, &sym
->declared_at
);
7131 sym
->attr
.untyped
= 1;
7134 if (sym
->ts
.type
== BT_DERIVED
&& !sym
->ts
.derived
->attr
.use_assoc
7135 && !gfc_check_access (sym
->ts
.derived
->attr
.access
,
7136 sym
->ts
.derived
->ns
->default_access
)
7137 && gfc_check_access (sym
->attr
.access
, sym
->ns
->default_access
))
7139 gfc_error ("PUBLIC function '%s' at %L cannot be of PRIVATE type '%s'",
7140 sym
->name
, &sym
->declared_at
, sym
->ts
.derived
->name
);
7143 /* Make sure that the type of a module derived type function is in the
7144 module namespace, by copying it from the namespace's derived type
7145 list, if necessary. */
7146 if (sym
->ts
.type
== BT_DERIVED
7147 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
7148 && sym
->ts
.derived
->ns
7149 && sym
->ns
!= sym
->ts
.derived
->ns
)
7151 gfc_dt_list
*dt
= sym
->ns
->derived_types
;
7153 for (; dt
; dt
= dt
->next
)
7154 if (gfc_compare_derived_types (sym
->ts
.derived
, dt
->derived
))
7155 sym
->ts
.derived
= dt
->derived
;
7159 for (el
= ns
->entries
->next
; el
; el
= el
->next
)
7161 if (el
->sym
->result
== el
->sym
7162 && el
->sym
->ts
.type
== BT_UNKNOWN
7163 && gfc_set_default_type (el
->sym
, 0, NULL
) == FAILURE
7164 && !el
->sym
->attr
.untyped
)
7166 gfc_error ("ENTRY '%s' at %L has no IMPLICIT type",
7167 el
->sym
->name
, &el
->sym
->declared_at
);
7168 el
->sym
->attr
.untyped
= 1;
7173 /* 12.3.2.1.1 Defined operators. */
7176 gfc_resolve_uops (gfc_symtree
*symtree
)
7180 gfc_formal_arglist
*formal
;
7182 if (symtree
== NULL
)
7185 gfc_resolve_uops (symtree
->left
);
7186 gfc_resolve_uops (symtree
->right
);
7188 for (itr
= symtree
->n
.uop
->operator; itr
; itr
= itr
->next
)
7191 if (!sym
->attr
.function
)
7192 gfc_error ("User operator procedure '%s' at %L must be a FUNCTION",
7193 sym
->name
, &sym
->declared_at
);
7195 if (sym
->ts
.type
== BT_CHARACTER
7196 && !(sym
->ts
.cl
&& sym
->ts
.cl
->length
)
7197 && !(sym
->result
&& sym
->result
->ts
.cl
7198 && sym
->result
->ts
.cl
->length
))
7199 gfc_error ("User operator procedure '%s' at %L cannot be assumed "
7200 "character length", sym
->name
, &sym
->declared_at
);
7202 formal
= sym
->formal
;
7203 if (!formal
|| !formal
->sym
)
7205 gfc_error ("User operator procedure '%s' at %L must have at least "
7206 "one argument", sym
->name
, &sym
->declared_at
);
7210 if (formal
->sym
->attr
.intent
!= INTENT_IN
)
7211 gfc_error ("First argument of operator interface at %L must be "
7212 "INTENT(IN)", &sym
->declared_at
);
7214 if (formal
->sym
->attr
.optional
)
7215 gfc_error ("First argument of operator interface at %L cannot be "
7216 "optional", &sym
->declared_at
);
7218 formal
= formal
->next
;
7219 if (!formal
|| !formal
->sym
)
7222 if (formal
->sym
->attr
.intent
!= INTENT_IN
)
7223 gfc_error ("Second argument of operator interface at %L must be "
7224 "INTENT(IN)", &sym
->declared_at
);
7226 if (formal
->sym
->attr
.optional
)
7227 gfc_error ("Second argument of operator interface at %L cannot be "
7228 "optional", &sym
->declared_at
);
7231 gfc_error ("Operator interface at %L must have, at most, two "
7232 "arguments", &sym
->declared_at
);
7237 /* Examine all of the expressions associated with a program unit,
7238 assign types to all intermediate expressions, make sure that all
7239 assignments are to compatible types and figure out which names
7240 refer to which functions or subroutines. It doesn't check code
7241 block, which is handled by resolve_code. */
7244 resolve_types (gfc_namespace
*ns
)
7251 gfc_current_ns
= ns
;
7253 resolve_entries (ns
);
7255 resolve_contained_functions (ns
);
7257 gfc_traverse_ns (ns
, resolve_symbol
);
7259 resolve_fntype (ns
);
7261 for (n
= ns
->contained
; n
; n
= n
->sibling
)
7263 if (gfc_pure (ns
->proc_name
) && !gfc_pure (n
->proc_name
))
7264 gfc_error ("Contained procedure '%s' at %L of a PURE procedure must "
7265 "also be PURE", n
->proc_name
->name
,
7266 &n
->proc_name
->declared_at
);
7272 gfc_check_interfaces (ns
);
7274 for (cl
= ns
->cl_list
; cl
; cl
= cl
->next
)
7275 resolve_charlen (cl
);
7277 gfc_traverse_ns (ns
, resolve_values
);
7283 for (d
= ns
->data
; d
; d
= d
->next
)
7287 gfc_traverse_ns (ns
, gfc_formalize_init_value
);
7289 for (eq
= ns
->equiv
; eq
; eq
= eq
->next
)
7290 resolve_equivalence (eq
);
7292 /* Warn about unused labels. */
7293 if (warn_unused_label
)
7294 warn_unused_fortran_label (ns
->st_labels
);
7296 gfc_resolve_uops (ns
->uop_root
);
7300 /* Call resolve_code recursively. */
7303 resolve_codes (gfc_namespace
*ns
)
7307 for (n
= ns
->contained
; n
; n
= n
->sibling
)
7310 gfc_current_ns
= ns
;
7312 /* Set to an out of range value. */
7313 current_entry_id
= -1;
7314 resolve_code (ns
->code
, ns
);
7318 /* This function is called after a complete program unit has been compiled.
7319 Its purpose is to examine all of the expressions associated with a program
7320 unit, assign types to all intermediate expressions, make sure that all
7321 assignments are to compatible types and figure out which names refer to
7322 which functions or subroutines. */
7325 gfc_resolve (gfc_namespace
*ns
)
7327 gfc_namespace
*old_ns
;
7329 old_ns
= gfc_current_ns
;
7334 gfc_current_ns
= old_ns
;