"{ Encoding: utf8 }"

"

 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' }"

"{ NameSpace: Smalltalk }"

ExternalFunction subclass:#ExternalLibraryFunction

	instanceVariableNames:'flags moduleName returnType argumentTypes owningClass'

	classVariableNames:'CALLTYPE_API CALLTYPE_C CALLTYPE_MASK CALLTYPE_OLE

		CALLTYPE_UNIX64 CALLTYPE_V8 CALLTYPE_V9 DLLPATH DllMapping

		FLAG_ASYNC FLAG_NONVIRTUAL FLAG_OBJECTIVEC FLAG_RETVAL_IS_CONST

		FLAG_UNLIMITEDSTACK FLAG_VIRTUAL LastModuleHandleHolder

		LastModuleHandleName Verbose FLAG_RETVAL_MUST_FREE TypeMap'

	poolDictionaries:''

	category:'System-Support'

!

!ExternalLibraryFunction primitiveDefinitions!

%{

#include "stxOSDefs.h"

#define VERBOSE

#ifdef VERBOSE

#  define DEBUGCODE_IF(flag, code) if ((flag) == true) {  code }

# else

#  define DEBUG_IF(flag, code) /* nothing */

# endif

#ifdef HAVE_FFI

# include <ffi.h>

# define MAX_ARGS    128

# ifdef USE_STANDARD_FFI

#  define __get_ffi_type_sint() &ffi_type_sint

#  define __get_ffi_type_sint8() &ffi_type_sint8

#  define __get_ffi_type_sint16() &ffi_type_sint16

#  define __get_ffi_type_sint32() &ffi_type_sint32

#  define __get_ffi_type_sint64() &ffi_type_sint64

#  define __get_ffi_type_uint() &ffi_type_uint

#  define __get_ffi_type_uint8() &ffi_type_uint8

#  define __get_ffi_type_uint16() &ffi_type_uint16

#  define __get_ffi_type_uint32() &ffi_type_uint32

#  define __get_ffi_type_uint64() &ffi_type_uint64

#  define __get_ffi_type_float() &ffi_type_float

#  define __get_ffi_type_double() &ffi_type_double

#  define __get_ffi_type_void() &ffi_type_void

#  define __get_ffi_type_pointer() &ffi_type_pointer

# else

   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();

   extern INTLFUNC __get_ffi_prep_cif();

   extern INTLFUNC __get_ffi_call();

#  ifdef _MINGW__

#   define ffi_prep_cif (*(__get_ffi_prep_cif()))

#   define ffi_call     (*(__get_ffi_call()))

#  endif

# endif

# define TYPE_UINT      __get_ffi_type_uint()

# define TYPE_UINT8     __get_ffi_type_uint8()

# define TYPE_UINT16    __get_ffi_type_uint16()

# define TYPE_UINT32    __get_ffi_type_uint32()

# define TYPE_UINT64    __get_ffi_type_uint64()

# define TYPE_SINT      __get_ffi_type_sint()

# define TYPE_SINT8     __get_ffi_type_sint8()

# define TYPE_SINT16    __get_ffi_type_sint16()

# define TYPE_SINT32    __get_ffi_type_sint32()

# define TYPE_SINT64    __get_ffi_type_sint64()

# define TYPE_POINTER   __get_ffi_type_pointer()

# define TYPE_FLOAT     __get_ffi_type_float()

# define TYPE_DOUBLE    __get_ffi_type_double()

# define TYPE_VOID      __get_ffi_type_void()

# define TYPE_STRUCT    FFI_TYPE_STRUCT // __get_ffi_type_struct()

#else /* NO FFI */

# define MAX_ARGS    15

# define TYPE_UINT      1

# define TYPE_UINT8     2

# define TYPE_UINT16    3

# define TYPE_UINT32    4

# define TYPE_UINT64    5

# define TYPE_SINT      11

# define TYPE_SINT8     12

# define TYPE_SINT16    13

# define TYPE_SINT32    14

# define TYPE_SINT64    15

# define TYPE_POINTER   20

# define TYPE_FLOAT     30

# define TYPE_DOUBLE    31

# define TYPE_VOID      40

# define FFI_DEFAULT_ABI        0

# define CALLTYPE_FFI_STDCALL   0

#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).

    Foreign function calls are based on the FFI library if available.

    A limited fallback implementation is provided for systems with no libffi.

    (this may have limitations on the supported argument types; for example,

     the x86_64 fallback does not support float/double arguments).

    Therefore the fallback should be considered a temporary workaround,

    until libffi has been ported.

    Inside a method, when a special external-call pragma such as:

	<api: bool MessageBeep(uint)>

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

	<correspondingExternalLibraryFunctionObject> invokeWithArguments: argumentArray.

    and the correspondingExternalLibraryFunctionObject is kept in the literal array.

    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.

    The parser supports the call-syntax of various other smalltalk dialects:

	Squeak / ST-X:

	    <cdecl:   [async] [virtual|nonVirtual][const] returnType functionNameStringOrIndex ( argType1..argTypeN ) module: moduleName >

	    <apicall: [async] [virtual|nonVirtual][const] returnType functionNameStringOrIndex ( argType1..argTypeN ) module: moduleName >

	Dolphin:

	    <stdcall: [virtual|nonVirtual][const] returnType functionNameStringOrIndex argType1..argTypeN>

	    <cdecl:   [virtual|nonVirtual][const] returnType functionNameStringOrIndex argType1..argTypeN>

	ST/V:

	    <api: functionName argType1 .. argTypeN returnType>

	    <ccall: functionName argType1 .. argTypeN returnType>

	    <ole: vFunctionIndex argType1 .. argTypeN returnType>

	VisualWorks:

	    <c: ...>

	    <c: #define NAME value>

"

!

example

"

								[exBegin]

	|f|

	f := ExternalLibraryFunction new.

	f beCallTypeWINAPI.

	f name:'MessageBeep'

	  module:'user32.dll'

	  returnType:#boolean

	  argumentTypes:#(uint).

	f invokeWith:1.

								[exEnd]

  Synchronous vs. Asynchronous calls:

    by default, foreign function calls are synchronous, effectively blocking the whole ST/X system

    (that is by purpose,´because most C-code is not prepared for being interrupted, and also, normal

     code is not prepared for a garbage collector to move objects around, while another C thread might

     access the data...).

    Therefore, the following will block all ST/X activity for 10 seconds

    (try interacting with the launcher while the Sleep is performing):

								[exBegin]

	|f|

	f := ExternalLibraryFunction new.

	f beCallTypeWINAPI.

	f name:'Sleep'

	  module:'kernel32.dll'

	  returnType:#void

	  argumentTypes:#(uint).

	f invokeWith:10000.

								[exEnd]

    if you know what you do and you do not pass any possibly moving objects (such as strings) as argument,

    the call can be made asynchronous. In that case, ONLY the calling thread will be blocked; all other smalltalk

    threads will continue to execute.

    (try interacting now with the launcher while the Sleep is performing):

								[exBegin]

	|f|

	f := ExternalLibraryFunction new.

	f beCallTypeWINAPI.

	f beAsync.

	f name:'Sleep'

	  module:'kernel32.dll'

	  returnType:#void

	  argumentTypes:#(uint).

	f invokeWith:10000.

								[exEnd]

"

! !

!ExternalLibraryFunction class methodsFor:'instance creation'!

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

    ^ self new

	name:functionName module:moduleName

	returnType:returnType argumentTypes:argTypes;

	callType:callTypeSymbol

    "Created: / 04-03-2019 / 11:00:57 / Claus Gittinger"

!

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

addToDllPath:aDirectoryPathName

    "can be used during initialization, to add more places for dll-loading"

    |oldPath newPath|

    oldPath := self dllPath.

    oldPath isNil ifTrue:[ oldPath := OrderedCollection new ].

    (oldPath includes:aDirectoryPathName) ifFalse:[

	newPath := oldPath asOrderedCollection.

	newPath add:aDirectoryPathName.

	self dllPath:newPath

    ]

    "

     self addToDllPath:'c:\matrix\API\dll'

    "

!

defaultDLLPath

    "return a default dll-path, as per operating system"

    |path try|

    path := OrderedCollection with:'.'.

    try := [:dir | dir asFilename exists ifTrue:[path add:dir]].

    OperatingSystem isUNIXlike ifTrue:[

	#(

	    '/lib'

	    '/usr/lib'

	    '/usr/local/lib'

	    '/opt/lib'

	    '/opt/local/lib'

	) do:try

    ].

    ^ path

    "

     self defaultDLLPath

    "

