# HG changeset patch # User Claus Gittinger # Date 1145961207 -7200 # Node ID 41c391bfbf03eb0936154389b1ce1eefdd1009dd # Parent 734c7c432461b7af4cacc7cc1bf7f6515b3b4e2b *** empty log message *** diff -r 734c7c432461 -r 41c391bfbf03 ExternalLibraryFunction.st --- a/ExternalLibraryFunction.st Mon Apr 24 10:49:16 2006 +0200 +++ b/ExternalLibraryFunction.st Tue Apr 25 12:33:27 2006 +0200 @@ -1,6 +1,6 @@ " COPYRIGHT (c) 2004 by eXept Software AG - All Rights Reserved + 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 @@ -19,12 +19,38 @@ category:'System-Support' ! +!ExternalLibraryFunction primitiveDefinitions! +%{ +# include + +# 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 + 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 @@ -33,15 +59,30 @@ 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 +name:functionName module:moduleName callType:callType + returnType:returnType argumentTypes:argTypes ^ self new - name:functionName module:moduleName callType:callType - returnType:returnType argumentTypes:argTypes + name:functionName module:moduleName callType:callType + returnType:returnType argumentTypes:argTypes ! ! !ExternalLibraryFunction class methodsFor:'constants'! @@ -72,42 +113,42 @@ invoke self hasCode ifFalse:[ - self prepareInvoke. + self prepareInvoke. ]. ^ self invokeFFIWithArguments:#() ! invokeWith:arg self hasCode ifFalse:[ - self prepareInvoke. + self prepareInvoke. ]. ^ self invokeFFIWithArguments:(Array with:arg) ! invokeWith:arg1 with:arg2 self hasCode ifFalse:[ - self prepareInvoke. + self prepareInvoke. ]. ^ self invokeFFIWithArguments:(Array with:arg1 with:arg2) ! invokeWith:arg1 with:arg2 with:arg3 self hasCode ifFalse:[ - self prepareInvoke. + 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 prepareInvoke. ]. ^ self invokeFFIWithArguments:(Array with:arg1 with:arg2 with:arg3 with:arg4) ! invokeWithArguments:argArray self hasCode ifFalse:[ - self prepareInvoke. + self prepareInvoke. ]. ^ self invokeFFIWithArguments:argArray ! ! @@ -127,79 +168,66 @@ !ExternalLibraryFunction methodsFor:'private'! invokeFFIWithArguments:arguments - |ffiArgTypes failureCode| + |argTypeSymbols returnTypeSymbol failureCode| argumentTypes notNil ifTrue:[ - ffiArgTypes := argumentTypes collect:[:argType | self ffiArgTypeForType:argType]. + argTypeSymbols := argumentTypes collect:[:argType | self ffiTypeSymbolForType:argType]. ]. + returnTypeSymbol := self ffiTypeSymbolForType:returnType. + %{ -#if defined(i386) -# ifndef STX_FFI_TYPE_VOID -# 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 13 -# define STX_FFI_TYPE_POINTER 14 - -# define MAX_NUMARGS 128 -typedef void * ffi_type; -# endif - - void *argValues[MAX_NUMARGS]; - ffi_type *argtypes[MAX_NUMARGS]; + 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 (ffiArgTypes != nil) { - if (! __isArray(ffiArgTypes)) goto error; - if (__arraySize(ffiArgTypes) != numArgs) goto error; + 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(ffiArgTypes)) goto error; - if (__arraySize(ffiArgTypes) != numArgs) goto error; + if (! __isArray(argTypeSymbols)) goto error; + if (__arraySize(argTypeSymbols) != numArgs) goto error; } - if (numArgs > MAX_NUMARGS) { + if (numArgs > MAX_ARGS) { failureCode = @symbol(TooManyArguments); goto error; } + for (i=0; ia_element[i]) ) { - case STX_FFI_TYPE_VOID: - case STX_FFI_TYPE_INT: - case STX_FFI_TYPE_FLOAT: - case STX_FFI_TYPE_DOUBLE: - case STX_FFI_TYPE_LONGDOUBLE: - case STX_FFI_TYPE_UINT8: - case STX_FFI_TYPE_SINT8: - case STX_FFI_TYPE_UINT16: - case STX_FFI_TYPE_SINT16: - case STX_FFI_TYPE_UINT32: - case STX_FFI_TYPE_SINT32: - case STX_FFI_TYPE_UINT64: - case STX_FFI_TYPE_SINT64: - case STX_FFI_TYPE_STRUCT: - case STX_FFI_TYPE_POINTER: - default: - failureCode = @symbol(UnknownArgumentType); - goto error; + 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; } -#else +# 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; @@ -219,7 +247,8 @@ 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 +# endif + error: ; %} ! @@ -231,26 +260,26 @@ |handle code| moduleName isNil ifTrue:[ - self error:'Missing moduleName'. + self error:'Missing moduleName'. ]. handle := ObjectFileLoader loadDynamicObject:moduleName. handle isNil ifTrue:[ - self error:'Cannot load module: ', moduleName. + 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. + self error:'Missing function: ', name, ' in module: ', moduleName. ]. ! prepareInvoke self hasCode ifFalse:[ - moduleHandle isNil ifTrue:[ - self linkToModule. - self setupFFI. - ]. + moduleHandle isNil ifTrue:[ + self linkToModule. + self setupFFI. + ]. ]. ! @@ -261,14 +290,211 @@ "/ #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)) != FFI_OK) -"/ #endif -"/ %} +"/ if (ffi_prep_cif(&cif, FFI_DEFAULT_ABI, 1, &ffi_type_uint, args)) ! ! !ExternalLibraryFunction methodsFor:'private-accessing'! -name:functionName module:aModuleName callType:aCallType returnType:aReturnType argumentTypes:argTypes +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. @@ -279,5 +505,5 @@ !ExternalLibraryFunction class methodsFor:'documentation'! version - ^ '$Header: /cvs/stx/stx/libbasic/ExternalLibraryFunction.st,v 1.5 2006-04-24 08:49:16 cg Exp $' + ^ '$Header: /cvs/stx/stx/libbasic/ExternalLibraryFunction.st,v 1.6 2006-04-25 10:33:27 cg Exp $' ! !