"
 COPYRIGHT (c) 2004 by eXept Software AG
	      All Rights Reserved

 This software is furnished under a license and may be used
 only in accordance with the terms of that license and with the
 inclusion of the above copyright notice.   This software may not
 be provided or otherwise made available to, or used by, any
 other person.  No title to or ownership of the software is
 hereby transferred.
"

"{ Package: 'stx:libbasic' }"

ExternalFunction subclass:#ExternalLibraryFunction
	instanceVariableNames:'flags moduleName callType returnType argumentTypes'
	classVariableNames:''
	poolDictionaries:''
	category:'System-Support'
!

!ExternalLibraryFunction primitiveDefinitions!
%{
# include <ffi.h>

# define MAX_ARGS    128

# define STX_FFI_TYPE_VOID              0
# define STX_FFI_TYPE_INT               1
# define STX_FFI_TYPE_FLOAT             2
# define STX_FFI_TYPE_DOUBLE            3
# define STX_FFI_TYPE_LONGDOUBLE        4
# define STX_FFI_TYPE_UINT8             5
# define STX_FFI_TYPE_SINT8             6
# define STX_FFI_TYPE_UINT16            7
# define STX_FFI_TYPE_SINT16            8
# define STX_FFI_TYPE_UINT32            9
# define STX_FFI_TYPE_SINT32            10
# define STX_FFI_TYPE_UINT64            11
# define STX_FFI_TYPE_SINT64            12
# define STX_FFI_TYPE_STRUCT            0x10000        /* + size */
# define STX_FFI_TYPE_STRUCT_SIZE_MASK  0x0FFFF        /* size mask */
# define STX_FFI_TYPE_POINTER           13

%}
! !

!ExternalLibraryFunction class methodsFor:'documentation'!

copyright
"
 COPYRIGHT (c) 2004 by eXept Software AG
	      All Rights Reserved

 This software is furnished under a license and may be used
 only in accordance with the terms of that license and with the
 inclusion of the above copyright notice.   This software may not
 be provided or otherwise made available to, or used by, any
 other person.  No title to or ownership of the software is
 hereby transferred.
"
!

example
"
        |f|

        f := ExternalLibraryFunction new.
        f name:'MessageBeep'
          module:'user32.dll'
          callType:#WINAPI
          returnType:#boolean
          argumentTypes:#(uint).

        f invokeWith:1.
"
! !

!ExternalLibraryFunction class methodsFor:'instance creation'!

name:functionName module:moduleName callType:callType
		  returnType:returnType argumentTypes:argTypes
    ^ self new
	name:functionName module:moduleName callType:callType
	returnType:returnType argumentTypes:argTypes
! !

!ExternalLibraryFunction class methodsFor:'constants'!

callTypeAPI
    ^ #callTypeAPI
!

callTypeC
    ^ #callTypeC
!

callTypeCDecl
    ^ #callTypeCDecl
!

callTypeOLE
    ^ #callTypeOLE
! !

!ExternalLibraryFunction methodsFor:'accessing'!

argumentTypes
    ^ argumentTypes
! !

!ExternalLibraryFunction methodsFor:'invoking'!

invoke
    self hasCode ifFalse:[
	self prepareInvoke.
    ].
    ^ self invokeFFIWithArguments:#()
!

invokeWith:arg
    self hasCode ifFalse:[
	self prepareInvoke.
    ].
    ^ self invokeFFIWithArguments:(Array with:arg)
!

invokeWith:arg1 with:arg2
    self hasCode ifFalse:[
	self prepareInvoke.
    ].
    ^ self invokeFFIWithArguments:(Array with:arg1 with:arg2)
!

invokeWith:arg1 with:arg2 with:arg3
    self hasCode ifFalse:[
	self prepareInvoke.
    ].
    ^ self invokeFFIWithArguments:(Array with:arg1 with:arg2 with:arg3)
!

invokeWith:arg1 with:arg2 with:arg3 with:arg4
    self hasCode ifFalse:[
	self prepareInvoke.
    ].
    ^ self invokeFFIWithArguments:(Array with:arg1 with:arg2 with:arg3 with:arg4)
!

invokeWithArguments:argArray
    self hasCode ifFalse:[
	self prepareInvoke.
    ].
    ^ self invokeFFIWithArguments:argArray
! !

!ExternalLibraryFunction methodsFor:'printing'!

printOn:aStream
    aStream nextPutAll:'<'.
    callType printOn:aStream.
    aStream nextPutAll:' '.
    name printOn:aStream.
    aStream nextPutAll:' module:'.
    moduleName printOn:aStream.
    aStream nextPutAll:'>'.
! !

!ExternalLibraryFunction methodsFor:'private'!

invokeFFIWithArguments:arguments
    |argTypeSymbols returnTypeSymbol failureCode|

    argumentTypes notNil ifTrue:[
        argTypeSymbols := argumentTypes collect:[:argType | self ffiTypeSymbolForType:argType].
    ].
    returnTypeSymbol := self ffiTypeSymbolForType:returnType.

