LVAL xslpzgedi(V)
{
LVAL a, ipvt, det, work;
dcomplex *da, *ddet, *dwork;
int lda, offa, n, *dipvt, job, i, ilda;
a = xlgetarg();
offa = getfixnum(xlgafixnum());
lda = getfixnum(xlgafixnum());
n = getfixnum(xlgafixnum());
ipvt = xlgetarg();
det = xlgetarg();
work = xlgetarg();
job = getfixnum(xlgafixnum());
xllastarg();
checkldim(lda, n);
da = getlinalgzvec(offa, lda * n, a);
dipvt = getlinalgivec(0, n, ipvt);
ddet = (job / 10 != 0) ? getlinalgzvec(0, 2, det) : NULL;
dwork = getlinalgzvec(0, n, work);
if (job % 10 != 0)
for (i = 0, ilda = 0; i < n; i++, ilda += lda)
if (da[ilda + i].r == 0.0 && da[ilda + i].i == 0.0)
xlfail("matrix is (numerically) singular");
linpack_zgedi(da, lda, n, dipvt, ddet, dwork, job);
return NIL;
}
LVAL xslpzgesl(V)
{
LVAL a, ipvt, b;
dcomplex *da, *db;
int lda, offa, n, *dipvt, job, i, ilda;
a = xlgetarg();
offa = getfixnum(xlgafixnum());
lda = getfixnum(xlgafixnum());
n = getfixnum(xlgafixnum());
ipvt = xlgetarg();
b = xlgetarg();
job = getfixnum(xlgafixnum());
xllastarg();
checkldim(lda, n);
da = getlinalgzvec(offa, lda * n, a);
dipvt = getlinalgivec(0, n, ipvt);
db = getlinalgzvec(0, n, b);
for (i = 0, ilda = 0; i < n; i++, ilda += lda)
if (da[ilda + i].r == 0.0 && da[ilda + i].i == 0.0)
xlfail("matrix is (numerically) singular");
linpack_zgesl(da, lda, n, dipvt, db, job);
return NIL;
}
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 xsbasespline(V)
{
LVAL x, y, xs, ys, work;
double *dx, *dy, *dxs, *dys, *dwork;
int n, ns, error;
n = getfixnum(xlgafixnum());
x = xlgetarg();
y = xlgetarg();
ns = getfixnum(xlgafixnum());
xs = xlgetarg();
ys = xlgetarg();
work = xlgetarg();
xllastarg();
dx = getlinalgdvec(0, n, x);
dy = getlinalgdvec(0, n, y);
dxs = getlinalgdvec(0, ns, xs);
dys = getlinalgdvec(0, ns, ys);
dwork = getlinalgdvec(0, 2 * n, work);
error = fit_spline(n, dx, dy, ns, dxs, dys, dwork);
return error ? s_true : NIL;
}
LVAL xsbasekernelsmooth(V)
{
LVAL x, y, xs, ys, targ;
int n, ns, error, ktype;
double *dx, *dy, *dxs, *dys, width;
n = getfixnum(xlgafixnum());
x = xlgetarg();
y = xlgetarg();
ns = getfixnum(xlgafixnum());
xs = xlgetarg();
ys = xlgetarg();
width = makefloat(xlgetarg());
targ = xlgasymbol();
xllastarg();
dx = getlinalgdvec(0, n, x);
dy = null(y) ? NULL : getlinalgdvec(0, n, y);
dxs = getlinalgdvec(0, ns, xs);
dys = getlinalgdvec(0, ns, ys);
switch (getstring(getpname(targ))[0]) {
case 'U': ktype = 'U'; break;
case 'T': ktype = 'T'; break;
case 'G': ktype = 'G'; break;
default: ktype = 'B'; break;
}
error = kernel_smooth(dx, dy, n, width, NULL, NULL, dxs, dys, ns, ktype);
return error ? s_true : NIL;
}
LVAL xsmake_rotation(V)
{
LVAL x, y, dx, dy, val;
double alpha=0.0;
int n, use_alpha = FALSE;
x = xlgetarg();
y = xlgetarg();
if (moreargs()) {
use_alpha = TRUE;
alpha = makefloat(xlgetarg());
}
xllastarg();
xlstkcheck(3);
xlsave(dx);
xlsave(dy);
xlsave(val);
dx = coerce_to_tvec(x, s_c_double);
dy = coerce_to_tvec(y, s_c_double);
n = gettvecsize(dx);
if (gettvecsize(dy) != n)
xlfail("sequences not the same length");
val = mktvec(n * n, s_c_double);
make_rotation(n, REDAT(val), REDAT(dx), REDAT(dy), use_alpha, alpha);
val = linalg2genmat(val, n, n, FALSE);
xlpopn(3);
return val;
}
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);
}
/* 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;
}
LVAL xlc_snd_multiseq(void)
{
LVAL arg1 = xlgetarg();
LVAL arg2 = xlgetarg();
LVAL result;
xllastarg();
result = snd_make_multiseq(arg1, arg2);
return (result);
}
static LVAL base_ifelse(V)
{
LVAL a, b, c;
a = xlgetarg();
b = xlgetarg();
c = xlgetarg();
xllastarg();
return((a != NIL) ? b : c);
}
/* xequal - are these equal? (recursive) */
LVAL xequal(void)
{
LVAL arg1,arg2;
/* get the two arguments */
arg1 = xlgetarg();
arg2 = xlgetarg();
xllastarg();
/* compare the arguments */
return (lval_equal(arg1,arg2) ? s_true : NIL);
}
/* xcons - construct a new list cell */
LVAL xcons()
{
LVAL carval,cdrval;
/* get the two arguments */
carval = xlgetarg();
cdrval = xlgetarg();
xllastarg();
/* construct a new cons node */
return (cons(carval,cdrval));
}
/* xcons - construct a new list cell */
LVAL xcons(void)
{
LVAL arg1,arg2;
/* get the two arguments */
arg1 = xlgetarg();
arg2 = xlgetarg();
xllastarg();
/* construct a new list element */
return (cons(arg1,arg2));
}
LVAL xlc_snd_ifft(void)
{
double arg1 = testarg2(xlgaanynum());
double arg2 = testarg2(xlgaanynum());
LVAL arg3 = xlgetarg();
long arg4 = getfixnum(xlgafixnum());
LVAL arg5 = xlgetarg();
sound_type result;
xllastarg();
result = snd_ifft(arg1, arg2, arg3, arg4, arg5);
return cvsound(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);
}
LVAL xsgen2linalg(V)
{
LVAL x, type;
int m, n, trans;
x = xlgetarg();
m = getfixnum(xlgafixnum());
n = getfixnum(xlgafixnum());
type = xlgetarg();
trans = moreargs() ? ! null(xlgetarg()) : FALSE;
xllastarg();
return gen2linalg(x, m, n, type, trans);
}
LVAL xstransposeinto(V)
{
LVAL x, y;
int m, n;
x = xlgetarg();
m = getfixnum(xlgafixnum());
n = getfixnum(xlgafixnum());
y = xlgetarg();
xllastarg();
transposeinto(x, m, n, y);
return y;
}
/* x1macroexpand - expand a macro call */
LVAL x1macroexpand(void)
{
LVAL form,fun,args;
/* protect some pointers */
xlstkcheck(2);
xlsave(fun);
xlsave(args);
/* get the form */
form = xlgetarg();
xllastarg();
/* expand until the form isn't a macro call */
if (consp(form)) {
fun = car(form); /* get the macro name */
args = cdr(form); /* get the arguments */
if (symbolp(fun) && fboundp(fun)) {
fun = xlgetfunction(fun); /* get the expansion function */
macroexpand(fun,args,&form);
}
}
/* restore the stack and return the expansion */
xlpopn(2);
return (form);
}
/* xmacroexpand - expand a macro call repeatedly */
LVAL xmacroexpand(void)
{
LVAL form;
form = xlgetarg();
xllastarg();
return (xlexpandmacros(form));
}
/* xquote - special form 'quote' */
LVAL xquote(V)
{
LVAL val;
val = xlgetarg();
xllastarg();
return (val);
}
/* xtype - return type of a thing */
LVAL xtype(void)
{
LVAL arg;
if (!(arg = xlgetarg()))
return (NIL);
switch (ntype(arg)) {
case SUBR: return (a_subr);
case FSUBR: return (a_fsubr);
case CONS: return (a_cons);
case SYMBOL: return (a_symbol);
case FIXNUM: return (a_fixnum);
case FLONUM: return (a_flonum);
case STRING: return (a_string);
case OBJECT: return (a_object);
case STREAM: return (a_stream);
case VECTOR: return (a_vector);
case CLOSURE: return (a_closure);
case CHAR: return (a_char);
case USTREAM: return (a_ustream);
case EXTERN: return (exttype(arg));
default: xlfail("bad node type");
return NIL; /* never happens */
}
}
/* xsort - built-in function 'sort' */
LVAL xsort(void)
{
LVAL sortlist();
LVAL list,fcn;
/* protect some pointers */
xlstkcheck(2);
xlsave(list);
xlsave(fcn);
/* get the list to sort and the comparison function */
list = xlgalist();
fcn = xlgetarg();
xllastarg();
/* sort the list */
list = sortlist(list,fcn);
if (list && (ntype(list) == FREE_NODE)) {
stdputstr("error in sort 2");
}
/* restore the stack and return the sorted list */
xlpopn(2);
return (list);
}
/* 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));
}
/* remif - common code for 'remove-if' and 'remove-if-not' */
LOCAL LVAL remif(int tresult)
{
LVAL list,fcn,val,last=NULL,next;
/* protect some pointers */
xlstkcheck(2);
xlsave(fcn);
xlsave(val);
/* get the expression to remove and the list */
fcn = xlgetarg();
list = xlgalist();
xllastarg();
/* remove matches */
for (; consp(list); list = cdr(list))
/* check to see if this element should be deleted */
if (dotest1(car(list),fcn) != tresult) {
next = consa(car(list));
if (val) rplacd(last,next);
else val = next;
last = next;
}
/* restore the stack */
xlpopn(2);
/* return the updated list */
return (val);
}
/* xassoc - built-in function 'assoc' */
LVAL xassoc(void)
{
LVAL x,alist,fcn,pair,val;
int tresult;
/* protect some pointers */
xlsave1(fcn);
/* get the expression to look for and the association list */
x = xlgetarg();
alist = xlgalist();
xltest(&fcn,&tresult);
/* look for the expression */
for (val = NIL; consp(alist); alist = cdr(alist))
if ((pair = car(alist)) && consp(pair))
if (dotest2(x,car(pair),fcn) == tresult) {
val = pair;
break;
}
/* restore the stack */
xlpop();
/* return result */
return (val);
}
/* xmember - built-in function 'member' */
LVAL xmember(void)
{
LVAL x,list,fcn,val;
int tresult;
/* protect some pointers */
xlsave1(fcn);
/* get the expression to look for and the list */
x = xlgetarg();
list = xlgalist();
xltest(&fcn,&tresult);
/* look for the expression */
for (val = NIL; consp(list); list = cdr(list))
if (dotest2(x,car(list),fcn) == tresult) {
val = list;
break;
}
/* restore the stack */
xlpop();
/* return the result */
return (val);
}
/* 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 */
}
}
LVAL iview_transformation(V)
{
IVIEW_WINDOW w;
LVAL m = NULL, object;
int set = FALSE;
int vars;
object = xlgaobject();
w = (IVIEW_WINDOW) get_iview_address(object);
if (moreargs()) {
set = TRUE;
m = xlgetarg();
}
vars = IViewNumVariables(w);
if (set) {
if (m == NIL) IViewSetIdentityTransformation(w);
else {
set_internal_transformation(vars, m, NIL);
IViewSetTransformation(w, transform);
}
check_redraw(object, TRUE, TRUE);
}
else m = (IViewIsTransformed(w))
? make_transformation(IViewTransformation(w), vars) : NIL;
return(m);
}
/* xcomplement - create a complementary function */
LVAL xcomplement(V)
{
LVAL val;
LVAL args, body;
LVAL newxlenv;
/* protect some pointers */
xlstkcheck(3);
xlsave(newxlenv);
xlsave(args);
xlsave(body);
/* get the argument */
val = xlgetarg();
xllastarg();
/* build the argument list (&rest x) */
args = cons(lk_rest, consa(s_x));
/* build body (not (apply s x)) */
body = consa(cons(s_not, consa(cons(s_apply, cons(s_s, consa(s_x))))));
/* create a closure for lambda expressions */
newxlenv = xlframe(newxlenv);
xlpbind(s_s, val, newxlenv);
val = xlclose(NIL,s_lambda,args,body,newxlenv,NIL);
/* unprotect pointers */
xlpopn(3);
/* return the function */
return (val);
}
LVAL iview_hist_add_points(V)
{
IVIEW_WINDOW w;
int old_n, n;
LVAL object, data, hdata;
gethistargs(&w, &object, &hdata);
if (IVIEW_WINDOW_NULL(w)) return(NIL);
old_n = IViewNumPoints(w);
xlsave1(data);
data = xlgetarg();
data = (fixp(data) || (consp(data) && seqp(car(data))))
? data : consa(data);
internal_iview_add_points(w, object, data);
xlpop();
n = IViewNumPoints(w);
allocate_internal_points(object, n);
initialize_points(w, hdata, old_n, n);
check_add_to_screen(object, 'P', old_n, n, TRUE);
return(NIL);
}
