module mcadincl
use ifwin
! Источник: http://rosettacode.org/wiki/Variadic_function
abstract interface
! integer ( LRESULT ) function LPCFUNCTION( arglist )
! !DEC$ ATTRIBUTES C :: LPCFUNCTION
!
! use ifwin
!
! implicit none
!
! integer (4), dimension(:), intent(in) :: arglist
!
! end function
! Внимание. В этом шаблоне подразумевается, что параметры передаются по ссылке
integer ( LRESULT ) function LPCFUNCTION( ReturnValue, Arg0 )
use ifwin
implicit none
! Здесь мы используем встроенный тип, т.к. он полностью совпадает
! с описанием типа COMPLEXSCALAR в mcadincl.h
double complex, intent(in) :: ReturnValue
double complex, intent(in) :: Arg0
end function
end interface
! Константы для задания типов аргументов функций и результата
! Скаляр
integer, parameter :: COMPLEX_SCALAR = 1
! Массив
integer, parameter :: COMPLEX_ARRAY = 2
! Строка
integer, parameter :: MATHCAD_STRING = 8
! Максимальное число аргументов функции
integer, parameter :: MAX_ARGS = 10
! Скалярная величина
type COMPLEXSCALAR
real (8) Re
real (8) Im
end type
! Массив в MathCAD
type COMPLEXARRAY
integer ( UINT ) rows ! число строк
integer ( UINT ) cols ! число столбцов
! hReal: tPtrToMatrix; // действительная часть = NIL, если отсутствует
! hImag: tPtrToMatrix; // мнимая часть = NIL, если отсутствует
end type
! Информация для регистрации функции
type FUNCTIONINFO
! Имя, под которым будет использоваться внутри Mathcad (чувствительно к регистру букв)
character ( 256 ), pointer :: lpstrName
! Перечень параметров (только как информационное сообщение)
character ( 256 ), pointer :: lpstrParameters
! Описание (только как информационное сообщение)
character ( 256 ), pointer :: lpstrDescription
! Указатель на функцию
! Источник: http://scicomp.stackexchange.com/questions/285/how-to-work-with-function-pointers-in-fortran-in-scientific-programs
procedure ( LPCFUNCTION ), nopass, pointer :: lpfnMyCFunction
! Тип возвращаемого значения
integer ( UINT ) :: returnType
! Число аргументов
integer ( UINT ) :: nArgs
! Типы аргументов
integer ( UINT ), dimension ( MAX_ARGS ) :: argType
end type
contains
! ! Источник: http://rosettacode.org/wiki/Variadic_function
! integer ( LRESULT ) function mcad_TestFunc1( arglist )
! !DEC$ ATTRIBUTES C :: mcad_TestFunc1
!
! use ifwin
!
! implicit none
!
! integer (4), dimension(:), intent(in) :: arglist
!
! ! Инициализируем значение функции признаком успешного завершения
! ! работы (см. The Developer's Reference в справке Mathcad)
! mcad_TestFunc1 = 0
!
! end function
integer ( LRESULT ) function mcad_TestFunc1( ReturnValue, Arg0 )
use ifwin
implicit none
double complex, intent(out) :: ReturnValue
double complex, intent(in) :: Arg0
ReturnValue = Arg0
! Инициализируем значение функции признаком успешного завершения
! работы (см. The Developer's Reference в справке Mathcad)
mcad_TestFunc1 = 0
end function mcad_TestFunc1
end module mcadincl
!********************************************************************
!* FUNCTION: DllMain(HANDLE, DWORD, LPVOID)
!*
!* PURPOSE: DllMain is called by Windows when
!* the DLL is initialized, Thread Attached, and other times.
!* Refer to SDK documentation, as to the different ways this
!* may be called.
!*
!* The DllMain function should perform additional initialization
!* tasks required by the DLL. DllMain should return a value of 1
!* if the initialization is successful.
!*
!* Источник: http://h21007.www2.hp.com/portal/download/files/unprot/Fortran/docs/vf-html/pg/pgmindll.htm
!* Источник: http://objectmix.com/fortran/351982-issues-c-fortran-loadlibrary-getprocaddress.html
!*
!*********************************************************************
logical(BOOL) function DllMain( hinstDll, fdwReason, lpvReserved )
!DEC$ IF DEFINED(_X86_)
!DEC$ ATTRIBUTES DEFAULT, STDCALL, ALIAS : '_DllMain@12' :: DllMain
!DEC$ ELSE
!DEC$ ATTRIBUTES DEFAULT, STDCALL, ALIAS : 'DllMain' :: DllMain
!DEC$ ENDIF
use ifwin
use mcadincl
implicit none
! Описание прототипов функций библиотеки mcaduser.dll
interface
! const void * CreateUserFunction( HINSTANCE, FUNCTIONINFO * );
integer( LPVOID ) function CreateUserFunction( hInstance, pFunctionInfo )
!DEC$ ATTRIBUTES C :: CreateUserFunction
use ifwin
use mcadincl
integer( HANDLE ), intent( in ) :: hInstance
type ( FUNCTIONINFO ), pointer, intent( in ) :: pFunctionInfo
end function
! void MathcadFree( char * address );
subroutine MathcadFree( address )
use ifwin
integer( LPVOID ), intent( in ) :: address
end subroutine
! function CreateUserErrorMessageTable( hInstance, nErrorMessages, ErrorMessageTable )
!
! use ifwinty
!
! logical( BOOL ) PCREATEUSERERRORMESSAGETABLE
! integer( HANDLE ), intent( in ) :: hInstance
! integer( DWORD ), intent( in ) :: nErrorMessages
! integer( LPVOID ), intent( in ) :: ErrorMessageTable
!
! end function CreateUserErrorMessageTable
!
logical( BOOL ) function isUserInterrupted()
use ifwinty
end function isUserInterrupted
end interface
! Назначение указателей
pointer( PCREATE_USER_FUNCTION, CreateUserFunction )
! pointer( PCREATE_USERERROR_MESSAGE_TABLE, CreateUserErrorMessageTable )
! pointer( PMATHCADALLOCATE, MathcadAllocate )
pointer( PMATHCADFREE, MathcadFree )
! pointer( PMATHCADARRAYALLOCATE, MathcadArrayAllocate )
! pointer( PMATHCADARRAYFREE, MathcadArrayFree )
pointer( PIS_USER_INTERRUPTED, isUserInterrupted )
integer( HANDLE ), intent( in ) :: hinstDll
integer( DWORD ), intent( in ) :: fdwReason
integer( LPVOID ), intent( in ) :: lpvReserved
integer ( HANDLE ) hMathcadUserDll
integer( LPVOID ) Res
character (256), target :: FuncName = "TestFunc1"C
character (256), target :: FuncParameters = "(x) - parameter"C
character (256), target :: FuncDescription = "Fortran test function"C
type( FUNCTIONINFO ), target :: Info_mcad_TestFunc1
type ( FUNCTIONINFO ), pointer :: pInfo
select case ( fdwReason )
! DLL проецируется на адресное пространство процесса
case ( DLL_PROCESS_ATTACH )
! 'C' в конце добавляет нулевой байт в стиле Си
hMathcadUserDll = LoadLibrary( "mcaduser.dll"C )
! Инициализация указателей функций
PCREATE_USER_FUNCTION = GetProcAddress( hMathcadUserDll, "CreateUserFunction"C )
PMATHCADFREE = GetProcAddress( hMathcadUserDll, "MathcadFree"C )
PIS_USER_INTERRUPTED = GetProcAddress( hMathcadUserDll, "isUserInterrupted"C )
Info_mcad_TestFunc1%lpstrName => FuncName
Info_mcad_TestFunc1%lpstrParameters => FuncParameters
Info_mcad_TestFunc1%lpstrDescription => FuncDescription
Info_mcad_TestFunc1%returnType = COMPLEX_SCALAR
Info_mcad_TestFunc1%nArgs = 1
Info_mcad_TestFunc1%argType(1) = COMPLEX_SCALAR
Info_mcad_TestFunc1%lpfnMyCFunction => mcad_TestFunc1
pInfo => Info_mcad_TestFunc1
! Регистрируем функции библиотеки (пользовательские)
Res = CreateUserFunction( hinstDll, pInfo )
! создаётся поток
case ( DLL_THREAD_ATTACH )
! поток корректно завершается
case ( DLL_THREAD_DETACH )
case ( DLL_PROCESS_DETACH )
end select
DllMain = .TRUE.
end function
|
