"

 COPYRIGHT (c) 1994 by Claus Gittinger

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

ExecutableFunction subclass:#ExternalFunction

	instanceVariableNames:'name moduleHandle'

	classVariableNames:'InvalidCustomFunctionSignal'

	poolDictionaries:''

	category:'System-Support'

!

!ExternalFunction primitiveDefinitions!

%{

typedef INT  (*LINTFUNC)();

%}

! !

!ExternalFunction primitiveFunctions!

%{

/*

 * given an ST-object, make something useful for C

 * cast it to an int

 *

 * CAVEAT: floats are not allowed.

 */

INT

    OBJ stObj;

{

	INT flags, nInst;

	OBJ *oP;

	if (__isString(stObj) || __isSymbol(stObj)) {

	    return (INT)(__stringVal(stObj));

	}

	if (__isByteArray(stObj)) {

	    return (INT)(__ByteArrayInstPtr(stObj)->ba_element);

	}

	if (__isExternalBytes(stObj)) {

	    return (INT)(__externalBytesAddress(stObj));

	}

	if (__isExternalAddress(stObj)) {

	    return (INT)(__externalAddressVal(stObj));

	}

	if (__isExternalFunction(stObj)) {

	    return (INT)(__externalFunctionVal(stObj));

	}

	if (__isSmallInteger(stObj)) {

	    return (INT)(__intVal(stObj));

	}

	if (__isLargeInteger(stObj)) {

	    return (INT)(__signedLongIntVal(stObj));

	}

	if (__isCharacter(stObj)) {

	    return (INT)(__intVal(__characterVal(stObj)));

	}

	if (stObj == nil) {

	    return 0;

	}

	if (__qClass(stObj) == @global(ShortFloat)) {

	    return (INT)(__shortFloatVal(stObj));

	}

	flags = __intVal(__ClassInstPtr(__qClass(stObj))->c_flags) & ARRAYMASK;

	nInst = __intVal(__ClassInstPtr(__qClass(stObj))->c_ninstvars);

	oP = (OBJ *)__InstPtr(stObj)->i_instvars[nInst];

	if (flags & FLOATARRAY) {

	    return (INT)(oP);

	}

	if (flags & DOUBLEARRAY) {

	    return (INT)(oP);

	}

	if (flags & DOUBLEARRAY) {

	    return (INT)(oP);

	}

	if (flags & BYTEARRAY) {

	    return (INT)(oP);

	}

	if (flags & WORDARRAY) {

	    return (INT)(oP);

	}

	if (flags & LONGARRAY) {

	    return (INT)(oP);

	}

	if (flags & SWORDARRAY) {

	    return (INT)(oP);

	}

	if (flags & SLONGARRAY) {

	    return (INT)(oP);

	}

	if (stObj == true) {

	    return 1;

	}

	if (stObj == false) {

	    return 0;

	}

	return 0;

}

! !

!ExternalFunction class methodsFor:'documentation'!

copyright

"

 COPYRIGHT (c) 1994 by Claus Gittinger

	      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 this class represent external (non-Smalltalk) functions.

    (they are kind of what user-primitives are in ST-80).

    You can register your own custom C-functions in a private main.c

    and relink ST/X from the binaries.

    (see the demo functions provided in main.c).

    If you have the stc compiler, we recommend using inline primitive

    code: its much easier to enter, compile, debug and maintain.

    (especially, to maintain, since the primitive code is contained

     external to the classLibraries).

    and returned by the ObjectFileHandles>>getFunction: method.

    The C functions contained in that lib are callable (instances of myself)

    with the call / callWith: methods.

    ST-arguments are converted to C as follows:

	ST class            C argument

	------------------------------

	SmallInteger        int

	LargeInteger        int (must be 4-byte unsigned largeInteger)

	String              char *

	Symbol              char *

	Character           int

	ExternalBytes       char *

	ExternalAddress     char *

	ExternalFunction    char *

	FloatArray          float *

	DoubleArray         double *

	ByteArray           char *

	ShortFloat          float

	true                1

	false               0

    The returned value is converted to an unsigned integer (smallInteger or largeInteger).

    Notice, that no doubles can be passed; the reason is that the calling

    conventions (on stack, in registers, in FPU registers etc.) are so different among

    to program here. To pass doubles, either use shortFloats, or pack them into a DoubleArray.

    For functions with up to 2 double arguments, specialized call methods are provided.

    Sorry for that inconvenience.

      general use. For now, either use inline C-code, or use the customFunction call

      mechanism.

    [author:]

	Claus Gittinger

    [see also:]

	ExternalAddress ExternalBytes

	( how to write primitive code :html: programming/primitive.html )

"

!

examples

"

    see a sample demo c file in doc/coding/cModules;

    compile and link (shared) it to an object module.

    Load it into the system:

	handle := ObjectFileLoader loadDynamicObject:'demo1.o'.

    get a C-function (an instance of ExternalFunction):

	f := handle getFunction:'function1'.

    call it:

	f callWith:999

"

! !

!ExternalFunction class methodsFor:'initialization'!

initialize

    "create signals"

    InvalidCustomFunctionSignal isNil ifTrue:[

	InvalidCustomFunctionSignal := ExecutionError newSignalMayProceed:true.

	InvalidCustomFunctionSignal nameClass:self message:#invalidCustomFunctionSignal.

	InvalidCustomFunctionSignal notifierString:'attempt to execute unknown custom function'.

    ]

    "Modified: 22.4.1996 / 18:08:55 / cg"

! !

!ExternalFunction class methodsFor:'Signal constants'!

invalidCustomFunctionSignal

    "return the signal raised when a non existent custom function is

     called for."

    ^ InvalidCustomFunctionSignal

! !

!ExternalFunction class methodsFor:'calling custom functions'!

callCustomFunction:nr

    "call the custom function #nr without arguments"

    ^ self callCustomFunction:nr withArguments:#()

    "

     ExternalFunction callCustomFunction:0

    "

    "Modified: 22.4.1996 / 18:06:52 / cg"

!

callCustomFunction:nr with:arg

    "call the custom function #nr with a single argument"

    ^ self callCustomFunction:nr withArguments:(Array with:arg)

    "

     ExternalFunction callCustomFunction:1 with:'hello world'

    "

    "Modified: 22.4.1996 / 18:07:03 / cg"

!

callCustomFunction:nr with:arg1 with:arg2

    "call the custom function #nr with two arguments"

    ^ self callCustomFunction:nr withArguments:(Array with:arg1 with:arg2)

    "

     ExternalFunction callCustomFunction:2 with:(Float pi) with:1.0

    "

    "Modified: 22.4.1996 / 18:07:11 / cg"

!

callCustomFunction:nr with:arg1 with:arg2 with:arg3

    "call the custom function #nr with three arguments"

		withArguments:(Array with:arg1 with:arg2 with:arg3)

    "Modified: 22.4.1996 / 18:07:18 / cg"

!

callCustomFunction:nr withArguments:argArray

    "call the custom function #nr with arguments from argArray"

    |retVal called|

%{

#ifndef __stxNCustomFunctions__

    extern int __stxNCustomFunctions__;

    extern CUSTOMFUNCTION __stxCustomFunctions__[];

#endif

    int (* func)();

    called = false;

    if (__isSmallInteger(nr) && __isArray(argArray)) {

	int nargs = __arraySize(argArray);

	int functionNr;

	functionNr = __intVal(nr);

	if ((functionNr >= 0) && (functionNr < __stxNCustomFunctions__)) {

	    /*

	     * now, call the function; passing nargs and arg-vector

	     */

	    func = __stxCustomFunctions__[functionNr].func;

	    if (func) {

		int ok;

		retVal = self;

		ok = (*func)(nargs, &retVal, __ArrayInstPtr(argArray)->a_element);

		if (ok) {

		    RETURN (retVal);

		}

		called = true;

	    }

	}

    }

%}.

    called ifTrue:[

	"

	 the customFunction returned 0 (failure)

	"

	^ self primitiveFailed

    ].

    "

     an invalid customFunction-nr was given,

    "

    InvalidCustomFunctionSignal raise

    "

     ExternalFunction callCustomFunction:2 withArguments:#(1.0 1.0)

     ExternalFunction callCustomFunction:999 withArguments:#(1.0 1.0)

    "

!

callCustomFunctionNamed:name withArguments:argArray

    "call a custom function by name with arguments from argArray"

    |index|

    index := self indexOfCustomFunctionNamed:name.

    index notNil ifTrue:[

	^ self callCustomFunction:index withArguments:argArray

    ].

    "

     no such function exists

    "

    InvalidCustomFunctionSignal raise

    "

     ExternalFunction callCustomFunctionNamed:'demoFunction0'

				withArguments:#()

    "

    "Modified: 22.4.1996 / 18:08:09 / cg"

!

indexOfCustomFunctionNamed:functionName

    "return the index of a named custom function"

%{  /* NOCONTEXT */

#ifndef __stxNCustomFunctions__

    extern int __stxNCustomFunctions__;

    extern CUSTOMFUNCTION __stxCustomFunctions__[];

#endif

    if (__isString(functionName)) {

	char *nm;

	int i;

	nm = (char *)__stringVal(functionName);

	for (i=0; i < __stxNCustomFunctions__; i++) {

	   if (strcmp(__stxCustomFunctions__[i].name, nm) == 0) {

		RETURN (__MKSMALLINT(i));

	   }

	}

    }

%}.

    ^ nil

    "

    "

! !

!ExternalFunction class methodsFor:'queries'!

isBuiltInClass

    "return true if this class is known by the run-time-system.

     Here, true is returned for myself, false for subclasses."

    ^ self == ExternalFunction

    "Created: 16.4.1996 / 11:24:50 / cg"

    "Modified: 23.4.1996 / 15:58:55 / cg"

! !

!ExternalFunction methodsFor:'accessing'!

moduleHandle

    "return the functions moduleHandle (nil if not loaded dynamically)"

    ^ moduleHandle

!

name

    "return the functions name"

    ^ name

! !

!ExternalFunction methodsFor:'function calling'!

call

    "call the underlying C function, passing no argument.

     (and must be converted to an externalBytes object,

      if it is a pointer to something).

     DANGER alert: This is an unprotected low-level entry.

     Not for normal application usage.

    "

%{

    LINTFUNC func;

    INT retVal;

    func = (LINTFUNC) __INST(code_);

    if (func) {

	retVal = (*func)();

	RETURN (__MKINT(retVal));

    }

%}.

    self primitiveFailed

!

callO

    "call the underlying C function, passing no argument.

     The return value must be a valid object.

     DANGER alert: This is an unprotected low-level entry.

     Not for normal application usage.

    "

%{

    OBJFUNC func;

    OBJ retVal;

    func = (OBJFUNC) __INST(code_);

    if (func) {

	retVal = (*func)();

	RETURN (retVal);

    }

%}.

    self primitiveFailed

!

callOWith:arg

    "call the underlying C function, passing a single object argument.

     DANGER alert: This is an unprotected low-level entry.

     Not for normal application usage.

    "

%{

    OBJFUNC func;

    OBJ retVal;

    func = (OBJFUNC) __INST(code_);

    if (func) {

	retVal = (*func)(arg);

	RETURN (retVal);

    }

%}.

    self primitiveFailed

!

callOWith:arg1 with:arg2

    "call the underlying C function, passing two args.

     DANGER alert: This is an unprotected low-level entry.

     Not for normal application usage.

    "

%{

    OBJFUNC func;

    OBJ retVal;

    func = (OBJFUNC) __INST(code_);

    if (func) {

	retVal = (*func)(arg1, arg2);