"

 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.

"

ExecutableFunction subclass:#ExternalFunction

	 instanceVariableNames:''

	 classVariableNames:'InvalidCustomFunctionSignal'

	 poolDictionaries:''

	 category:'System-Support'

!

!ExternalFunction primitiveDefinitions!

%{

#ifdef NOTDEF /* already in stc.h */

    typedef int (* INTFUNC)();     /* a function returning an int */

#endif

%}   

! !

!ExternalFunction primitiveFunctions!

%{

/*

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

 * cast it to an int

 *

 * CAVEAT: floats are not allowed.

 */

int

convertST_to_C(stObj) 

    OBJ stObj;

{

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

	    return (int)(__stringVal(stObj));

	}

	if (__isSmallInteger(stObj)) {

	    return (int)(__intVal(stObj));

	}

	if (__isCharacter(stObj)) {

	    return (int)(__intVal(__characterVal(stObj)));

	}

	if (stObj == true) {

	    return 1;

	}

	if (stObj == false) {

	    return 0;

	}

	if (stObj == nil) {

	    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.

    Also, the class provides access to custom functions 

    These custom functions enable you to call c functions even if no

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

    You can register your own custom C-functions and relink ST/X from the

    binaries.

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

    Non custom externalFunctions provide the basic low level mechanism

    to call external C functions (as loaded dynamically by the ObjectLoader)

    - however, this is still in construction and 

      NOT yet published for general use.

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

    mechanism.

"

! !

!ExternalFunction class methodsFor:'initialization'!

initialize

    InvalidCustomFunctionSignal isNil ifTrue:[

	InvalidCustomFunctionSignal := ExecutionErrorSignal newSignalMayProceed:true.

	InvalidCustomFunctionSignal nameClass:self message:#invalidCustomFunctionSignal.

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

    ]

! !

!ExternalFunction class methodsFor:'Signal constants'!

invalidCustomFunctionSignal

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

     called for."

    ^ InvalidCustomFunctionSignal

! !

!ExternalFunction class methodsFor:'custom functions'!

callCustomFunction:nr

    ^ self callCustomFunction:nr withArguments:#()

    "

     ExternalFunction callCustomFunction:0

     ExternalFunction callCustomFunction:999 

    "

!

callCustomFunction:nr with:arg

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

    "

     ExternalFunction callCustomFunction:1 with:'hello world'

    "

!

callCustomFunction:nr with:arg1 with:arg2

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

    "

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

    "

!

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

    ^ self callCustomFunction:nr 

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

!

callCustomFunction:nr withArguments:argArray

    |retVal called|

%{

    extern int stxNCustomFunctions;

    extern CUSTOMFUNCTION customFunctions[];

    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 = customFunctions[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

    |index|

    index := self indexOfCustomFunctionNamed:name.

    index notNil ifTrue:[

	^ self callCustomFunction:index withArguments:argArray

    ].

    "

     no such function exists

    "

    InvalidCustomFunctionSignal raise

    "

     ExternalFunction callCustomFunctionNamed:'demoFunction0'

				withArguments:#()

    "

!

indexOfCustomFunctionNamed:functionName

%{  /* NOCONTEXT */

    extern int stxNCustomFunctions;

    extern CUSTOMFUNCTION customFunctions[];

    if (__isString(functionName)) {

	char *nm;

	int i;

	nm = _stringVal(functionName);

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

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

		RETURN (_MKSMALLINT(i));

	   }

	}

    }

%}.

    ^ nil

    "

     ExternalFunction indexOfCustomFunctionNamed:'demoFunction0'  

     ExternalFunction indexOfCustomFunctionNamed:'fooBar' 

    "

! !

!ExternalFunction methodsFor:'function calling'!

call

    "call the underlying C function, passing no argument.

     The return value is interpreted as an integer 

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

    "

%{

    INTFUNC func;

    int retVal;

    func = (INTFUNC) _INST(code_);

    retVal = (*func)();

    RETURN (__MKINT(retVal));

%}

!

callWith:arg

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

     The argument arg is converted to a corresponding C data type,

     as defined in the convertST_to_C() function.

     The return value is interpreted as an integer 

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

    "

%{

    INTFUNC func;

    int retVal;

    func = (INTFUNC) _INST(code_);

    retVal = (*func)(convertST_to_C(arg));

    RETURN (__MKINT(retVal));

%}

!

callWithArguments:argArray

    "call the underlying C function, passing up to 10 arguments.

     The arguments are converted to a corresponding C data type,

     as defined in the convertST_to_C() function.

     The return value is interpreted as an integer 

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

    "

%{

    INTFUNC func;

#   define NUMARGS 10

    int args[NUMARGS];

    int retVal;

    OBJ *ap;

    if (__isArray(argArray)) {

	int n = _arraySize(argArray);

	int i;

	if (n <= 10) {

	    ap = _ArrayInstPtr(argArray)->a_element;

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

		args[i] = convertST_to_C(*ap++);

	    }

	}

	func = (INTFUNC) _INST(code_);

	switch (n) {

	    case 0:

		retVal = (*func)();

		break;

	    case 1:

		retVal = (*func)(args[0]);

		break;

	    case 2:

		retVal = (*func)(args[0], args[1]);

		break;

	    case 3:

		retVal = (*func)(args[0], args[1], args[2]);

		break;

	    case 4:

		retVal = (*func)(args[0], args[1], args[2], args[3]);

		break;

	    case 5:

		retVal = (*func)(args[0], args[1], args[2], args[3],

				 args[4]);

		break;

	    case 6:

		retVal = (*func)(args[0], args[1], args[2], args[3],

				 args[4], args[5]);

		break;

	    case 7:

		retVal = (*func)(args[0], args[1], args[2], args[3],

				 args[4], args[5], args[6]);

		break;

	    case 8:

		retVal = (*func)(args[0], args[1], args[2], args[3],

				 args[4], args[5], args[6], args[7]);

		break;

	    case 9:

		retVal = (*func)(args[0], args[1], args[2], args[3],

				 args[4], args[5], args[6], args[7],

				 args[8]);

		break;

	    case 10:

		retVal = (*func)(args[0], args[1], args[2], args[3],

				 args[4], args[5], args[6], args[7],

				 args[8], args[9]);

		break;

	    default:

		goto err;

	}

	RETURN (__MKINT(retVal));

    }

  err: ;

%}.

    self primitiveFailed

! !

!ExternalFunction class methodsFor:'documentation'!

version

    ^ '$Header: /cvs/stx/stx/libbasic/ExternalFunction.st,v 1.1 1996-01-11 13:51:36 cg Exp $'

! !

ExternalFunction initialize!