"Steve Lionel" <steve....@intel.invalid> wrote in message
news:aap9q5...@mid.individual.net...
> James,
> Thanks for this test. Indeed, ifort does not seem to make the right
> choice in all these cases. We'll investigate.
You're welcome. Unfortunately, the test was limited to what that
old version of ifort could handle, which meant excluding newer
intrinsics and no initialization expressions. I have written up
a test which is a little more comprehensive:
C:\gfortran\clf\logtest>type exit_test.f90
program exit_test
stop 7
end program exit_test
C:\gfortran\clf\logtest>gfortran exit_test.f90 -oexit_test
C:\gfortran\clf\logtest>type logtest3.f90
!DEC$ IF(.FALSE.)
module ifwin
use ISO_C_BINDING
implicit none
integer, parameter, public :: BOOL = C_INT
public SetEnvironmentVariable
interface
function SetEnvironmentVariable(lpName, lpValue) &
bind(C,name='SetEnvironmentVariableA')
import
implicit none
!gcc$ attributes stdcall :: SetEnvironmentVariable
integer(BOOL) SetEnvironmentVariable
character(kind=C_CHAR) lpName(*)
character(kind=C_CHAR) lpValue(*)
end function SetEnvironmentVariable
end interface
end module ifwin
!DEC$ ENDIF
program logtest3
implicit none
! ********************************************************!
! ******* Everything depends on this parameter ***********!
integer, parameter :: A1 = 2
! ********************************************************!
integer A
logical, parameter :: L1 = transfer(A1,.FALSE.)
logical L
character(*), parameter :: strings(2) = ['.TRUE. ','.FALSE.']
integer, parameter :: I_TRANSFER = transfer(L1,0)
logical, parameter :: L_ALL = all([L1])
logical, parameter :: L_ANY = any([L1])
integer, parameter :: I_COUNT = count([L1])
logical, parameter :: L_DOT_PRODUCT = dot_product([L1],[L1])
! integer, parameter :: I_FINDLOC_MASK(1) = findloc([1,1],1, &
! mask=[L1,.TRUE.])
! integer, parameter :: I_FINDLOC_BACK(1) = findloc([1,1],1, &
! back=x)
integer, parameter :: I_IALL = iall([1],mask=[L1])
integer, parameter :: I_IANY = iany([1],mask=[L1])
integer, parameter :: I_INDEX = index('AA','A',back=L1)
integer, parameter :: I_IPARITY = iparity([1],mask=[L1])
logical(selected_int_kind(2)), parameter :: L_LOGICAL = &
logical(L1,kind(L_LOGICAL))
logical, parameter, dimension(1,1) :: b = &
reshape([L1],shape(b))
logical, parameter :: L_MATMUL(1,1) = matmul(b,b)
! integer, parameter :: I_MAXLOC_MASK(1) = &
! maxloc([2,1],mask=[L1,.TRUE.])
! integer, parameter :: I_MAXLOC_BACK(1) = &
! maxloc([1,1],back=L1)
! integer, parameter :: I_MAXVAL = &
! maxval([2,1],mask=[L1,.TRUE.])
integer, parameter :: I_MERGE = merge(1,2,L1)
! integer, parameter :: I_MINLOC_MASK(1) = &
! minloc([2,1],mask=[L1,.TRUE.])
! integer, parameter :: I_MINLOC_BACK(1) = &
! minloc([1,1],back=L1)
! integer, parameter :: I_MINVAL = &
! minval([2,1],mask=[L1,.TRUE.])
integer, parameter :: I_PACK(1) = pack([1],[L1],[2])
logical, parameter :: L_PARITY = parity([L1])
integer, parameter :: I_PRODUCT = product([2],[L1])
integer, parameter :: I_SCAN = scan('AA','A',back=L1)
integer, parameter :: I_SUM = sum([1],[L1])
integer, parameter :: I_UNPACK(1) = unpack([1],[L1],[2])
integer, parameter :: I_VERIFY = verify('AA','b',back=L1)
logical, parameter :: L_TOTAL = L_ALL .NEQV. L_ANY &
.NEQV. L_DOT_PRODUCT .NEQV. L_LOGICAL .NEQV. &
L_MATMUL(1,1) .NEQV. L_PARITY
integer, parameter :: I_TOTAL = I_COUNT+I_IALL+I_IANY &
+I_INDEX+I_IPARITY+I_PACK(1)+I_PRODUCT+I_SCAN+I_SUM &
! +I_FINDLOC_MASK(1)+I_FINDLOC_BACK(1)+I_MAXLOC_MASK(1) &
! +I_MAXLOC_BACK(1)+I_MAXVAL+I_MINLOC_MASK(1) &
! +I_MINLOC_BACK(1)+I_MINVAL
+I_UNPACK(1)+I_VERIFY
integer, parameter :: I_CHECK = min(I_TOTAL,0)+ &
merge(kind(1.0),kind(1.0d0),L_TOTAL)
real(I_CHECK) x_check
x_check = 1
write(*,'(a)') 'Testing constant expressions'
write(*,'(a,i0)') 'Value by TRANSFER: ', I_TRANSFER
if(L_ALL) then
write(*,'(a)') 'Value by ALL: .TRUE.'
else
write(*,'(a)') 'Value by ALL: .FALSE.'
end if
if(L_ANY) then
write(*,'(a)') 'Value by ANY: .TRUE.'
else
write(*,'(a)') 'Value by ANY: .FALSE.'
end if
if(I_COUNT == 1) then
write(*,'(a)') 'Value by COUNT: .TRUE.'
else
write(*,'(a)') 'Value by COUNT: .FALSE.'
end if
if(L_DOT_PRODUCT) then
write(*,'(a)') 'Value by DOT_PRODUCT: .TRUE.'
else
write(*,'(a)') 'Value by DOT_PRODUCT: .FALSE.'
end if
! write(*,'(a)') 'Value by FINDLOC(MASK): '// &
! trim(strings(I_FINDLOC_MASK(1)))
! write(*,'(a)') 'Value by FINDLOC(BACK): '// &
! trim(strings(3-I_FINDLOC_BACK(1)))
if(I_IALL == 1) then
write(*,'(a)') 'Value by IALL: .TRUE.'
else
write(*,'(a)') 'Value by IALL: .FALSE.'
end if
if(I_IANY == 1) then
write(*,'(a)') 'Value by IANY: .TRUE.'
else
write(*,'(a)') 'Value by IANY: .FALSE.'
end if
write(*,'(a)') 'Value by INDEX: '// &
trim(strings(3-I_INDEX))
if(I_IPARITY == 1) then
write(*,'(a)') 'Value by IPARITY: .TRUE.'
else
write(*,'(a)') 'Value by IPARITY: .FALSE.'
end if
if(L_LOGICAL) then
write(*,'(a)') 'Value by LOGICAL: .TRUE.'
else
write(*,'(a)') 'Value by LOGICAL: .FALSE.'
end if
if(L_MATMUL(1,1)) then
write(*,'(a)') 'Value by MATMUL: .TRUE.'
else
write(*,'(a)') 'Value by MATMUL: .FALSE.'
end if
! write(*,'(a)') 'Value by MAXLOC(MASK): '// &
! trim(strings(I_MAXLOC_MASK(1)))
! write(*,'(a)') 'Value by MAXLOC(BACK): '// &
! trim(strings(3-I_MAXLOC_BACK(1)))
! write(*,'(a)') 'Value by MAXVAL: '//trim(strings(3-I_MAXVAL))
write(*,'(a)') 'Value by MERGE: '//trim(strings(I_MERGE))
! write(*,'(a)') 'Value by MINLOC(MASK): '// &
! trim(strings(I_MINLOC_MASK(1)))
! write(*,'(a)') 'Value by MINLOC(BACK): '// &
! trim(strings(3-I_MINLOC_BACK(1)))
! write(*,'(a)') 'Value by MINVAL: '//trim(strings(3-I_MINVAL))
write(*,'(a)') 'Value by PACK: '//trim(strings(I_PACK(1)))
if(L_PARITY) then
write(*,'(a)') 'Value by PARITY: .TRUE.'
else
write(*,'(a)') 'Value by PARITY: .FALSE.'
end if
write(*,'(a)') 'Value by PRODUCT: '// &
trim(strings(3-I_PRODUCT))
write(*,'(a)') 'Value by SCAN: '// &
trim(strings(3-I_SCAN))
write(*,'(a)') 'Value by SUM: '//trim(strings(2-I_SUM))
write(*,'(a)') 'Value by UNPACK: '// &
trim(strings(I_UNPACK(1)))
write(*,'(a)') 'Value by VERIFY: '// &
trim(strings(3-I_VERIFY))
A = A1
L = transfer(A,L)
call sub(L)
end program logtest3
subroutine sub(x)
use ifwin
implicit none
logical x
character c
integer a(1)
character(*), parameter :: strings(2) = ['.TRUE. ','.FALSE.']
integer i
logical b(1,1)
integer m
integer exitstat
character(7) var
integer(BOOL) res
write(*,'(/a)') 'Testing ordinary expressions'
write(*,'(a,i0)') 'Value by TRANSFER: ', transfer(x,0)
exitstat = 999
call execute_command_line(COMMAND = 'exit_test', &
WAIT = x, EXITSTAT = exitstat)
select case(exitstat)
case(999)
write(*,'(a)') 'Value by EXECUTE_COMMAND_LINE: .FALSE.'
case(7)
write(*,'(a)') 'Value by EXECUTE_COMMAND_LINE: .TRUE.'
case default
write(*,'(a)') 'EXECUTE_COMMAND_LINE test failed'
end select
! a = findloc([1,1],1,mask=[x,.TRUE.])
! write(*,'(a)') 'Value by FINDLOC(MASK): '// &
! trim(strings(a(1)))
! a = findloc([1,1],back=x)
! write(*,'(a)') 'Value by FINDLOC(BACK): '// &
! trim(strings(3-a(1)))
res = SetEnvironmentVariable('PhiX174 '//achar(0), &
'.FALSE.'//achar(0))
res = SetEnvironmentVariable('PhiX174'//achar(0), &
'.TRUE.'//achar(0))
call get_environment_variable('PhiX174 ', &
value=var,status=m,trim_name=x)
if(m == 0) then
write(*,'(a)') 'Value by GET_ENVIRONMENT_'// &
'VARIABLE: '//trim(var)
else
write(*,'(a)') 'GET_ENVIRONMENT_VARIABLE test failed'
end if
if(iall([1],mask=[x]) == 1) then
write(*,'(a)') 'Value by IALL: .TRUE.'
else
write(*,'(a)') 'Value by IALL: .FALSE.'
end if
if(iany([1],mask=[x]) == 1) then
write(*,'(a)') 'Value by IANY: .TRUE.'
else
write(*,'(a)') 'Value by IANY: .FALSE.'
end if
write(*,'(a)') 'Value by INDEX: '// &
trim(strings(3-index('AA','A',back=x)))
if(iparity([1],mask=[x]) == 1) then
write(*,'(a)') 'Value by IPARITY: .TRUE.'
else
write(*,'(a)') 'Value by IPARITY: .FALSE.'
end if
if(logical(x,selected_int_kind(2))) then
write(*,'(a)') 'Value by LOGICAL: .TRUE.'
else
write(*,'(a)') 'Value by LOGICAL: .FALSE.'
end if
b = reshape([x],shape(b))
b = matmul(b,b)
if(b(1,1)) then
write(*,'(a)') 'Value by MATMUL: .TRUE.'
else
write(*,'(a)') 'Value by MATMUL: .FALSE.'
end if
a = maxloc([2,1],mask=[x,.TRUE.])
write(*,'(a)') 'Value by MAXLOC(MASK): '// &
trim(strings(a(1)))
! a = maxloc([1,1],back=x)
! write(*,'(a)') 'Value by MAXLOC(BACK): '// &
! trim(strings(3-a(1)))
m = maxval([2,1],mask=[x,.TRUE.])
write(*,'(a)') 'Value by MAXVAL: '//trim(strings(3-m))
write(*,'(a)') 'Value by MERGE: '// &
trim(merge('.TRUE. ','.FALSE.',x))
a = minloc([1,2],mask=[x,.TRUE.])
write(*,'(a)') 'Value by MINLOC(MASK): '// &
trim(strings(a(1)))
! a = minloc([1,1],back=x)
! write(*,'(a)') 'Value by MINLOC(BACK): '// &
! trim(strings(3-a(1)))
m = minval([1,2],mask=[x,.TRUE.])
write(*,'(a)') 'Value by MINVAL: '//trim(strings(m))
a = pack([1],[x],[2])
write(*,'(a)') 'Value by PACK: '//trim(strings(a(1)))
if(parity([x])) then
write(*,'(a)') 'Value by PARITY: .TRUE.'
else
write(*,'(a)') 'Value by PARITY: .FALSE.'
end if
m = product([2],[x])
write(*,'(a)') 'Value by PRODUCT: '//trim(strings(3-m))
write(*,'(a)') 'Value by SCAN: '// &
trim(strings(3-scan('AA','A',back=x)))
m = sum([1],[x])
write(*,'(a)') 'Value by SUM: '//trim(strings(2-m))
a = unpack([1],[x],[2])
write(*,'(a)') 'Value by UNPACK: '// &
trim(strings(a(1)))
write(*,'(a)') 'Value by VERIFY: '// &
trim(strings(3-verify('AA','b',back=x)))
end subroutine sub
C:\gfortran\clf\logtest>gfortran logtest3.f90 -ologtest3
logtest3.f90:47.15:
reshape([L1],shape(b))
1
Warning: Assigning value other than 0 or 1 to LOGICAL has undefined result
at (1
)
logtest3.f90:28.29:
logical, parameter :: L1 = transfer(A1,.FALSE.)
1
Warning: Assigning value other than 0 or 1 to LOGICAL has undefined result
at (1
)
Now, it's not the purpose of this post to discuss whether or
not gfortran documents the internal representations denied
above, so we change to:
integer, parameter :: A1 = 0
and recompile to get:
C:\gfortran\clf\logtest>gfortran logtest3.f90 -ologtest3
C:\gfortran\clf\logtest>logtest3
Testing constant expressions
Value by TRANSFER: 0
Value by ALL: .FALSE.
Value by ANY: .FALSE.
Value by COUNT: .FALSE.
Value by DOT_PRODUCT: .FALSE.
Value by IALL: .FALSE.
Value by IANY: .FALSE.
Value by INDEX: .FALSE.
Value by IPARITY: .FALSE.
Value by LOGICAL: .FALSE.
Value by MATMUL: .FALSE.
Value by MERGE: .FALSE.
Value by PACK: .FALSE.
Value by PARITY: .FALSE.
Value by PRODUCT: .FALSE.
Value by SCAN: .FALSE.
Value by SUM: .FALSE.
Value by UNPACK: .FALSE.
Value by VERIFY: .FALSE.
Testing ordinary expressions
Value by TRANSFER: 0
Value by WRITE: .FALSE.
Value by SELECT CASE: .FALSE.
Value by IF: .FALSE.
Value by WHERE: .FALSE.
Value by FORALL: .FALSE.
Value by ALL: .FALSE.
Value by ANY: .FALSE.
Value by COUNT: .FALSE.
Value by DOT_PRODUCT: .FALSE.
STOP 7
Value by EXECUTE_COMMAND_LINE: .TRUE.
GET_ENVIRONMENT_VARIABLE test failed
Value by IALL: .FALSE.
Value by IANY: .FALSE.
Value by INDEX: .FALSE.
Value by IPARITY: .FALSE.
Value by LOGICAL: .FALSE.
Value by MATMUL: .FALSE.
Value by MAXLOC(MASK): .FALSE.
Value by MAXVAL: .FALSE.
Value by MERGE: .FALSE.
Value by MINLOC(MASK): .FALSE.
Value by MINVAL: .FALSE.
Value by PACK: .FALSE.
Value by PARITY: .FALSE.
Value by PRODUCT: .FALSE.
Value by SCAN: .FALSE.
Value by SUM: .FALSE.
Value by UNPACK: .FALSE.
Value by VERIFY: .FALSE.
So that's all OK, except gfortran hasn't yet implemented WAIT=.FALSE.
yet for EXECUTE_COMMAND_LINE on Windows and also gfortran seems to
be saving the state of the environmental variables at program start
and not taking into account the dynamic state of the environmental
variables as it changes during program execution.
Then we change to the other value that gfortran approves of:
integer, parameter :: A1 = 1
Recompile and rerun:
C:\gfortran\clf\logtest>gfortran logtest3.f90 -ologtest3
C:\gfortran\clf\logtest>logtest3
Testing constant expressions
Value by TRANSFER: 1
Value by ALL: .TRUE.
Value by ANY: .TRUE.
Value by COUNT: .TRUE.
Value by DOT_PRODUCT: .TRUE.
Value by IALL: .TRUE.
Value by IANY: .TRUE.
Value by INDEX: .TRUE.
Value by IPARITY: .TRUE.
Value by LOGICAL: .TRUE.
Value by MATMUL: .TRUE.
Value by MERGE: .TRUE.
Value by PACK: .TRUE.
Value by PARITY: .TRUE.
Value by PRODUCT: .TRUE.
Value by SCAN: .TRUE.
Value by SUM: .TRUE.
Value by UNPACK: .TRUE.
Value by VERIFY: .TRUE.
Testing ordinary expressions
Value by TRANSFER: 1
Value by WRITE: .TRUE.
Value by SELECT CASE: .TRUE.
Value by IF: .TRUE.
Value by WHERE: .TRUE.
Value by FORALL: .TRUE.
Value by ALL: .TRUE.
Value by ANY: .TRUE.
Value by COUNT: .TRUE.
Value by DOT_PRODUCT: .TRUE.
STOP 7
Value by EXECUTE_COMMAND_LINE: .TRUE.
GET_ENVIRONMENT_VARIABLE test failed
Value by IALL: .TRUE.
Value by IANY: .TRUE.
Value by INDEX: .TRUE.
Value by IPARITY: .TRUE.
Value by LOGICAL: .TRUE.
Value by MATMUL: .TRUE.
Value by MAXLOC(MASK): .TRUE.
Value by MAXVAL: .TRUE.
Value by MERGE: .TRUE.
Value by MINLOC(MASK): .TRUE.
Value by MINVAL: .TRUE.
Value by PACK: .TRUE.
Value by PARITY: .TRUE.
Value by PRODUCT: .TRUE.
Value by SCAN: .FALSE.
Value by SUM: .TRUE.
Value by UNPACK: .TRUE.
Value by VERIFY: .FALSE.
And we can see that gfortran fails for SCAN and VERIFY for ordinary
expressions. The reason for this is that gfortran uses its
constant expression mechanism whenever it can so you have to take
extra precautions (here making the BACK= argument to the intrinsics
a dummy argument in subroutine sub) to discourage gfortran from
doing so, permitting us to test behaviour with ordinary expressions
when gfortran's test suite missed it.
As can be seen from the commented out code, gfortran does not yet
implement the BACK= argument for the MAXLOC and MINLOC intrinsics,
doesn't yet implement MAXLOC, MAXVAL, MINLOC, MINVAL for constant
expressions and doesn't implement FINDLOC at all.
Well, as I like to say, there are some tricky points regarding the
seemingly simple LOGICAL type in Fortran and hopefully my tests
will help persuade the reader that maybe there is some validity to
my assertion.
How much of this can the latest ifort handle, and can it do any of
the commented-out code?