Intel® Fortran Compiler
Build applications that can scale for the future with optimized code designed for Intel® Xeon® and compatible processors.
28950 Discussions

Initialization of a procedure pointers

netphilou31
New Contributor III
369 Views

Hi,

I have an existing Fortran module which provides interfaces to another dll (let say dll1, also written in Fortran). For each procedure exported from dll1, I have a local procedure which loads the dll if not already loaded and retrieves the procedure pointer using the GetProcAddress method. In the current version the value is assigned to an integer pointer associated to the procedure.
Something like:

 

    interface
        subroutine Dll_GetNumericalParameters(CRIT,EPSC,CLIM,NAPM,ALPHA)
        !dec$ attributes stdcall :: Dll_GetNumericalParameters
        !dec$ attributes reference :: CRIT, EPSC, CLIM, NAPM, ALPHA
            integer(4), intent(out) :: NAPM
            real(8),    intent(out) :: CRIT, CLIM, EPSC, ALPHA
        end subroutine Dll_GetNumericalParameters
    end interface
    pointer(PTR_GetNumericalParameters, Dll_GetNumericalParameters)

 

The pointer is initialized with:

 

    if (hLib == 0) then
        hLib = LoadLibrary(dll1_name)
        if (hLib == 0) then
            call SysErrorMessage(GetLastError(), DllName)
            call RaiseException(#EFFFFFFF, EXCEPTION_NONCONTINUABLE, 0,  NULL)
        end if
    end if
    PTR_GetNumericalParameters = GetProcAddress(hLib, "GetNumericalParameters"C)

 

hLib being the handle of the DLL dll1. This last part of code in located into a single procedure which is called for every method of dll1 I want to access.

Today (mainly because the use of integer pointers is not compliant with the Fortran standard), I would like to use the procedure pointers, in the form of:

 

    interface
        subroutine Dll_GetNumericalParameters(CRIT,EPSC,CLIM,NAPM,ALPHA)
        !dec$ attributes stdcall :: Dll_GetNumericalParameters
        !dec$ attributes reference :: CRIT, EPSC, CLIM, NAPM, ALPHA
            integer(4), intent(out) :: NAPM
            real(8),    intent(out) :: CRIT, CLIM, EPSC, LPHA
        end subroutine Dll_GetNumericalParameters
    end interface
    procedure(Dll_GetNumericalParameters), pointer :: PTR_GetNumericalParameters

 

But I don't know how to translate the pointer initialization code. Any suggestions?

In the past, Steve Lionel, aka Dr Fortran, gave me a code template showing how to use procedure pointers but the pointer initialization was performed directly inside the routine. I was able to use this method for some fortran modules but my goal today is to avoid rewriting the same initialization code for tens of interface procedures.

Bets regards,

0 Kudos
1 Solution
andrew_4619
Honored Contributor III
267 Views

I use a helper routine to make is more friendly for the  Fortran:

 

! example usage
call GetProcAddress_helper( istat,  hLib, procptr1, "ProccName" ) ! proc in dll have names
call GetProcAddress_helper( istat,  hLib, procptr2, ord=3_handle ) ! proc in dll is ordinal number 3


subroutine GetProcAddress_helper( istat, lib_hnd, procptr, procname, ord )
    use, intrinsic :: ISO_C_BINDING, only: C_LOC, C_NULL_FUNPTR, C_F_PROCPOINTER, C_INTPTR_T
    integer, intent(out)                :: istat    ! exit status OK is 0
    integer(handle), intent(in)         :: lib_hnd  ! handle to dll file
    procedure(), intent(inout), pointer :: procptr  ! pointer to proc in dll
    character(*), intent(in), optional  :: procname ! we find proc pointer value by name or ordinal number
    integer(handle), intent(in), optional  :: ord   ! ordinal number
    character(256), target :: gbuf
    integer(C_INTPTR_T) :: lp_func, iptr   
    istat = -1  ! error status bad
    if ( present(procname) ) then ! do name if present
        gbuf = trim(procname)//achar(0)
        iptr = transfer( C_LOC(gbuf), 0_C_INTPTR_T )
    elseif ( present(ord) ) then  ! if no name check if there is an ordinal
        iptr = ord
    else                          ! duff call no name and no ordinal 
        return
    endif
    lp_func = GetProcAddress(lib_hnd, iptr )
    if( lp_func == 0 ) RETURN
    call C_F_PROCPOINTER (TRANSFER(lp_func, C_NULL_FUNPTR), procptr )
    istat = 0  ! error status good
end subroutine GetProcAddress_helper

 

View solution in original post

4 Replies
netphilou31
New Contributor III
351 Views

Just a corrigendum of my previous initialization code, which should be:

logical(4) function LoadModuleEx(DllName, ProcName, hLib, PTR_Proc) result(rc)
.../...
    if (hLib == 0) then
        hLib = LoadLibrary(DllName)
        if (hLib == 0) then
            call SysErrorMessage(GetLastError(), DllName)
            call RaiseException(#EFFFFFFF, EXCEPTION_NONCONTINUABLE, 0,  NULL)
        end if
    end if
    PTR_Proc = GetProcAddress(hLib, trim(ProcName)//char(0))
.../...
   rc = ...

Function which is called for each procedure of dll1 I want to get a pointer to.

0 Kudos
Steve_Lionel
Honored Contributor III
300 Views

See the attached, one of the compiler samples, for the technique to use.

andrew_4619
Honored Contributor III
268 Views

I use a helper routine to make is more friendly for the  Fortran:

 

! example usage
call GetProcAddress_helper( istat,  hLib, procptr1, "ProccName" ) ! proc in dll have names
call GetProcAddress_helper( istat,  hLib, procptr2, ord=3_handle ) ! proc in dll is ordinal number 3


subroutine GetProcAddress_helper( istat, lib_hnd, procptr, procname, ord )
    use, intrinsic :: ISO_C_BINDING, only: C_LOC, C_NULL_FUNPTR, C_F_PROCPOINTER, C_INTPTR_T
    integer, intent(out)                :: istat    ! exit status OK is 0
    integer(handle), intent(in)         :: lib_hnd  ! handle to dll file
    procedure(), intent(inout), pointer :: procptr  ! pointer to proc in dll
    character(*), intent(in), optional  :: procname ! we find proc pointer value by name or ordinal number
    integer(handle), intent(in), optional  :: ord   ! ordinal number
    character(256), target :: gbuf
    integer(C_INTPTR_T) :: lp_func, iptr   
    istat = -1  ! error status bad
    if ( present(procname) ) then ! do name if present
        gbuf = trim(procname)//achar(0)
        iptr = transfer( C_LOC(gbuf), 0_C_INTPTR_T )
    elseif ( present(ord) ) then  ! if no name check if there is an ordinal
        iptr = ord
    else                          ! duff call no name and no ordinal 
        return
    endif
    lp_func = GetProcAddress(lib_hnd, iptr )
    if( lp_func == 0 ) RETURN
    call C_F_PROCPOINTER (TRANSFER(lp_func, C_NULL_FUNPTR), procptr )
    istat = 0  ! error status good
end subroutine GetProcAddress_helper

 

netphilou31
New Contributor III
202 Views

Thank you Steve and Andrew,

This helped me a lot, especially in the way I can declare a procedure pointer as an argument, I didn't know I could declare something like:

procedure(), pointer, intent(inout) :: ProcPtr

This was, indeed, my main concern.

Thanky you guys,

Best regards,

Reply