!

dllMapping

    "allows for dll's to be replaced,

     for example, if you want to use the mozilla sqlite dll

	C:\Program Files\Mozilla Firefox\mozsqlite3.dll

     for the sqlite3, execute:

	ExternalLibraryFunction

	    dllMapping at:'sqlite3'

	    put: 'C:\Program Files\Mozilla Firefox\mozsqlite3.dll'

     for mingw:

	ExternalLibraryFunction

	    dllMapping at:'sqlite3'

	    put:'C:\mingw64\opt\bin\libsqlite3-0.dll'

    "

    DllMapping isNil ifTrue:[

	DllMapping := Dictionary new.

    ].

    ^ DllMapping

    "Created: / 10-04-2012 / 12:21:45 / cg"

!

dllMapping:aDictionary

    "allows for dll's to be replaced,

     for example, if you want to use the mozilla sqlite dll

	C:\Program Files\Mozilla Firefox\mozsqlite3.dll

     for the sqlite3, execute:

	ExternalLibraryFunction

	    dllMapping at:'sqlite3'

	    put: 'C:\Program Files\Mozilla Firefox\mozsqlite3.dll'

     for mingw:

	ExternalLibraryFunction

	    dllMapping at:'sqlite3'

	    put:'C:\mingw64\opt\bin\libsqlite3-0.dll'

    "

    DllMapping := aDictionary

    "Created: / 26-11-2016 / 04:06:14 / cg"