%{
    ffi_type *argTypes[MAX_ARGS];
    union {
        int iVal;
    } argValues[MAX_ARGS];
    void *argValuePointers[MAX_ARGS];
    int numArgs;
    int i;
    static int null = 0;

    if (arguments == nil) {
        numArgs = 0;
        if (argTypeSymbols != nil) {
            if (! __isArray(argTypeSymbols)) goto error;
            if (__arraySize(argTypeSymbols) != numArgs) goto error;
        }
    } else {
        if (! __isArray(arguments)) goto error;
        numArgs = __arraySize(arguments);
        if (! __isArray(argTypeSymbols)) goto error;
        if (__arraySize(argTypeSymbols) != numArgs) goto error;
    }
    if (numArgs > MAX_ARGS) {
        failureCode = @symbol(TooManyArguments);
        goto error;
    }

    for (i=0; i<numArgs; i++) {
        ffi_type *argType;
        void *argValuePtr;
        OBJ typeSymbol;

        typeSymbol = __ArrayInstPtr(argTypeSymbols)->a_element[i];
        if (typeSymbol == @symbol(int)) {
        } else if (typeSymbol == @symbol(void)) {
#if 0
            argType = &ffi_type_void;
#endif
            argValuePtr = &null;
        } else {
            failureCode = @symbol(UnknownArgumentType);
            goto error;
        }

        argTypes[i] = argType;
        argValuePointers[i] = argValuePtr;
    }

# if 0
    /* Initialize the cif */
    CHECK(ffi_prep_cif(&cif, FFI_DEFAULT_ABI, 1,
                       &ffi_type_sint64, args) == FFI_OK);

    argtypes = (ffi_type **)C_alloca(sizeof(ffi_type *) * (n + 3));
    argvalues = (void **)C_alloca(sizeof(void *) * (n + 3));
    argtypes[ 0 ] = &ffi_type_pointer;
    argtypes[ 1 ] = &ffi_type_pointer;
    argtypes[ 2 ] = &ffi_type_pointer;
    c = n + 2;
    argvalues[ 0 ] = &c;
    argvalues[ 1 ] = &fn;
    argvalues[ 2 ] = &k;

    for(i = 0; i < n; ++i) {
      argtypes[ i + 3 ] = &ffi_type_pointer;
      argvalues[ i + 3 ] = C_temporary_stack_bottom - (i + 1);
    }

    C_temporary_stack = C_temporary_stack_bottom;
    status = ffi_prep_cif(&cif, FFI_DEFAULT_ABI, n + 3, &ffi_type_void, argtypes);
    assert(status == FFI_OK);
    ffi_call(&cif, (void *)C_block_item(fn, 0), NULL, argvalues);
# endif

error: ;
%}
!

linkToModule
    "link this function to the external module.
     I.e. retrieve the module handle and the code pointer."

    |handle code|

    moduleName isNil ifTrue:[
	self error:'Missing moduleName'.
    ].

    handle := ObjectFileLoader loadDynamicObject:moduleName.
    handle isNil ifTrue:[
	self error:'Cannot load module: ', moduleName.
    ].
    moduleHandle := handle.
    code := moduleHandle getFunctionAddress:name into:self.
    code isNil ifTrue:[
	self error:'Missing function: ', name, ' in module: ', moduleName.
    ].
!

prepareInvoke
    self hasCode ifFalse:[
	moduleHandle isNil ifTrue:[
	    self linkToModule.
	    self setupFFI.
	].
    ].
!

setupFFI
    "setup foreign function interface"

"/    %{
"/    #if defined(WIN32) && defined(i386)
"/        /* Have special code for this case - no need to use of ffi code. */
"/    #else
"/        if (ffi_prep_cif(&cif, FFI_DEFAULT_ABI, 1, &ffi_type_uint, args)) 
! !

!ExternalLibraryFunction methodsFor:'private-accessing'!

STX_FFI_TYPE_DOUBLE
%{
    RETURN(__MKSMALLINT(STX_FFI_TYPE_DOUBLE));
%}.

    "
     self new STX_FFI_TYPE_DOUBLE
    "
!

STX_FFI_TYPE_FLOAT
%{
    RETURN(__MKSMALLINT(STX_FFI_TYPE_FLOAT));
%}.

    "
     self new STX_FFI_TYPE_FLOAT
    "
!

STX_FFI_TYPE_LONGDOUBLE
%{
    RETURN(__MKSMALLINT(STX_FFI_TYPE_LONGDOUBLE));
%}.

    "
     self new STX_FFI_TYPE_LONGDOUBLE
    "
!

STX_FFI_TYPE_POINTER
%{
    RETURN(__MKSMALLINT(STX_FFI_TYPE_POINTER));
%}.

    "
     self new STX_FFI_TYPE_POINTER
    "
