|
forums.silverfrost.com Welcome to the Silverfrost forums
|
View previous topic :: View next topic |
Author |
Message |
mecej4
Joined: 31 Oct 2006 Posts: 1886
|
Posted: Mon Sep 07, 2020 12:51 pm Post subject: Valid code built with /64 leads to access violations |
|
|
The following test code constructs a basic binary tree out of an unsorted array of integers, and outputs the tree in sorted order. It runs without error with FTN95-32 bit, as well as with other compilers.
The 8.65 FTN95 compiler, used with /64 alone or /64 with other options, produces EXEs that abort with access violations or "reference through unset Fortran pointer".
Code: | ! For each node, the convention is:
! If %v == 0, the node is not yet allocated and has no value or branches
! if %l is unassociated, there is no left branch
! if %l is unassociated, there is no right branch
! Duplicate values are rejected
!
module BinaryTree
type node
type(node), pointer :: l => NULL(), r => NULL()
integer :: v = 0
end type
integer, parameter :: NVM = 60
type(node), target,save :: nodes(NVM)
integer :: nnodes = 0
contains
subroutine insert(anode,val,found,nnod)
implicit none
type(node), intent(in),target :: anode(*)
integer, intent(in) :: val
integer, intent(in out) :: nnod
logical, intent(out) :: found
type(node), pointer :: nd
found = .false.; nd => anode(1)
do
if(nd%v == 0)then ! Do not move this IF block since
nd%v = val ! nd%l, nd%v should not be referenced
nnod = nnod+1 ! unless nd%v is not zero
return
else if(val < nd%v)then
if(.not.associated(nd%l))then
nnod = nnod+1
nd%l => anode(nnod)
nd%l%v = val
return
endif
nd => nd%l
else if(val > nd%v)then
if(.not.associated(nd%r))then
nnod = nnod+1
nd%r => anode(nnod)
nd%r%v = val
return
endif
nd => nd%r
else if(val == nd%v)then
found = .true.
return
endif
end do
stop 'Should not have reached this line at end of Subroutine INSERT!'
end subroutine insert
recursive subroutine ptree(base)
type(node) :: base
if(base%v == 0)return
if(associated(base%l))call ptree(base%l);
write(*,'(i5)',advance='no')base%v
if(associated(base%r))call ptree(base%r);
return
end subroutine
end module
program tst
use BinaryTree
implicit none
integer, parameter :: NX = 15
integer, dimension(NX) :: vals = &
[172, 97, 2,166,189, 91, 27, 23,156, 64,113, 29,173,172,114]
type(node), pointer :: base
logical :: found
integer :: i
!
base => nodes(1)
nullify(base%l); nullify(base%r); base%v = 0
nnodes = 0
print '(A,/,15i5,/)','Unsorted array:',vals
do i = 1,NX
call insert(nodes,vals(i),found,nnodes)
if(found)print *,'Value ',vals(i),' already in tree, not inserted'
end do
print *
print *,'Sorted array, duplicates removed:'
call ptree(nodes(1))
end program |
|
|
Back to top |
|
|
PaulLaidler Site Admin
Joined: 21 Feb 2005 Posts: 7925 Location: Salford, UK
|
Posted: Mon Sep 07, 2020 1:09 pm Post subject: |
|
|
Thank you for the feedback. I have made a note of this. |
|
Back to top |
|
|
mecej4
Joined: 31 Oct 2006 Posts: 1886
|
Posted: Wed Sep 09, 2020 6:22 pm Post subject: |
|
|
Here is a variant of the same program which yields the opposite kind of behavior. This program is also error free, and runs fine with /64 or /p6, but aborts with spurious errors when compiled with /check, with or without /64.
Code: | PROGRAM sim_pop
IMPLICIT NONE
TYPE node
TYPE (node), POINTER :: l, r
INTEGER :: v
END TYPE
TYPE (node), DIMENSION (:, :), ALLOCATABLE, TARGET :: visite
INTEGER :: n, day, days, uscite, usc, nnode, ierror
INTEGER :: vals(16)=(/ 1511, 2879, 1519, 754, 912, &
902, 1658, 2, 1076, 1661, &
763, 11, 4224, 1052, 1234, 627 /)
!
n = 150
days = 1
usc = 16
ALLOCATE (visite(1:usc,n*n), STAT = ierror)
IF (ierror /= 0) THEN
WRITE (*, *) 'Error allocating VISITE(:,:), stat = ',ierror
STOP
END IF
DO day = 1, days ! This loop runs only once.
visite(:, :) = node(null(), null(), 0) ! Removing the DO..END DO makes the bug disappear
nnode = 0
uscite = 1
DO WHILE (uscite <= usc)
print *,uscite, vals(uscite)
CALL insert (visite(1,1),vals(uscite),nnode)
uscite = uscite + 1
END DO !while
END DO !day
call ptree(visite(1,1))
STOP
!
CONTAINS
SUBROUTINE insert(anode, val, nnod)
IMPLICIT NONE
TYPE (node), INTENT (IN OUT), TARGET :: anode(*)
INTEGER, INTENT (IN) :: val
INTEGER, INTENT (IN OUT) :: nnod
TYPE (node), POINTER :: nd
nd => anode(1)
DO
IF (nd%v == 0) THEN ! Do not move this IF block since
nd%v = val ! nd%l, nd%v should not be referenced
nnod = nnod + 1 ! unless nd%v is not zero
RETURN
ELSE IF (val < nd%v) THEN
IF (.NOT. associated(nd%l)) THEN
nd%l => anode(nnod+1)
END IF
nd => nd%l
ELSE IF (val > nd%v) THEN
IF (.NOT. associated(nd%r)) THEN
nd%r => anode(nnod+1)
END IF
nd => nd%r
ELSE IF (val == nd%v) THEN
RETURN
END IF
END DO
END SUBROUTINE
RECURSIVE SUBROUTINE ptree(base)
TYPE (node) :: base
IF (base%v == 0) RETURN
IF (associated(base%l)) CALL ptree(base%l)
WRITE (*, '(1x,i6)', ADVANCE='no') base%v
IF (associated(base%r)) CALL ptree(base%r)
RETURN
END SUBROUTINE
END PROGRAM |
|
|
Back to top |
|
|
PaulLaidler Site Admin
Joined: 21 Feb 2005 Posts: 7925 Location: Salford, UK
|
Posted: Thu Sep 10, 2020 10:58 am Post subject: |
|
|
The failure with /CHECK in program sim_pop has now been fixed for the next release of FTN95. |
|
Back to top |
|
|
PaulLaidler Site Admin
Joined: 21 Feb 2005 Posts: 7925 Location: Salford, UK
|
Posted: Sat Sep 12, 2020 4:30 pm Post subject: |
|
|
The FTN95 failure in the first program (tst) is that the line
Code: | type(node), pointer :: l => NULL(), r => NULL() |
is not working. It probably doesn't work for 32 bits either but the default values are presumably OK.
A temporary work-around is to nullify these values in a different way, for example...
Code: | do i = 1,NX
base => nodes(i)
nullify(base%l); nullify(base%r); base%v = 0
end do
|
|
|
Back to top |
|
|
PaulLaidler Site Admin
Joined: 21 Feb 2005 Posts: 7925 Location: Salford, UK
|
Posted: Wed Oct 28, 2020 4:23 pm Post subject: |
|
|
This bug has now been fixed for the next release of FTN95. |
|
Back to top |
|
|
|
|
You cannot post new topics in this forum You cannot reply to topics in this forum You cannot edit your posts in this forum You cannot delete your posts in this forum You cannot vote in polls in this forum
|
Powered by phpBB © 2001, 2005 phpBB Group
|