module mcadincl use ifwin ! Исходник: http://rosettacode.org/wiki/Variadic_function abstract interface integer ( LRESULT ) function LPCFUNCTION( arglist ) use ifwin implicit none integer (4), dimension(, intent(in), optional :: arglist end function LPCFUNCTION 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 ) :: lpstrName ! перечень параметров (только как информационное сообщение) character ( 256 ) :: lpstrParameters ! описание (только как информационное сообщение) character ( 256 ) :: lpstrDescription ! указатель на функцию ! Источник: http://scicomp.stackexchange.com/questions/285/how-to-work-with-function-pointers-in-fortran-in-scientific-programs procedure ( LPCFUNCTION ), pointer :: lpfnMyCFunction ! тип возвращаемого значения integer ( UINT ) :: returnType ! число аргументов integer ( UINT ) :: nArgs ! типы аргументов integer ( UINT ), dimension ( MAX_ARGS ) :: argType end type end module mcadincl ! Исходник: http://rosettacode.org/wiki/Variadic_function integer ( LRESULT ) function mcad_TestFunc1( arglist ) use ifwin implicit none integer (4), dimension(, intent(in), optional :: arglist ! Инициализируем значение функции признаком успешного завершения ! работы (см. The Developer's Reference в справке Mathcad) mcad_TestFunc1 = 0 end function mcad_TestFunc1 !integer (4) function mcad_TestFunc1( ReturnValue, Arg0 ) ! ! use ifwin ! use mcadincl ! ! implicit none ! ! type ( COMPLEXSCALAR ), intent( out ) :: ReturnValue ! type ( COMPLEXSCALAR ), intent( in ) :: Arg0 ! ! ReturnValue%Re = Arg0%Re ! ReturnValue%Im = Arg0%Im ! ! ! Инициализируем значение функции признаком успешного завершения ! ! работы (см. The Developer's Reference в справке Mathcad) ! mcad_TestFunc1 = 0 ! !end function mcad_TestFunc1 !******************************************************************** !* 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 !* !********************************************************************* ! В этом описании атрибутов наличие параметра DECORATE ведёт к ошибке связывания ! !DEC$ ATTRIBUTES DEFAULT, DECORATE, STDCALL, ALIAS: "DllMain" :: DllMain 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 ) use ifwin use mcadincl integer( HANDLE ), intent( in ) :: hInstance type ( FUNCTIONINFO ), intent( out ), pointer :: pFunctionInfo end function CreateUserFunction ! void MathcadFree( char * address ); subroutine MathcadFree( address ) use ifwin integer( LPVOID ), intent( in ) :: address end subroutine MathcadFree ! 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 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 = "TestFunc1"C Info_mcad_TestFunc1%lpstrParameters = "(x) - parameter"C Info_mcad_TestFunc1%lpstrDescription = "Fortran test function"C 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 |