Two issues prevented ASSOCIATE constructs whose selector is a call to a
contained function from subsequently calling type-bound procedures on the
associate name.
When the selector is a contained function, resolving it
at parse time (before CONTAINS is fully processed) prematurely set the
function's attribute to FL_PROCEDURE/EXTERNAL, conflicting with its later
declaration as an internal procedure and giving a spurious "attribute
conflict" error.
When the first access is a generic type-bound procedure name, no candidate
type was found, and the associate name got no type, giving "no IMPLICIT type".
Now also search type-bound procedure names via gfc_find_typebound_proc; exclude vtable
types to avoid false positives.
Assisted by: Claude Sonnet 4.6
PR fortran/125530
gcc/fortran/ChangeLog:
* match.cc (gfc_match_call): Route ASSOCIATE names followed by '%'
to match_typebound_call without first resolving the selector, to
avoid prematurely marking a contained-function selector as EXTERNAL.
* symbol.cc (find_derived_types): Also search type-bound procedure
names via gfc_find_typebound_proc when inferring the type of an
inferred-type ASSOCIATE name; exclude vtable types.
gcc/testsuite/ChangeLog:
* gfortran.dg/associate_contained_func_typebound.f90: New test.
* gfortran.dg/associate_contained_func_typebound_2.f90: New
run-time test exercising generic resolution and a module-scope
selector.
(cherry picked from commit
64fee7f4475c756fc17fa9e15aee7683e716ba8a)
target type. */
if (((sym->attr.flavor != FL_PROCEDURE
|| gfc_is_function_return_value (sym, gfc_current_ns))
- && (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS))
- ||
- (sym->assoc && sym->assoc->target
- && gfc_resolve_expr (sym->assoc->target)
- && (sym->assoc->target->ts.type == BT_DERIVED
- || sym->assoc->target->ts.type == BT_CLASS)))
+ && (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS))
+ ||
+ /* Skip gfc_resolve_expr for ASSOCIATE names followed by '%'.
+ resolving a contained-function selector before CONTAINS is
+ parsed prematurely, marks it EXTERNAL, conflicting with its
+ later INTERNAL declaration. */
+ (sym->assoc && sym->assoc->target && gfc_peek_ascii_char () == '%')
+ ||
+ (sym->assoc && sym->assoc->target
+ && gfc_resolve_expr (sym->assoc->target)
+ && (sym->assoc->target->ts.type == BT_DERIVED
+ || sym->assoc->target->ts.type == BT_CLASS)))
return match_typebound_call (st);
/* If it does not seem to be callable (include functions so that the
if (st->n.sym && st->n.sym->attr.flavor == FL_DERIVED
&& !st->n.sym->attr.is_class
&& ((contained && st->n.sym->attr.use_assoc) || !contained)
- && gfc_find_component (st->n.sym, name, true, true, NULL))
+ && !st->n.sym->attr.vtype
+ && (gfc_find_component (st->n.sym, name, true, true, NULL)
+ || (st->n.sym->f2k_derived
+ && gfc_find_typebound_proc (st->n.sym, NULL, name, true,
+ NULL))))
{
/* Do the stashing, if required. */
cts++;
--- /dev/null
+! { dg-do compile }
+! { dg-options "" }
+!
+! PR fortran/125530
+! ASSOCIATE with a contained-function selector giving spurious errors when
+! type-bound (including generic) procedures are called on the associate name.
+
+module tbp_m
+ implicit none
+ type :: t
+ integer :: n = 0
+ contains
+ procedure :: direct_call
+ procedure :: target_of_generic
+ generic :: generic_call => target_of_generic
+ end type
+contains
+ subroutine direct_call (self)
+ class(t), intent(in) :: self
+ print *, self%n
+ end subroutine
+ subroutine target_of_generic (self)
+ class(t), intent(in) :: self
+ print *, self%n
+ end subroutine
+end module
+
+! Direct type-bound call.
+subroutine test_direct ()
+ use tbp_m
+ implicit none
+ associate (x => make_t())
+ call x%direct_call()
+ end associate
+contains
+ function make_t() result(r)
+ type(t) :: r
+ r%n = 1
+ end function
+end subroutine
+
+! Generic type-bound call.
+subroutine test_generic ()
+ use tbp_m
+ implicit none
+ associate (x => make_t())
+ call x%generic_call()
+ end associate
+contains
+ function make_t() result(r)
+ type(t) :: r
+ r%n = 2
+ end function
+end subroutine
--- /dev/null
+! { dg-do run }
+! { dg-options "" }
+!
+! PR fortran/125530
+! ASSOCIATE with a contained-function selector must allow type-bound
+! (including generic) procedure calls on the associate name, and resolve
+! them to the correct target. Run-time companion to
+! associate_contained_func_typebound.f90.
+
+module m
+ implicit none
+ type :: t
+ integer :: n = 0
+ contains
+ procedure :: direct_call
+ procedure :: target_of_generic1
+ procedure :: target_of_generic2
+ generic :: generic_call => target_of_generic1, target_of_generic2
+ end type
+ integer :: ctr = 0
+contains
+ subroutine direct_call (self)
+ class(t), intent(in) :: self
+ ctr = ctr + self%n
+ end subroutine
+ subroutine target_of_generic1 (self)
+ class(t), intent(in) :: self
+ ctr = ctr + self%n * 10
+ end subroutine
+ subroutine target_of_generic2 (self, arg)
+ class(t), intent(in) :: self
+ integer, intent(in) :: arg
+ ctr = ctr + (self%n + arg) * 100
+ end subroutine
+end module
+
+module m2
+ use m
+ implicit none
+contains
+ ! Selector is a contained function.
+ subroutine test_direct ()
+ associate (x => make_t ())
+ call x%direct_call ()
+ end associate
+ contains
+ function make_t () result (r)
+ type(t) :: r
+ r%n = 1
+ end function
+ end subroutine
+
+ ! Selector is the module-scope function; generic resolved by argument count.
+ subroutine test_generic ()
+ associate (x => make_t ())
+ call x%generic_call ()
+ call x%generic_call (1)
+ end associate
+ end subroutine
+
+ function make_t () result (r)
+ type(t) :: r
+ r%n = 2
+ end function
+end module
+
+program p
+ use m
+ use m2
+ call test_generic ! 2*10 + (2+1)*100 = 320
+ call test_direct ! + 1 = 321
+ if (ctr /= 321) stop 1
+end program p
projects / thirdparty / gcc.git / commitdiff
