1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
|
! { dg-do run }
! The compiler_options() function is dependent on the
! command line options and thus incompatible with -fcompare-debug.
! { dg-skip-if "-fcompare-debug incompatible test" { *-*-* } { "-fcompare-debug" } { "" } } */
!
! Test the fix for PR92785, where the array passed to 'write scalar' was not
! normalised to LBOUND = 1.
!
! Contributed by <urbanjost@comcast.net>
!
program tst
use iso_fortran_env, only : compiler_version, compiler_options
implicit none
integer :: i
integer :: ibad=0
integer :: iarr(10) = [(i*10, i = 1,size (iarr))]
character(len=:), allocatable :: line
character(len=*), parameter :: expected = '10 20 30 40 50 60 70 80 90 100'
character(len=*), parameter :: expected_minus = '-10 -20 -30 -40 -50 -60 -70 -80 -90 -100'
print '(4a)', &
'This file was compiled by ', compiler_version(), &
' using the options ', compiler_options()
call write_row ('iarr ', iarr) ! pass in the array, OK
call write_row ('iarr+0 ', iarr+0) ! pass in an expression, NOT OK
call write_row ('-iarr ', -iarr) ! pass in an expression, NOT OK
call write_row ('iarr(::1) ', iarr(::1)) ! pass in the array, OK
call write_row ('[iarr(::1)] ', [iarr(::1)]) ! pass in compound constructor, NOT OK
call write_row ('[(i*10,i=1,size(iarr))]', [(i*10,i=1,size(iarr))]) ! pass in constructor, OK
call write_row ('10*[(i,i=1,size(iarr))]', 10*[(i,i=1,size(iarr))]) ! pass in constructor, OK
if (ibad .gt. 0) stop 1
contains
subroutine write_scalar (g1)
class(*) :: g1
character(len = 20) :: word
select type(g1)
type is (integer)
write (word, '(i0)') g1
line = line // trim( word) // ' '
end select
end subroutine write_scalar
subroutine write_row (string,array)
character(len = *) :: string
class(*) :: array(:)
integer :: i
line = ''
do i = 1, size (array)
call write_scalar (array(i))
enddo
if (expected .eq. line) then
write (*, *) string, ':GOOD'
else if (expected_minus .eq. line) then
write (*, *) string, ':GOOD'
else
write (*, *) string, ':BAD. EXPECTED [', expected, '] got [', trim (line),']'
ibad = ibad + 1
endif
end subroutine write_row
end program tst
|
