 |
forums.silverfrost.com
Welcome to the Silverfrost forums
|
| View previous topic :: View next topic |
| Author |
Message |
StamK
Joined: 12 Oct 2016
Posts: 162
|
|
| Back to top |
|
 |
PaulLaidler
Site Admin
Joined: 21 Feb 2005
Posts: 7995
Location: Salford, UK
|
 Posted: Fri Jun 07, 2024 7:23 am Post subject: |
 |
|
StamK
C_ASSOCIATED is not currently implemented. I will add it to the wish list.
If you can post or send some sample code (in addition to that in your gcc link) that illustrates its use then that would be a great help.
Half the battle is in working out how these features might be used.
By the way, there is not much left in the 2003 Standard that is not already implemented by FTN95. For example, TYPE EXTENDS is almost ready for release. |
|
| Back to top |
|
|
StamK
Joined: 12 Oct 2016
Posts: 162
|
| Posted: Fri Jun 07, 2024 8:42 am Post subject: |
|
|
We have an issue where a corrupt file causes an array to be populated with UNDEFINED via READ routines (as per other topic https://forums.silverfrost.com/viewtopic.php?t=4825&highlight=undefined) .
So we are hoping to catch it as follows, where c_associated checks the validity of C pointer p.
| Code: |
INTEGER FUNCTION CORE4_FTN95(IAD)
use iso_c_binding
USE clrwin$
IMPLICIT NONE
INTEGER(CW_HANDLE) :: IAD
type(c_ptr) :: p
INTEGER, pointer :: fp =>NULL()
INTEGER :: I_OUT
I_OUT = 0
p = transfer(IAD, p)
call c_f_pointer(p, fp)
IF (c_associated(p)) THEN
IF (ASSOCIATED(fp)) THEN
I_OUT = fp
END IF
END IF
CORE4_FTN95 = I_OUT
END FUNCTION
|
|
|
| Back to top |
|
|
PaulLaidler
Site Admin
Joined: 21 Feb 2005
Posts: 7995
Location: Salford, UK
|
| Posted: Wed Jun 12, 2024 3:36 pm Post subject: |
|
|
StamK
C_ASSOCIATED has been implemented for the next release of FTN95.
I don't understand the sample code that you have posted so I don't know if this function will be of any help to you.
Here is a test program for C_ASSOCIATED that may help.
| Code: | !$ extern "C" void __c_f_pointer_test(float*& a)
!$ {
!$ a = (float*)malloc(12 * sizeof(float));
!$ float* b = a;
!$ for (int i = 1; i <= 12; ++i) *b++ = (float)i;
!$ }
subroutine association_test(a,b)
use iso_c_binding, only: c_associated, c_loc, c_ptr
implicit none
type(c_ptr) :: a
real, pointer :: b
logical L
L = c_associated(a, c_loc(b))
if(.not.L) print*, 'a and b do not point to same target'
end subroutine association_test
program main
use,intrinsic::iso_c_binding,only:c_ptr,c_loc,c_associated,c_f_pointer
implicit none
interface
subroutine c_f_pointer_test(p) bind(c,name='__c_f_pointer_test')
import :: c_ptr
type(c_ptr), intent(out) :: p
end subroutine
end interface
interface
subroutine association_test(a,b)
import :: c_ptr
type(c_ptr) :: a
real, pointer :: b
end subroutine association_test
end interface
type(c_ptr) :: cptr
real,pointer :: a(:)
real,pointer :: b(:,:)
real,pointer :: c
logical L(7)
L(7) = .not.associated(c)
L(1) = .not.c_associated(cptr)
call c_f_pointer_test(cptr) ! Create cptr
call c_f_pointer(cptr, a, [12]) ! 'a' points to cptr.
call c_f_pointer(cptr, b, [3,4]) ! 'b' has the same target as 'a' but different shape.
call c_f_pointer(cptr, c) ! 'c' is just the first element of the cptr array.
L(2) = (sum(a) == sum(b) .and. c == 1.0)
L(3) = c_associated(cptr)
L(4) = c_associated(cptr, c_loc(a))
L(5) = c_associated(cptr, c_loc(b))
L(6) = c_associated(cptr, c_loc(c))
call association_test(cptr, c)
if(all(L)) print*, "Success"
end program main |
|
|
| 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
|
FAQ
Search
Memberlist
Usergroups
Register
Profile
Log in to check your private messages
Log in
