aboutsummaryrefslogtreecommitdiff
path: root/gcc/testsuite/gfortran.dg
diff options
context:
space:
mode:
Diffstat (limited to 'gcc/testsuite/gfortran.dg')
-rw-r--r--gcc/testsuite/gfortran.dg/associate_70.f902
-rw-r--r--gcc/testsuite/gfortran.dg/assumed_charlen_in_main.f902
-rw-r--r--gcc/testsuite/gfortran.dg/bessel_3.f902
-rw-r--r--gcc/testsuite/gfortran.dg/c_funloc_tests_6.f902
-rw-r--r--gcc/testsuite/gfortran.dg/class_79.f9025
-rw-r--r--gcc/testsuite/gfortran.dg/cray_pointers_2.f904
-rw-r--r--gcc/testsuite/gfortran.dg/derived_result_4.f9038
-rw-r--r--gcc/testsuite/gfortran.dg/gomp/append-args-interop.f9028
-rw-r--r--gcc/testsuite/gfortran.dg/gomp/declare-variant-mod-2.f906
-rw-r--r--gcc/testsuite/gfortran.dg/gomp/interop-4.f9010
-rw-r--r--gcc/testsuite/gfortran.dg/gomp/interop-5.f9027
-rw-r--r--gcc/testsuite/gfortran.dg/parity_2.f902
-rw-r--r--gcc/testsuite/gfortran.dg/proc_ptr_comp_54.f9030
-rw-r--r--gcc/testsuite/gfortran.dg/reduce_1.f90202
-rw-r--r--gcc/testsuite/gfortran.dg/reduce_2.f90145
15 files changed, 506 insertions, 19 deletions
diff --git a/gcc/testsuite/gfortran.dg/associate_70.f90 b/gcc/testsuite/gfortran.dg/associate_70.f90
index ddb38b8..6f8f5d6a 100644
--- a/gcc/testsuite/gfortran.dg/associate_70.f90
+++ b/gcc/testsuite/gfortran.dg/associate_70.f90
@@ -1,5 +1,5 @@
! { dg-do run }
-! ( dg-options "-Wuninitialized" )
+! { dg-options "-Wuninitialized" }
!
! Test fix for PR115700 comment 5, in which ‘.tmp1’ is used uninitialized and
! both normal and scalarized array references did not work correctly.
diff --git a/gcc/testsuite/gfortran.dg/assumed_charlen_in_main.f90 b/gcc/testsuite/gfortran.dg/assumed_charlen_in_main.f90
index f4bb701..695a580 100644
--- a/gcc/testsuite/gfortran.dg/assumed_charlen_in_main.f90
+++ b/gcc/testsuite/gfortran.dg/assumed_charlen_in_main.f90
@@ -20,7 +20,7 @@ end subroutine poobar
program test
character(len=*), parameter :: foo = 'test' ! Parameters must work.
character(len=4) :: bar = foo
- character(len=*) :: foobar = 'This should fail' ! { dg-error "must be a dummy" }
+ character(len=*) :: foobar = 'This should fail' ! { dg-error "must be a dummy" }
print *, bar
call poobar ()
end
diff --git a/gcc/testsuite/gfortran.dg/bessel_3.f90 b/gcc/testsuite/gfortran.dg/bessel_3.f90
index 51e11e9..4191d24 100644
--- a/gcc/testsuite/gfortran.dg/bessel_3.f90
+++ b/gcc/testsuite/gfortran.dg/bessel_3.f90
@@ -6,7 +6,7 @@
!
IMPLICIT NONE
print *, SIN (1.0)
-print *, BESSEL_J0(1.0) ! { dg-error "has no IMPLICIT type" })
+print *, BESSEL_J0(1.0) ! { dg-error "has no IMPLICIT type" }
print *, BESSEL_J1(1.0) ! { dg-error "has no IMPLICIT type" }
print *, BESSEL_JN(1,1.0) ! { dg-error "has no IMPLICIT type|Type mismatch" }
print *, BESSEL_JN(1,2,1.0) ! { dg-error "has no IMPLICIT type|Type mismatch|More actual than formal" }
diff --git a/gcc/testsuite/gfortran.dg/c_funloc_tests_6.f90 b/gcc/testsuite/gfortran.dg/c_funloc_tests_6.f90
index 45d0955..d8c8039 100644
--- a/gcc/testsuite/gfortran.dg/c_funloc_tests_6.f90
+++ b/gcc/testsuite/gfortran.dg/c_funloc_tests_6.f90
@@ -20,7 +20,7 @@ procedure(sub), pointer :: fsub
integer, external :: noCsub
procedure(integer), pointer :: fint
-cp = c_funloc (sub) ! { dg-error "Cannot convert TYPE.c_funptr. to TYPE.c_ptr." })
+cp = c_funloc (sub) ! { dg-error "Cannot convert TYPE.c_funptr. to TYPE.c_ptr." }
cfp = c_loc (int) ! { dg-error "Cannot convert TYPE.c_ptr. to TYPE.c_funptr." }
call c_f_pointer (cfp, int) ! { dg-error "Argument CPTR at .1. to C_F_POINTER shall have the type TYPE.C_PTR." }
diff --git a/gcc/testsuite/gfortran.dg/class_79.f90 b/gcc/testsuite/gfortran.dg/class_79.f90
new file mode 100644
index 0000000..a2226e4
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/class_79.f90
@@ -0,0 +1,25 @@
+!{ dg-do run }
+
+! Check double free on array constructor in argument list is fixed.
+! Contributed by Damian Rouson <damian@archaeologic.codes>
+program pr119349
+ implicit none
+
+ type string_t
+ character(len=:), allocatable :: string_
+ end type
+
+ print *, true([string()])
+
+contains
+
+ type(string_t) function string()
+ string%string_ = ""
+ end function
+
+ logical elemental function true(rhs)
+ class(string_t), intent(in) :: rhs
+ true = .true.
+ end function
+
+end program
diff --git a/gcc/testsuite/gfortran.dg/cray_pointers_2.f90 b/gcc/testsuite/gfortran.dg/cray_pointers_2.f90
index 4351874..e646fc8 100644
--- a/gcc/testsuite/gfortran.dg/cray_pointers_2.f90
+++ b/gcc/testsuite/gfortran.dg/cray_pointers_2.f90
@@ -1,6 +1,4 @@
-! Using two spaces between dg-do and run is a hack to keep gfortran-dg-runtest
-! from cycling through optimization options for this expensive test.
-! { dg-do run }
+! { dg-do run }
! { dg-options "-O3 -fcray-pointer -fbounds-check -fno-inline" }
! { dg-timeout-factor 4 }
!
diff --git a/gcc/testsuite/gfortran.dg/derived_result_4.f90 b/gcc/testsuite/gfortran.dg/derived_result_4.f90
new file mode 100644
index 0000000..12ab190
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/derived_result_4.f90
@@ -0,0 +1,38 @@
+! { dg-do compile }
+! { dg-additional-options "-Wall -Wno-return-type -Wno-unused-variable" }
+!
+! PR fortran/118796 - bogus recursion with DT default initialization
+
+module m1
+ implicit none
+
+ type :: t1
+ type(integer) :: f1 = 0
+ end type t1
+
+ TYPE :: c1
+ contains
+ procedure, public :: z
+ END TYPE c1
+
+contains
+ ! type-bound procedure z has a default initialization
+ function z( this )
+ type(t1) :: z
+ class(c1), intent(in) :: this
+ end function z
+end module m1
+
+module m2
+ use m1, only : c1
+contains
+ function z() result(field)
+ end function z
+end module m2
+
+module m3
+ use m1, only : c1
+contains
+ function z()
+ end function z
+end module m3
diff --git a/gcc/testsuite/gfortran.dg/gomp/append-args-interop.f90 b/gcc/testsuite/gfortran.dg/gomp/append-args-interop.f90
new file mode 100644
index 0000000..f2c4d97
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/gomp/append-args-interop.f90
@@ -0,0 +1,28 @@
+! { dg-do compile }
+! { dg-additional-options "-fdump-tree-gimple" }
+
+! Test that interop objects are implicitly created/destroyed when a dispatch
+! construct doesn't provide enough of them to satisfy the declare variant
+! append_args clause.
+
+module m
+ use iso_c_binding, only: c_intptr_t
+ integer, parameter :: omp_interop_kind = c_intptr_t
+contains
+subroutine g(x,y,z)
+ integer(omp_interop_kind) :: x, y, z
+ value :: y
+end
+subroutine f()
+ !$omp declare variant(f: g) append_args(interop(target), interop(prefer_type("cuda","hip"), targetsync), interop(target,targetsync,prefer_type({attr("ompx_foo")}))) match(construct={dispatch})
+end
+end
+
+use m
+!$omp dispatch device(99)
+ call f()
+end
+
+! { dg-final { scan-tree-dump "__builtin_GOMP_interop \\(99, 3, interopobjs\.\[0-9\]+, tgt_tgtsync\.\[0-9\]+, pref_type\.\[0-9\]+, " "gimple" } }
+! { dg-final { scan-tree-dump "__builtin_GOMP_interop \\(99, 0, 0B, 0B, 0B, 0, 0B, 3, interopobjs\.\[0-9\]+," "gimple" } }
+! { dg-final { scan-tree-dump "g \\(&interop\.\[0-9\]+, interop\.\[0-9\]+, &interop\.\[0-9\]+\\)" "gimple" } }
diff --git a/gcc/testsuite/gfortran.dg/gomp/declare-variant-mod-2.f90 b/gcc/testsuite/gfortran.dg/gomp/declare-variant-mod-2.f90
index f75b49c..ab44050 100644
--- a/gcc/testsuite/gfortran.dg/gomp/declare-variant-mod-2.f90
+++ b/gcc/testsuite/gfortran.dg/gomp/declare-variant-mod-2.f90
@@ -9,12 +9,6 @@
! { dg-error "'x' at .1. is specified more than once" "" { target *-*-* } 17 }
-! { dg-message "sorry, unimplemented: 'append_args' clause not yet supported for 'm2_f1', except when specifying all 1 objects in the 'interop' clause of the 'dispatch' directive" "" { target *-*-* } 27 }
-! { dg-note "required by 'dispatch' construct" "" { target *-*-* } 33 }
-! { dg-message "sorry, unimplemented: 'append_args' clause not yet supported for 'm2_f2', except when specifying all 2 objects in the 'interop' clause of the 'dispatch' directive" "" { target *-*-* } 27 }
-! { dg-note "required by 'dispatch' construct" "" { target *-*-* } 37 }
-! { dg-message "sorry, unimplemented: 'append_args' clause not yet supported for 'm2_f3', except when specifying all 3 objects in the 'interop' clause of the 'dispatch' directive" "" { target *-*-* } 27 }
-! { dg-note "required by 'dispatch' construct" "" { target *-*-* } 43 }
! Check that module-file handling works for declare_variant
! and its match/adjust_args/append_args clauses
diff --git a/gcc/testsuite/gfortran.dg/gomp/interop-4.f90 b/gcc/testsuite/gfortran.dg/gomp/interop-4.f90
index 8783f4c..43c28d6 100644
--- a/gcc/testsuite/gfortran.dg/gomp/interop-4.f90
+++ b/gcc/testsuite/gfortran.dg/gomp/interop-4.f90
@@ -26,18 +26,18 @@ implicit none
integer(omp_interop_kind) :: obj1, obj2, obj3, obj4, obj5, obj6, obj7
integer :: x(6)
-!$omp interop init ( obj1, obj2) use (obj3) destroy(obj4) init(obj5) destroy(obj6) use(obj7) ! { dg-message "'#pragma omp interop' not yet supported" }
+!$omp interop init ( obj1, obj2) use (obj3) destroy(obj4) init(obj5) destroy(obj6) use(obj7)
! { dg-final { scan-tree-dump-times "#pragma omp interop init\\(obj1\\) init\\(obj2\\) init\\(obj5\\) use\\(obj3\\) use\\(obj7\\) destroy\\(obj4\\) destroy\\(obj6\\)\[\r\n\]" 1 "original" } }
-!$omp interop nowait init (targetsync : obj1, obj2) use (obj3) destroy(obj4) init(target, targetsync : obj5) destroy(obj6) use(obj7) depend(inout: x) ! { dg-message "'#pragma omp interop' not yet supported" }
+!$omp interop nowait init (targetsync : obj1, obj2) use (obj3) destroy(obj4) init(target, targetsync : obj5) destroy(obj6) use(obj7) depend(inout: x)
! { dg-final { scan-tree-dump-times "#pragma omp interop depend\\(inout:x\\) init\\(targetsync: obj1\\) init\\(targetsync: obj2\\) init\\(target, targetsync: obj5\\) use\\(obj3\\) use\\(obj7\\) destroy\\(obj4\\) destroy\\(obj6\\) nowait\[\r\n\]" 1 "original" } }
-!$omp interop init ( obj1, obj2) init (target: obj3) init(targetsync : obj4) init(target,targetsync: obj5) ! { dg-message "'#pragma omp interop' not yet supported" }
+!$omp interop init ( obj1, obj2) init (target: obj3) init(targetsync : obj4) init(target,targetsync: obj5)
! { dg-final { scan-tree-dump-times "#pragma omp interop init\\(obj1\\) init\\(obj2\\) init\\(target: obj3\\) init\\(targetsync: obj4\\) init\\(target, targetsync: obj5\\)\[\r\n\]" 1 "original" } }
! --------------------------------------------
-!$omp interop init (target, prefer_type(omp_ifr_cuda, omp_ifr_cuda+1, "hsa", "myPrivateInterop", omp_ifr_cuda-2) : obj1, obj2) init (target: obj3) init(prefer_type(omp_ifr_hip, "sycl", omp_ifr_opencl), targetsync : obj4, obj7) init(target,prefer_type("level_zero", omp_ifr_level_zero+0),targetsync: obj5) ! { dg-message "'#pragma omp interop' not yet supported" }
+!$omp interop init (target, prefer_type(omp_ifr_cuda, omp_ifr_cuda+1, "hsa", "myPrivateInterop", omp_ifr_cuda-2) : obj1, obj2) init (target: obj3) init(prefer_type(omp_ifr_hip, "sycl", omp_ifr_opencl), targetsync : obj4, obj7) init(target,prefer_type("level_zero", omp_ifr_level_zero+0),targetsync: obj5)
!
! { dg-warning "Unknown foreign runtime identifier 'myPrivateInterop' at \\(1\\) \\\[-Wopenmp\\\]" "" { target *-*-* } .-2 }
! { dg-warning "Unknown foreign runtime identifier '-1' at \\(1\\) \\\[-Wopenmp\\\]" "" { target *-*-* } .-3 }
@@ -47,7 +47,7 @@ integer :: x(6)
! --------------------------------------------
-!$omp interop init ( target, prefer_type( {fr(1_"hip"), attr("ompx_gnu_prio:1", 1_"ompx_gnu_debug")}, {attr("ompx_gnu_nicest"), attr("ompx_something")}) : obj1, obj2) init ( prefer_type( {fr("cuda")}, {fr(omp_ifr_cuda_driver), attr("ompx_nix")}, {fr("best")}), targetsync : obj3, obj4) nowait use(obj5) ! { dg-message "'#pragma omp interop' not yet supported" }
+!$omp interop init ( target, prefer_type( {fr(1_"hip"), attr("ompx_gnu_prio:1", 1_"ompx_gnu_debug")}, {attr("ompx_gnu_nicest"), attr("ompx_something")}) : obj1, obj2) init ( prefer_type( {fr("cuda")}, {fr(omp_ifr_cuda_driver), attr("ompx_nix")}, {fr("best")}), targetsync : obj3, obj4) nowait use(obj5)
!
! ! { dg-warning "Unknown foreign runtime identifier 'best' at \\(1\\) \\\[-Wopenmp\\\]" "" { target *-*-* } .-2 }
!
diff --git a/gcc/testsuite/gfortran.dg/gomp/interop-5.f90 b/gcc/testsuite/gfortran.dg/gomp/interop-5.f90
new file mode 100644
index 0000000..a08eeb8
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/gomp/interop-5.f90
@@ -0,0 +1,27 @@
+! { dg-additional-options "-fdump-tree-omplower" }
+
+subroutine sub1 (a1, a2, a3, a4)
+ use iso_c_binding
+ implicit none
+
+ ! The following definitions are in omp_lib, which cannot be included
+ ! in gcc/testsuite/
+ integer, parameter :: omp_interop_kind = c_intptr_t
+
+ integer(omp_interop_kind) :: a1 ! by ref
+ integer(omp_interop_kind), optional :: a2 ! as pointer
+ integer(omp_interop_kind), allocatable :: a3 ! ref to pointer
+ integer(omp_interop_kind), value :: a4
+ integer(omp_interop_kind) :: b
+
+ !$omp interop init(target : a1, a2, a3, a4, b)
+ ! { dg-final { scan-tree-dump-times "void \\* interopobjs\.\[0-9\]+\\\[5\\\];\[\r\n ]*integer\\(kind=4\\) tgt_tgtsync\.\[0-9\]+\\\[5\\\];\[\r\n ]*integer\\(kind=\[48\]\\) \\* & a3\.\[0-9\]+;\[\r\n ]*integer\\(kind=\[48\]\\) \\* D\.\[0-9\]+;\[\r\n ]*integer\\(kind=\[48\]\\) \\* a2\.\[0-9\]+;\[\r\n ]*integer\\(kind=\[48\]\\) & a1\.\[0-9\]+;\[\r\n ]*interopobjs\.\[0-9\]+\\\[0\\\] = &b;\[\r\n ]*tgt_tgtsync\.\[0-9\]+\\\[0\\\] = 1;\[\r\n ]*interopobjs\.\[0-9\]+\\\[1\\\] = &a4;\[\r\n ]*tgt_tgtsync\.\[0-9\]+\\\[1\\\] = 1;\[\r\n ]*a3\.\[0-9\]+ = a3;\[\r\n ]*D\.\[0-9\]+ = \\*a3\.\[0-9\]+;\[\r\n ]*interopobjs\.\[0-9\]+\\\[2\\\] = D\.\[0-9\]+;\[\r\n ]*tgt_tgtsync\.\[0-9\]+\\\[2\\\] = 1;\[\r\n ]*a2\.\[0-9\]+ = a2;\[\r\n ]*interopobjs\.\[0-9\]+\\\[3\\\] = a2\.\[0-9\]+;\[\r\n ]*tgt_tgtsync\.\[0-9\]+\\\[3\\\] = 1;\[\r\n ]*a1\.\[0-9\]+ = a1;\[\r\n ]*interopobjs\.\[0-9\]+\\\[4\\\] = a1\.\[0-9\]+;\[\r\n ]*tgt_tgtsync\.\[0-9\]+\\\[4\\\] = 1;\[\r\n ]*__builtin_GOMP_interop \\(-5, 5, &interopobjs\.\[0-9\]+, &tgt_tgtsync\.\[0-9\]+, 0B, 0, 0B, 0, 0B, 0, 0B\\);" 1 "omplower" } }
+
+ !$omp interop use(a1, a2, a3, a4, b)
+ ! { dg-final { scan-tree-dump-times "void \\* interopobjs\.\[0-9\]+\\\[5\\\];\[\r\n ]*integer\\(kind=\[48\]\\) b\.\[0-9\]+;\[\r\n ]*void \\* b\.\[0-9\]+;\[\r\n ]*integer\\(kind=\[48\]\\) a4\.\[0-9\]+;\[\r\n ]*void \\* a4\.\[0-9\]+;\[\r\n ]*integer\\(kind=\[48\]\\) \\* & a3\.\[0-9\]+;\[\r\n ]*integer\\(kind=\[48\]\\) \\* D\.\[0-9\]+;\[\r\n ]*integer\\(kind=\[48\]\\) D\.\[0-9\]+;\[\r\n ]*void \\* D\.\[0-9\]+;\[\r\n ]*integer\\(kind=\[48\]\\) \\* a2\.\[0-9\]+;\[\r\n ]*integer\\(kind=\[48\]\\) D\.\[0-9\]+;\[\r\n ]*void \\* D\.\[0-9\]+;\[\r\n ]*integer\\(kind=\[48\]\\) & a1\.\[0-9\]+;\[\r\n ]*integer\\(kind=\[48\]\\) D\.\[0-9\]+;\[\r\n ]*void \\* D\.\[0-9\]+;\[\r\n ]*b\.\[0-9\]+ = b;\[\r\n ]*b\.\[0-9\]+ = \\(void \\*\\) b\.\[0-9\]+;\[\r\n ]*interopobjs\.\[0-9\]+\\\[0\\\] = b\.\[0-9\]+;\[\r\n ]*a4\.\[0-9\]+ = a4;\[\r\n ]*a4\.\[0-9\]+ = \\(void \\*\\) a4\.\[0-9\]+;\[\r\n ]*interopobjs\.\[0-9\]+\\\[1\\\] = a4\.\[0-9\]+;\[\r\n ]*a3\.\[0-9\]+ = a3;\[\r\n ]*D\.\[0-9\]+ = \\*a3\.\[0-9\]+;\[\r\n ]*D\.\[0-9\]+ = \\*D\.\[0-9\]+;\[\r\n ]*D\.\[0-9\]+ = \\(void \\*\\) D\.\[0-9\]+;\[\r\n ]*interopobjs\.\[0-9\]+\\\[2\\\] = D\.\[0-9\]+;\[\r\n ]*a2\.\[0-9\]+ = a2;\[\r\n ]*D\.\[0-9\]+ = \\*a2\.\[0-9\]+;\[\r\n ]*D\.\[0-9\]+ = \\(void \\*\\) D\.\[0-9\]+;\[\r\n ]*interopobjs\.\[0-9\]+\\\[3\\\] = D\.\[0-9\]+;\[\r\n ]*a1\.\[0-9\]+ = a1;\[\r\n ]*D\.\[0-9\]+ = \\*a1\.\[0-9\]+;\[\r\n ]*D\.\[0-9\]+ = \\(void \\*\\) D\.\[0-9\]+;\[\r\n ]*interopobjs\.\[0-9\]+\\\[4\\\] = D\.\[0-9\]+;\[\r\n ]*__builtin_GOMP_interop \\(-5, 0, 0B, 0B, 0B, 5, &interopobjs\.\[0-9\]+, 0, 0B, 0, 0B\\);" 1 "omplower" } }
+
+ !$omp interop destroy(a1, a2, a3, a4, b)
+ ! { dg-final { scan-tree-dump-times "void \\* interopobjs\.\[0-9\]+\\\[5\\\];\[\r\n ]*integer\\(kind=\[48\]\\) \\* & a3\.\[0-9\]+;\[\r\n ]*integer\\(kind=\[48\]\\) \\* D\.\[0-9\]+;\[\r\n ]*integer\\(kind=\[48\]\\) \\* a2\.\[0-9\]+;\[\r\n ]*integer\\(kind=\[48\]\\) & a1\.\[0-9\]+;\[\r\n ]*interopobjs\.\[0-9\]+\\\[0\\\] = &b;\[\r\n ]*interopobjs\.\[0-9\]+\\\[1\\\] = &a4;\[\r\n ]*a3\.\[0-9\]+ = a3;\[\r\n ]*D\.\[0-9\]+ = \\*a3\.\[0-9\]+;\[\r\n ]*interopobjs\.\[0-9\]+\\\[2\\\] = D\.\[0-9\]+;\[\r\n ]*a2\.\[0-9\]+ = a2;\[\r\n ]*interopobjs\.\[0-9\]+\\\[3\\\] = a2\.\[0-9\]+;\[\r\n ]*a1\.\[0-9\]+ = a1;\[\r\n ]*interopobjs\.\[0-9\]+\\\[4\\\] = a1\.\[0-9\]+;\[\r\n ]*__builtin_GOMP_interop \\(-5, 0, 0B, 0B, 0B, 0, 0B, 5, &interopobjs\.\[0-9\]+, 0, 0B\\);" 1 "omplower" } }
+end subroutine
+
+
diff --git a/gcc/testsuite/gfortran.dg/parity_2.f90 b/gcc/testsuite/gfortran.dg/parity_2.f90
index 5ff11da..9a8e035 100644
--- a/gcc/testsuite/gfortran.dg/parity_2.f90
+++ b/gcc/testsuite/gfortran.dg/parity_2.f90
@@ -6,7 +6,7 @@
! Check implementation of PARITY
!
implicit none
-print *, parity([real ::]) ! { dg-error "must be LOGICAL" })
+print *, parity([real ::]) ! { dg-error "must be LOGICAL" }
print *, parity([integer ::]) ! { dg-error "must be LOGICAL" }
print *, parity([logical ::])
print *, parity(.true.) ! { dg-error "must be an array" }
diff --git a/gcc/testsuite/gfortran.dg/proc_ptr_comp_54.f90 b/gcc/testsuite/gfortran.dg/proc_ptr_comp_54.f90
new file mode 100644
index 0000000..f5b7fa8
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/proc_ptr_comp_54.f90
@@ -0,0 +1,30 @@
+!{ dg-do run }
+
+! Do not free procedure pointer components.
+! Contributed by Damian Rouson <damian@archaeologic.codes>
+
+ implicit none
+
+ type foo_t
+ integer, allocatable :: i_
+ procedure(f), pointer, nopass :: f_
+ procedure(c), pointer, nopass :: c_
+ end type
+
+ class(foo_t), allocatable :: ff
+
+ associate(foo => foo_t(1,f))
+ end associate
+
+contains
+
+ function f()
+ logical, allocatable :: f
+ f = .true.
+ end function
+
+ function c()
+ class(foo_t), allocatable :: c
+ allocate(c)
+ end function
+end
diff --git a/gcc/testsuite/gfortran.dg/reduce_1.f90 b/gcc/testsuite/gfortran.dg/reduce_1.f90
new file mode 100644
index 0000000..585cad7
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/reduce_1.f90
@@ -0,0 +1,202 @@
+! { dg-do run }
+!
+! Test results from the F2018 intrinsic REDUCE
+!
+! Contributed by Paul Thomas <pault@gcc.gnu.org>
+!
+
+module operations
+ type :: s
+ integer, allocatable :: i
+ integer :: j
+ end type s
+
+contains
+
+ pure function add(i,j) result(sum_ij)
+ integer, intent(in) :: i, j
+ integer :: sum_ij
+ sum_ij = i + j
+ end function add
+!
+ pure function mult(i,j) result(prod_ij)
+ integer, intent(in) :: i, j
+ integer :: prod_ij
+ prod_ij = i * j
+ end function mult
+
+ pure function mult_by_val(i,j) result(prod_ij)
+ integer, intent(in), value :: i, j
+ integer :: prod_ij
+ prod_ij = i * j
+ end function mult_by_val
+
+ pure function non_com(i,j) result(nc_ij)
+ integer, intent(in) :: i, j
+ integer :: nc_ij
+ if (i > j) then
+ nc_ij = i - j
+ else
+ nc_ij = i + j
+ endif
+ end function non_com
+
+ pure function c_op (i, j) result (ij)
+ character(8), intent(in) :: i, j
+ character(8) :: ij
+ integer :: n
+ ij = i
+ do n = 1, 8
+ if (i(n:n) .ne. j(n:n)) ij(n:n) = '!'
+ end do
+ end function c_op
+
+ pure function t_op (i, j) result (ij)
+ type(s), intent(in) :: i, j
+ type(s) :: ij
+ ij%i = non_com (i%i, j%i)
+ ij%j = non_com (j%j, i%j)
+ end function t_op
+
+ pure function t_add (i, j) result (ij)
+ type(s), intent(in) :: i, j
+ type(s) :: ij
+ ij%i = i%i + j%i
+ ij%j = j%j + i%j
+ end function t_add
+end module operations
+
+program test_reduce
+ use operations
+ implicit none
+ integer :: i
+ integer, parameter :: n = 3
+ integer, parameter :: vec(n) = [2, 5, 10]
+ integer, parameter :: mat(n,2) = reshape([vec,2*vec],shape=[size(vec),2])
+ integer :: res0
+ integer, dimension(:), allocatable :: res1
+ integer, dimension(:,:), allocatable :: res2
+ logical, parameter :: t = .true., f = .false.
+ LOGICAL, PARAMETER :: keep(n) = [t,f,t]
+ logical, parameter :: keepM(n,2) = reshape([keep,keep],shape=[n,2])
+ logical, parameter :: all_false(n,2) = reshape ([(f, i = 1,2*n)],[n,2])
+ character(*), parameter :: carray (4) = ['abctefgh', 'atcdefgh', &
+ 'abcdefth', 'abcdtfgh']
+ character(:), allocatable :: cres0, cres1(:)
+ type(s), allocatable :: tres1(:)
+ type(s), allocatable :: tres2(:,:)
+ type(s) :: tres2_na(2, 4)
+ type(s), allocatable :: tarray(:,:,:)
+ type(s), allocatable :: tvec(:)
+ type(s), allocatable :: tres0
+ integer, allocatable :: ires(:)
+
+! Simple cases with and without DIM
+ res0 = reduce (vec, add, dim=1)
+ if (res0 /= 17) stop 1
+ res0 = reduce (vec, mult, 1)
+ if (res0 /= 100) stop 2
+ res1 = reduce (mat, add, 1)
+ if (any (res1 /= [17, 34])) stop 3
+ res1 = reduce (mat, mult, 1)
+ if (any (res1 /= [100, 800])) stop 4
+ res1 = reduce (mat, add, 2)
+ if (any (res1 /= [6, 15, 30])) stop 5
+ res1 = reduce (mat, mult, 2)
+ if (any (res1 /= [8, 50, 200])) stop 6
+ res0 = reduce (mat, add)
+ if (res0 /= 51) stop 7
+ res0 = reduce (mat, mult)
+ if (res0 /= 80000) stop 8
+! Repeat previous test with arguments passed by value to operation
+ res0 = reduce (mat, mult_by_val)
+ if (res0 /= 80000) stop 9
+
+! Using MASK and IDENTITY
+ res0 = reduce (vec,add, mask=keep, identity = 1)
+ if (res0 /= 12) stop 10
+ res0 = reduce (vec,mult, mask=keep, identity = 1)
+ if (res0 /= 20) stop 11
+ res0 = reduce (mat, add, mask=keepM, identity = 1)
+ if (res0 /= 36) stop 12
+ res0 = reduce (mat, mult, mask=keepM, identity = 1)
+ if (res0 /= 1600) stop 13
+ res0 = reduce (mat, mult, mask=all_false, identity = -1)
+ if (res0 /= -1) stop 14
+
+! 3-D ARRAYs with and without DIM and MASK
+ res0 = reduce (reshape ([(i, i=1,8)], [2,2,2]),mult)
+ if (res0 /= 40320) stop 15
+ res2 = reduce (reshape ([(i, i=1,8)], [2,2,2]),mult,dim=2)
+ if (any (res2 /= reshape ([3,8,35,48], [2,2]))) stop 16
+ res2 = reduce (reshape ([(i, i=1,8)], [2,2,2]),mult,dim=2, &
+ mask=reshape ([t,f,t,f,t,f,t,f],[2,2,2]), identity=-1)
+ if (any (res2 /= reshape ([3,-1,35,-1], [2,2]))) stop 17
+ res2 = reduce (reshape([(i, i=1,16)], [2,4,2]), add, dim = 3, &
+ mask=reshape([f,t,t,f,t,t,t,t,t,t,t,t,t,t,t,t],[2,4,2]), &
+ identity=-1)
+ if (any (res2 /= reshape ([9,12,14,12,18,20,22,24], [2,4]))) stop 18
+ res1 = reduce (reshape([(i, i=1,16)], [4,4]),add, dim = 2, &
+ mask=reshape([f,t,t,f,t,t,t,t,t,t,t,t,t,t,t,t],[4,4]), &
+ identity=-1)
+ if (any (res1 /= [27,32,36,36])) stop 19
+
+! Verify that the library function treats non-comutative OPERATION in the
+! correct order. If this were incorrect,the result would be [9,8,8,12,8,8,8,8].
+ res2 = reduce (reshape([(i, i=1,16)], [2,4,2]), non_com, dim = 3, &
+ mask=reshape([f,t,t,f,t,t,t,t,t,t,t,t,t,t,t,t],[2,4,2]), &
+ identity=-1)
+ if (any (res2 /= reshape([9,12,14,12,18,20,22,24],shape(res2)))) stop 20
+
+! Character ARRAY and OPERATION
+ cres0 = reduce (carray, c_op); if (cres0 /= 'a!c!!f!h') stop 21
+ cres1 = reduce (reshape (carray, [2,2]), c_op, dim = 1)
+ if (any (cres1 /= ['a!c!efgh','abcd!f!h'])) stop 22
+
+! Derived type ARRAY and OPERATION - was checked for memory leaks of the
+! allocatable component.
+! tarray = reshape([(s(i, i), i = 1, 16)], [2,4,2]) leaks memory!
+ allocate (tvec(16))
+ do i = 1, 16
+ tvec(i)%i = i
+ tvec(i)%j = i
+ enddo
+ tarray = reshape(tvec, [2,4,2])
+
+ tres2 = reduce (tarray, t_op, dim = 3, &
+ mask=reshape([t,t,t,f,t,t,t,t,t,f,t,t,t,t,t,t],[2,4,2]), &
+ identity = s(NULL(),1))
+ ires = [10,2,14,12,18,20,22,24]
+ tres1 = reshape (tres2, [size (tres2, 1)* size (tres2, 2)])
+ do i = 1, size (tres2, 1)* size (tres2, 2)
+ if (tres1(i)%i /= ires(i)) stop 23
+ end do
+ if (any (tres2%j /= reshape([8,2,8,12,8,8,8,8],shape(tres2)))) stop 24
+
+! Check that the non-allocatable result with an allocatable component does not
+! leak memory from the allocatable component
+ tres2_na = reduce (tarray, t_op, dim = 3, &
+ mask=reshape([t,t,t,f,t,t,t,t,t,f,t,t,t,t,t,t],[2,4,2]), &
+ identity = s(NULL(),1))
+ tres1 = reshape (tres2_na, [size (tres2_na, 1)* size (tres2, 2)])
+ do i = 1, size (tres2_na, 1)* size (tres2_na, 2)
+ if (tres1(i)%i /= ires(i)) stop 25
+ end do
+ if (any (tres2_na%j /= reshape([8,2,8,12,8,8,8,8],shape(tres2_na)))) stop 26
+
+
+ tres0 = reduce (tarray, t_add)
+ if (tres0%i /= 136) stop 27
+ if (tres0%j /= 136) stop 28
+
+! Test array being a component of an array of derived types
+ i = reduce (tarray%j, add, &
+ mask=reshape([t,t,t,f,t,t,t,t,t,f,t,t,t,t,f,t],[2,4,2]), &
+ identity = 0)
+ if (i /= 107) stop 29
+
+
+! Deallocate the allocatable components and then the allocatable variables
+ tres2_na = reshape ([(s(NULL (), 0), i = 1, size (tres2_na))], shape (tres2_na))
+ deallocate (res1, res2, cres0, cres1, tarray, ires, tres0, tres1, tres2, tvec)
+end
diff --git a/gcc/testsuite/gfortran.dg/reduce_2.f90 b/gcc/testsuite/gfortran.dg/reduce_2.f90
new file mode 100644
index 0000000..52d7c68
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/reduce_2.f90
@@ -0,0 +1,145 @@
+! { dg-do compile }
+!
+! Test argument compliance for the F2018 intrinsic REDUCE
+!
+! Contributed by Paul Thomas <pault@gcc.gnu.org>
+!
+ class (*), allocatable :: cstar (:)
+ integer, allocatable :: i(:,:,:)
+ integer :: n(2,2)
+ Logical :: l1(4), l2(2,3), l3(2,2)
+
+! The ARRAY argument at (1) of REDUCE shall not be polymorphic
+ print *, reduce (cstar, add) ! { dg-error "shall not be polymorphic" }
+
+! OPERATION argument at %L must be a PURE function
+ print *, reduce (i, iadd) ! { dg-error "must be a PURE function" }
+ print *, reduce (i, foo) ! { dg-error "must be a PURE function" }
+
+! The function passed as OPERATION at (1) shall have scalar nonallocatable
+! nonpointer arguments and return a nonallocatable nonpointer scalar
+ print *, reduce (i, vadd) ! { dg-error "return a nonallocatable nonpointer scalar" }
+
+! The function passed as OPERATION at (1) shall have two arguments
+ print *, reduce (i, add_1a) ! { dg-error "shall have two arguments" }
+ print *, reduce (i, add_3a) ! { dg-error "shall have two arguments" }
+
+!The ARRAY argument at (1) has type INTEGER(4) but the function passed as OPERATION at
+! (2) returns REAL(4)
+ print *, reduce (i, add_r) ! { dg-error "returns REAL" }
+
+! The function passed as OPERATION at (1) shall have scalar nonallocatable nonpointer
+! arguments and return a nonallocatable nonpointer scalar
+ print *, reduce (i, add_a) ! { dg-error "return a nonallocatable nonpointer scalar" }
+
+! The function passed as OPERATION at (1) shall have scalar nonallocatable nonpointer arguments and
+! return a nonallocatable nonpointer scalar
+ print *, reduce (i, add_array) ! { dg-error "scalar nonallocatable nonpointer arguments" }
+
+! The function passed as OPERATION at (1) shall not have the OPTIONAL attribute for either of the arguments
+ print *, reduce (i, add_optional) ! { dg-error "shall not have the OPTIONAL attribute" }
+
+! The function passed as OPERATION at (1) shall have the VALUE attribute either for none or both arguments
+ print *, reduce (i, add_one_value) ! { dg-error "VALUE attribute either for none or both arguments" }
+
+! The character length of the ARRAY argument at (1) and of the arguments of the OPERATION at (2)
+! shall be the same
+ print *, reduce ([character(4) :: 'abcd','efgh'], char_one) ! { dg-error "The character length of the ARRAY" }
+
+! The character length of the ARRAY argument at (1) and of the function result of the OPERATION
+! at (2) shall be the same
+ print *, reduce ([character(4) :: 'abcd','efgh'], char_two) ! { dg-error "function result of the OPERATION" }
+
+! The character length of the ARRAY argument at (1) and of the arguments of the OPERATION at
+! (2) shall be the same
+ print *, reduce ([character(4) :: 'abcd','efgh'], char_three) ! { dg-error "arguments of the OPERATION" }
+
+! The DIM argument at (1), if present, must be an integer scalar
+ print *, reduce (i, add, dim = 2.0) ! { dg-error "must be an integer scalar" }
+
+! The DIM argument at (1), if present, must be an integer scalar
+ print *, reduce (i, add, dim = [2]) ! { dg-error "must be an integer scalar" }
+
+! The MASK argument at (1), if present, must be a logical array with the same rank as ARRAY
+ print *, reduce (n, add, mask = l1) ! { dg-error "same rank as ARRAY" }
+ print *, reduce (n, add, mask = n) ! { dg-error "must be a logical array" }
+
+! Different shape for arguments 'ARRAY' and 'MASK' for intrinsic REDUCE at (1) on
+! dimension 2 (2 and 3)
+ print *, reduce (n, add, mask = l2) ! { dg-error "Different shape" }
+
+! The IDENTITY argument at (1), if present, must be a scalar with the same type as ARRAY
+ print *, reduce (n, add, mask = l3, identity = 1.0) ! { dg-error "same type as ARRAY" }
+ print *, reduce (n, add, mask = l3, identity = [1]) ! { dg-error "must be a scalar" }
+
+! MASK present at (1) without IDENTITY
+ print *, reduce (n, add, mask = l3) ! { dg-warning "without IDENTITY" }
+
+contains
+ pure function add(i,j) result(sum_ij)
+ integer, intent(in) :: i, j
+ integer :: sum_ij
+ sum_ij = i + j
+ end function add
+ function iadd(i,j) result(sum_ij)
+ integer, intent(in) :: i, j
+ integer :: sum_ij
+ sum_ij = i + j
+ end function iadd
+ pure function vadd(i,j) result(sum_ij)
+ integer, intent(in) :: i, j
+ integer :: sum_ij(6)
+ sum_ij = i + j
+ end function vadd
+ pure function add_1a(i) result(sum_ij)
+ integer, intent(in) :: i
+ integer :: sum_ij
+ sum_ij = 0
+ end function add_1a
+ pure function add_3a(i) result(sum_ij)
+ integer, intent(in) :: i
+ integer :: sum_ij
+ sum_ij = 0
+ end function add_3a
+ pure function add_r(i, j) result(sum_ij)
+ integer, intent(in) :: i, j
+ real :: sum_ij
+ sum_ij = 0.0
+ end function add_r
+ pure function add_a(i, j) result(sum_ij)
+ integer, intent(in) :: i, j
+ integer, allocatable :: sum_ij
+ sum_ij = 0
+ end function add_a
+ pure function add_array(i, j) result(sum_ij)
+ integer, intent(in), dimension(:) :: i, j
+ integer :: sum_ij
+ sum_ij = 0
+ end function add_array
+ pure function add_optional(i, j) result(sum_ij)
+ integer, intent(in), optional :: i, j
+ integer :: sum_ij
+ sum_ij = 0
+ end function add_optional
+ pure function add_one_value(i, j) result(sum_ij)
+ integer, intent(in), value :: i
+ integer, intent(in) :: j
+ integer :: sum_ij
+ sum_ij = 0
+ end function add_one_value
+ pure function char_one(i, j) result(sum_ij)
+ character(8), intent(in) :: i, j
+ character(8) :: sum_ij
+ end function char_one
+ pure function char_two(i, j) result(sum_ij)
+ character(4), intent(in) :: i, j
+ character(8) :: sum_ij
+ end function char_two
+ pure function char_three(i, j) result(sum_ij)
+ character(8), intent(in) :: i
+ character(4), intent(in) :: j
+ character(4) :: sum_ij
+ end function char_three
+ subroutine foo
+ end subroutine foo
+end
generated by cgit v1.1 at 2025-04-02 05:52:30 +0000