!

dllMappingAt:baseLibname put:aNameOrPath

    "allows for dll's to be replaced,

     for example, if you want to use the mozilla sqlite dll

	C:\Program Files\Mozilla Firefox\mozsqlite3.dll

     for the sqlite3, execute:

	ExternalLibraryFunction

	    dllMappingAt:'sqlite3'

	    put: 'C:\Program Files\Mozilla Firefox\mozsqlite3.dll'

     for mingw:

	ExternalLibraryFunction

	    dllMappingAt:'sqlite3'

	    put:'C:\mingw64\opt\bin\libsqlite3-0.dll'

    "

    self dllMapping at:baseLibname put: aNameOrPath

!

dllPath

    "provide a default dllPath, where external libraries are searched for"

    ^ DLLPATH

    "

     ExternalLibraryFunction dllPath

    "

    "Modified (comment): / 12-02-2017 / 02:15:23 / cg"

!

dllPath:aCollectionOfDirectoryPathNames

    "provide a default dllPath, where external libraries are searched for"

    DLLPATH := aCollectionOfDirectoryPathNames

!

flushModuleHandlesForLibrary:aLibraryName

    self flushModuleHandlesForWhich:[:fn | fn moduleName = aLibraryName].

    "

     self flushModuleHandlesForLibrary:'ole32.dll'

    "

    "Created: / 12-11-2016 / 11:49:09 / cg"

!

flushModuleHandlesForWhich:aBlock

    self allInstancesDo:[:fn |

	(aBlock value:fn) ifTrue:[

	    fn setModuleHandle:nil.

	]

    ].

    "

     self flushModuleHandlesForLibrary:'ole32.dll'

    "

    "Created: / 12-11-2016 / 11:48:32 / cg"

!

initialize

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

    DLLPATH isNil ifTrue:[

	DLLPATH := self defaultDLLPath.

    ].

%{

#ifndef __SCHTEAM__

    @global(FLAG_VIRTUAL) = __MKSMALLINT(__EXTL_FLAG_VIRTUAL);                  // a virtual c++ call

    @global(FLAG_NONVIRTUAL) = __MKSMALLINT(__EXTL_FLAG_NONVIRTUAL);            // a non-virtual c++ call

    @global(FLAG_OBJECTIVEC) = __MKSMALLINT(__EXTL_FLAG_OBJECTIVEC);            // an objectiveC message send

    @global(FLAG_UNLIMITEDSTACK) = __MKSMALLINT(__EXTL_FLAG_UNLIMITEDSTACK);    // unlimitedstack under unix

    @global(FLAG_ASYNC) = __MKSMALLINT(__EXTL_FLAG_ASYNC);                      // async under win32

    @global(FLAG_RETVAL_IS_CONST) = __MKSMALLINT(__EXTL_FLAG_RETVAL_IS_CONST);    // retvalue is not to be registered for finalization

    @global(FLAG_RETVAL_MUST_FREE) = __MKSMALLINT(__EXTL_FLAG_RETVAL_MUST_FREE);  // retvalue is to be freed

    @global(CALLTYPE_API) = __MKSMALLINT(__EXTL_CALLTYPE_API);                  // WINAPI-call (win32 only)

    @global(CALLTYPE_C) = __MKSMALLINT(__EXTL_CALLTYPE_C);                      // regular C-call (the default)

    @global(CALLTYPE_V8) = __MKSMALLINT(__EXTL_CALLTYPE_V8);                    // v8 call (sparc only)

    @global(CALLTYPE_V9) = __MKSMALLINT(__EXTL_CALLTYPE_V9);                    // v9 call (sparc only)

    @global(CALLTYPE_UNIX64) = __MKSMALLINT(__EXTL_CALLTYPE_UNIX64);            // unix64 call (alpha only)

    @global(CALLTYPE_MASK) = __MKSMALLINT(__EXTL_CALLTYPE_MASK);

#endif

%}.

    "DLLPATH := nil.

     self initialize

    "

    "Modified: / 12-02-2017 / 23:43:23 / cg"

!

removeFromDllPath:aDirectoryPathName

    "remove added places from dll-loading"

    |oldPath|

    oldPath := self dllPath.

    oldPath notNil ifTrue:[

	self dllPath:(oldPath copyWithout:aDirectoryPathName)

    ].

    "

     |prevDllPath|

     prevDllPath := self dllPath.

     self removeFromDllPath:'C:\aaa\bbb'.

     self addToDllPath:'C:\aaa\bbb'.

     self assert:self dllPath size = (prevDllPath size + 1).

     self removeFromDllPath:'C:\aaa\bbb'.

     self assert:self dllPath size = (prevDllPath size).

    "

    "Modified (comment): / 23-07-2018 / 11:16:26 / Stefan Vogel"

! !

!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