!
!  clsfact.f90 - This file contains methods of the IClassFactory 
!  interface that is used to create instances of the user's classes
!
!  Generated by the Visual Fortran COM Server Wizard on
!  11/08/00 at 15:04:32.
!
!   DO NOT EDIT THIS FILE!
!
!  This file is re-generated every time the object hierarchy is changed.
!

function IClassFactory_QueryInterface (pData, riid, ppv) result (r)
!DEC$ ATTRIBUTES STDCALL :: IClassFactory_QueryInterface
    use IClassFactory_Types
    use dfwinty
    use dfcom
    use kernel32
    implicit none

    type (IClassFactory_Data) pData
	!dec$ attributes reference :: pData
    type(GUID) riid
	!dec$ attributes reference :: riid
    integer(INT_PTR_KIND()) ppv
	!dec$ attributes reference :: ppv
    integer(LONG) r

    integer(LONG) i

    r = S_OK

    !  Ensure that they are requesting 
    !  the IClassFactory or IUnknown interface
    if ((.not. COMIsEqualGUID(riid, IID_IClassFactory)) .AND. &
        (.not. COMIsEqualGUID(riid, IID_IUnknown))) then
        r = E_UNEXPECTED 
        return
    end if

    i = InterlockedIncrement (loc(pData % refCount)) 
    ppv = loc(pData)

end function 

function IClassFactory_AddRef (pData) result (r)
!DEC$ ATTRIBUTES STDCALL :: IClassFactory_AddRef
    use IClassFactory_Types
    use dfwinty
    use kernel32
    implicit none

    type (IClassFactory_Data) pData
	!dec$ attributes reference :: pData
    integer r

    integer(LONG) i

    i = InterlockedIncrement (loc(pData % refCount)) 
    r = pData % refCount

end function 

function IClassFactory_Release (pData) result (r)
!DEC$ ATTRIBUTES STDCALL :: IClassFactory_Release
    use IClassFactory_Types
    use dfwinty
    use ErrorInfo_global
    use kernel32
    implicit none

    type (IClassFactory_Data), target :: pData
	!dec$ attributes reference :: pData
    integer r

    type (IClassFactory_Data),  pointer :: pCFData
    integer status

    call EnterCriticalSection(loc(gGlobalCriticalSection))
    pData % refCount = pData % refCount - 1
    r = pData % refCount
    if (pData % refCount == 0) then
        !  Time to delete ourself....
        deallocate (pData % pVtbl)
        pCFData => pData
        deallocate (pCFData)
        !status = ServerUnlock()
    end if
    call LeaveCriticalSection(loc(gGlobalCriticalSection))

end function 

function IClassFactory_LockServer (pData, bLock) result (r)
!DEC$ ATTRIBUTES STDCALL :: IClassFactory_LockServer
    use IClassFactory_Types
    use dfwinty
    use ErrorInfo_global
    implicit none

    type (IClassFactory_Data) pData
	!dec$ attributes reference :: pData
    logical bLock
	!dec$ attributes value :: bLock
    integer(LONG) r

    integer status

    r = S_OK

    if (bLock) then
        status = ServerLock()
    else
        status = ServerUnlock()
    end if

end function 

