Dear all, here's a patch that allows vector subscripts to INTENT(OUT/INOUT) array arguments to elemental procedures and basically fixes defined assignment as used in the PR.
Not yet resolved: when the l.h.s. depends on the r.h.s., and the l.h.s. uses vector subscripts, the result is incorrect because the temporary is not properly copied back. (Well, some other compilers have issues here, too.) Paul indicated in the PR that he is working on this issue. The testcase exercises what works and indicates what doesn't. (I also tested with NAG, ifx, and AMD flang, and each of them has some issue here or there.) Regtested cleanly on x86_64-pc-linux-gnu. OK for mainline? Or should I rather wait for Paul? Thanks, Harald
From 8ba4f8d6c967d63018fb751d2fdbe46c4d4fd7bc Mon Sep 17 00:00:00 2001 From: Harald Anlauf <[email protected]> Date: Fri, 10 Apr 2026 23:01:49 +0200 Subject: [PATCH] Fortran: defined assignment and vector subscripts [PR120140] Fortran allows array sections with vector subscripts as actual arguments to elemental procedures (e.g. F2023: 15.5.2.5): (21) If the procedure is nonelemental, the dummy argument does not have the VALUE attribute, and the actual argument is an array section having a vector subscript, the dummy argument is not definable and shall not have the ASYNCHRONOUS, INTENT (OUT), INTENT (INOUT), or VOLATILE attributes. Adjust the checking accordingly to allow vector subscripts in defined assignment. PR fortran/120140 gcc/fortran/ChangeLog: * dependency.cc (gfc_check_argument_var_dependency): For elemental subroutines skip the dependency check for array references. Correct description of function return value. * interface.cc (gfc_compare_actual_formal): Allow array sections with vector subscripts as actual arguments to elemental procedures in accordance with the Fortran standard. gcc/testsuite/ChangeLog: * gfortran.dg/defined_assignment_13.f90: New test. Co-authored-by: Mikael Morin <[email protected]> --- gcc/fortran/dependency.cc | 4 +- gcc/fortran/interface.cc | 9 + .../gfortran.dg/defined_assignment_13.f90 | 298 ++++++++++++++++++ 3 files changed, 309 insertions(+), 2 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/defined_assignment_13.f90 diff --git a/gcc/fortran/dependency.cc b/gcc/fortran/dependency.cc index 71b0433058f..61a6a5aa067 100644 --- a/gcc/fortran/dependency.cc +++ b/gcc/fortran/dependency.cc @@ -975,7 +975,7 @@ gfc_is_data_pointer (gfc_expr *e) } -/* Return true if array variable VAR could be passed to the same function +/* Return false if array variable VAR could be passed to the same function as argument EXPR without interfering with EXPR. INTENT is the intent of VAR. @@ -997,7 +997,7 @@ gfc_check_argument_var_dependency (gfc_expr *var, sym_intent intent, case EXPR_VARIABLE: /* In case of elemental subroutines, there is no dependency between two same-range array references. */ - if (gfc_ref_needs_temporary_p (expr->ref) + if ((elemental == NOT_ELEMENTAL && gfc_ref_needs_temporary_p (expr->ref)) || gfc_check_dependency (var, expr, elemental == NOT_ELEMENTAL)) { if (elemental == ELEM_DONT_CHECK_VARIABLE) diff --git a/gcc/fortran/interface.cc b/gcc/fortran/interface.cc index 1cfa4975f16..d25cf0591b7 100644 --- a/gcc/fortran/interface.cc +++ b/gcc/fortran/interface.cc @@ -4053,10 +4053,19 @@ gfc_compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal, } } + /* F2023: 15.5.2.5 Ordinary dummy variables: + "(21) If the procedure is nonelemental, the dummy argument does not + have the VALUE attribute, and the actual argument is an array section + having a vector subscript, the dummy argument is not definable and + shall not have the ASYNCHRONOUS, INTENT (OUT), INTENT (INOUT), or + VOLATILE attributes." + */ if ((f->sym->attr.intent == INTENT_OUT || f->sym->attr.intent == INTENT_INOUT || f->sym->attr.volatile_ || f->sym->attr.asynchronous) + && !f->sym->attr.value + && !is_elemental && gfc_has_vector_subscript (a->expr)) { if (where) diff --git a/gcc/testsuite/gfortran.dg/defined_assignment_13.f90 b/gcc/testsuite/gfortran.dg/defined_assignment_13.f90 new file mode 100644 index 00000000000..5a8a904fa25 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/defined_assignment_13.f90 @@ -0,0 +1,298 @@ +! { dg-do run } +! +! PR fortran/120140 - defined assignment and vector subscripts + +!--------------------------------------- +! Part 1: Derived from original testcase +!--------------------------------------- +module mod1 + implicit none + + type typ1 + integer :: i + contains + procedure, pass(y) :: assign_typ1 + generic :: assignment(=) => assign_typ1 + end type typ1 + +contains + + elemental subroutine assign_typ1(x,y) + class(typ1), intent(inout) :: x + class(typ1), intent(in) :: y + x%i = y%i + 42 + end subroutine assign_typ1 + + subroutine test1(x,y) + class(typ1), intent(inout) :: x(:) + class(typ1), intent(in) :: y(:) + x([2,1]) = y([1,2]) + end subroutine test1 + +end module mod1 + +module mod2 + implicit none + + type typ2 + integer i + end type typ2 + + interface assignment(=) + module procedure sub + end interface assignment(=) + +contains + + elemental subroutine sub(x, y) + class(typ2), intent(inout) :: x + class(typ2), intent(in) :: y + x%i = y%i + 42 + end subroutine sub + + subroutine test2(x,y) + class(typ2), intent(inout) :: x(:) + class(typ2), intent(in) :: y(:) + x([2,1]) = y([1,2]) + end subroutine test2 + +end module mod2 + +subroutine pr120140 + use mod1 + use mod2 + implicit none + + type(typ1) :: p1(8), q1(8) + type(typ2) :: p2(8), q2(8) + integer :: j + + p1%i = 0 + q1%i = [(j,j=1,8)] + call test1 (p1, q1) + if (any(p1%i /= [44, 43, 0, 0, 0, 0, 0, 0])) then + print *, p1%i + stop 1 + end if + + p2%i = 0 + q2%i = [(j,j=1,8)] + call test2 (p2, q2) + if (any(p2%i /= [44, 43, 0, 0, 0, 0, 0, 0])) then + print *, p2%i + stop 2 + end if +end subroutine pr120140 + +!--------------------------- +! Part 2: Supplemental tests +!--------------------------- +module pr120140_extras + implicit none + public :: extra_tests + private + + type t1 + integer :: i = 0 + end type t1 + + type t2 + integer :: i = 0 + end type t2 + + interface assignment(=) + module procedure sub1 + module procedure sub2 + end interface assignment(=) + +contains + + elemental subroutine sub1 (x, y) + type(t1), intent(inout) :: x + type(t1), intent(in) :: y + x%i = y%i + 23 + end subroutine sub1 + + elemental subroutine sub2 (x, y) + class(t2), intent(inout) :: x + class(t2), intent(in) :: y + x%i = y%i + 42 + end subroutine sub2 + + subroutine extra_tests () + integer :: j + type(t1) :: p1(4), q1(4) = [(t1(j),j=1,4)] + type(t2) :: p2(4), q2(4) = [(t2(j),j=1,4)] + integer :: operm(2) = [2,1] + integer :: iperm(2) = [1,2] + integer :: expect1(4) = [25,24,0,0] + integer :: expect2(4) = [44,43,0,0] + + !----------------------------------- + ! (1) l.h.s. not depending on r.h.s. + ! check type and class + !----------------------------------- + ! l.h.s. array section, r.h.s. array section + p1%i = 0 + p1(2:1:-1) = q1(1:2) + call check (p1%i, expect1, 11) + + p2%i = 0 + p2(2:1:-1) = q2(1:2) + call check (p2%i, expect2, 21) + + p1%i = 0 + call sub1 (p1(2:1:-1), q1(1:2)) + call check (p1%i, expect1, 31) + + p2%i = 0 + call sub2 (p2(2:1:-1), q2(1:2)) + call check (p2%i, expect2, 41) + + ! l.h.s. vector indices, r.h.s. array section + p1%i = 0 + p1([2,1]) = q1(1:2) + call check (p1%i, expect1, 12) + + p1%i = 0 + call sub1 (p1([2,1]), q1(1:2)) + call check (p1%i, expect1, 22) + + p2%i = 0 + p2([2,1]) = q2(1:2) + call check (p2%i, expect2, 32) + + p2%i = 0 + call sub2 (p2([2,1]), q2(1:2)) + call check (p2%i, expect2, 42) + + ! l.h.s. permutation vector, r.h.s. array section + p1%i = 0 + p1(operm) = q1(1:2) + call check (p1%i, expect1, 13) + + p1%i = 0 + call sub1 (p1(operm), q1(1:2)) + call check (p1%i, expect1, 23) + + p2%i = 0 + p2(operm) = q2(1:2) + call check (p2%i, expect2, 33) + + p2%i = 0 + call sub2 (p2(operm), q2(1:2)) + call check (p2%i, expect2, 43) + + ! l.h.s. array section, r.h.s vector indices + p1%i = 0 + p1(2:1:-1) = q1([1,2]) + call check (p1%i, expect1, 14) + + p1%i = 0 + call sub1 (p1(2:1:-1), q1([1,2])) + call check (p1%i, expect1, 24) + + p2%i = 0 + p2(2:1:-1) = q2([1,2]) + call check (p1%i, expect1, 34) + + p2%i = 0 + call sub2 (p2(2:1:-1), q2([1,2])) + call check (p2%i, expect2, 44) + + ! l.h.s. vector indices, r.h.s vector indices + p1%i = 0 + p1([2,1]) = q1([1,2]) + call check (p1%i, expect1, 15) + + p1%i = 0 + call sub1 (p1([2,1]), q1([1,2])) + call check (p1%i, expect1, 25) + + p2%i = 0 + p2([2,1]) = q2([1,2]) + call check (p2%i, expect2, 35) + + p2%i = 0 + call sub2 (p2([2,1]), q2([1,2])) + call check (p2%i, expect2, 45) + + !--------------------------------- + ! (2) l.h.s. *depending* on r.h.s. + ! check type and class + !--------------------------------- + expect1 = [25,24,3,4] + expect2 = [44,43,3,4] + + ! l.h.s. array section, r.h.s. array section + p1%i = q1%i + p1(2:1:-1) = p1(1:2) + call check (p1%i, expect1, 51) + + p2%i = q2%i + p2(2:1:-1) = p2(1:2) + call check (p2%i, expect2, 53) + + p1%i = q1%i + call sub1 (p1(2:1:-1), (p1(1:2))) ! Beware: force evaluation of arg2! + call check (p1%i, expect1, 52) + + p2%i = q2%i + call sub2 (p2(2:1:-1), (p2(1:2))) ! Beware: force evaluation of arg2! + call check (p2%i, expect2, 54) + + ! l.h.s. array section, r.h.s vector indices + p1%i = q1%i + p1(2:1:-1) = p1([1,2]) + call check (p1%i, expect1, 61) + + p2%i = q2%i + p2(2:1:-1) = p2([1,2]) + call check (p2%i, expect2, 63) + + p1%i = q1%i + call sub1 (p1(2:1:-1), (p1([1,2]))) + call check (p1%i, expect1, 62) + + p2%i = q2%i + call sub2 (p2(2:1:-1), (p2([1,2]))) + call check (p2%i, expect2, 64) + + ! l.h.s. vector indices, r.h.s. array section + ! (this part currently disabled because the temporary for the l.h.s. + ! is not yet implemented properly) +! p1%i = q1%i +! p1([2,1]) = p1(1:2) +! call check (p1%i, expect1, 71) +! +! p2%i = q2%i +! p2([2,1]) = p2(1:2) +! call check (p2%i, expect2, 73) + +! p1%i = q1%i +! call sub1 (p1([2,1]), (p1(1:2))) +! call check (p1%i, expect1, 72) +! +! p2%i = q2%i +! call sub2 (p2([2,1]), (p2(1:2))) +! call check (p2%i, expect2, 74) + + end subroutine extra_tests + + subroutine check (result, expect, code) + integer, intent(in) :: result(:), expect(:), code + if (any (result /= expect)) then + print *, code, ":", result, "/=", expect + stop code + end if + end subroutine check + +end module pr120140_extras + +!----------- + +program main + use pr120140_extras + call pr120140 () + call extra_tests () +end -- 2.51.0
