"

 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 returnType argumentTypes owningClass'

	classVariableNames:'DLLPATH FLAG_VIRTUAL FLAG_NONVIRTUAL FLAG_ASYNC

		FLAG_UNLIMITEDSTACK FLAG_RETVAL_IS_CONST CALLTYPE_MASK

		CALLTYPE_API CALLTYPE_C CALLTYPE_OLE CALLTYPE_V8 CALLTYPE_V9

		CALLTYPE_UNIX64'

	poolDictionaries:''

	category:'System-Support'

!

!ExternalLibraryFunction primitiveDefinitions!

%{

#ifdef HAVE_FFI

# include <ffi.h>

# define MAX_ARGS    128

extern ffi_type *__get_ffi_type_sint();

extern ffi_type *__get_ffi_type_sint8();

extern ffi_type *__get_ffi_type_sint16();

extern ffi_type *__get_ffi_type_sint32();

extern ffi_type *__get_ffi_type_sint64();

extern ffi_type *__get_ffi_type_uint();

extern ffi_type *__get_ffi_type_uint8();

extern ffi_type *__get_ffi_type_uint16();

extern ffi_type *__get_ffi_type_uint32();

extern ffi_type *__get_ffi_type_uint64();

extern ffi_type *__get_ffi_type_float();

extern ffi_type *__get_ffi_type_double();

extern ffi_type *__get_ffi_type_void();

extern ffi_type *__get_ffi_type_pointer();

#endif

%}

! !

!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.

"

!

documentation

"

    instances of me are used to interface to external library functions (as found in a dll/shared object).

    When a special external-call pragma such as:

	<api: bool MessageBeep(uint)>

    is encountered by the parser in a method, the compiler generates a call via

	<correspondingExternalLibraryFunctionObject> invokeWithArguments: argumentArray.

    In the invoke method, the library is checked to be loaded (and loaded if not already),

    the arguments are converted to C and pushed onto the C-stack, the function is called,

    and finally, the return value is converted back from C to a smalltalk object.

"

!

example

"

								[exBegin]

	|f|

	f := ExternalLibraryFunction new.

	f name:'MessageBeep'

	  module:'user32.dll'

	  callType:#WINAPI

	  returnType:#boolean

	  argumentTypes:#(uint).

	f invokeWith:1.

								[exEnd]

"

! !

!ExternalLibraryFunction class methodsFor:'instance creation'!

name:functionName module:moduleName returnType:returnType argumentTypes:argTypes

    ^ self new

	name:functionName module:moduleName

	returnType:returnType argumentTypes:argTypes

    "Created: / 01-08-2006 / 15:19:08 / cg"

! !

!ExternalLibraryFunction class methodsFor:'class initialization'!

dllPath

    ^ DLLPATH ? #( '.' )

!

dllPath:aCollectionOfDirectoryPathNames

    DLLPATH := aCollectionOfDirectoryPathNames

!

initialize

    "using inline access to corresponding c--defines to avoid duplicate places of knowledge"

    FLAG_VIRTUAL := %{ __MKSMALLINT(__EXTL_FLAG_VIRTUAL) %}.                "/ a virtual c++ call

    FLAG_NONVIRTUAL := %{ __MKSMALLINT(__EXTL_FLAG_NONVIRTUAL) %}.          "/ a non-virtual c++ call

    FLAG_UNLIMITEDSTACK := %{ __MKSMALLINT(__EXTL_FLAG_UNLIMITEDSTACK) %}.  "/ unlimitedstack under unix

    FLAG_ASYNC := %{ __MKSMALLINT(__EXTL_FLAG_ASYNC) %}.                    "/ async under win32

    FLAG_RETVAL_IS_CONST := %{ __MKSMALLINT(__EXTL_FLAG_RETVAL_IS_CONST) %}."/ return value is not to be registered for finalization

    CALLTYPE_API := %{ __MKSMALLINT(__EXTL_CALLTYPE_API) %}.                "/ WINAPI-call (win32 only)

    CALLTYPE_C := %{ __MKSMALLINT(__EXTL_CALLTYPE_C) %}.                    "/ regular C-call (the default)

    CALLTYPE_V8 := %{ __MKSMALLINT(__EXTL_CALLTYPE_V8) %}.                  "/ v8 call (sparc only)

    CALLTYPE_V9 := %{ __MKSMALLINT(__EXTL_CALLTYPE_V9) %}.                  "/ v9 call (sparc only)

    CALLTYPE_UNIX64 := %{ __MKSMALLINT(__EXTL_CALLTYPE_UNIX64) %}.          "/ unix64 call (alpha only)

    CALLTYPE_MASK := %{ __MKSMALLINT(__EXTL_CALLTYPE_MASK) %}.

    "

     self initialize

    "

    "Modified: / 03-10-2006 / 21:27:47 / cg"

