/* 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);
}
/* 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);
}
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);
}
/* 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);
}
/* 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);
}
/* 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);
}
