// Support routines for use with TclObj.
// Copyright 1991 Manticore, Inc.  All Rights Reserved.
// 
// You may freely copy, distribute and reuse the code in this example.
// Manticore disclaims any warranty of any kind, expressed or
// implied, as to its fitness for any particular use.

#import "TclApp.h"
#import "TclObj.h"
#include <strings.h>
#include <stdlib.h>
#import <appkit/Application.h>
#import <appkit/publicWraps.h>
#import <objc/objc-runtime.h>
#import <appkit/defaults.h>

typedef double (*DPROC)();
typedef float (*FPROC)();

#define TCLBUFLEN 2048
static char tclBuf[TCLBUFLEN];  // common command building buffer

// usage: echo [<arg1> .... <argn>]
//
// Sends the strings <arg1> through <argn> to the debugging window.
// If <arg1> is '-n' then no newline is appended at the end of output.
//
static int
tclEcho(tclobj, interp, argc, argv)
id tclobj;
Tcl_Interp *interp;
int argc;
char *argv[];
{
	int i;
	int newline = 1;
	
	for (i = 1; i < argc; i++) {
		if (i == 1 && strcmp(argv[i], "-n") == 0) {
			newline = 0;
		} else {
			[tclobj addText:argv[i]];
			if ((i + 1) < argc) {
				[tclobj addText:" "];
			}
		}
	}
	if (newline) {
		[tclobj addText:"\n"];
	}
	[tclobj cursorVisible];
	
	Tcl_Return(interp, NULL, TCL_STATIC);
	return TCL_OK;	
}

// usage: argc
//
// Returns the value of NXArgc.
//
static int
tclArgc(data, interp, argc, argv)
ClientData data;
Tcl_Interp *interp;
int argc;
char *argv[];
{

	sprintf(tclBuf, "%d", NXArgc);
	Tcl_Return(interp, tclBuf, TCL_STATIC);
	return TCL_OK;	
}

// usage: argv <index>
//
// Returns the value of NXArgv[<index>].
//
static int
tclArgv(data, interp, argc, argv)
ClientData data;
Tcl_Interp *interp;
int argc;
char *argv[];
{

	strcpy(tclBuf, NXArgv[atoi(argv[1])]);
	Tcl_Return(interp, tclBuf, TCL_STATIC);
	return TCL_OK;	
}

// This routine is used to convert procedure calls from the Tcl method of
// calling a procedure with a set of strings as its arguments to the method
// of argument passing that C and Objective-C use. The routine is normally
// called from Tcl after having been configured by a call to Tcl_CreateCommand.
// The <user data> argument contains a pointer to an instance of 'TCLARGS'
// structure. This structure contains a pointer to the actual procedure to
// be called and a string representing the types of arguments and return
// values that the actual procedure expects. The routine converts the
// set of string arguments passed in by Tcl into the form expected by
// the procedure, calls the procedure, and then reformats the result into
// a string and passes it back to Tcl.
// The first character in <argument types> gives the expected result from the
// procedure call. After the procedure is called the return value will be
// converted to a string according to this code and placed at the front of the 
// result string. The codes for the result are:
 