! !

!ExternalLibraryFunction class methodsFor:'constants'!

callTypeAPI

    ^ CALLTYPE_API

    "Modified: / 01-08-2006 / 13:44:41 / cg"

!

callTypeC

    ^ CALLTYPE_C

    "Modified: / 01-08-2006 / 13:44:49 / cg"

!

callTypeCDecl

    ^ CALLTYPE_C

    "Modified: / 01-08-2006 / 13:44:52 / cg"

!

callTypeOLE

    ^ CALLTYPE_OLE

    "Modified: / 01-08-2006 / 13:44:57 / cg"

! !

!ExternalLibraryFunction methodsFor:'accessing'!

argumentTypes

    ^ argumentTypes

!

beAsync

    "let this execute in a separate thread, in par with the other execution thread(s).

     Ignored under unix/linux (until those support multiple threads too)."

    flags := (flags ? 0) bitOr: FLAG_ASYNC.

    "Created: / 01-08-2006 / 13:42:38 / cg"

!

beCallTypeAPI

    flags := (flags ? 0) bitOr: CALLTYPE_API.

    "Created: / 01-08-2006 / 15:12:40 / cg"

!

beCallTypeC

    flags := (flags ? 0) bitOr: CALLTYPE_C.

    "Created: / 01-08-2006 / 15:12:40 / cg"

!

beCallTypeOLE

    flags := (flags ? 0) bitOr: FLAG_VIRTUAL.

    "Created: / 01-08-2006 / 15:12:40 / cg"

!

beCallTypeUNIX64

    flags := (flags ? 0) bitOr: CALLTYPE_UNIX64.

    "Created: / 01-08-2006 / 15:13:38 / cg"

!

beCallTypeV8

    flags := (flags ? 0) bitOr: CALLTYPE_V8.

    "Created: / 01-08-2006 / 15:13:28 / cg"

!

beCallTypeV9

    flags := (flags ? 0) bitOr: CALLTYPE_V9.

    "Created: / 01-08-2006 / 15:13:31 / cg"

!

beCallTypeWINAPI

    self beCallTypeAPI

    "Modified: / 01-08-2006 / 15:14:02 / cg"

!

beConstReturnValue

    "specify that a pointer return value is not to be finalized

     (i.e. points to static data or data which is freed by c)"

    flags := (flags ? 0) bitOr: FLAG_RETVAL_IS_CONST.

    "Created: / 01-08-2006 / 13:56:48 / cg"

!

beNonVirtualCPP

    "specify this as a non-virtual c++-function"

    flags := (flags ? 0) bitOr: FLAG_NONVIRTUAL.

    "Created: / 01-08-2006 / 13:56:44 / cg"

!

beUnlimitedStack

    "let this execute on the c-stack (as opposed to the thread-stack)

     for unlimited auto-sized-stack under unix/linux.

     Ignored under windows."

    flags := (flags ? 0) bitOr: FLAG_UNLIMITEDSTACK.

    "Created: / 01-08-2006 / 13:41:54 / cg"

!

beVirtualCPP

    "specify this as a virtual c++-function"

    flags := (flags ? 0) bitOr: FLAG_VIRTUAL.

    "Created: / 01-08-2006 / 13:56:48 / cg"

!

callTypeNumber

    ^ (flags ? 0) bitAnd: CALLTYPE_MASK.

    "Created: / 01-08-2006 / 15:12:10 / cg"

!

isAsync

    "is this executed in a separate thread, in par with the other execution thread(s) ?"

    ^ (flags ? 0) bitTest: FLAG_ASYNC.

    "Created: / 01-08-2006 / 13:46:53 / cg"

!

isCPPFunction

    "is this a virtual or non-virtual c++-function ?"

    ^ (flags ? 0) bitTest: (FLAG_VIRTUAL bitOr: FLAG_NONVIRTUAL).

    "Created: / 01-08-2006 / 13:56:54 / cg"

!

isCallTypeAPI

    ^ ((flags ? 0) bitAnd: CALLTYPE_MASK) == CALLTYPE_API.

    "Created: / 01-08-2006 / 15:21:16 / cg"

!

isCallTypeC

    ^ ((flags ? 0) bitAnd: CALLTYPE_MASK) == CALLTYPE_C.

    "Created: / 01-08-2006 / 15:21:23 / cg"

!

