From: Paul Thomas Date: Thu, 30 Apr 2020 08:56:01 +0000 (+0100) Subject: PR94725 - deleting gfortran.dg/dtio_5.f90 and pdt_5.f03 X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=31e6f8293362979aea53b5cae3fa6ab0b6981694;p=gcc.git PR94725 - deleting gfortran.dg/dtio_5.f90 and pdt_5.f03 --- diff --git a/gcc/testsuite/gfortran.dg/dtio_5.f90 b/gcc/testsuite/gfortran.dg/dtio_5.f90 deleted file mode 100644 index f761b259486..00000000000 --- a/gcc/testsuite/gfortran.dg/dtio_5.f90 +++ /dev/null @@ -1,280 +0,0 @@ -! { dg-do run } -! -! This test is based on the second case in the PGInsider article at -! https://www.pgroup.com/lit/articles/insider/v6n2a3.htm -! -! The complete original code is at: -! https://www.pgroup.com/lit/samples/pginsider/stack.f90 -! -! Thanks to Mark LeAir. -! -! Copyright (c) 2015, 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. -! - -module stack_mod - - type, abstract :: stack - private - class(*), allocatable :: item ! an item on the stack - class(stack), pointer :: next=>null() ! next item on the stack - contains - procedure :: empty ! returns true if stack is empty - procedure :: delete ! empties the stack - end type stack - -type, extends(stack) :: integer_stack -contains - procedure :: push => push_integer ! add integer item to stack - procedure :: pop => pop_integer ! remove integer item from stack - procedure :: compare => compare_integer ! compare with an integer array -end type integer_stack - -type, extends(integer_stack) :: io_stack -contains - procedure,private :: wio_stack - procedure,private :: rio_stack - procedure,private :: dump_stack - generic :: write(unformatted) => wio_stack ! write stack item to file - generic :: read(unformatted) => rio_stack ! push item from file - generic :: write(formatted) => dump_stack ! print all items from stack -end type io_stack - -contains - - subroutine rio_stack (dtv, unit, iostat, iomsg) - - ! read item from file and add it to stack - - class(io_stack), intent(inout) :: dtv - integer, intent(in) :: unit - integer, intent(out) :: iostat - character(len=*), intent(inout) :: iomsg - - integer :: item - - read(unit,IOSTAT=iostat,IOMSG=iomsg) item - - if (iostat .ne. 0) then - call dtv%push(item) - endif - - end subroutine rio_stack - - subroutine wio_stack(dtv, unit, iostat, iomsg) - - ! pop an item from stack and write it to file - - class(io_stack), intent(in) :: dtv - integer, intent(in) :: unit - integer, intent(out) :: iostat - character(len=*), intent(inout) :: iomsg - integer :: item - - item = dtv%pop() - write(unit,IOSTAT=iostat,IOMSG=iomsg) item - - end subroutine wio_stack - - subroutine dump_stack(dtv, unit, iotype, v_list, iostat, iomsg) - - ! Pop all items off stack and write them out to unit - ! Assumes default LISTDIRECTED output - - class(io_stack), intent(in) :: dtv - integer, intent(in) :: unit - character(len=*), intent(in) :: iotype - integer, intent(in) :: v_list(:) - integer, intent(out) :: iostat - character(len=*), intent(inout) :: iomsg - character(len=80) :: buffer - integer :: item - - if (iotype .ne. 'LISTDIRECTED') then - ! Error - iomsg = 'dump_stack: unsupported iotype' - iostat = 1 - else - iostat = 0 - do while( (.not. dtv%empty()) .and. (iostat .eq. 0) ) - item = dtv%pop() - write(unit, '(I6/)',IOSTAT=iostat,IOMSG=iomsg) item - enddo - endif - end subroutine dump_stack - - logical function empty(this) - class(stack) :: this - if (.not.associated(this%next)) then - empty = .true. - else - empty = .false. - end if - end function empty - - subroutine push_integer(this,item) - class(integer_stack) :: this - integer :: item - type(integer_stack), allocatable :: new_item - - allocate(new_item) - allocate(new_item%item, source=item) - new_item%next => this%next - allocate(this%next, source=new_item) - end subroutine push_integer - - function pop_integer(this) result(item) - class(integer_stack) :: this - class(stack), pointer :: dealloc_item - integer item - - if (this%empty()) then - stop 'Error! pop_integer invoked on empty stack' - endif - select type(top=>this%next) - type is (integer_stack) - select type(i => top%item) - type is(integer) - item = i - class default - stop 'Error #1! pop_integer encountered non-integer stack item' - end select - dealloc_item => this%next - this%next => top%next - deallocate(dealloc_item) - class default - stop 'Error #2! pop_integer encountered non-integer_stack item' - end select - end function pop_integer - -! gfortran addition to check read/write - logical function compare_integer (this, array, error) - class(integer_stack), target :: this - class(stack), pointer :: ptr, next - integer :: array(:), i, j, error - compare_integer = .true. - ptr => this - do j = 0, size (array, 1) - if (compare_integer .eqv. .false.) return - select type (ptr) - type is (integer_stack) - select type(k => ptr%item) - type is(integer) - if (k .ne. array(j)) error = 1 - class default - error = 2 - compare_integer = .false. - end select - class default - if (j .ne. 0) then - error = 3 - compare_integer = .false. - end if - end select - next => ptr%next - if (associated (next)) then - ptr => next - else if (j .ne. size (array, 1)) then - error = 4 - compare_integer = .false. - end if - end do - end function - - subroutine delete (this) - class(stack), target :: this - class(stack), pointer :: ptr1, ptr2 - ptr1 => this%next - ptr2 => ptr1%next - do while (associated (ptr1)) - deallocate (ptr1) - ptr1 => ptr2 - if (associated (ptr1)) ptr2 => ptr1%next - end do - end subroutine - -end module stack_mod - -program stack_demo - - use stack_mod - implicit none - - integer i, k(10), error - class(io_stack), allocatable :: stk - allocate(stk) - - k = [3,1,7,0,2,9,4,8,5,6] - - ! step 1: set up an 'output' file > changed to 'scratch' - - open(10, status='scratch', form='unformatted') - - ! step 2: add values to stack - - do i=1,10 -! write(*,*) 'Adding ',i,' to the stack' - call stk%push(k(i)) - enddo - - ! step 3: pop values from stack and write them to file - -! write(*,*) -! write(*,*) 'Removing each item from stack and writing it to file.' -! write(*,*) - do while(.not.stk%empty()) - write(10) stk - enddo - - ! step 4: close file and reopen it for read > changed to rewind. - - rewind(10) - - ! step 5: read values back into stack -! write(*,*) 'Reading each value from file and adding it to stack:' - do while(.true.) - read(10,END=9999) i -! write(*,*), 'Reading ',i,' from file. Adding it to stack' - call stk%push(i) - enddo - -9999 continue - - ! step 6: Dump stack to standard out - -! write(*,*) -! write(*,*), 'Removing every element from stack and writing it to screen:' -! write(*,*) stk - -! gfortran addition to check read/write - if (.not. stk%compare (k, error)) then - select case (error) - case(1) - print *, "values do not match" - case(2) - print *, "non integer found in stack" - case(3) - print *, "type mismatch in stack" - case(4) - print *, "too few values in stack" - end select - STOP 1 - end if - - close(10) - -! Clean up - valgrind indicates no leaks. - call stk%delete - deallocate (stk) -end program stack_demo diff --git a/gcc/testsuite/gfortran.dg/pdt_5.f03 b/gcc/testsuite/gfortran.dg/pdt_5.f03 deleted file mode 100644 index 2472603db41..00000000000 --- a/gcc/testsuite/gfortran.dg/pdt_5.f03 +++ /dev/null @@ -1,223 +0,0 @@ -! { 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) STOP 1 - if (adj%c .ne. 2) STOP 2 - if (adj%r .ne. 4) STOP 3 - a = reshape ([(i, i = 1, 6)], [2,3]) - adj = a - b = adj - if (any (b .ne. a)) STOP 4 - -! 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) STOP 5 - a_4 = reshape (a, [3,2]) - adj_4 = a_4 - b_4 = adj_4 - if (any (b_4 .ne. a_4)) STOP 6 - -end program adj3 - - -