This is TclApp.m in view mode; [Download] [Up]
// 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);
}
}
These are the contents of the former NiCE NeXT User Group NeXTSTEP/OpenStep software archive, currently hosted by Netfuture.ch.