diff options
Diffstat (limited to 'gcc/testsuite')
| -rw-r--r-- | gcc/testsuite/ChangeLog | 8 | ||||
| -rw-r--r-- | gcc/testsuite/gfortran.dg/pdt_1.f03 | 62 | ||||
| -rw-r--r-- | gcc/testsuite/gfortran.dg/pdt_2.f03 | 27 | ||||
| -rw-r--r-- | gcc/testsuite/gfortran.dg/pdt_3.f03 | 79 | ||||
| -rw-r--r-- | gcc/testsuite/gfortran.dg/pdt_4.f03 | 90 | ||||
| -rw-r--r-- | gcc/testsuite/gfortran.dg/pdt_5.f03 | 223 |
6 files changed, 489 insertions, 0 deletions
diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 8eb288159e8..cdbb5557011 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,11 @@ +2017-09-09 Paul Thomas <pault@gcc.gnu.org> + + * gfortran.dg/pdt_1.f03 : New test. + * gfortran.dg/pdt_2.f03 : New test. + * gfortran.dg/pdt_3.f03 : New test. + * gfortran.dg/pdt_4.f03 : New test. + * gfortran.dg/pdt_5.f03 : New test. + 2017-09-08 Eric Botcazou <ebotcazou@adacore.com> * gcc.dg/pr81988.c: New test. diff --git a/gcc/testsuite/gfortran.dg/pdt_1.f03 b/gcc/testsuite/gfortran.dg/pdt_1.f03 new file mode 100644 index 00000000000..ac57633978b --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pdt_1.f03 @@ -0,0 +1,62 @@ +! { dg-do run } +! { dg-options "-fcheck=all" } +! +! Basic check of Parameterized Derived Types. +! +! -fcheck=all is used here to ensure that when the parameter +! 'b' of the dummy in 'foo' is assumed, there is no error. +! Likewise in 'bar' and 'foobar', when 'b' has the correct +! explicit value. +! + implicit none + integer, parameter :: ftype = kind(0.0e0) + integer :: pdt_len = 4 + integer :: i + type :: mytype (a,b) + integer, kind :: a = kind(0.0d0) + integer, LEN :: b + integer :: i + real(kind = a) :: d(b, b) + character (len = b*b) :: chr + end type + + type(mytype(b=4)) :: z(2) + type(mytype(ftype, pdt_len)) :: z2 + + z(1)%i = 1 + z(2)%i = 2 + z(1)%d = reshape ([(real(i), i = 1, 16)],[4,4]) + z(2)%d = 10*z(1)%d + z(1)%chr = "hello pdt" + z(2)%chr = "goodbye pdt" + + z2%d = z(1)%d * 10 - 1 + z2%chr = "scalar pdt" + + call foo (z) + call bar (z) + call foobar (z2) +contains + elemental subroutine foo (arg) + type(mytype(8,*)), intent(in) :: arg + if (arg%i .eq. 1) then + if (trim (arg%chr) .ne. "hello pdt") error stop + if (int (sum (arg%d)) .ne. 136) error stop + else if (arg%i .eq. 2 ) then + if (trim (arg%chr) .ne. "goodbye pdt") error stop + if (int (sum (arg%d)) .ne. 1360) error stop + else + error stop + end if + end subroutine + subroutine bar (arg) + type(mytype(b=4)) :: arg(:) + if (int (sum (arg(1)%d)) .ne. 136) call abort + if (trim (arg(2)%chr) .ne. "goodbye pdt") call abort + end subroutine + subroutine foobar (arg) + type(mytype(ftype, pdt_len)) :: arg + if (int (sum (arg%d)) .ne. 1344) call abort + if (trim (arg%chr) .ne. "scalar pdt") call abort + end subroutine +end diff --git a/gcc/testsuite/gfortran.dg/pdt_2.f03 b/gcc/testsuite/gfortran.dg/pdt_2.f03 new file mode 100644 index 00000000000..f34a9b7f258 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pdt_2.f03 @@ -0,0 +1,27 @@ +! { dg-do run } +! { dg-options "-fcheck=all" } +! { dg-shouldfail "value of the PDT LEN parameter" } +! +! Reduced version of pdt_1.f03 to check that an incorrect +! value for the parameter 'b' in the dummy is picked up. +! + implicit none + integer, parameter :: ftype = kind(0.0e0) + integer :: pdt_len = 4 + integer :: i + type :: mytype (a,b) + integer, kind :: a = kind(0.0d0) + integer, LEN :: b + integer :: i + real(kind = a) :: d(b, b) + character (len = b*b) :: chr + end type + + type(mytype(ftype, pdt_len)) :: z2 + call foobar (z2) +contains + subroutine foobar (arg) + type(mytype(ftype, 8)) :: arg + print *, arg%i + end subroutine +end diff --git a/gcc/testsuite/gfortran.dg/pdt_3.f03 b/gcc/testsuite/gfortran.dg/pdt_3.f03 new file mode 100644 index 00000000000..a097149aab7 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pdt_3.f03 @@ -0,0 +1,79 @@ +! { dg-do run } +! +! Check PDT type extension and simple OOP. +! +module vars + integer :: d_dim = 4 + integer :: mat_dim = 256 + integer, parameter :: ftype = kind(0.0d0) +end module + + use vars + implicit none + integer :: i + type :: mytype (a,b) + integer, kind :: a = kind(0.0e0) + integer, LEN :: b = 4 + integer :: i + real(kind = a) :: d(b, b) + end type + + type, extends(mytype) :: thytype(h) + integer, kind :: h + integer(kind = h) :: j + end type + + type x (q, r, s) + integer, kind :: q + integer, kind :: r + integer, LEN :: s + integer(kind = q) :: idx_mat(2,2) ! check these do not get treated as pdt_arrays. + type (mytype (b=s)) :: mat1 + type (mytype (b=s*2)) :: mat2 + end type x + + real, allocatable :: matrix (:,:) + type(thytype(ftype, 4, 4)) :: w + type(x(8,4,mat_dim)) :: q + class(mytype(ftype, :)), allocatable :: cz + + w%d = reshape ([(real(i), i = 1, d_dim*d_dim)],[d_dim,d_dim]) + +! Make sure that the type extension is ordering the parameters correctly. + if (w%a .ne. ftype) call abort + if (w%b .ne. 4) call abort + if (w%h .ne. 4) call abort + if (size (w%d) .ne. 16) call abort + if (int (w%d(2,4)) .ne. 14) call abort + if (kind (w%j) .ne. w%h) call abort + +! As a side issue, ensure PDT components are OK + if (q%mat1%b .ne. q%s) call abort + if (q%mat2%b .ne. q%s*2) call abort + if (size (q%mat1%d) .ne. mat_dim**2) call abort + if (size (q%mat2%d) .ne. 4*mat_dim**2) call abort + +! Now check some basic OOP with PDTs + matrix = w%d + +! TODO - for some reason, using w%d directly in the source causes a seg fault. + allocate (cz, source = mytype(ftype, d_dim, 0, matrix)) + select type (cz) + type is (mytype(ftype, *)) + if (int (sum (cz%d)) .ne. 136) call abort + type is (thytype(ftype, *, 8)) + call abort + end select + deallocate (cz) + + allocate (thytype(ftype, d_dim*2, 8) :: cz) + cz%d = reshape ([(i*10, i = 1, cz%b**2)], [cz%b,cz%b]) + select type (cz) + type is (mytype(ftype, *)) + call abort + type is (thytype(ftype, *, 8)) + if (int (sum (cz%d)) .ne. 20800) call abort + end select + + deallocate (cz) +end diff --git a/gcc/testsuite/gfortran.dg/pdt_4.f03 b/gcc/testsuite/gfortran.dg/pdt_4.f03 new file mode 100644 index 00000000000..ea4ece4b646 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pdt_4.f03 @@ -0,0 +1,90 @@ +! { dg-do compile } +! +! Test bad PDT coding: Based on pdt_3.f03 +! +module vars + integer :: d_dim = 4 + integer :: mat_dim = 256 + integer, parameter :: ftype = kind(0.0d0) +end module + + use vars + implicit none + integer :: i + integer, kind :: bad_kind ! { dg-error "not allowed outside a TYPE definition" } + integer, len :: bad_len ! { dg-error "not allowed outside a TYPE definition" } + + type :: bad_pdt (a,b, c, d) + real, kind :: a ! { dg-error "must be INTEGER" } + INTEGER(8), kind :: b ! { dg-error "be default integer kind" } + real, LEN :: c ! { dg-error "must be INTEGER" } + INTEGER(8), LEN :: d ! { dg-error "be default integer kind" } + end type + + type :: mytype (a,b) + integer, kind :: a = kind(0.0e0) + integer, LEN :: b = 4 + integer :: i + real(kind = a) :: d(b, b) + end type + + type, extends(mytype) :: thytype(h) + integer, kind :: h + integer(kind = h) :: j + end type + + type x (q, r, s) + integer, kind :: q + integer, kind :: r + integer, LEN :: s + integer(kind = q) :: idx_mat(2,2) + type (mytype (b=s)) :: mat1 + type (mytype (b=s*2)) :: mat2 + end type x + + real, allocatable :: matrix (:,:) + +! Bad KIND parameters + type(thytype(d_dim, 4, 4)) :: wbad ! { dg-error "does not reduce to a constant" } + type(thytype(*, 4, 4)) :: worse ! { dg-error "cannot either be ASSUMED or DEFERRED" } + type(thytype(:, 4, 4)) :: w_ugh ! { dg-error "cannot either be ASSUMED or DEFERRED" } + + type(thytype(ftype, b=4, h=4)) :: w + type(x(8,4,mat_dim)) :: q + class(mytype(ftype, :)), allocatable :: cz + + w%a = 1 ! { dg-error "assignment to a KIND or LEN component" } + w%b = 2 ! { dg-error "assignment to a KIND or LEN component" } + w%h = 3 ! { dg-error "assignment to a KIND or LEN component" } + + w%d = reshape ([(real(i), i = 1, d_dim*d_dim)],[d_dim,d_dim]) + + matrix = w%d + + allocate (cz, source = mytype(*, d_dim, 0, matrix)) ! { dg-error "Syntax error" } + allocate (cz, source = mytype(ftype, :, 0, matrix)) ! { dg-error "Syntax error" } + select type (cz) + type is (mytype(ftype, d_dim)) ! { dg-error "must be ASSUMED" } + if (int (sum (cz%d)) .ne. 136) call abort ! { dg-error "Expected TYPE IS" } + type is (thytype(ftype, *, 8)) + call abort + end select + deallocate (cz) + + allocate (thytype(ftype, d_dim*2, 8) :: cz) + cz%d = reshape ([(i*10, i = 1, cz%b**2)], [cz%b,cz%b]) + select type (cz) + type is (mytype(4, *)) ! { dg-error "must be an extension" } + call abort + type is (thytype(ftype, *, 8)) + if (int (sum (cz%d)) .ne. 20800) call abort + end select + deallocate (cz) +contains + subroutine foo(arg) ! { dg-error "has no IMPLICIT type" } + type (mytype(4, *)) :: arg ! { dg-error "is being used before it is defined" } + end subroutine + subroutine bar(arg) ! { dg-error "cannot have DEFERRED type parameters" } + type (thytype(8, :, 4) :: arg + end subroutine +end diff --git a/gcc/testsuite/gfortran.dg/pdt_5.f03 b/gcc/testsuite/gfortran.dg/pdt_5.f03 new file mode 100644 index 00000000000..f888c3bb1ec --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pdt_5.f03 @@ -0,0 +1,223 @@ +! { dg-do run } +! +! Third, complete example from the PGInsider article: +! "Object-Oriented Programming in Fortran 2003 Part 3: Parameterized Derived Types" +! by Mark Leair +! +! Copyright (c) 2013, NVIDIA CORPORATION. All rights reserved. +! +! NVIDIA CORPORATION and its licensors retain all intellectual property +! and proprietary rights in and to this software, related documentation +! and any modifications thereto. Any use, reproduction, disclosure or +! distribution of this software and related documentation without an express +! license agreement from NVIDIA CORPORATION is strictly prohibited. +! + +! THIS CODE AND INFORMATION ARE PROVIDED "AS IS" WITHOUT +! WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING BUT +! NOT LIMITED TO THE IMPLIED WARRANTIES OF MERCHANTABILITY AND/OR +! FITNESS FOR A PARTICULAR PURPOSE. +! +! Note that modification had to be made all of which are commented. +! +module matrix + +type :: base_matrix(k,c,r) + private + integer, kind :: k = 4 + integer, len :: c = 1 + integer, len :: r = 1 +end type base_matrix + +type, extends(base_matrix) :: adj_matrix + private + class(*), pointer :: m(:,:) => null() +end type adj_matrix + +interface getKind + module procedure getKind4 + module procedure getKind8 +end interface getKind + +interface getColumns + module procedure getNumCols4 + module procedure getNumCols8 +end interface getColumns + +interface getRows + module procedure getNumRows4 + module procedure getNumRows8 +end interface getRows + +interface adj_matrix + module procedure construct_4 ! kind=4 constructor + module procedure construct_8 ! kind=8 constructor +end interface adj_matrix + +interface assignment(=) + module procedure m2m4 ! assign kind=4 matrix + module procedure a2m4 ! assign kind=4 array + module procedure m2m8 ! assign kind=8 matrix + module procedure a2m8 ! assign kind=8 array + module procedure m2a4 ! assign kind=4 matrix to array + module procedure m2a8 ! assign kind=8 matrix to array +end interface assignment(=) + + +contains + + function getKind4(this) result(rslt) + class(adj_matrix(4,*,*)) :: this + integer :: rslt + rslt = this%k + end function getKind4 + + function getKind8(this) result(rslt) + class(adj_matrix(8,*,*)) :: this + integer :: rslt + rslt = this%k + end function getKind8 + + function getNumCols4(this) result(rslt) + class(adj_matrix(4,*,*)) :: this + integer :: rslt + rslt = this%c + end function getNumCols4 + + function getNumCols8(this) result(rslt) + class(adj_matrix(8,*,*)) :: this + integer :: rslt + rslt = this%c + end function getNumCols8 + + function getNumRows4(this) result(rslt) + class(adj_matrix(4,*,*)) :: this + integer :: rslt + rslt = this%r + end function getNumRows4 + + function getNumRows8(this) result(rslt) + class(adj_matrix(8,*,*)) :: this + integer :: rslt + rslt = this%r + end function getNumRows8 + + + function construct_4(k,c,r) result(mat) + integer(4) :: k + integer :: c + integer :: r + class(adj_matrix(4,:,:)),allocatable :: mat + + allocate(adj_matrix(4,c,r)::mat) + + end function construct_4 + + function construct_8(k,c,r) result(mat) + integer(8) :: k + integer :: c + integer :: r + class(adj_matrix(8,:,:)),allocatable :: mat + + allocate(adj_matrix(8,c,r)::mat) + + end function construct_8 + + subroutine a2m4(d,s) + class(adj_matrix(4,:,:)),allocatable :: d + class(*),dimension(:,:) :: s + + if (allocated(d)) deallocate(d) +! allocate(adj_matrix(4,size(s,1),size(s,2))::d) ! generates assembler error + allocate(d, mold = adj_matrix(4,size(s,1),size(s,2))) + allocate(d%m(size(s,1),size(s,2)),source=s) + end subroutine a2m4 + + subroutine a2m8(d,s) + class(adj_matrix(8,:,:)),allocatable :: d + class(*),dimension(:,:) :: s + + if (allocated(d)) deallocate(d) +! allocate(adj_matrix(8,size(s,1),size(s,2))::d) ! generates assembler error + allocate(d, mold = adj_matrix(8_8,size(s,1),size(s,2))) ! Needs 8_8 to match arg1 of 'construct_8' + allocate(d%m(size(s,1),size(s,2)),source=s) + end subroutine a2m8 + +subroutine m2a8(a,this) +class(adj_matrix(8,*,*)), intent(in) :: this ! Intents required for +real(8),allocatable, intent(out) :: a(:,:) ! defined assignment + select type (array => this%m) ! Added SELECT TYPE because... + type is (real(8)) + if (allocated(a)) deallocate(a) + allocate(a,source=array) + end select +! allocate(a(size(this%m,1),size(this%m,2)),source=this%m) ! ...CLASS(*) source does not work in gfortran + end subroutine m2a8 + + subroutine m2a4(a,this) + class(adj_matrix(4,*,*)), intent(in) :: this ! Intents required for + real(4),allocatable, intent(out) :: a(:,:) ! defined assignment + select type (array => this%m) ! Added SELECT TYPE because... + type is (real(4)) + if (allocated(a)) deallocate(a) + allocate(a,source=array) + end select +! allocate(a(size(this%m,1),size(this%m,2)),source=this%m) ! ...CLASS(*) source does not work in gfortran + end subroutine m2a4 + + subroutine m2m4(d,s) + CLASS(adj_matrix(4,:,:)),allocatable, intent(OUT) :: d ! Intents required for + CLASS(adj_matrix(4,*,*)), intent(in) :: s ! defined assignment + + if (allocated(d)) deallocate(d) + allocate(d,source=s) + end subroutine m2m4 + + subroutine m2m8(d,s) + CLASS(adj_matrix(8,:,:)),allocatable, intent(OUT) :: d ! Intents required for + CLASS(adj_matrix(8,*,*)), intent(in) :: s ! defined assignment + + if (allocated(d)) deallocate(d) + allocate(d,source=s) + end subroutine m2m8 + + +end module matrix + + +program adj3 + + use matrix + implicit none + integer(8) :: i + + class(adj_matrix(8,:,:)),allocatable :: adj ! Was TYPE: Fails in + real(8) :: a(2,3) ! defined assignment + real(8),allocatable :: b(:,:) + + class(adj_matrix(4,:,:)),allocatable :: adj_4 ! Ditto and .... + real(4) :: a_4(3,2) ! ... these declarations were + real(4),allocatable :: b_4(:,:) ! added to check KIND=4 + +! Check constructor of PDT and instrinsic assignment + adj = adj_matrix(INT(8,8),2,4) + if (adj%k .ne. 8) call abort + if (adj%c .ne. 2) call abort + if (adj%r .ne. 4) call abort + a = reshape ([(i, i = 1, 6)], [2,3]) + adj = a + b = adj + if (any (b .ne. a)) call abort + +! Check allocation with MOLD of PDT. Note that only KIND parameters set. + allocate (adj_4, mold = adj_matrix(4,3,2)) ! Added check of KIND = 4 + if (adj_4%k .ne. 4) call abort + a_4 = reshape (a, [3,2]) + adj_4 = a_4 + b_4 = adj_4 + if (any (b_4 .ne. a_4)) call abort + +end program adj3 + + + |