//	' ':	Ignore the result.
//	'i':	The result is a 32 bit integer
//	'f':	The result is a float.
//  'd':	The result is a double.
//  '*':	The result is a pointer to a null terminated character string.
//  '@':	The result is an object id.
//  '-':	The result is passed back as the result of the procedure
//			In this case Tcl_Return is not called.
//
// Following the result indicator character in the <arg types> string come
// the argument type characters. Each argument type character is used to
// convert the next argument string into the proper type so that it can
// be passed in the message. One type of argument is a direct value, such as
// an integer or float. Another type of argument is a pointer to some data
// such as a point type which is a pointer to an array of 2 floats. A third
// type of argument is a pointer to an area where a result will be stored. In
// this case, on return, the values that were returned will be converted
// to character form and appended to the result string. An example of this
// is a point that is being returned. The argument type characters are:
//
//  'i':	Integer.
//	'I':	Pointer to an integer to be returned.
//  'f':	Float.
//	'F':	Pointer to a float to be returned.
//  'd':	Double.
//	'D':	Pointer to a double to be returned.
//  '*':	Pointer to character string.
//  '@':	id.
//	':':	Message selector.
//  'p':	pointer to a 2 element float array.
//	'q':	pointer to a 4 element float array.
//	'P':	pointer to a 2 element float array to be returned.
//	'Q':	pointer to a 4 element float array to be returned.
//	'^':	pointer to a 'char *' which, after the message is sent,
//          holds a pointer to a string which is fetched and returned.
//
static int
tclCall(data, interp, argc, argv)
TCLARGS *data;
Tcl_Interp *interp;
int argc;
char *argv[];
{
	char *at;  // pointer to the arg types string
	int arg[10];  // direct arguments
	int a = 0;  // next available element in arg
	float fret;  // float return value
	double dret;  // double return value
	int iret = TCL_OK;  // integer return value
	int i;  // current argument number
	int c;  // current argument type character
	float farg[20];  // floating indirect arguments
	int iarg[20];  // int indirect arguments
	double darg[20];  // double indirect arguments
	int fa = 0;  // next avail cell in farg
	int ia = 0;  // next avail cell in iarg
	int da = 0;  // next avail cell in darg
	char rt[10];  // return data types
	char rx[10];  // index of data for return
	int rn = 0;  // number of returns
	char rat;  // return type code
	IPROC pptr;  // pointer to procedure to call
	
	if (data->argtypes[0] == '\0') {
		pptr = data->proc;
		rat = argv[1][0];  // get arguments desc. from the first arg
		at = &argv[1][1];
		argv += 2;  // move to first real argument
	} else {
		pptr = data->proc;
		rat = data->argtypes[0];  // get argument desc. from data passed in
		at = &data->argtypes[1];
		argv++;  // move to first real argument
	}
	
	// convert args
	while (c = *at++) {
		switch (c) {
	
		case 'i':
		case '@':
			arg[a++] = atoi(*argv++);
			break;
			
		case 'I':
			arg[a++] = (int)&iarg[ia];
			rt[rn] = 'I';
			rx[rn] = ia;
			rn++;
			ia += 1;
			break;
			
		case 'F':
			arg[a++] = (int)&farg[fa];
			rt[rn] = 'F';
			rx[rn] = fa;
			rn++;
			fa += 1;
			break;
			
		case 'D':
			arg[a++] = (int)&darg[ia];
			rt[rn] = 'D';
			rx[rn] = da;
			rn++;
			da += 1;
			break;
			
		case ':':
			arg[a++] = (int)sel_getUid(*argv++);
			break;
			
		case '*':
			arg[a++] = (int)*argv++;
			break;
			
		case 'f':
			sscanf(*argv++, "%f", &arg[a]);
			a++;
			break;
			
		case 'd':
			sscanf(*argv++, "%F", &arg[a]);
			a += 2;
			break;
			
		case 'p':
			sscanf(*argv++, "%f %f", &farg[fa], &farg[fa + 1]);
			arg[a++] = (int)&farg[fa];
			fa += 2;
			break;
			
		case 'q':
			sscanf(*argv++, "%f %f %f %f", &farg[fa], &farg[fa + 1],
				&farg[fa + 2], &farg[fa + 3]);			
			arg[a++] = (int)&farg[fa];
			fa += 4;
			break;
			
		case 'P':
			arg[a++] = (int)&farg[fa];
			rt[rn] = 'P';
			rx[rn] = fa;
			rn++;
			fa += 2;
			break;
			
		case 'Q':
			arg[a++] = (int)&farg[fa];
			rt[rn] = 'Q';
			rx[rn] = fa;
			rn++;
			fa += 4;
			break;
			
		case '^':
			arg[a++] = (int)&iarg[ia];
			rt[rn] = '^';
			rx[rn] = ia;
			rn++;
			ia++;
			break;
		}
	}
	
	// send the message and convert the return value 
	switch (rat) {
		
	case '*':
	 	iret = (*pptr)(arg[0], arg[1], arg[2], arg[3],
			arg[4], arg[5], arg[6], arg[7], arg[8], arg[9]);
		if (iret) {
			strncpy(tclBuf, (char *)iret, 1023);
			tclBuf[1023] = '\0';  // in case returned string was long
		} else {
			tclBuf[0] = '\0';
		}
		break;
		
	case 'f':
	 	fret = (*(FPROC)(*pptr))(arg[0], arg[1], arg[2],
			arg[3], arg[4], arg[5], arg[6], arg[7], arg[8], arg[9]);
		sprintf(tclBuf, "%g", fret);
		break;
		
	case 'd':
	 	dret = (*(DPROC)(*pptr))(arg[0], arg[1], arg[2],
			arg[3], arg[4], arg[5], arg[6], arg[7], arg[8], arg[9]);
		sprintf(tclBuf, "%g", dret);
		break;
		
	case 'i':
	case '@':
	 	iret = (*pptr)(arg[0], arg[1], arg[2], arg[3],
			arg[4], arg[5], arg[6], arg[7], arg[8], arg[9]);
		sprintf(tclBuf, "%d", iret);
		break;
		
	case '-':
	 	iret = (*pptr)(arg[0], arg[1], arg[2], arg[3],
			arg[4], arg[5], arg[6], arg[7], arg[8], arg[9]);
		break;
	
	default:
	 	(*pptr)(arg[0], arg[1], arg[2], arg[3], arg[4],
			arg[5], arg[6], arg[7], arg[8], arg[9]);
		strcpy(tclBuf, "");
		break;
	}
	
	// convert argument results
	if (rat == '-') {
		return iret;
	} else {
		for (i = 0; i < rn; i++) {
			switch(rt[i]) {
			
			case 'P':
				sprintf(&tclBuf[strlen(tclBuf)], " %g %g", farg[rx[i]],
					farg[rx[i] + 1]);
				break;
			
			case 'Q':
				sprintf(&tclBuf[strlen(tclBuf)], " %g %g %g %g", farg[rx[i]],
					farg[rx[i] + 1], farg[rx[i] + 2], farg[rx[i] + 3]);
				break;
				
			case '^':
				strncat(tclBuf, (char *)iarg[rx[i]],
					TCLBUFLEN - strlen(tclBuf));
				tclBuf[TCLBUFLEN - 1] = 0;  // in case strncat clips
				break;
				
			case 'I':
				sprintf(&tclBuf[strlen(tclBuf)], " %d", iarg[rx[i]]);
				break;
				
			case 'F':
				sprintf(&tclBuf[strlen(tclBuf)], " %g", farg[rx[i]]);
				break;
				
			case 'D':
				sprintf(&tclBuf[strlen(tclBuf)], " %g", darg[rx[i]]);
				break;
			} 		
		}
	}
		
	Tcl_Return(interp, tclBuf, TCL_STATIC);
	return TCL_OK;	
}

// Add new commands to tcl interpreter <interp>
//
void
addTclCmds(Tcl_Interp *interp, id objid)
{
	TCLARGS *p;
	
	// register procedures that are called directly from Tcl
	Tcl_CreateCommand(interp, "echo", tclEcho, objid, NULL);	
	Tcl_CreateCommand(interp, "argc", tclArgc, 0, NULL);	
	Tcl_CreateCommand(interp, "argv", tclArgv, 0, NULL);	

	// register procedures that will be called via the tclCall routine
	for (p = tclProcInitTab; p->name; p++) {
		Tcl_CreateCommand(interp, p->name, tclCall, p, NULL);
	}
}