!

STX_FFI_TYPE_SINT
%{
#if sizeof(int) == 4 
    RETURN(__MKSMALLINT(STX_FFI_TYPE_SINT32));
#endif
#if sizeof(int) == 8 
    RETURN(__MKSMALLINT(STX_FFI_TYPE_SINT64));
#endif
%}.
    self primitiveFailed

    "
     self new STX_FFI_TYPE_SINT
    "
!

STX_FFI_TYPE_SINT16
%{
    RETURN(__MKSMALLINT(STX_FFI_TYPE_SINT16));
%}.

    "
     self new STX_FFI_TYPE_SINT16
    "
!

STX_FFI_TYPE_SINT32
%{
    RETURN(__MKSMALLINT(STX_FFI_TYPE_SINT32));
%}.

    "
     self new STX_FFI_TYPE_SINT32
    "
!

STX_FFI_TYPE_SINT64
%{
    RETURN(__MKSMALLINT(STX_FFI_TYPE_SINT64));
%}.

    "
     self new STX_FFI_TYPE_SINT64
    "
!

STX_FFI_TYPE_SINT8
%{
    RETURN(__MKSMALLINT(STX_FFI_TYPE_SINT8));
%}.

    "
     self new STX_FFI_TYPE_SINT8
    "
!

STX_FFI_TYPE_STRUCT
%{
    RETURN(__MKSMALLINT(STX_FFI_TYPE_STRUCT));
%}.

    "
     self new STX_FFI_TYPE_STRUCT
    "
!

STX_FFI_TYPE_STRUCT:size
    ^ self STX_FFI_TYPE_STRUCT + size

    "
     self new STX_FFI_TYPE_STRUCT:0
     self new STX_FFI_TYPE_STRUCT:16 
    "
!

STX_FFI_TYPE_UINT
%{
#if sizeof(int) == 4 
    RETURN(__MKSMALLINT(STX_FFI_TYPE_UINT32));
#endif
#if sizeof(int) == 8 
    RETURN(__MKSMALLINT(STX_FFI_TYPE_UINT64));
#endif
%}.
    self primitiveFailed

    "
     self new STX_FFI_TYPE_UINT
    "
!

STX_FFI_TYPE_UINT16
%{
    RETURN(__MKSMALLINT(STX_FFI_TYPE_UINT16));
%}.

    "
     self new STX_FFI_TYPE_UINT16
    "
!

STX_FFI_TYPE_UINT64
%{
    RETURN(__MKSMALLINT(STX_FFI_TYPE_UINT64));
%}.

    "
     self new STX_FFI_TYPE_UINT64
    "
!

STX_FFI_TYPE_UINT8
%{
    RETURN(__MKSMALLINT(STX_FFI_TYPE_UINT8));
%}.

    "
     self new STX_FFI_TYPE_UINT8
    "
!

STX_FFI_TYPE_VOID
%{
    RETURN(__MKSMALLINT(STX_FFI_TYPE_VOID));
%}

    "
     self new STX_FFI_TYPE_VOID
    "
!

ffiTypeForType:aType
    "/ kludge

    aType isSymbol ifTrue:[
        "/ for those who do not have the CType package...
        aType == #int ifTrue:[ ^ self STX_FFI_TYPE_INT ].
        aType == #uint ifTrue:[ ^ self STX_FFI_TYPE_UINT ].
        aType == #short ifTrue:[ ^ self STX_FFI_TYPE_SHORT ].
        aType == #ushort ifTrue:[ ^ self STX_FFI_TYPE_USHORT ].
        aType == #long ifTrue:[ ^ self STX_FFI_TYPE_LONG ].
        aType == #ulong ifTrue:[ ^ self STX_FFI_TYPE_ULONG ].
        aType == #float ifTrue:[ ^ self STX_FFI_TYPE_FLOAT ].
        aType == #double ifTrue:[ ^ self STX_FFI_TYPE_DOUBLE ].
        aType == #void ifTrue:[ ^ self STX_FFI_TYPE_VOID ].
        self error:'unknown type'.
    ].
    self error:'unknown type'.
!

ffiTypeSymbolForType:aType
    "/ kludge for those who do not have the CType package...
    aType isSymbol ifTrue:[ ^ aType ].
    CType isNil ifTrue:[
        self error:'unknown type'.
    ].
    ^ aType typeSymbol
!

name:functionName module:aModuleName callType:aCallType returnType:aReturnType argumentTypes:argTypes
    name := functionName.
    moduleName := aModuleName.
    callType := aCallType.
    returnType := aReturnType.
    argumentTypes := argTypes.
! !

!ExternalLibraryFunction class methodsFor:'documentation'!

version
    ^ '$Header: /cvs/stx/stx/libbasic/ExternalLibraryFunction.st,v 1.6 2006-04-25 10:33:27 cg Exp $'
! !