Using extended derived type in a DLL

[Ned_B_]

I am trying to find a way to have a DLL that defines a type that extends a base derived type that is used by the main executable. The extended type needs to be able to be accessed by a pointer and it needs to contain type-bound procedures that override procedures in the base type. The main program will not be able to USE the module where the extended type is defined, except indirectly through the DLL. So far I have come up with code that enables the main program to instantiate an object of the extended type, and see public data members, but I get Access Violation when I try to invoke a type-bound procedure. Here's what I have so far. In the code below, the AV happens at "call t4%GetName(name)". Before that line executes, in the debugger I can see that t4%Name equals 'Type 4 initial name' as expected.  If any one has suggestions about what I am missing, that would be great.

Main project:

BaseType.f90:

module BaseModule
implicit none
private

public :: BaseType
  type :: BaseType
  character(len=50) :: Name
contains
  procedure :: GetName
end type BaseType

contains

subroutine GetName(this, name)
  implicit none
  class(BaseType), intent(in) :: this
  character(len=*), intent(inout) :: name
  name = this%Name
  return
end subroutine GetName

end module BaseModule

main.f90:

program main
  
  use ifport
  use ifwin

  use, intrinsic :: ISO_C_BINDING, only:  &
      C_F_PROCPOINTER, C_FUNPTR, C_INTPTR_T,  &
      C_NULL_CHAR, C_CHAR, C_ASSOCIATED, C_PTR, c_funloc, &
      C_NULL_FUNPTR
  
  use BaseModule, only: BaseType
  
  implicit none
  
  interface 
     function GetProcAddress(hModule, lpProcName)  &
         bind(C, name='GetProcAddress')
       use, intrinsic :: ISO_C_BINDING, only:  &
           C_FUNPTR, C_INTPTR_T, C_CHAR
       implicit none
       type(C_FUNPTR) :: GetProcAddress
       integer(C_INTPTR_T), value :: hModule
       character(KIND=C_CHAR) :: lpProcName(*)
     end function GetProcAddress      
  END INTERFACE
  
  abstract INTERFACE
    function gettype_intf() result(tt)
      import BaseType
      class(BaseType), pointer :: tt
    END function gettype_intf
  END INTERFACE

  integer(LPVOID) :: proc_address
  PROCEDURE(gettype_intf), POINTER :: my_proc
  class(BaseType), pointer :: t4
  integer(handle) lib_handle 
  character(len=20) :: name
  character(len=20) :: procname
  !
  nullify(t4)
  lib_handle = LoadLibrary(C_CHAR_'Type4lib.dll' // C_NULL_CHAR)
  if (lib_handle == 0) stop "DLL not loaded" 

  proc_address = GetProcAddress( lib_handle,  &
      C_CHAR_'GETTYPE' // C_NULL_CHAR )
  IF (proc_address == 0) STOP 'Unable to obtain procedure address'
   
  call C_F_PROCPOINTER(transfer(proc_address,C_NULL_FUNPTR), my_proc) 

  t4 => my_proc()
  call t4%GetName(name)
  print*, 'name t4 = ',name
  stop

end program main

DLL project:

(includes BaseType.f90, above)

Test4Type.f90:

module Type4Module
  use BaseModule, only: BaseType
  implicit none
  
  private
  public :: Test4Type
  
  type, extends (BaseType) :: Test4Type
  contains
    procedure :: GetName => get_name
  end type Test4Type
  
contains
  
  subroutine get_name(this, name)
    implicit none
    class(Test4Type), intent(in) :: this
    character(len=*), intent(inout) :: name
    !
    name = this%Name
    return
  end subroutine get_name

end module Type4Module

Type4DLL.f90:

function gettype() result (tt)
  !DEC$ ATTRIBUTES DLLEXPORT::GETTYPE
  use BaseModule, only: BaseType
  use Type4Module, only: Test4Type
  implicit none
  type(Test4Type), pointer :: tt
  !
  allocate(tt)
  tt%name = 'Type 4 initial name'
  return
end function gettype

[Jauch]

Hello Ned,

If you try to return a "class" from the function, do not matter if it is the base class, the type4 or a polymorphic one (*), I get an internal compiler error. What is strange, because I have a project where I do exactly this (but it is not in a DLL).

If you just return a "type(Test4Type)", everything works INSIDE the function when called from the main routine, but you get an AV in the main project, because to this works, I think you should return a polymorphic class(*) and do a Select Type to use it as your BaseClass.

So, I tried a "new" thing, that is instead of returning the object, to pass a polymorphic class pointer to the routine. I changed the dll exported routine and the main code a little:

function gettype(to_allocate)
!DEC$ ATTRIBUTES DLLEXPORT::GETTYPE

use BaseModule, only: BaseType
use Type4Module, only: Test4Type

implicit none
class(*), pointer :: to_allocate
logical :: gettype

write (*,*) 'Inside gettype'

nullify (to_allocate)
allocate(Test4Type::to_allocate)

select type (to_allocate)
type is (Test4Type)
to_allocate%name = 'Type 4 initial name'
end select

gettype = .true.

end function gettype

Now, the new Main code:
 

program main

use ifport
use ifwin

use, intrinsic :: ISO_C_BINDING, only: &
C_F_PROCPOINTER, C_FUNPTR, C_INTPTR_T, &
C_NULL_CHAR, C_CHAR, C_ASSOCIATED, C_PTR, c_funloc, &
C_NULL_FUNPTR

use BaseModule, only: BaseType

implicit none

interface
function GetProcAddress(hModule, lpProcName) &
bind(C, name='GetProcAddress')
use, intrinsic :: ISO_C_BINDING, only: &
C_FUNPTR, C_INTPTR_T, C_CHAR
implicit none
type(C_FUNPTR) :: GetProcAddress
integer(C_INTPTR_T), value :: hModule
character(KIND=C_CHAR) :: lpProcName(*)
end function GetProcAddress
END INTERFACE

abstract INTERFACE
function gettype_intf(to_allocate) result(r)
class(*), pointer :: to_allocate
logical :: r
END function gettype_intf
END INTERFACE

integer(LPVOID) :: proc_address
PROCEDURE(gettype_intf), POINTER :: my_proc
class(*), pointer :: t4
logical :: res
integer(handle) lib_handle
character(len=50) :: name
character(len=20) :: procname
!
nullify(t4)
lib_handle = LoadLibrary(C_CHAR_'Type4lib.dll' // C_NULL_CHAR)
if (lib_handle == 0) stop "DLL not loaded"

proc_address = GetProcAddress( lib_handle, &
C_CHAR_'GETTYPE' // C_NULL_CHAR )
IF (proc_address == 0) STOP 'Unable to obtain procedure address'

call C_F_PROCPOINTER(transfer(proc_address,C_NULL_FUNPTR), my_proc)

res = .false.
nullify (t4)
res = my_proc(t4)

print *, 'result: ', res

select type (t4)
class is (BaseType)
print *, t4
call t4%GetName(name)
print*, 'on MAIN: name t4 = ',name
class default
print *, "t4 is not a BaseType derived class"
end select

stop

end program main

This works.
But you have to pay attention to, at least, two main concerns. Scalability/Maintanance and Memory allocation/deallocation on DLL's, that creates lots of problems. At least was what I could pick up here and there. ;)

I tested the original conde on ifort 14.0.4 and on the new 15 (out on the last week (I think).
None worked with the original code (AV) and with the routine returning in the DLL a polymorphic pointer (Compiler Internal error).

Also, it seems that an "associated" check to the pointer after the DLL routine is called do not works, for some reason. Maybe because the pointer was allocated inside the DLL?

Good luck! :)

[Ned_B_]

Eduardo,
Thank you so much for taking the time to work on this problem! I am looking forward to downloading a trial of ifort 15 and testing your suggestion.
Regards,
Ned

[Steven_L_Intel1]

Eduardo, would you please provide us with a copy of the source that results in an internal compiler error?  Thanks.

[Jauch]

Hello Steve,

I'm sending attached the project for the DLL. As it is now, it raises an ICE. If you delete the gettext2 function, it compiles fine. It seems that inside DLL's projects, the compiler doesn't like routines that return a "pointer to class".

I managed to get the routine working returning a pointer for type BaseType, like this:

function gettype3() 
    !DEC$ ATTRIBUTES DLLEXPORT::GETTYPE3 
    
    use BaseModule, only: BaseType 
    use Type4Module, only: Test4Type  
  
    implicit none
    Type(BaseType), pointer :: gettype3
    class(*), pointer :: myType
  
    write (*,*) 'Inside gettype3'
  
    allocate(Test4Type::myType)
    
    select type (myType)
        type is (Test4Type)
            myType%name = 'Type 4 initial name for gettype 3'
        end select
    
    select type (myType)
    type is (BaseType)
        gettype3 => myType
    end select
    
    gettype3 => myType
    print *, gettype3%name        
    
    return
    
end function gettype3

But I think the use of a pointer to a class should work. At least it works if it's not a DLL.

Cheers,

Eduardo Jauch
 

[Steven_L_Intel1]

Thanks., Eduardo. That this is in a DLL is not relevant. If you disable "Check routine interfaces", it compiles. Even better would be to put these functions in a module, since you're required to have an explicit interface for them anyway. If you do that, the error goes away as well.

Escalated as issue DPD200361372.

[Jauch]

Hi Steve!

Yes. I have an object that has a member function that returns a polymorphic pointer (class(*)) and it works well. In this case, it is inside a module.

Thanks for the suggestions.

I myself want to explore more this "DLL" side, because I'm thinking in prepare a small "plugin system" for the model that I work on and it is good to explore all the possibilities.

Cheers,

Eduardo.

[Steven_L_Intel1]

Eduardo, I have been told to expect the fix for the problem you reported will be in the 16.0 product release later this year.