LOCAL VOID pushnextargs P4C(LVAL, fcn, int, n, LVAL, args, int, i)
{
LVAL *newfp, next, value = NULL;
/* build a new argument stack frame */
newfp = xlsp;
pusharg(cvfixnum((FIXTYPE)(newfp - xlfp)));
pusharg(fcn);
pusharg(cvfixnum((FIXTYPE)n));
/* push the arguments and shift the list pointers */
for (next = args; consp(next); next = cdr(next)) {
switch (ntype(car(next))) {
case VECTOR:
value = getelement(car(next), i);
break;
case TVEC:
value = gettvecelement(car(next), i);
break;
case CONS:
value = car(car(next));
rplaca(next, cdr(car(next)));
break;
}
pusharg(value);
}
/* establish the new stack frame */
xlfp = newfp;
}
LOCAL VOID set_hardware_address P3C(CPTR, ptr, LVAL, object, int *, type)
{
LVAL t, p, last, result, oblistsym, newoblist;
if (! objectp(object)) xlerror("not an object", object);
oblistsym = s_hardware_objects;
if (! consp(getvalue(oblistsym))) setvalue(oblistsym, NIL);
xlstkcheck(4);
xlsave(t);
xlsave(p);
xlsave(result);
xlsave(newoblist);
t = cvfixnum((FIXTYPE) time_stamp);
p = cvfixnum((FIXTYPE) ptr);
result = last = consa(object);
result = cons(p, result);
result = cons(t, result);
newoblist = cons(result, getvalue(oblistsym));
setvalue(oblistsym, newoblist);
set_slot_value(object, s_hardware_address, result);
for (;*type != NONE; type++, last = cdr(last)) {
t = cvfixnum((FIXTYPE) *type);
t = consa(t);
rplacd(last, t);
}
xlpopn(4);
}
/* evalhook - call the evalhook function */
LOCAL LVAL evalhook(LVAL expr)
{
LVAL *newfp,olddenv,val;
/* create the new call frame */
newfp = xlsp;
pusharg(cvfixnum((FIXTYPE)(newfp - xlfp)));
pusharg(getvalue(s_evalhook));
pusharg(cvfixnum((FIXTYPE)2));
pusharg(expr);
pusharg(cons(xlenv,xlfenv));
xlfp = newfp;
/* rebind the hook functions to nil */
olddenv = xldenv;
xldbind(s_evalhook,NIL);
xldbind(s_applyhook,NIL);
/* call the hook function */
val = xlapply(2);
/* unbind the symbols */
xlunbind(olddenv);
/* return the value */
return (val);
}
/* clisnew - initialize a new class */
LVAL clisnew(void)
{
LVAL self,ivars,cvars,super;
int n;
/* get self, the ivars, cvars and superclass */
self = xlgaobject();
ivars = xlgalist();
cvars = (moreargs() ? xlgalist() : NIL);
super = (moreargs() ? xlgaobject() : object);
xllastarg();
/* store the instance and class variable lists and the superclass */
setivar(self,IVARS,ivars);
setivar(self,CVARS,cvars);
setivar(self,CVALS,(cvars ? newvector(listlength(cvars)) : NIL));
setivar(self,SUPERCLASS,super);
/* compute the instance variable count */
n = listlength(ivars);
setivar(self,IVARCNT,cvfixnum((FIXTYPE)n));
n += getivcnt(super,IVARTOTAL);
setivar(self,IVARTOTAL,cvfixnum((FIXTYPE)n));
/* return the new class object */
return (self);
}
/* evpushargs - evaluate and push a list of arguments */
LOCAL int evpushargs(LVAL fun, LVAL args)
{
LVAL *newfp;
int argc;
/* protect the argument list */
xlprot1(args);
/* build a new argument stack frame */
newfp = xlsp;
pusharg(cvfixnum((FIXTYPE)(newfp - xlfp)));
pusharg(fun);
pusharg(NIL); /* will be argc */
/* evaluate and push each argument */
for (argc = 0; consp(args); args = cdr(args), ++argc)
pusharg(xleval(car(args)));
/* establish the new stack frame */
newfp[2] = cvfixnum((FIXTYPE)argc);
xlfp = newfp;
/* restore the stack */
xlpop();
/* return the number of arguments */
return (argc);
}
/* dotest2 - call a test function with two arguments */
int dotest2 P3C(LVAL, arg1, LVAL, arg2, LVAL, fun)
{
FRAMEP newfp;
/* Speedup for default case TAA MOD */
if (fun == getfunction(s_eql))
return (eql(arg1,arg2));
/* Speedup for EQ and EQUAL for hash tables */
if (fun == getfunction(s_eq))
return (arg1 == arg2);
if (fun == getfunction(s_equal))
return (equal(arg1,arg2));
/* create the new call frame */
newfp = xlsp;
pusharg(cvfixnum((FIXTYPE)(newfp - xlfp)));
pusharg(fun);
pusharg(cvfixnum((FIXTYPE)2));
pusharg(arg1);
pusharg(arg2);
xlfp = newfp;
/* return the result of applying the test function */
return (xlapply(2) != NIL);
}
VOID StGWObDoMouse P5C(LVAL, object, int, x, int, y, MouseEventType, type, MouseClickModifier, mods)
{
LVAL Lx, Ly, argv[6], olddenv;
int extend, option;
xlstkcheck(2);
xlsave(Lx);
xlsave(Ly);
argv[0] = object;
argv[2] = Lx = cvfixnum((FIXTYPE) x);
argv[3] = Ly = cvfixnum((FIXTYPE) y);
olddenv = xldenv;
xldbind(s_in_callback, s_true);
if (type == MouseClick) {
extend = ((int) mods) % 2;
option = ((int) mods) / 2;
argv[1] = sk_do_click;
argv[4] = (extend) ? s_true : NIL;
argv[5] = (option) ? s_true : NIL;
xscallsubrvec(xmsend, 6, argv);
}
else {
argv[1] = sk_do_motion;
xscallsubrvec(xmsend, 4, argv);
}
xlpopn(2);
xlunbind(olddenv);
}
/* callmacro - call a read macro */
LVAL callmacro(LVAL fptr, int ch)
{
LVAL *newfp;
/* create the new call frame */
newfp = xlsp;
pusharg(cvfixnum((FIXTYPE)(newfp - xlfp)));
pusharg(cdr(getelement(getvalue(s_rtable),ch)));
pusharg(cvfixnum((FIXTYPE)2));
pusharg(fptr);
pusharg(cvchar(ch));
xlfp = newfp;
return (xlapply(2));
}
/* xmkstrinput - make a string input stream */
LVAL xmkstrinput(void)
{
int start,end,len,i;
unsigned char *str;
LVAL string,val;
/* protect the return value */
xlsave1(val);
/* get the string and length */
string = xlgastring();
str = getstring(string);
len = getslength(string) - 1;
/* get the starting offset */
if (moreargs()) {
val = xlgafixnum();
start = (int)getfixnum(val);
}
else start = 0;
/* get the ending offset */
if (moreargs()) {
val = xlgafixnum();
end = (int)getfixnum(val);
}
else end = len;
xllastarg();
/* check the bounds */
if (start < 0 || start > len)
xlerror("string index out of bounds",cvfixnum((FIXTYPE)start));
if (end < 0 || end > len)
xlerror("string index out of bounds",cvfixnum((FIXTYPE)end));
/* make the stream */
val = newustream();
/* copy the substring into the stream */
for (i = start; i < end; ++i)
xlputc(val,str[i]);
/* restore the stack */
xlpop();
/* return the new stream */
return (val);
}
/* search for string within a string */
LVAL xstrsearch(void)
{
int start,end,pat_len,str_len;
unsigned char *pat,*str,*patptr,*strptr,*patend;
LVAL str1,str2;
/* get the strings */
str1 = xlgastring(); /* the pat */
str2 = xlgastring(); /* the string */
/* get the substring specifiers */
getbounds(str2, k_start, k_end, &start, &end);
/* setup the string pointers */
pat = getstring(str1);
str = &getstring(str2)[start];
pat_len = getslength(str1) - 1;
str_len = end - start;
patend = pat + pat_len;
for (; pat_len <= str_len; str_len--) {
patptr = pat;
strptr = str;
/* two outcomes: (1) no match, goto step (2) match, return */
while (patptr < patend) {
if (*patptr++ != *strptr++) goto step;
}
/* compute match index */
return cvfixnum(str - getstring(str2));
step:
str++;
}
/* no match */
return NIL;
}
static NODE *binary(NODE *args, int fcn)
{
long ival,iarg;
float fval,farg;
NODE *arg;
int imode;
arg = xlarg(&args);
if (((arg) && (arg)->n_type == 5)) {
ival = ((arg)->n_info.n_xint.xi_int);
imode = 1;
}
else if (((arg) && (arg)->n_type == 9)) {
fval = ((arg)->n_info.n_xfloat.xf_float);
imode = 0;
}
else
xlerror("bad argument type",arg);
if (fcn == '-' && args == (NODE *)0)
if (imode)
ival = -ival;
else
fval = -fval;
while (args) {
arg = xlarg(&args);
if (((arg) && (arg)->n_type == 5))
if (imode) iarg = ((arg)->n_info.n_xint.xi_int);
else farg = (float)((arg)->n_info.n_xint.xi_int);
else if (((arg) && (arg)->n_type == 9))
if (imode) { fval = (float)ival; farg = ((arg)->n_info.n_xfloat.xf_float); imode = 0; }
else farg = ((arg)->n_info.n_xfloat.xf_float);
else
xlerror("bad argument type",arg);
if (imode)
switch (fcn) {
case '+': ival += iarg; break;
case '-': ival -= iarg; break;
case '*': ival *= iarg; break;
case '/': checkizero(iarg); ival /= iarg; break;
case '%': checkizero(iarg); ival %= iarg; break;
case 'M': if (iarg > ival) ival = iarg; break;
case 'm': if (iarg < ival) ival = iarg; break;
case '&': ival &= iarg; break;
case '|': ival |= iarg; break;
case '^': ival ^= iarg; break;
default: badiop();
}
else
switch (fcn) {
case '+': fval += farg; break;
case '-': fval -= farg; break;
case '*': fval *= farg; break;
case '/': checkfzero(farg); fval /= farg; break;
case 'M': if (farg > fval) fval = farg; break;
case 'm': if (farg < fval) fval = farg; break;
case 'E': fval = pow(fval,farg); break;
default: badfop();
}
}
return (imode ? cvfixnum(ival) : cvflonum(fval));
}
/* xdigitp - built-in function 'digit-char-p' */
LVAL xdigitp(void)
{
int ch;
ch = getchcode(xlgachar());
xllastarg();
return (isdigit(ch) ? cvfixnum((FIXTYPE)(ch - '0')) : NIL);
}
/* xlapp1 - apply a function of a single argument */
LVAL xlapp1 P2C(LVAL, fun, LVAL, arg)
{
FRAMEP newfp;
/* create the new call frame */
newfp = xlsp;
pusharg(cvfixnum((FIXTYPE)(newfp - xlfp)));
pusharg(fun);
pusharg(cvfixnum((FIXTYPE)1));
pusharg(arg);
xlfp = newfp;
/* return the result of applying the function */
return xlapply(1);
}
LVAL xseispackrs(V)
{
int nm, n, matz, ierr;
LVAL a, w, z, fv1, fv2;
double *da, *dw, *dz, *dfv1, *dfv2;
nm = getfixnum(xlgafixnum());
n = getfixnum(xlgafixnum());
a = xlgetarg();
w = xlgetarg();
matz = getfixnum(xlgafixnum());
z = xlgetarg();
fv1 = xlgetarg();
fv2 = xlgetarg();
xllastarg();
checkldim(nm, n);
da = getlinalgdvec(0, nm * n, a);
dw = getlinalgdvec(0, n, w);
dz = (matz != 0) ? getlinalgdvec(0, nm * n, z) : NULL;
dfv1 = getlinalgdvec(0, n, fv1);
dfv2 = getlinalgdvec(0, n, fv2);
eispack_rs(nm, n, da, dw, matz, dz, dfv1, dfv2, &ierr);
return (ierr == 0) ? NIL : cvfixnum((FIXTYPE) ierr);
}
LVAL xssystem()
{
char *cmd;
int status;
LVAL stream = NIL;
FILE *p;
int ch;
cmd = (char *) getstring(xlgastring());
if (moreargs()) {
stream = xlgetarg();
if (stream == s_true)
stream = getvalue(s_stdout);
else if (!streamp(stream) && !ustreamp(stream))
xlbadtype(stream);
}
if (stream == NIL) {
status = system(cmd);
if (status == 127) xlfail("shell could not execute command");
}
else {
if ((p = popen(cmd, "r")) == NULL)
xlfail("could not execute command");
while ((ch = getc(p)) != EOF) xlputc(stream, ch);
status = pclose(p);
}
return(cvfixnum((FIXTYPE) status));
}
/* xcharint - convert an integer to a character */
LVAL xcharint(void)
{
LVAL arg;
arg = xlgachar();
xllastarg();
return (cvfixnum((FIXTYPE)getchcode(arg)));
}
LOCAL LVAL datareduce1 P4C(subrfun, f, subrfun, bf, LVAL, nullval, int, count)
{
LVAL fcn, x, result;
switch (xlargc) {
case 0: result = nullval; break;
case 1:
if (compoundp(peekarg(0))) {
xlstkcheck(2);
xlsave(x);
xlsave(fcn);
fcn = cvsubr(bf, SUBR, 0);
x = subr_map_elements(f);
x = compounddataseq(x);
result = reduce(fcn, x, FALSE, NIL);
xlpopn(2);
}
else result = (count) ? cvfixnum((FIXTYPE) 1) : xlgetarg();
break;
default:
xlsave1(x);
x = makearglist(xlargc, xlargv);
result = xlcallsubr1(f, x);
xlpop();
}
return(result);
}
/* xcharcode - built-in function 'char-code' */
LVAL xcharcode(void)
{
int ch;
ch = getchcode(xlgachar());
xllastarg();
return (cvfixnum((FIXTYPE)ch));
}
/* getbounds - get the start and end bounds of a string */
LOCAL void getbounds(LVAL str, LVAL skey, LVAL ekey, int *pstart, int *pend)
{
LVAL arg;
int len;
/* get the length of the string */
len = getslength(str) - 1;
/* get the starting index */
if (xlgkfixnum(skey,&arg)) {
*pstart = (int)getfixnum(arg);
if (*pstart < 0 || *pstart > len)
xlerror("string index out of bounds",arg);
}
else
*pstart = 0;
/* get the ending index */
if (xlgkfixnum(ekey,&arg)) {
*pend = (int)getfixnum(arg);
if (*pend < 0 || *pend > len)
xlerror("string index out of bounds",arg);
}
else
*pend = len;
/* make sure the start is less than or equal to the end */
if (*pstart > *pend)
xlerror("starting index error",cvfixnum((FIXTYPE)*pstart));
}
LVAL xlc_snd_save(void)
{
LVAL arg1 = xlgetarg();
long arg2 = getfixnum(xlgafixnum());
unsigned char * arg3 = getstring(xlgastring());
long arg4 = getfixnum(xlgafixnum());
long arg5 = getfixnum(xlgafixnum());
long arg6 = getfixnum(xlgafixnum());
long arg7 = getfixnum(xlgafixnum());
double arg8 = 0.0;
long arg9 = 0;
double arg10 = 0.0;
LVAL arg11 = xlgetarg();
double result;
xllastarg();
result = sound_save(arg1, arg2, arg3, arg4, arg5, arg6, arg7, &arg8, &arg9, &arg10, arg11);
{ LVAL *next = &getvalue(RSLT_sym);
*next = cons(NIL, NIL);
car(*next) = cvflonum(arg8); next = &cdr(*next);
*next = cons(NIL, NIL);
car(*next) = cvfixnum(arg9); next = &cdr(*next);
*next = cons(NIL, NIL);
car(*next) = cvflonum(arg10);
}
return cvflonum(result);
}
LVAL xseispackch(V)
{
int nm, n, matz, ierr;
LVAL ar, ai, w, zr, zi, fv1, fv2, fm1;
double *dar, *dai, *dw, *dzr, *dzi, *dfv1, *dfv2, *dfm1;
nm = getfixnum(xlgafixnum());
n = getfixnum(xlgafixnum());
ar = xlgetarg();
ai = xlgetarg();
w = xlgetarg();
matz = getfixnum(xlgafixnum());
zr = xlgetarg();
zi = xlgetarg();
fv1 = xlgetarg();
fv2 = xlgetarg();
fm1 = xlgetarg();
xllastarg();
checkldim(nm, n);
dar = getlinalgdvec(0, nm * n, ar);
dai = getlinalgdvec(0, nm * n, ai);
dw = getlinalgdvec(0, n, w);
dzr = (matz != 0) ? getlinalgdvec(0, nm * n, zr) : NULL;
dzi = (matz != 0) ? getlinalgdvec(0, nm * n, zi) : NULL;
dfv1 = getlinalgdvec(0, n, fv1);
dfv2 = getlinalgdvec(0, n, fv2);
dfm1 = getlinalgdvec(0, 2 * n, fm1);
eispack_ch(nm, n, dar, dai, dw, matz, dzr, dzi, dfv1, dfv2, dfm1, &ierr);
return (ierr == 0) ? NIL : cvfixnum((FIXTYPE) ierr);
}
/******************************************************************************
* Prim_SYSTEM - run a process, sending output (if any) to stdout/stderr
*
* syntax: (system <command line>)
* <command line> is a string to be sent to the subshell (sh).
*
* Returns T if the command executed succesfully, otherwise returns the
* integer shell exit status for the command.
*
* Added to XLISP by Niels Mayer
******************************************************************************/
LVAL Prim_SYSTEM()
{
extern LVAL true;
extern int sys_nerr;
extern char *sys_errlist[];
extern int errno;
LVAL command;
int result;
char temptext[1024];
/* get shell command */
command = xlgastring();
xllastarg();
/* run the process */
result = system((char *) getstring(command));
if (result == -1) { /* if a system error has occured */
if (errno < sys_nerr)
(void) sprintf(temptext, "Error in system(3S): %s\n", sys_errlist[errno]);
else
(void) strcpy(temptext, "Error in system(3S): unknown error\n");
xlfail(temptext);
}
/* return T if success (exit status 0), else return exit status */
return (result ? cvfixnum(result) : true);
}
/******************************************************************************
* Prim_PCLOSE - close a pipe opened by Prim_POPEN().
* (code stolen from xlfio.c:xclose())
*
* syntax: (pclose <stream>)
* <stream> is a stream created by popen.
* returns T if the command executed successfully, otherwise,
* returns the exit status of the opened command.
*
* Added to XLISP by Niels Mayer
******************************************************************************/
LVAL Prim_PCLOSE()
{
extern LVAL true;
LVAL fptr;
int result;
/* get file pointer */
fptr = xlgastream();
xllastarg();
/* make sure the file exists */
if (getfile(fptr) == NULL)
xlfail("file not open");
/* close the pipe */
result = pclose(getfile(fptr));
if (result == -1)
xlfail("<stream> has not been opened with popen");
setfile(fptr,NULL);
/* return T if success (exit status 0), else return exit status */
return (result ? cvfixnum(result) : true);
}
/* dotest1 - call a test function with one argument */
int dotest1(LVAL arg, LVAL fun)
{
LVAL *newfp;
/* create the new call frame */
newfp = xlsp;
pusharg(cvfixnum((FIXTYPE)(newfp - xlfp)));
pusharg(fun);
pusharg(cvfixnum((FIXTYPE)1));
pusharg(arg);
xlfp = newfp;
/* return the result of applying the test function */
return (xlapply(1) != NIL);
}
/* xlength - return the length of a list or string */
LVAL xlength(void)
{
FIXTYPE n=0;
LVAL arg;
/* get the list or string */
arg = xlgetarg();
xllastarg();
/* find the length of a list */
if (listp(arg))
for (n = 0; consp(arg); n++)
arg = cdr(arg);
/* find the length of a string */
else if (stringp(arg))
n = (FIXTYPE)getslength(arg)-1;
/* find the length of a vector */
else if (vectorp(arg))
n = (FIXTYPE)getsize(arg);
/* otherwise, bad argument type */
else
xlerror("bad argument type",arg);
/* return the length */
return (cvfixnum(n));
}
/* Built in COMPOUND-DATA-LENGTH */
LVAL xscompound_length(V)
{
LVAL x;
x = checkcompound(xlgetarg());
xllastarg();
return(cvfixnum((FIXTYPE) compounddatalen(x)));
}
/* SHLIB-INIT funtab &optional (version -1) (oldest version) */
LVAL xshlibinit()
{
LVAL subr, val, sym;
xlshlib_modinfo_t *info = getnpaddr(xlganatptr());
FUNDEF *p = info->funs;
FIXCONSTDEF *pfix = info->fixconsts;
FLOCONSTDEF *pflo = info->floconsts;
STRCONSTDEF *pstr = info->strconsts;
struct version_info defversion;
defversion.current = moreargs()?getfixnum(xlgafixnum()):-1;
defversion.oldest = moreargs()?getfixnum(xlgafixnum()):defversion.current;
xllastarg();
if (! check_version(&defsysversion, &(info->sysversion)))
xlfail("shared library not compatible with current system");
if (defversion.current >= 0 &&
! check_version(&defversion, &(info->modversion)))
xlfail("module not compatible with requested version");
xlsave1(val);
val = NIL;
if (p != NULL)
for (val = NIL; (p->fd_subr) != (LVAL(*)(void)) NULL; p++) {
subr = cvsubr(p->fd_subr, p->fd_type & TYPEFIELD, 0);
setmulvalp(subr, (p->fd_type & (TYPEFIELD + 1)) ? TRUE : FALSE);
val = cons(subr, val);
if (p->fd_name != NULL) {
sym = xlenter(p->fd_name);
setfunction(sym, subr);
}
}
if (pfix != NULL)
for (; pfix->name != NULL; pfix++) {
sym = xlenter(pfix->name);
defconstant(sym, cvfixnum(pfix->val));
}
if (pflo != NULL)
for (; pflo->name != NULL; pflo++) {
sym = xlenter(pflo->name);
defconstant(sym, cvflonum(pflo->val));
}
if (pstr != NULL)
for (; pstr->name != NULL; pstr++) {
sym = xlenter(pstr->name);
defconstant(sym, cvstring(pstr->val));
}
if (info->sysversion.current >= MAKEVERSION(0,1)) {
ULONGCONSTDEF *pulong = info->ulongconsts;
if (pulong != NULL)
for (; pulong->name != NULL; pulong++) {
sym = xlenter(pulong->name);
defconstant(sym, ulong2lisp(pulong->val));
}
}
xlpop();
return xlnreverse(val);
}
LVAL xlc_seq_get(void)
{
seq_type arg1 = getseq(xlgaseq());
long arg2 = 0;
long arg3 = 0;
long arg4 = 0;
long arg5 = 0;
long arg6 = 0;
long arg7 = 0;
long arg8 = 0;
LVAL result;
xllastarg();
seq_get(arg1, &arg2, &arg3, &arg4, &arg5, &arg6, &arg7, &arg8);
{ LVAL *next = &getvalue(RSLT_sym);
*next = cons(NIL, NIL);
car(*next) = cvfixnum(arg2); next = &cdr(*next);
*next = cons(NIL, NIL);
car(*next) = cvfixnum(arg3); next = &cdr(*next);
*next = cons(NIL, NIL);
car(*next) = cvfixnum(arg4); next = &cdr(*next);
*next = cons(NIL, NIL);
car(*next) = cvfixnum(arg5); next = &cdr(*next);
*next = cons(NIL, NIL);
car(*next) = cvfixnum(arg6); next = &cdr(*next);
*next = cons(NIL, NIL);
car(*next) = cvfixnum(arg7); next = &cdr(*next);
*next = cons(NIL, NIL);
car(*next) = cvfixnum(arg8);
}
result = getvalue(RSLT_sym);
return result;
}
LVAL ulong2lisp P1C(unsigned long, x)
{
#ifdef BIGNUMS
if (x > MAXFIX)
return cvtulongbignum(x, 0);
else
#endif /* BIGNUMS */
return cvfixnum((FIXTYPE) x);
}
static LVAL newmatrix P2C(unsigned, r, unsigned, c)
{
LVAL rows, cols, dim, result;
xlstkcheck(3);
xlsave(rows);
xlsave(cols);
xlsave(dim);
rows = cvfixnum((FIXTYPE) r);
cols = cvfixnum((FIXTYPE) c);
dim = list2(rows, cols);
result = mkarray(dim, NIL, NIL, s_true);
xlpopn(3);
return(result);
}