isConstReturnValue

    "is the pointer return value not to be finalized

     (i.e. points to static data or data which is freed by c)"

    ^ (flags ? 0) bitTest: FLAG_RETVAL_IS_CONST.

    "Created: / 01-08-2006 / 13:56:48 / cg"

!

isNonVirtualCPP

    "is this a non-virtual c++-function ?"

    ^ (flags ? 0) bitTest: FLAG_NONVIRTUAL.

    "Created: / 01-08-2006 / 13:56:51 / cg"

!

isUnlimitedStack

    "will this execute on the c-stack (as opposed to the thread-stack)

     for unlimited auto-sized-stack under unix/linux.

     Ignored under windows."

    ^ (flags ? 0) bitTest: FLAG_UNLIMITEDSTACK.

    "Created: / 01-08-2006 / 14:17:07 / cg"

!

isVirtualCPP

    "is this a virtual c++-function ?"

    ^ (flags ? 0) bitTest: FLAG_VIRTUAL.

    "Created: / 01-08-2006 / 13:56:54 / cg"

! !

!ExternalLibraryFunction methodsFor:'invoking'!

invoke

    self hasCode ifFalse:[

        self prepareInvoke.

    ].

    ^ self invokeFFIWithArguments:nil

!

invokeCPPVirtualOn:anInstance

    self hasCode ifFalse:[

        self prepareInvoke.

    ].

    ^ self invokeCPPVirtualFFIOn:anInstance withArguments:nil

!

invokeCPPVirtualOn:instance with:arg

    self hasCode ifFalse:[

	self prepareInvoke.

    ].

    ^ self invokeCPPVirtualFFIOn:instance withArguments:(Array with:arg)

!

invokeCPPVirtualOn:instance with:arg1 with:arg2

    self hasCode ifFalse:[

	self prepareInvoke.

    ].

    ^ self invokeCPPVirtualFFIOn:instance withArguments:(Array with:arg1 with:arg2)

!

invokeCPPVirtualOn:instance with:arg1 with:arg2 with:arg3

    self hasCode ifFalse:[

	self prepareInvoke.

    ].

    ^ self invokeCPPVirtualFFIOn:instance withArguments:(Array with:arg1 with:arg2 with:arg3)

!

invokeCPPVirtualOn:instance with:arg1 with:arg2 with:arg3 with:arg4

    self hasCode ifFalse:[

	self prepareInvoke.

    ].

    ^ self invokeCPPVirtualFFIOn:instance withArguments:(Array with:arg1 with:arg2 with:arg3 with:arg4)

!

invokeCPPVirtualOn:instance withArguments:args

    self hasCode ifFalse:[

        self prepareInvoke.

    ].

    ^ self invokeCPPVirtualFFIOn:instance withArguments:args

!

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 forCPPInstance:nil

    "Modified: / 01-08-2006 / 16:04:08 / cg"

! !

!ExternalLibraryFunction methodsFor:'printing'!

printOn:aStream

    aStream nextPutAll:'<'.

    self isCallTypeAPI ifTrue:[

	'API:' printOn:aStream.

    ] ifFalse:[

	'C:' printOn:aStream.

    ].

    aStream nextPutAll:' '.

    name printOn:aStream.

    moduleName notNil ifTrue:[

	aStream nextPutAll:' module:'.

	moduleName printOn:aStream.

    ].

    aStream nextPutAll:'>'.

    "Modified: / 01-08-2006 / 15:21:42 / cg"

! !

!ExternalLibraryFunction methodsFor:'private'!

adjustTypes

    argumentTypes notNil ifTrue:[

	argumentTypes := argumentTypes collect:[:argType | self ffiTypeSymbolForType:argType].

    ].

    returnType := self ffiTypeSymbolForType:returnType.

!

linkToModule

    "link this function to the external module.

     I.e. retrieve the module handle and the code pointer."

    |handle moduleNameUsed functionName|

    name isNumber ifTrue:[

        self isCPPFunction ifTrue:[

            "/ no need to load a dll.   

            ^ self

        ]

    ].

    (moduleNameUsed := moduleName) isNil ifTrue:[

        owningClass isNil ifTrue:[

            self error:'Missing moduleName'.

        ].   

        moduleNameUsed := owningClass theNonMetaclass libraryName asSymbol.

    ].

    moduleHandle isNil ifTrue:[ 

        handle := self loadLibrary:moduleNameUsed.

        handle isNil ifTrue:[

            self error:'Cannot load module: ', moduleNameUsed.

        ].

        moduleHandle := handle.

    ].

    name isNumber ifFalse:[

        functionName := name.

        (moduleHandle getFunctionAddress:functionName into:self) isNil ifTrue:[