Quantcast
Channel: Intel® Fortran Compiler
Viewing all articles
Browse latest Browse all 3270

Second experiment with unlimited polymorphism

$
0
0

This program works

module whatMOD
   use ISO_FORTRAN_ENV
   use ISO_C_BINDING
   implicit none
   interface
      function strlen(str) bind(C,name='_strlen')
         import
         implicit none
         integer(C_SIZE_T) strlen
         type(C_PTR), value :: str
      end function strlen
   end interface
   contains
      function strlen_internal(x) bind(C,name='_strlen')
         integer(C_SIZE_T) strlen_internal
         character(kind=C_CHAR) x(*)

         strlen_internal = 0
         do while(x(strlen_internal+1) /= achar(0))
            strlen_internal = strlen_internal+1
         end do
      end function strlen_internal
!DEC$ IF DEFINED(FUN)
      function whatFUN(x)
!DEC$ ELSE
      subroutine whatSUB(x,whatFUN)
!DEC$ ENDIF
         character(:), allocatable :: whatFUN
         class(*) x
         type Xtype
            class(*), allocatable :: x
         end type Xtype
         type(Xtype) t
         integer(INT8), pointer :: U(:), V(:)
         type(C_PTR) W
         integer, parameter :: N = bit_size(0_C_INTPTR_T)/8
         integer(INT8) Z(0:7*N-1)
         integer(C_SIZE_T) Xlen

         allocate(t%x,source=x)
         Z = transfer(t,Z)
         W = transfer(Z(6*N:7*N-1),W)
         call C_F_POINTER(W,V,[N])
         U(0:N-1) => V
         W = transfer(U(0:N-1),W)
         allocate(character(strlen(W)) :: whatFUN)
         BLOCK
            character(len(whatFUN)), pointer :: whatPOINT
            call C_F_POINTER(W,whatPOINT)
            whatFUN = whatPOINT
         END BLOCK
!DEC$ IF DEFINED(FUN)
      end function whatFUN
!DEC$ ELSE
      end subroutine whatSUB
!DEC$ ENDIF
end module whatMOD

program P
   use whatMOD
   implicit none
   type donkey
      integer x
      real y
   end type donkey
   type(donkey) D
   character(:), allocatable :: what

!DEC$ IF DEFINED(FUN)
   write(*,'(a)') whatFUN(19)
   write(*,'(a)') whatFUN(3.14)
   write(*,'(a)') whatFUN(2.99792458d8)
   write(*,'(a)') whatFUN((0,1))
   write(*,'(a)') whatFUN('what FUN')
   write(*,'(a)') whatFUN(.TRUE.)
   write(*,'(a)') whatFUN(C_NULL_PTR)
   write(*,'(a)') whatFUN(D)
!DEC$ ELSE
   call whatSUB(19,what)
   write(*,'(a)') what
   deallocate(what)
   call whatSUB(3.14,what)
   write(*,'(a)') what
   deallocate(what)
   call whatSUB(2.99792458d8,what)
   write(*,'(a)') what
   deallocate(what)
   call whatSUB((0,1),what)
   write(*,'(a)') what
   deallocate(what)
   call whatSUB('what FUN',what)
   write(*,'(a)') what
   deallocate(what)
   call whatSUB(.TRUE.,what)
   write(*,'(a)') what
   deallocate(what)
   call whatSUB(C_NULL_PTR,what)
   write(*,'(a)') what
   deallocate(what)
   call whatSUB(D,what)
   write(*,'(a)') what
   deallocate(what)
!DEC$ ENDIF
end program P

but that subroutine interface is a little clunky. However, if I set /DFUN to activate the functional interface, I get a C0000005.

 


Viewing all articles
Browse latest Browse all 3270

Trending Articles


Practice Sheet of Right form of verbs for HSC Students


Rajasthan Board 10th Result 2016 Roll No wise & Name Wise


Moondru Mudichu 20-07-2016 – Polimer tv Serial


fs_older_downloads


Calaveras conflict results in shooting, 4 arrests


Guilty Pleasures


Black Angus Grilled Artichokes


Download: Rich Bizzy -Panono Ukwenda (Cover)


Muloraki Au


where in jaunpur randi khana