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/bounds_check_15.f9033
-rw-r--r--gcc/testsuite/gfortran.dg/dependency_25.f9095
-rw-r--r--gcc/testsuite/gfortran.dg/extends_10.f0334
-rw-r--r--gcc/testsuite/gfortran.dg/extends_6.f032
-rw-r--r--gcc/testsuite/gfortran.dg/interface_assignment_5.f9049
-rw-r--r--gcc/testsuite/gfortran.dg/private_type_6.f902
-rw-r--r--gcc/testsuite/gfortran.dg/proc_ptr_comp_pass_6.f9035
-rw-r--r--gcc/testsuite/gfortran.dg/structure_constructor_8.f032
-rw-r--r--gcc/testsuite/gfortran.dg/typebound_call_12.f0336
-rw-r--r--gcc/testsuite/gfortran.dg/vect/fast-math-mgrid-resid.f45
10 files changed, 330 insertions, 3 deletions
diff --git a/gcc/testsuite/gfortran.dg/bounds_check_15.f90 b/gcc/testsuite/gfortran.dg/bounds_check_15.f90
new file mode 100644
index 00000000000..947ffb2f4b4
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/bounds_check_15.f90
@@ -0,0 +1,33 @@
+! { dg-do run }
+! { dg-options "-fbounds-check" }
+! Test the fix for PR42783, in which a bogus array bounds violation
+! with missing optional array argument.
+!
+! Contributed by Harald Anlauf <anlauf@gmx.de>
+!
+program gfcbug99
+ implicit none
+ character(len=8), parameter :: mnem_list(2) = "A"
+
+ call foo (mnem_list) ! This call succeeds
+ call foo () ! This call fails
+contains
+ subroutine foo (mnem_list)
+ character(len=8) ,intent(in) ,optional :: mnem_list(:)
+
+ integer :: i,j
+ character(len=256) :: ml
+ ml = ''
+ j = 0
+ if (present (mnem_list)) then
+ do i = 1, size (mnem_list)
+ if (mnem_list(i) /= "") then
+ j = j + 1
+ if (j > len (ml)/8) call abort ()
+ ml((j-1)*8+1:(j-1)*8+8) = mnem_list(i)
+ end if
+ end do
+ end if
+ if (j > 0) print *, trim (ml(1:8))
+ end subroutine foo
+end program gfcbug99
diff --git a/gcc/testsuite/gfortran.dg/dependency_25.f90 b/gcc/testsuite/gfortran.dg/dependency_25.f90
new file mode 100644
index 00000000000..25769857d76
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/dependency_25.f90
@@ -0,0 +1,95 @@
+! { dg-do run }
+! Test the fix for PR42736, in which an excessively rigorous dependency
+! checking for the assignment generated an unnecessary temporary, whose
+! rank was wrong. When accessed by the scalarizer, a segfault ensued.
+!
+! Contributed by Tobias Burnus <burnus@gcc.gnu.org>
+! Reported by Armelius Cameron <armeliusc@gmail.com>
+!
+module UnitValue_Module
+
+ implicit none
+ private
+
+ public :: &
+ operator(*), &
+ assignment(=)
+
+ type, public :: UnitValue
+ real :: &
+ Value = 1.0
+ character(31) :: &
+ Label
+ end type UnitValue
+
+ interface operator(*)
+ module procedure ProductReal_LV
+ end interface operator(*)
+
+ interface assignment(=)
+ module procedure Assign_LV_Real
+ end interface assignment(=)
+
+contains
+
+ elemental function ProductReal_LV(Multiplier, Multiplicand) result(P_R_LV)
+
+ real, intent(in) :: &
+ Multiplier
+ type(UnitValue), intent(in) :: &
+ Multiplicand
+ type(UnitValue) :: &
+ P_R_LV
+
+ P_R_LV%Value = Multiplier * Multiplicand%Value
+ P_R_LV%Label = Multiplicand%Label
+
+ end function ProductReal_LV
+
+
+ elemental subroutine Assign_LV_Real(LeftHandSide, RightHandSide)
+
+ real, intent(inout) :: &
+ LeftHandSide
+ type(UnitValue), intent(in) :: &
+ RightHandSide
+
+ LeftHandSide = RightHandSide%Value
+
+ end subroutine Assign_LV_Real
+
+end module UnitValue_Module
+
+program TestProgram
+
+ use UnitValue_Module
+
+ implicit none
+
+ type :: TableForm
+ real, dimension(:,:), allocatable :: &
+ RealData
+ end type TableForm
+
+ type(UnitValue) :: &
+ CENTIMETER
+
+ type(TableForm), pointer :: &
+ Table
+
+ allocate(Table)
+ allocate(Table%RealData(10,5))
+
+ CENTIMETER%value = 42
+ Table%RealData = 1
+ Table%RealData(:,1) = Table%RealData(:,1) * CENTIMETER
+ Table%RealData(:,2) = Table%RealData(:,2) * CENTIMETER
+ Table%RealData(:,3) = Table%RealData(:,3) * CENTIMETER
+ Table%RealData(:,5) = Table%RealData(:,5) * CENTIMETER
+
+! print *, Table%RealData
+ if (any (abs(Table%RealData(:,4) - 1) > epsilon(1.0))) call abort ()
+ if (any (abs(Table%RealData(:,[1,2,3,5]) - 42) > epsilon(1.0))) call abort ()
+end program TestProgram
+
+! { dg-final { cleanup-modules "UnitValue_Module" } }
diff --git a/gcc/testsuite/gfortran.dg/extends_10.f03 b/gcc/testsuite/gfortran.dg/extends_10.f03
new file mode 100644
index 00000000000..fbcaa7efc3f
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/extends_10.f03
@@ -0,0 +1,34 @@
+! { dg-do compile }
+!
+! PR 42545: type extension: parent component has wrong accessibility
+!
+! Reported by Reinhold Bader <bader@lrz.de>
+
+module mo
+ implicit none
+ type :: t1
+ integer :: i = 1
+ end type
+ type, extends(t1) :: t2
+ private
+ real :: x = 2.0
+ end type
+ type :: u1
+ integer :: j = 1
+ end type
+ type, extends(u1) :: u2
+ real :: y = 2.0
+ end type
+ private :: u1
+end module
+
+program pr
+ use mo
+ implicit none
+ type(t2) :: a
+ type(u2) :: b
+ print *,a%t1%i
+ print *,b%u1%j ! { dg-error "is a PRIVATE component of" }
+end program
+
+! { dg-final { cleanup-modules "mo" } }
diff --git a/gcc/testsuite/gfortran.dg/extends_6.f03 b/gcc/testsuite/gfortran.dg/extends_6.f03
index 866fbbd1c50..a50a9b751b1 100644
--- a/gcc/testsuite/gfortran.dg/extends_6.f03
+++ b/gcc/testsuite/gfortran.dg/extends_6.f03
@@ -30,7 +30,7 @@ end module m
end type two
o_dt%day = 5 ! VALID but failed in first version of EXTENDS patch
- o_dt%yr = 5 ! { dg-error "All components of 'date' are PRIVATE" }
+ o_dt%yr = 5 ! { dg-error "is a PRIVATE component of" }
t = two(one = one(4), i = 5, r=4.4) ! { dg-error "has already been set" }
diff --git a/gcc/testsuite/gfortran.dg/interface_assignment_5.f90 b/gcc/testsuite/gfortran.dg/interface_assignment_5.f90
new file mode 100644
index 00000000000..8444dd0847e
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/interface_assignment_5.f90
@@ -0,0 +1,49 @@
+! { dg-do compile }
+!
+! PR 42677: [4.5 Regression] Bogus Error: Ambiguous interfaces '...' in intrinsic assignment operator
+!
+! Contributed by Harald Anlauf <anlauf@gmx.de>
+
+module mod1
+ implicit none
+ type t_m
+ integer :: i = 0
+ end type t_m
+!------------------------------------------------------------------------------
+ interface assignment (=)
+ module procedure assign_m
+ end interface
+!------------------------------------------------------------------------------
+contains
+ subroutine assign_m (y, x)
+ type(t_m) ,intent(inout) :: y
+ type(t_m) ,intent(in) :: x
+ end subroutine assign_m
+end module mod1
+!==============================================================================
+module mod2
+ use mod1, only: t_m, assignment(=)
+ implicit none
+ type t_atm
+ integer :: k
+ end type t_atm
+!------------------------------------------------------------------------------
+ interface assignment(=)
+ module procedure assign_to_atm
+ end interface
+!------------------------------------------------------------------------------
+ interface
+ pure subroutine delete_m (x)
+ use mod1
+ type(t_m) ,intent(in) :: x
+ end subroutine delete_m
+ end interface
+!------------------------------------------------------------------------------
+contains
+ subroutine assign_to_atm (atm, r)
+ type(t_atm) ,intent(inout) :: atm
+ integer ,intent(in) :: r
+ end subroutine assign_to_atm
+end module mod2
+
+! { dg-final { cleanup-modules "mod1 mod2" } }
diff --git a/gcc/testsuite/gfortran.dg/private_type_6.f90 b/gcc/testsuite/gfortran.dg/private_type_6.f90
index 5e13ed53477..4af3f704f98 100644
--- a/gcc/testsuite/gfortran.dg/private_type_6.f90
+++ b/gcc/testsuite/gfortran.dg/private_type_6.f90
@@ -18,7 +18,7 @@ program foo_test
implicit none
TYPE(footype) :: foo
TYPE(bartype) :: foo2
- foo = footype(1) ! { dg-error "All components of 'footype' are PRIVATE" }
+ foo = footype(1) ! { dg-error "is a PRIVATE component" }
foo2 = bartype(1,2) ! { dg-error "is a PRIVATE component" }
foo2%dummy2 = 5 ! { dg-error "is a PRIVATE component" }
end program foo_test
diff --git a/gcc/testsuite/gfortran.dg/proc_ptr_comp_pass_6.f90 b/gcc/testsuite/gfortran.dg/proc_ptr_comp_pass_6.f90
new file mode 100644
index 00000000000..8898a597d53
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/proc_ptr_comp_pass_6.f90
@@ -0,0 +1,35 @@
+! { dg-do compile }
+! { dg-options "-fcheck=bounds" }
+!
+! PR 42804: ICE with -fcheck=bounds and type bound procedure call on array element
+!
+! Contributed by Ian Harvey <ian_harvey@bigpond.com>
+
+MODULE ModA
+ IMPLICIT NONE
+ TYPE, PUBLIC :: A
+ PROCEDURE(a_proc),pointer :: Proc
+ END TYPE A
+CONTAINS
+ SUBROUTINE a_proc(this, stat)
+ CLASS(A), INTENT(INOUT) :: this
+ INTEGER, INTENT(OUT) :: stat
+ WRITE (*, *) 'a_proc'
+ stat = 0
+ END SUBROUTINE a_proc
+END MODULE ModA
+
+PROGRAM ProgA
+ USE ModA
+ IMPLICIT NONE
+ INTEGER :: ierr
+ INTEGER :: i
+ TYPE(A), ALLOCATABLE :: arr(:)
+ ALLOCATE(arr(2))
+ DO i = 1, 2
+ arr(i)%proc => a_proc
+ CALL arr(i)%Proc(ierr)
+ END DO
+END PROGRAM ProgA
+
+! { dg-final { cleanup-modules "ModA" } }
diff --git a/gcc/testsuite/gfortran.dg/structure_constructor_8.f03 b/gcc/testsuite/gfortran.dg/structure_constructor_8.f03
index 520b52853d5..b86d0ecccaf 100644
--- a/gcc/testsuite/gfortran.dg/structure_constructor_8.f03
+++ b/gcc/testsuite/gfortran.dg/structure_constructor_8.f03
@@ -51,7 +51,7 @@ PROGRAM test
struct1 = haspriv_t (b = 2, a = 1) ! { dg-error "is a PRIVATE component" }
! This should fail as all components are private
- struct2 = allpriv_t (5) ! { dg-error "of 'allpriv_t' are PRIVATE" }
+ struct2 = allpriv_t (5) ! { dg-error "is a PRIVATE component" }
! This should fail as the type itself is private, and the expression should
! be deduced as call to an undefined function.
diff --git a/gcc/testsuite/gfortran.dg/typebound_call_12.f03 b/gcc/testsuite/gfortran.dg/typebound_call_12.f03
new file mode 100644
index 00000000000..afb0fda71a4
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/typebound_call_12.f03
@@ -0,0 +1,36 @@
+! { dg-do compile }
+! { dg-options "-fcheck=bounds" }
+!
+! PR 42804: ICE with -fcheck=bounds and type bound procedure call on array element
+!
+! Contributed by Ian Harvey <ian_harvey@bigpond.com>
+
+MODULE ModA
+ IMPLICIT NONE
+ PRIVATE
+ TYPE, PUBLIC :: A
+ CONTAINS
+ PROCEDURE :: Proc => a_proc
+ END TYPE A
+CONTAINS
+ SUBROUTINE a_proc(this, stat)
+ CLASS(A), INTENT(INOUT) :: this
+ INTEGER, INTENT(OUT) :: stat
+ WRITE (*, *) 'a_proc'
+ stat = 0
+ END SUBROUTINE a_proc
+END MODULE ModA
+
+PROGRAM ProgA
+ USE ModA
+ IMPLICIT NONE
+ INTEGER :: ierr
+ INTEGER :: i
+ TYPE(A), ALLOCATABLE :: arr(:)
+ ALLOCATE(arr(2))
+ DO i = 1, 2
+ CALL arr(i)%Proc(ierr)
+ END DO
+END PROGRAM ProgA
+
+! { dg-final { cleanup-modules "ModA" } }
diff --git a/gcc/testsuite/gfortran.dg/vect/fast-math-mgrid-resid.f b/gcc/testsuite/gfortran.dg/vect/fast-math-mgrid-resid.f
new file mode 100644
index 00000000000..cf47204e04e
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/vect/fast-math-mgrid-resid.f
@@ -0,0 +1,45 @@
+! { dg-do compile { target i?86-*-* x86_64-*-* } }
+! { dg-require-effective-target vect_double }
+! { dg-options "-O3 -ffast-math -msse2 -fpredictive-commoning -ftree-vectorize -fdump-tree-optimized" }
+
+
+******* RESID COMPUTES THE RESIDUAL: R = V - AU
+*
+* THIS SIMPLE IMPLEMENTATION COSTS 27A + 4M PER RESULT, WHERE
+* A AND M DENOTE THE COSTS OF ADDITION (OR SUBTRACTION) AND
+* MULTIPLICATION, RESPECTIVELY. BY USING SEVERAL TWO-DIMENSIONAL
+* BUFFERS ONE CAN REDUCE THIS COST TO 13A + 4M IN THE GENERAL
+* CASE, OR 10A + 3M WHEN THE COEFFICIENT A(1) IS ZERO.
+*
+ SUBROUTINE RESID(U,V,R,N,A)
+ INTEGER N
+ REAL*8 U(N,N,N),V(N,N,N),R(N,N,N),A(0:3)
+ INTEGER I3, I2, I1
+C
+ DO 600 I3=2,N-1
+ DO 600 I2=2,N-1
+ DO 600 I1=2,N-1
+ 600 R(I1,I2,I3)=V(I1,I2,I3)
+ > -A(0)*( U(I1, I2, I3 ) )
+ > -A(1)*( U(I1-1,I2, I3 ) + U(I1+1,I2, I3 )
+ > + U(I1, I2-1,I3 ) + U(I1, I2+1,I3 )
+ > + U(I1, I2, I3-1) + U(I1, I2, I3+1) )
+ > -A(2)*( U(I1-1,I2-1,I3 ) + U(I1+1,I2-1,I3 )
+ > + U(I1-1,I2+1,I3 ) + U(I1+1,I2+1,I3 )
+ > + U(I1, I2-1,I3-1) + U(I1, I2+1,I3-1)
+ > + U(I1, I2-1,I3+1) + U(I1, I2+1,I3+1)
+ > + U(I1-1,I2, I3-1) + U(I1-1,I2, I3+1)
+ > + U(I1+1,I2, I3-1) + U(I1+1,I2, I3+1) )
+ > -A(3)*( U(I1-1,I2-1,I3-1) + U(I1+1,I2-1,I3-1)
+ > + U(I1-1,I2+1,I3-1) + U(I1+1,I2+1,I3-1)
+ > + U(I1-1,I2-1,I3+1) + U(I1+1,I2-1,I3+1)
+ > + U(I1-1,I2+1,I3+1) + U(I1+1,I2+1,I3+1) )
+C
+ RETURN
+ END
+! we want to check that predictive commoning did something on the
+! vectorized loop, which means we have to have exactly 13 vector
+! additions.
+! { dg-final { scan-tree-dump-times "vect_var\[^\\n\]*\\+ " 13 "optimized" } }
+! { dg-final { cleanup-tree-dump "vect" } }
+! { dg-final { cleanup-tree-dump "optimized" } }
generated by cgit v1.2.3 (git 2.25.1) at 2024-07-23 00:51:32 +0000