void nyx_set_audio_params(double rate, long len)
{
LVAL flo;
LVAL con;
xlstkcheck(2);
xlsave(flo);
xlsave(con);
/* Bind the sample rate to the "*sound-srate*" global */
flo = cvflonum(rate);
setvalue(xlenter("*SOUND-SRATE*"), flo);
/* Bind selection len to "len" global */
flo = cvflonum(len);
setvalue(xlenter("LEN"), flo);
/* Set the "*warp*" global based on the length of the audio */
con = cons(NULL, NULL);
flo = cvflonum(len > 0 ? (double) len / rate : 1.0);
con = cons(flo, con);
flo = cvflonum(0);
con = cons(flo, con);
setvalue(xlenter("*WARP*"), con);
xlpopn(2);
}
/* cons - construct a new cons node */
LVAL cons(LVAL x, LVAL y)
{
LVAL nnode;
/* get a free node */
if ((nnode = fnodes) == NIL) {
xlstkcheck(2);
xlprotect(x);
xlprotect(y);
findmem();
if ((nnode = fnodes) == NIL)
xlabort("insufficient node space");
xlpop();
xlpop();
}
/* unlink the node from the free list */
fnodes = cdr(nnode);
--nfree;
/* initialize the new node */
nnode->n_type = CONS;
rplaca(nnode,x);
rplacd(nnode,y);
/* return the new node */
return (nnode);
}
LVAL xsfft(V)
{
LVAL data, result, x, work;
int n, isign;
data = xlgaseq();
isign = (moreargs() && xlgetarg() != NIL) ? -1.0 : 1.0;
xllastarg();
/* check and convert the data */
n = seqlen(data);
if (n <= 0)
xlfail("not enough data");
xlstkcheck(2);
xlsave(x);
xlsave(work);
x = gen2linalg(data, n, 1, s_c_dcomplex, FALSE);
work = mktvec(4 * n + 15, s_c_double);
cfft(n, REDAT(x), REDAT(work), isign);
result = listp(x) ? coerce_to_list(x) : coerce_to_tvec(x, s_true);
xlpopn(2);
return result;
}
/* 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);
}
/* 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);
}
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);
}
/* 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);
}
/* 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);
}
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);
}
/* Internal version of Common Lisp MAP function */
LOCAL LVAL map P4C(LVAL, type, LVAL, fcn, LVAL, args, int, rlen)
{
LVAL nextr, result;
int nargs, i;
/* protect some pointers */
xlstkcheck(2);
xlsave(result);
xlprotect(fcn);
if (rlen < 0) rlen = findmaprlen(args);
if (type == a_vector)
result = newvector(rlen);
else
result = mklist(rlen, NIL);
nargs = llength(args);
for (i = 0, nextr = result; i < rlen; i++) {
pushnextargs(fcn, nargs, args, i);
setnextelement(&nextr, i, xlapply(nargs));
}
/* restore the stack frame */
xlpopn(2);
return(result);
}
/* MAP-ELEMENTS for internal subroutines */
LVAL subr_map_elements P1C(mapfun, f)
{
LVAL arglist, result, fcn, first_compound, type;
int rlen;
first_compound = findcompound(FALSE);
if (first_compound == NIL) result = (*f)();
else {
xlstkcheck(3);
xlsave(arglist);
xlsave(fcn);
xlsave(result);
fcn = cvsubr(f, SUBR, 0);
type = compoundseqtype(first_compound);
arglist = makearglist(xlargc, xlargv);
rlen = findrlen(arglist);
fixuparglist(arglist);
result = map(type, fcn, arglist, rlen);
result = makecompound(first_compound, result);
#ifdef MULVALS
xlnumresults = 1;
xlresults[0] = result;
#endif /* MULVALS */
xlpopn(3);
}
return(result);
}
/* xlexpandmacros - expand macros in a form */
LVAL xlexpandmacros(LVAL form)
{
LVAL fun,args;
/* protect some pointers */
xlstkcheck(3);
xlprotect(form);
xlsave(fun);
xlsave(args);
/* expand until the form isn't a macro call */
while (consp(form)) {
fun = car(form); /* get the macro name */
args = cdr(form); /* get the arguments */
if (!symbolp(fun) || !fboundp(fun))
break;
fun = xlgetfunction(fun); /* get the expansion function */
if (!macroexpand(fun,args,&form))
break;
}
/* restore the stack and return the expansion */
xlpopn(3);
return (form);
}
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);
}
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 xschol_decomp(V)
{
LVAL a, da, val;
int n;
double maxoffl, maxadd;
a = xlgadarray();
maxoffl = moreargs() ? makefloat(xlgetarg()) : 0.0;
xllastarg();
checksquarematrix(a);
n = numrows(a);
xlstkcheck(2);
xlsave(da);
xlsave(val);
da = gen2linalg(a, n, n, s_c_double, FALSE);
choldecomp(REDAT(da), n, maxoffl, &maxadd);
val = consa(cvflonum((FLOTYPE) maxadd));
val = cons(linalg2genmat(da, n, n, FALSE), val);
xlpopn(2);
return val;
}
LVAL xssample(V)
{
LVAL x, result, temp, elem;
int n, N, replace, i, j;
x = xlgaseq();
n = getfixnum(xlgafixnum());
N = seqlen(x);
replace = (moreargs()) ? (xlgetarg() != NIL) : FALSE;
xllastarg();
if (! replace && n > N) n = N;
xlstkcheck(4);
xlprotect(x);
xlsave(result);
xlsave(elem);
xlsave(temp);
x = (listp(x)) ? coerce_to_tvec(x, s_true) : copyvector(x);
result = NIL;
if (N > 0 && n > 0) {
for (i = 0; i < n; i++) {
j = (replace) ? osrand(N) : i + osrand(N - i);
elem = gettvecelement(x, j);
result = cons(elem, result);
if (! replace) { /* swap elements i and j */
temp = gettvecelement(x, i);
settvecelement(x, i, elem);
settvecelement(x, j, temp);
}
}
}
xlpopn(4);
return(result);
}
/* plist - parse a list */
LOCAL LVAL plist(LVAL fptr)
{
LVAL val,expr,lastnptr,nptr;
/* protect some pointers */
xlstkcheck(2);
xlsave(val);
xlsave(expr);
/* keep appending nodes until a closing paren is found */
for (lastnptr = NIL; nextch(fptr) != ')'; )
/* get the next expression */
switch (readone(fptr,&expr)) {
case EOF:
badeof(fptr);
case TRUE:
/* check for a dotted tail */
if (expr == s_dot) {
/* make sure there's a node */
if (lastnptr == NIL)
xlfail("invalid dotted pair");
/* parse the expression after the dot */
if (!xlread(fptr,&expr,TRUE))
badeof(fptr);
rplacd(lastnptr,expr);
/* make sure its followed by a close paren */
if (nextch(fptr) != ')')
xlfail("invalid dotted pair");
}
/* otherwise, handle a normal list element */
else {
nptr = consa(expr);
if (lastnptr == NIL)
val = nptr;
else
rplacd(lastnptr,nptr);
lastnptr = nptr;
}
break;
}
/* skip the closing paren */
xlgetc(fptr);
/* restore the stack */
xlpopn(2);
/* return successfully */
return (val);
}
/* pvector - parse a vector */
LOCAL LVAL pvector(LVAL fptr)
{
LVAL list,expr,val,lastnptr,nptr;
int len,ch,i;
/* protect some pointers */
xlstkcheck(2);
xlsave(list);
xlsave(expr);
/* keep appending nodes until a closing paren is found */
for (lastnptr = NIL, len = 0; (ch = nextch(fptr)) != ')'; ) {
/* check for end of file */
if (ch == EOF)
badeof(fptr);
/* get the next expression */
switch (readone(fptr,&expr)) {
case EOF:
badeof(fptr);
case TRUE:
nptr = consa(expr);
if (lastnptr == NIL)
list = nptr;
else
rplacd(lastnptr,nptr);
lastnptr = nptr;
len++;
break;
}
}
/* skip the closing paren */
xlgetc(fptr);
/* make a vector of the appropriate length */
val = newvector(len);
/* copy the list into the vector */
for (i = 0; i < len; ++i, list = cdr(list))
setelement(val,i,car(list));
/* restore the stack */
xlpopn(2);
/* return successfully */
return (val);
}
/* evmethod - evaluate a method */
LOCAL LVAL evmethod(LVAL obj, LVAL msgcls, LVAL method)
{
LVAL oldenv,oldfenv,cptr,name,val=NULL;
XLCONTEXT cntxt;
/* protect some pointers */
xlstkcheck(3);
xlsave(oldenv);
xlsave(oldfenv);
xlsave(cptr);
/* create an 'object' stack entry and a new environment frame */
oldenv = xlenv;
oldfenv = xlfenv;
xlenv = cons(cons(obj,msgcls),closure_getenv(method));
xlenv = xlframe(xlenv);
xlfenv = getfenv(method);
/* bind the formal parameters */
xlabind(method,xlargc,xlargv);
/* setup the implicit block */
if ((name = getname(method)))
xlbegin(&cntxt,CF_RETURN,name);
/* execute the block */
if (name && _setjmp(cntxt.c_jmpbuf))
val = xlvalue;
else
for (cptr = getbody(method); consp(cptr); cptr = cdr(cptr))
val = xleval(car(cptr));
/* finish the block context */
if (name)
xlend(&cntxt);
/* restore the environment */
xlenv = oldenv;
xlfenv = oldfenv;
/* restore the stack */
xlpopn(3);
/* return the result value */
return (val);
}
/* evfun - evaluate a function */
LOCAL LVAL evfun(LVAL fun, int argc, LVAL *argv)
{
LVAL oldenv,oldfenv,cptr,name,val;
XLCONTEXT cntxt;
/* protect some pointers */
xlstkcheck(4);
xlsave(oldenv);
xlsave(oldfenv);
xlsave(cptr);
xlprotect(fun); /* (RBD) Otherwise, fun is unprotected */
/* create a new environment frame */
oldenv = xlenv;
oldfenv = xlfenv;
xlenv = xlframe(closure_getenv(fun));
xlfenv = getfenv(fun);
/* bind the formal parameters */
xlabind(fun,argc,argv);
/* setup the implicit block */
if (name = getname(fun))
xlbegin(&cntxt,CF_RETURN,name);
/* execute the block */
if (name && setjmp(cntxt.c_jmpbuf))
val = xlvalue;
else
for (val = NIL, cptr = getbody(fun); consp(cptr); cptr = cdr(cptr))
val = xleval(car(cptr));
/* finish the block context */
if (name)
xlend(&cntxt);
/* restore the environment */
xlenv = oldenv;
xlfenv = oldfenv;
/* restore the stack */
xlpopn(4);
/* return the result value */
return (val);
}
/* xevalhook - eval hook function */
LVAL xevalhook(void)
{
LVAL expr,newehook,newahook,newenv,oldenv,oldfenv,olddenv,val;
/* protect some pointers */
xlstkcheck(3);
xlsave(oldenv);
xlsave(oldfenv);
xlsave(newenv);
/* get the expression, the new hook functions and the environment */
expr = xlgetarg();
newehook = xlgetarg();
newahook = xlgetarg();
newenv = (moreargs() ? xlgalist() : NIL);
xllastarg();
/* bind *evalhook* and *applyhook* to the hook functions */
olddenv = xldenv;
xldbind(s_evalhook,newehook);
xldbind(s_applyhook,newahook);
/* establish the environment for the hook function */
if (newenv) {
oldenv = xlenv;
oldfenv = xlfenv;
xlenv = car(newenv);
xlfenv = cdr(newenv);
}
/* evaluate the expression (bypassing *evalhook*) */
val = xlxeval(expr);
/* restore the old environment */
xlunbind(olddenv);
if (newenv) {
xlenv = oldenv;
xlfenv = oldfenv;
}
/* restore the stack */
xlpopn(3);
/* return the result */
return (val);
}
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);
}
/* 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);
}
LVAL xssurface_contour(V)
{
LVAL s1, s2, mat, result;
LVAL x, y, z;
double *dx, *dy, *dz;
double v;
int i, j, n, m;
s1 = xlgaseq();
s2 = xlgaseq();
mat = xlgamatrix();
v = makefloat(xlgetarg());
xllastarg();
n = seqlen(s1);
m = seqlen(s2);
if (n != numrows(mat) || m != numcols(mat))
xlfail("dimensions do not match");
xlstkcheck(4);
xlsave(x);
xlsave(y);
xlsave(z);
xlsave(result);
x = gen2linalg(s1, n, 1, s_c_double, FALSE); dx = REDAT(x);
y = gen2linalg(s2, m, 1, s_c_double, FALSE); dy = REDAT(y);
z = gen2linalg(mat, n, m, s_c_double, FALSE); dz = REDAT(z);
result = NIL;
for (i = 0; i < n - 1; i++) {
for (j = 0; j < m - 1; j++) {
result = add_contour_point(m, i, j, i, j+1, dx, dy, dz, v, result);
result = add_contour_point(m, i, j+1, i+1, j+1, dx, dy, dz, v, result);
result = add_contour_point(m, i+1, j+1, i+1, j, dx, dy, dz, v, result);
result = add_contour_point(m, i+1, j, i, j, dx, dy, dz, v, result);
}
}
xlpopn(4);
return(result);
}
LVAL iview_get_nice_range(V)
{
double low, high;
int ticks;
LVAL temp, result;
low = makefloat(xlgetarg());
high = makefloat(xlgetarg());
ticks = getfixnum(xlgafixnum());
xllastarg();
GetNiceRange(&low, &high, &ticks);
xlstkcheck(2);
xlsave(result);
xlsave(temp);
temp = cvfixnum((FIXTYPE) ticks); result = consa(temp);
temp = cvflonum((FLOTYPE) high); result = cons(temp, result);
temp = cvflonum((FLOTYPE) low); result = cons(temp, result);
xlpopn(2);
return(result);
}
/* Built in MAP-ELEMENTS */
LVAL xsmap_elements(V)
{
LVAL arglist, result, fcn, first_compound, type;
int rlen;
if (xlargc < 2) xltoofew();
first_compound = findcompound(TRUE);
if (first_compound == NIL) result = xfuncall();
else {
xlstkcheck(2)
xlsave(arglist);
xlsave(result);
fcn = xlgetarg();
type = compoundseqtype(first_compound);
arglist = makearglist(xlargc, xlargv);
rlen = findrlen(arglist);
fixuparglist(arglist);
result = map(type, fcn, arglist, rlen);
result = makecompound(first_compound,result);
xlpopn(2);
}
return(result);
}
/* sortlist - sort a list using quicksort */
LOCAL LVAL sortlist(LVAL list, LVAL fcn)
{
LVAL gluelists();
LVAL smaller,pivot,larger;
/* protect some pointers */
xlstkcheck(3);
xlsave(smaller);
xlsave(pivot);
xlsave(larger);
/* lists with zero or one element are already sorted */
if (consp(list) && consp(cdr(list))) {
pivot = list; list = cdr(list);
splitlist(pivot,list,&smaller,&larger,fcn);
smaller = sortlist(smaller,fcn);
larger = sortlist(larger,fcn);
list = gluelists(smaller,pivot,larger);
}
/* cleanup the stack and return the sorted list */
xlpopn(3);
return (list);
}
/* xlload - load a file of xlisp expressions */
int xlload(char *fname, int vflag, int pflag)
{
char fullname[STRMAX+1];
char *ptr;
LVAL fptr,expr;
XLCONTEXT cntxt;
FILE *fp;
int sts;
/* protect some pointers */
xlstkcheck(2);
xlsave(fptr);
xlsave(expr);
/* space for copy + extension? */
if (strlen(fname) > STRMAX - 4) goto toolong;
strcpy(fullname,fname);
#ifdef WINDOWS
#ifdef WINGUI
if (strcmp(fullname, "*") == 0) {
if (sfn_valid) {
strcpy(fullname, save_file_name);
} else {
strcpy(fullname, "*.*");
}
}
if (strcmp(fullname, "*.*") == 0) {
char *name = getfilename(NULL, "lsp", "r", "Load file");
if (name) {
strcpy(fullname, name);
strcpy(save_file_name, name);
sfn_valid = TRUE;
} else {
xlpopn(2);
return FALSE;
}
}
#endif
/* replace "/" with "\" so that (current-path) will work */
for (ptr = fullname; *ptr; ptr++) {
if (*ptr == '/') *ptr = '\\';
}
#endif
/* default the extension if there is room */
if (needsextension(fullname)) {
strcat(fullname,".lsp");
}
/* allocate a file node */
fptr = cvfile(NULL);
/* open the file */
if ((fp = osaopen(fullname,"r")) == NULL) {
#ifdef UNIX
if (fname[0] != '/') {
char *paths = getenv("XLISPPATH");
if (!paths || !*paths) {
char msg[512];
sprintf(msg, "\n%s\n%s\n%s\n%s\n%s\n",
"Warning: XLISP failed to find XLISPPATH in the environment.",
"If you are using Nyquist, probably you should cd to the",
"nyquist directory and type:",
" setenv XLISPPATH `pwd`/runtime:`pwd`/lib",
"or set XLISPPATH in your .login or .cshrc file.");
errputstr(msg);
}
/* make sure we got paths, and the list is not empty */
while (paths && *paths) {
char *ptr = fullname;
/* skip over separator */
while (*paths == ':') paths++;
/* scan next directory into fullname */
while (*paths && (*paths != ':')) {
if ((ptr - fullname) >= STRMAX) goto toolong;
*ptr++ = *paths++;
}
/* add "/" if needed */
if (ptr[-1] != '/') *ptr++ = '/';
/* append the file name */
if ((ptr - fullname) + strlen(fname) + 4 > STRMAX)
goto toolong;
strcpy(ptr, fname);
/* append the .lsp extension */
if (needsextension(fullname)) {
strcat(fullname, ".lsp");
}
if (fp = osaopen(fullname, "r")) goto gotfile;
}
}
#endif
#ifdef WINDOWS
/* is this a relative path? */
if (fname[0] != '\\' && (strlen(fname) < 2 || fname[1] != ':')) {
#define paths_max 1024
char paths[paths_max];
char *p = paths;
get_xlisp_path(paths, paths_max);
/* make sure we got paths, and the list is not empty */
if (!*p) {
sprintf(paths, "\n%s\n%s\n%s\n",
"Warning: XLISP failed to find XLISPPATH in the Registry.",
"You should follow the installation instructions. Enter an",
"empty string if you really want no search path.");
errputstr(paths);
*p = 0;
}
while (*p) {
char *ptr = fullname;
/* skiip over separator */
while (*p == ',') p++;
/* scan next directory into fullname */
while (*p && (*p != ',')) {
if ((ptr - fullname) >= STRMAX) goto toolong;
*ptr++ = *p++;
}
/* add "\" if needed */
if (ptr[-1] != '\\') *ptr++ = '\\';
/* append the file name */
if ((ptr - fullname) + strlen(fname) + 4 > STRMAX)
goto toolong;
strcpy(ptr, fname);
/* append the .lsp extension */
if (needsextension(fullname)) {
strcat(fullname, ".lsp");
}
/* printf("Trying to open \"%s\"\n", fullname); */
if (fp = osaopen(fullname, "r")) goto gotfile;
}
}
#endif
#ifdef MACINTOSH
/* is this a relative path? I don't know how to do this
* correctly, so we'll assume it's relative if there is no
* embedded colon (:)
*/
if (strchr(fname, ':') == NULL) {
#define paths_max 1024
char paths[paths_max];
char *p = paths;
int prefs_found = false;
get_xlisp_path(paths, paths_max, &prefs_found);
/* make sure we got paths, and the list is not empty */
if (!*p) {
if (prefs_found) {
sprintf(paths, "\n%s\n%s\n%s\n",
"Warning: XLISP failed to find XLISPPATH in XLisp Preferences.",
"You should probably delete XLisp Preferences and let XLisp",
"create a new one for you.");
} else {
sprintf(paths, "\n%s\n%s\n%s\n%s\n%s\n",
"Warning: XLISP failed to find XLisp Preferences.",
"You should manually locate and load the file runtime:init.lsp",
"Nyquist will create an XLisp Preferences file to automatically",
"find the file next time. You may edit XLisp Preferences to add",
"additional search paths, using a comma as separator.");
}
errputstr(paths);
*p = 0;
}
while (*p) {
char *ptr = fullname;
/* skiip over separator */
while (*p == ',') p++;
/* scan next directory into fullname */
while (*p && (*p != ',')) {
if ((ptr - fullname) >= STRMAX) goto toolong;
*ptr++ = *p++;
}
/* add ":" if needed */
if (ptr[-1] != ':') *ptr++ = ':';
/* append the file name */
if ((ptr - fullname) + strlen(fname) + 4 > STRMAX)
goto toolong;
strcpy(ptr, fname);
/* append the .lsp extension */
if (needsextension(fullname)) {
strcat(fullname, ".lsp");
}
/* printf("Trying to open \"%s\"\n", fullname); */
if (fp = osaopen(fullname, "r")) goto gotfile;
}
}
#endif
xlpopn(2);
return (FALSE);
}
gotfile:
#ifdef MACINTOSH
/* We found the file ok, call setup_preferences to create
* XLisp Preferences file (this only happens if previous
* attempt to find the file failed
*/
setup_preferences(fullname);
#endif
setfile(fptr,fp);
setvalue(s_loadingfiles, cons(fptr, getvalue(s_loadingfiles)));
setvalue(s_loadingfiles, cons(cvstring(fullname), getvalue(s_loadingfiles)));
/* print the information line */
if (vflag)
{ sprintf(buf,"; loading \"%s\"\n",fullname); stdputstr(buf); }
/* read, evaluate and possibly print each expression in the file */
xlbegin(&cntxt,CF_ERROR,s_true);
if (setjmp(cntxt.c_jmpbuf))
sts = FALSE;
else {
while (xlread(fptr,&expr,FALSE)) {
expr = xleval(expr);
if (pflag)
stdprint(expr);
}
sts = TRUE;
}
xlend(&cntxt);
/* close the file */
osclose(getfile(fptr));
setfile(fptr,NULL);
if (consp(getvalue(s_loadingfiles)) &&
consp(cdr(getvalue(s_loadingfiles))) &&
car(cdr(getvalue(s_loadingfiles))) == fptr) {
setvalue(s_loadingfiles, cdr(cdr(getvalue(s_loadingfiles))));
}
/* restore the stack */
xlpopn(2);
/* return status */
return (sts);
toolong:
xlcerror("ignore file", "file name too long", NIL);
xlpopn(2);
return FALSE;
}
/* map - internal mapping function */
LOCAL LVAL map(int carflag, int valflag)
{
LVAL *newfp,fun,lists,val,last,p,x,y;
int argc;
/* protect some pointers */
xlstkcheck(3);
xlsave(fun);
xlsave(lists);
xlsave(val);
/* get the function to apply and the first list */
fun = xlgetarg();
lists = xlgalist();
/* initialize the result list */
val = (valflag ? NIL : lists);
/* build a list of argument lists */
for (lists = last = consa(lists); moreargs(); last = cdr(last))
rplacd(last,cons(xlgalist(),NIL));
/* loop through each of the argument lists */
for (;;) {
/* build an argument list from the sublists */
newfp = xlsp;
pusharg(cvfixnum((FIXTYPE)(newfp - xlfp)));
pusharg(fun);
pusharg(NIL);
argc = 0;
for (x = lists; x && (y = car(x)) && consp(y); x = cdr(x)) {
pusharg(carflag ? car(y) : y);
rplaca(x,cdr(y));
++argc;
}
/* quit if any of the lists were empty */
if (x) {
xlsp = newfp;
break;
}
/* apply the function to the arguments */
newfp[2] = cvfixnum((FIXTYPE)argc);
xlfp = newfp;
if (valflag) {
p = consa(xlapply(argc));
if (val) rplacd(last,p);
else val = p;
last = p;
}
else
xlapply(argc);
}
/* restore the stack */
xlpopn(3);
/* return the last test expression value */
return (val);
}
/* evform - evaluate a form */
LOCAL LVAL evform(LVAL form)
{
LVAL fun,args,val,type;
LVAL tracing=NIL;
LVAL *argv;
LVAL old_profile_fixnum = profile_fixnum;
FIXTYPE *old_profile_count_ptr = profile_count_ptr;
LVAL funname;
int argc;
/* protect some pointers */
xlstkcheck(2);
xlsave(fun);
xlsave(args);
(*profile_count_ptr)++; /* increment profile counter */
/* get the function and the argument list */
fun = car(form);
args = cdr(form);
funname = fun;
/* get the functional value of symbols */
if (symbolp(fun)) {
if (getvalue(s_tracelist) && member(fun,getvalue(s_tracelist)))
tracing = fun;
fun = xlgetfunction(fun);
}
/* check for nil */
if (null(fun))
xlerror("bad function",NIL);
/* dispatch on node type */
switch (ntype(fun)) {
case SUBR:
argv = xlargv;
argc = xlargc;
xlargc = evpushargs(fun,args);
xlargv = xlfp + 3;
trenter(tracing,xlargc,xlargv);
val = (*getsubr(fun))();
trexit(tracing,val);
xlsp = xlfp;
xlfp = xlfp - (int)getfixnum(*xlfp);
xlargv = argv;
xlargc = argc;
break;
case FSUBR:
argv = xlargv;
argc = xlargc;
xlargc = pushargs(fun,args);
xlargv = xlfp + 3;
val = (*getsubr(fun))();
xlsp = xlfp;
xlfp = xlfp - (int)getfixnum(*xlfp);
xlargv = argv;
xlargc = argc;
break;
case CONS:
if (!consp(cdr(fun)))
xlerror("bad function",fun);
if ((type = car(fun)) == s_lambda)
fun = xlclose(NIL,
s_lambda,
car(cdr(fun)),
cdr(cdr(fun)),
xlenv,xlfenv);
else
xlerror("bad function",fun);
/**** fall through into the next case ****/
case CLOSURE:
/* do profiling */
if (profile_flag && atomp(funname)) {
LVAL profile_prop = findprop(funname, s_profile);
if (null(profile_prop)) {
/* make a new fixnum, don't use cvfixnum because
it would return shared pointer to zero, but we
are going to modify this integer in place --
dangerous but efficient.
*/
profile_fixnum = newnode(FIXNUM);
profile_fixnum->n_fixnum = 0;
setplist(funname, cons(s_profile,
cons(profile_fixnum,
getplist(funname))));
setvalue(s_profile, cons(funname, getvalue(s_profile)));
} else profile_fixnum = car(profile_prop);
profile_count_ptr = &getfixnum(profile_fixnum);
}
if (gettype(fun) == s_lambda) {
argc = evpushargs(fun,args);
argv = xlfp + 3;
trenter(tracing,argc,argv);
val = evfun(fun,argc,argv);
trexit(tracing,val);
xlsp = xlfp;
xlfp = xlfp - (int)getfixnum(*xlfp);
}
else {
macroexpand(fun,args,&fun);
val = xleval(fun);
}
profile_fixnum = old_profile_fixnum;
profile_count_ptr = old_profile_count_ptr;
break;
default:
xlerror("bad function",fun);
}
/* restore the stack */
xlpopn(2);
/* return the result value */
return (val);
}
