/* find length of a compound item's data sequence */
int compounddatalen P1C(LVAL, x)
{
switch (ntype(x)) {
case OBJECT:
{
LVAL n = send_message(x, sk_data_length);
if (! fixp(n) || getfixnum(n) < 0) xlerror("bad length", n);
return((int) getfixnum(n));
}
case CONS:
return(llength(x));
case DARRAY:
x = getdarraydata(x);
if (stringp(x))
xlbadtype(x);
/* fall through */
case VECTOR:
case TVEC:
return(gettvecsize(x));
case SYMBOL:
if (null(x)) return(0);
default:
xlbadtype(x);
return(0);
}
}
LOCAL LVAL getlinalgdata P4C(int, off, int, n, LVAL, arg, int, type)
{
LVAL x;
x = darrayp(arg) ? getdarraydata(arg) : arg;
if (! tvecp(x))
xlbadtype(arg);
if (off < 0 || n < 0 || gettvecsize(x) < off + n)
xlerror("incompatible with access indices", x);
switch (type) {
case IN:
if (gettvectype(x) != CD_INT)
xlbadtype(x);
break;
case RE:
switch(gettvectype(x)) {
case CD_FLOTYPE:
case CD_DOUBLE:
break;
default:
xlbadtype(x);
}
break;
case CX:
switch(gettvectype(x)) {
case CD_CXFLOTYPE:
case CD_DCOMPLEX:
break;
default:
xlbadtype(x);
}
break;
}
return x;
}
/* xstring - return a string consisting of a single character */
LVAL xstring(void)
{
LVAL arg;
/* get the argument */
arg = xlgetarg();
xllastarg();
/* make sure its not NIL */
if (null(arg))
xlbadtype(arg);
/* check the argument type */
switch (ntype(arg)) {
case STRING:
return (arg);
case SYMBOL:
return (getpname(arg));
case CHAR:
buf[0] = (int)getchcode(arg);
buf[1] = '\0';
return (cvstring(buf));
case FIXNUM:
buf[0] = getfixnum(arg);
buf[1] = '\0';
return (cvstring(buf));
default:
xlbadtype(arg);
return NIL; /* never happens */
}
}
/* xlgetfname - get a filename */
LVAL xlgetfname(V)
{
LVAL name;
/* get the next argument */
name = xlgetarg();
/* get the filename string */
#ifdef FILETABLE
if (streamp(name) && getfile(name) > CONSOLE)
/* "Steal" name from file stream */
name = cvstring(filetab[getfile(name)].tname);
else
#endif
if (symbolp(name))
name = getpname(name);
else if (!stringp(name))
xlbadtype(name);
if (getslength(name) >= FNAMEMAX)
xlerror("file name too long", name);
/* return the name */
return (name);
}
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));
}
/* xformat - formatted output function */
LVAL xformat(void)
{
unsigned char *fmt;
LVAL stream,val;
int ch;
/* protect stream in case it is a new ustream */
xlsave1(stream);
/* get the stream and format string */
stream = xlgetarg();
if (stream == NIL)
val = stream = newustream();
else {
if (stream == s_true)
stream = getvalue(s_stdout);
else if (!streamp(stream) && !ustreamp(stream))
xlbadtype(stream);
val = NIL;
}
fmt = getstring(xlgastring());
/* process the format string */
while ((ch = *fmt++))
if (ch == '~') {
switch (*fmt++) {
case '\0':
xlerror("expecting a format directive",cvstring((char *) (fmt-1)));
case 'a': case 'A':
xlprint(stream,xlgetarg(),FALSE);
break;
case 's': case 'S':
xlprint(stream,xlgetarg(),TRUE);
break;
case '%':
xlterpri(stream);
break;
case '~':
xlputc(stream,'~');
break;
case '\n':
case '\r':
/* mac may read \r -- this should be ignored */
if (*fmt == '\r') fmt++;
while (*fmt && *fmt != '\n' && isspace(*fmt))
++fmt;
break;
default:
xlerror("unknown format directive",cvstring((char *) (fmt-1)));
}
}
else
xlputc(stream,ch);
/* return the value */
if (val) val = getstroutput(val);
xlpop();
return val;
}
LOCAL VOID transposeinto P4C(LVAL, x, int, m, int, n, LVAL, y)
{
int i, j, in, jm;
x = compounddataseq(x);
y = compounddataseq(y);
if (! vectorp(x) && ! tvecp(x) && ! stringp(x)) xlbadtype(x);
if (! vectorp(y) && ! tvecp(y) && ! stringp(y)) xlbadtype(y);
checknonneg(n);
checknonneg(m);
checktvecsize(x, n * m);
checktvecsize(y, n * m);
for (i = 0, in = 0; i < m; i++, in += n)
for (j = 0, jm = 0; j < n; j++, jm += m)
settvecelement(y, jm + i, gettvecelement(x, in + j));
}
/* xlgkfixnum - get a fixnum keyword argument */
int xlgkfixnum P2C(LVAL, key, LVAL *, pval)
{
if (xlgetkeyarg(key,pval)) {
if (!fixp(*pval))
xlbadtype(*pval);
return (TRUE);
}
return (FALSE);
}
unsigned long lisp2ulong P1C(LVAL, x)
{
unsigned long n = 0;
switch (ntype(x)) {
case FIXNUM:
if (getfixnum(x) < 0)
xlbadtype(x);
n = getfixnum(x);
break;
#ifdef BIGNUMS
case BIGNUM:
if (! cvtbigulong(x, &n))
xlbadtype(x);
break;
#endif /* BIGNUMS */
default: xlbadtype(x);
}
return n;
}
/* ARRAY-DATA-ADDRESS array */
LVAL xarraydata_addr()
{
LVAL x = xlgetarg();
xllastarg();
switch (ntype(x)) {
case DARRAY: x = getdarraydata(x); /* and drop through */
case VECTOR:
case STRING:
case TVEC: return newnatptr(gettvecdata(x), x);
default: return xlbadtype(x);
}
}
LOCAL LVAL linalg2genvec P2C(LVAL, x, int, n)
{
LVAL y;
if (! tvecp(x)) xlbadtype(x);
if (n <= 0 || gettvecsize(x) < n) xlfail("bad dimensions");
xlsave1(y);
y = newvector(n);
xlreplace(y, x, 0, n, 0, n);
xlpop();
return y;
}
LOCAL VOID getsweepdata P2C(int, n, double **, pdx)
{
LVAL arg, x;
int size, type;
arg = xlgetarg();
x = darrayp(arg) ? getdarraydata(arg) : arg;
if (! tvecp(x)) xlbadtype(arg);
size = gettvecsize(x);
type = gettvectype(x);
if (size < n)
xlerror("incompatible size", arg);
switch(type) {
case CD_FLOTYPE:
case CD_DOUBLE:
break;
default:
xlbadtype(arg);
}
*pdx = ((double *) gettvecdata(x));
}
/* CALL-BY-ADDRESS &rest args */
LVAL xshlibcalladdr()
{
void *(*f)() = (void *(*)()) getnpaddr(xlganatptr());
void *a[MAX_CALLADDR_ARGS];
int n, i;
if (xlargc > MAX_CALLADDR_ARGS)
xltoomany();
for (n = xlargc, i = 0; i < n; i++) {
LVAL arg = xlgetarg();
if (fixp(arg))
a[i] = (void *) getfixnum(arg);
else if (natptrp(arg))
a[i] = getnpaddr(arg);
else
xlbadtype(arg);
}
switch (n) {
case 0: return cvvoidptr(f());
case 1: return cvvoidptr(f(a[0]));
case 2: return cvvoidptr(f(a[0],a[1]));
case 3: return cvvoidptr(f(a[0],a[1],a[2]));
case 4: return cvvoidptr(f(a[0],a[1],a[2],a[3]));
case 5: return cvvoidptr(f(a[0],a[1],a[2],a[3],a[4]));
case 6: return cvvoidptr(f(a[0],a[1],a[2],a[3],a[4],a[5]));
case 7: return cvvoidptr(f(a[0],a[1],a[2],a[3],a[4],a[5],a[6]));
case 8: return cvvoidptr(f(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7]));
case 9: return cvvoidptr(f(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8]));
case 10: return cvvoidptr(f(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],
a[9]));
case 11: return cvvoidptr(f(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],
a[9],a[10]));
case 12: return cvvoidptr(f(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],
a[9],a[10],a[11]));
case 13: return cvvoidptr(f(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],
a[9],a[10],a[11],a[12]));
case 14: return cvvoidptr(f(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],
a[9],a[10],a[11],a[12],a[13]));
case 15: return cvvoidptr(f(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],
a[9],a[10],a[11],a[12],a[13],a[14]));
case 16: return cvvoidptr(f(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],
a[9],a[10],a[11],a[12],a[13],a[14],a[15]));
default: xlfail("too many arguments"); return NIL;
}
}
/* compute the length of the result sequence */
LOCAL int findmaprlen P1C(LVAL, args)
{
LVAL next, e;
int len, rlen;
for (rlen = -1, next = args; consp(next); next = cdr(next)) {
e = car(next);
if (! listp(e) && ! vectorp(e) && ! tvecp(e))
xlbadtype(car(next));
len = seqlen(e);
if (rlen == -1)
rlen = len;
else
rlen = (len < rlen) ? len : rlen;
}
return(rlen);
}
LVAL xslinalg2gen(V)
{
LVAL x, d;
int trans;
x = xlgetarg();
d = xlgetarg();
trans = moreargs() ? ! null(xlgetarg()) : FALSE;
xllastarg();
if (fixp(d))
return linalg2genvec(x, getfixnum(d));
else if (consp(d) && consp(cdr(d)) && fixp(car(d)) && fixp(car(cdr(d))))
return linalg2genmat(x, getfixnum(car(d)), getfixnum(car(cdr(d))), trans);
else
xlbadtype(d);
return NIL;
}
/* Common Lisp REDUCE function (internal version) */
LVAL reduce P4C(LVAL, fcn,LVAL, sequence, int, has_init, LVAL, initial_value)
{
LVAL next, result;
int i, n;
/* protect some pointers */
xlstkcheck(3);
xlsave(next);
xlsave(result);
xlprotect(fcn);
switch (ntype(sequence)) {
case CONS:
next = sequence;
if (has_init) result = initial_value;
else {
result = car(next);
next = cdr(next);
}
for (; consp(next); next = cdr(next))
result = xsfuncall2(fcn, result, car(next));
break;
case VECTOR:
case TVEC:
n = gettvecsize(sequence);
i = 0;
if (has_init) result = initial_value;
else {
result = gettvecelement(sequence, 0);
i = 1;
}
for (; i < n; i++)
result = xsfuncall2(fcn, result, gettvecelement(sequence, i));
break;
default:
xlbadtype(sequence);
}
/* restore the stack frame */
xlpopn(3);
return(result);
}
LOCAL LVAL linalg2genmat P4C(LVAL, arg, int, m, int, n, int, trans)
{
LVAL x, y;
int mn;
x = compounddataseq(arg);
mn = m * n;
if (! tvecp(x)) xlbadtype(arg);
if (n <= 0 || m <= 0 || gettvecsize(x) < mn) xlfail("bad dimensions");
xlsave1(y);
y = newmatrix(m, n);
if (trans)
transposeinto(x, n, m, y);
else
xlreplace(getdarraydata(y), x, 0, mn, 0, mn);
xlpop();
return y;
}
/* get compound item's data sequence */
LVAL compounddataseq P1C(LVAL, x)
{
switch (ntype(x)) {
case OBJECT:
{
LVAL seq = send_message(x, sk_data_seq);
if (! listp(seq) && ! vectorp(seq) && ! tvecp(seq))
xlerror("not a sequence", seq);
return(seq);
}
case DARRAY: return(getdarraydata(x));
case CONS:
case VECTOR:
case TVEC: return(x);
case SYMBOL:
if (null(x)) return(x);
/* fall through */
default: return(xlbadtype(x));
}
}
/* xlgetfile - get a file or stream */
LVAL xlgetfile P1C(int, outflag)
{
LVAL arg;
/* get a file or stream (cons) or nil */
if (null(arg = xlgetarg()))
return outflag ? NIL : getvalue(s_stdin);
else if (streamp(arg)) {
if (getfile(arg) == CLOSED)
xlfail("file not open");
#ifdef BIGNUMS
if (arg->n_sflags & S_BINARY)
xlfail("binary file");
#endif
}
else if (arg == s_true)
return getvalue(s_termio);
else if (!ustreamp(arg))
xlbadtype(arg);
return arg;
}
long lisp2long P1C(LVAL, x)
{
if (! fixp(x))
xlbadtype(x);
return getfixnum(x);
}
LVAL xsgetsmdata(V)
{
LVAL s1, s2, arg;
LVAL x, y, xs, ys;
int n, ns, i, supplied, is_reg;
double xmin, xmax, *dx, *dxs;
s1 = xlgaseq();
s2 = xlgetarg();
arg = xlgetarg();
is_reg = ! null(xlgetarg());
xllastarg();
if (is_reg && ! seqp(s2))
xlbadtype(s2);
if (! seqp(arg) && ! fixp(arg))
xlbadtype(arg);
ns = (fixp(arg)) ? getfixnum(arg) : seqlen(arg);
supplied = (seqp(arg) && ns >= 1) ? TRUE : FALSE;
if (ns < 1) ns = NS_DEFAULT;
n = seqlen(s1);
if (n <= 0)
xlfail("sequence too short");
if (is_reg && seqlen(s2) != n)
xlfail("sequences not the same length");
xlstkcheck(4);
xlsave(x);
xlsave(y);
xlsave(xs);
xlsave(ys);
x = gen2linalg(s1, n, 1, s_c_double, FALSE);
y = is_reg ? gen2linalg(s2, n, 1, s_c_double, FALSE) : NIL;
xs = supplied ?
gen2linalg(arg, ns, 1, s_c_double, FALSE) : mktvec(ns, s_c_double);
ys = mktvec(ns, s_c_double);
if (! supplied) {
dx = REDAT(x);
dxs = REDAT(xs);
for (xmax = xmin = dx[0], i = 1; i < n; i++) {
if (dx[i] > xmax) xmax = dx[i];
if (dx[i] < xmin) xmin = dx[i];
}
for (i = 0; i < ns; i++)
dxs[i] = xmin + (xmax - xmin) * ((double) i) / ((double) (ns - 1));
}
xlnumresults = 0;
xlresults[xlnumresults++] = cvfixnum((FIXTYPE) n);
xlresults[xlnumresults++] = x;
xlresults[xlnumresults++] = y;
xlresults[xlnumresults++] = cvfixnum((FIXTYPE) ns);
xlresults[xlnumresults++] = xs;
xlresults[xlnumresults++] = ys;
xlpopn(4);
return xlresults[0];
}