!  Per class
function IClassFactory_CreateAToIInstance (pData, pUnk, riid, ppv) result (r)
!DEC$ ATTRIBUTES STDCALL :: IClassFactory_CreateAToIInstance
    use IClassFactory_Types
    use dfwinty
    use dfcom
    use ErrorInfo_global
    use AToI_Types
    use IAToI_Methods
    use ISupportErrorInfo_Methods
    implicit none

    type (IClassFactory_Data) pData
	!dec$ attributes reference :: pData
    integer(INT_PTR_KIND()) pUnk
	!dec$ attributes value :: pUnk
    type(GUID) riid
	!dec$ attributes reference :: riid
    integer(INT_PTR_KIND()) ppv
	!dec$ attributes reference :: ppv
    integer(LONG) r

    integer status
    integer(INT_PTR_KIND()) ptr
    type (AToI_Data),  pointer :: pAToIData

    r = S_OK
    ppv = NULL

    !  Ensure that they are requesting a supported interface
    if ((.not. COMIsEqualGUID(riid, IID_IUnknown)) &
        !  Per interface
         .AND. (.not. COMIsEqualGUID(riid, IID_IAToI)) &
         .AND. (.not. COMIsEqualGUID(riid, IID_IDispatch)) &
         .AND. (.not. COMIsEqualGUID(riid, IID_ISupportErrorInfo)) &
        ) then
        r = E_UNEXPECTED 
        return
    end if

	!  Class does not support aggregation
	if (pUnk /= NULL) then
        r = CLASS_E_NOAGGREGATION
        return
	endif

    !  Allocate instance data structure and Vtbl
    allocate (pAToIData)

    !  Per interface
    allocate (pAToIData % IAToI_InternalData % pVtbl)
    pAToIData % IAToI_InternalData % pVtbl % QueryInterface = loc(AToI_QueryInterface)
    pAToIData % IAToI_InternalData % pVtbl % AddRef = loc(AToI_AddRef)
    pAToIData % IAToI_InternalData % pVtbl % Release = loc(AToI_Release)
    pAToIData % IAToI_InternalData % pVtbl % GetTypeInfoCount = loc(AToI_GetTypeInfoCount)
    pAToIData % IAToI_InternalData % pVtbl % GetTypeInfo = loc(AToI_GetTypeInfo)
    pAToIData % IAToI_InternalData % pVtbl % GetIDsOfNames = loc(AToI_GetIDsOfNames)
    pAToIData % IAToI_InternalData % pVtbl % Invoke = loc(AToI_Invoke)
    pAToIData % IAToI_InternalData % pVtbl % AToI = loc($IAToI_AToI)
    pAToIData % IAToI_InternalData % pInternalData => pAToIData % InternalData
    allocate (pAToIData % ISupportErrorInfo_InternalData % pVtbl)
    pAToIData % ISupportErrorInfo_InternalData % pVtbl % QueryInterface = loc(AToI_QueryInterface)
    pAToIData % ISupportErrorInfo_InternalData % pVtbl % AddRef = loc(AToI_AddRef)
    pAToIData % ISupportErrorInfo_InternalData % pVtbl % Release = loc(AToI_Release)
    pAToIData % ISupportErrorInfo_InternalData % pVtbl % InterfaceSupportsErrorInfo = loc($ISupportErrorInfo_InterfaceSupportsErrorInfo)
    pAToIData % ISupportErrorInfo_InternalData % pInternalData => pAToIData % InternalData
    pAToIData % InternalData % pStart => pAToIData
    pAToIData % InternalData % refCount = 1

    !  Allocate the user-defined instance data structure
    allocate (pAToIData % InternalData % pInstanceData)
    !  Call the "constructor"...
    status = AToI_CONSTRUCTOR(pAToIData % InternalData % pInstanceData)
    if (status /= S_OK) then
        deallocate (pAToIData % InternalData % pInstanceData)
        deallocate (pAToIData % IAToI_InternalData % pVtbl)
        deallocate (pAToIData % ISupportErrorInfo_InternalData % pVtbl)
        deallocate (pAToIData)
        r = status
        return
    endif

    !  Increment the server's active object count
    status = ServerLock()

    !  Return the correct interface
    if (COMIsEqualGUID(riid, IID_IUnknown)) then
        ppv = loc(pAToIData)
    !  Per interface
    else if (COMIsEqualGUID(riid, IID_IAToI)) then
        ppv = loc(pAToIData % IAToI_InternalData)
    else if (COMIsEqualGUID(riid, IID_IDispatch)) then
        ppv = loc(pAToIData % IAToI_InternalData)
    else if (COMIsEqualGUID(riid, IID_ISupportErrorInfo)) then
        ppv = loc(pAToIData % ISupportErrorInfo_InternalData)
    end if

end function 
