/* xlbfun.c - xlisp basic built-in functions */
/* Copyright (c) 1989, by David Michael Betz. */
/* You may give out copies of this software; for conditions see the file */
/* COPYING included with this distribution. */
#include "xlisp.h"
/* forward declarations */
LOCAL LVAL makesymbol P1H(int);
#ifdef CONDITIONS
LOCAL LVAL conditionhook P1H(LVAL);
#endif /* CONDITIONS */
/* xeval - the built-in function 'eval' */
LVAL xeval(V)
{
LVAL expr,oldenv,oldfenv;
/* protect some pointers */
xlstkcheck(2);
xlprotect(oldenv);
xlprotect(oldfenv);
/* get the expression to evaluate */
expr = xlgetarg();
xllastarg();
/* establish global environment */
oldenv = xlenv;
oldfenv = xlfenv;
xlenv = xlfenv = NIL;
/* evaluate the expression */
expr = xleval(expr);
/* restore environment */
xlenv = oldenv;
xlfenv = oldfenv;
/* restore the stack */
xlpopn(2);
/* return evaluated expression */
return (expr);
}
/* xapply - the built-in function 'apply' */
/* Algorithm based on Luke Tierney's XLISP-STAT */
LVAL xapply(V)
{
LVAL fun,arglist;
int n;
if (xlargc < 2) xltoofew();
if (! listp(xlargv[xlargc - 1])) xlfail("last argument must be a list");
/* protect some pointers */
xlstkcheck(2);
xlprotect(arglist);
xlprotect(fun);
fun = xlgetarg();
n = xlargc - 1;
arglist = xlargv[n];
while (n-- > 0) arglist = cons(xlargv[n], arglist);
/* restore the stack */
xlpopn(2);
return xlapply(pushargs(fun, arglist));
}
/* xfuncall - the built-in function 'funcall' */
LVAL xfuncall(V)
{
FRAMEP newfp;
int argc;
/* build a new argument stack frame */
newfp = xlsp;
pusharg(cvfixnum((FIXTYPE)(newfp - xlfp)));
pusharg(xlgetarg());
pusharg(NIL); /* will be argc */
/* push each argument */
for (argc = 0; moreargs(); ++argc)
pusharg(nextarg());
/* establish the new stack frame */
newfp[2] = cvfixnum((FIXTYPE)argc);
xlfp = newfp;
/* apply the function to the arguments */
return (xlapply(argc));
}
/* xl1macroexpand - expand a macro call; internal version. */
/* Uses macro definitions of FSUBR's stored in the MACRO property. */
LOCAL int xl1macroexpand P3C(LVAL, form, LVAL, newenv, LVAL *, newform)
{
LVAL sym,fun,args,oldenv,oldfenv;
int expanded = FALSE;
/* protect some pointers */
xlstkcheck(4);
xlsave(fun);
xlsave(args);
xlsave(oldenv);
xlsave(oldfenv);
/* expand the form if it isn't atomic */
if (consp(form)) {
oldenv = xlenv;
oldfenv = xlfenv;
if (!null(newenv)) {
xlenv = car(newenv);
xlfenv = cdr(newenv);
}
else {
xlenv = xlfenv = NIL;
}
sym = car(form); /* get the macro name */
args = cdr(form); /* get the arguments */
/* FSUBR's are assumed to be global. Macro definitions for them can */
/* be stored as the MACRO property of the symbol */
if (symbolp(sym)) {
fun = xlxgetfunction(sym);
if (fsubrp(fun))
fun = xlgetprop(sym, s_macro);
if (null(fun))
fun = s_unbound;
}
else
fun = s_unbound;
if (fun != s_unbound)
expanded = macroexpand(fun,args,&form);
xlenv = oldenv;
xlfenv = oldfenv;
}
/* restore the stack and return the expansion */
xlpopn(4);
*newform = form;
return expanded;
}
/* x1macroexpand - expand a macro call */
LVAL x1macroexpand(V)
{
LVAL form, newenv;
int expanded;
/* get the form */
form = xlgetarg();
newenv = (moreargs() ? xlgalist() : NIL);
xllastarg();
expanded = xl1macroexpand(form, newenv, &form);
#ifdef MULVALS
xlnumresults = 2;
xlresults[0] = form;
xlresults[1] = (expanded) ? s_true : NIL;
#endif /* MULVALS */
return (form);
}
/* xmacroexpand - expand a macro call repeatedly */
LVAL xmacroexpand(V)
{
LVAL form, newenv;
int expanded, again;
/* get the form */
form = xlgetarg();
newenv = (moreargs() ? xlgalist() : NIL);
xllastarg();
expanded = again = xl1macroexpand(form, newenv, &form);
while (again)
again = xl1macroexpand(form, newenv, &form);
#ifdef MULVALS
xlnumresults = 2;
xlresults[0] = form;
xlresults[1] = (expanded) ? s_true : NIL;
#endif /* MULVALS */
return (form);
}
/* xmacrofun - return the function of a macro */
LVAL xmacrofun(V)
{
LVAL sym, env, fun;
LVAL oldenv, oldfenv;
LVAL closure;
sym = xlgasymbol();
env = moreargs() ? xlgalist() : NIL;
xllastarg();
oldenv = xlenv;
oldfenv = xlfenv;
if (!null(env)) {
xlenv = car(env);
xlfenv = cdr(env);
}
else {
xlenv = xlfenv = NIL;
}
closure = NIL;
fun = xlxgetfunction(sym);
/* FSUBR's are assumed to be global. Macro definitions for them can */
/* be stored as the MACRO property of the symbol */
if (fsubrp(fun))
fun = xlgetprop(sym, s_macro);
switch (ntype(fun)) {
case CLOSURE:
if (gettype(fun) == s_macro)
closure = xlclose(getname(fun), s_lambda, getlambda(fun), getbody(fun),
getenvi(fun), getfenv(fun));
break;
#ifdef BYTECODE
case BCCLOSURE:
if (getbcctype(fun) == s_macro)
closure = newbcclosure(s_lambda, getbcccode(fun));
break;
#endif /* BYTECODE */
}
xlenv = oldenv;
xlfenv = oldfenv;
return closure;
}
/* xatom - is this an atom? */
LVAL xatom(V)
{
LVAL arg;
arg = xlgetarg();
xllastarg();
return (atom(arg) ? s_true : NIL);
}
/* xsymbolp - is this an symbol? */
LVAL xsymbolp(V)
{
LVAL arg;
arg = xlgetarg();
xllastarg();
return (symbolp(arg) ? s_true : NIL);
}
/* xnumberp - is this a number? */
LVAL xnumberp(V)
{
LVAL arg;
arg = xlgetarg();
xllastarg();
return (numberp(arg) ? s_true : NIL);
}
/* xcomplexp - is this a complex number? */
LVAL xcomplexp(V)
{
LVAL arg;
arg = xlgetarg();
xllastarg();
return (complexp(arg) ? s_true : NIL);
}
/* xintegerp - is this an integer? */
LVAL xintegerp(V)
{
LVAL arg;
arg = xlgetarg();
xllastarg();
return (integerp(arg) ? s_true : NIL);
}
/* xfloatp - is this a float? */
LVAL xfloatp(V)
{
LVAL arg;
arg = xlgetarg();
xllastarg();
return (floatp(arg) ? s_true : NIL);
}
#ifdef BIGNUMS
LVAL xrationalp(V)
{
LVAL arg;
arg = xlgetarg();
xllastarg();
return (rationalp(arg) ? s_true : NIL);
}
LVAL xnumerator(V)
{
LVAL arg;
arg = xlgetarg();
xllastarg();
if (integerp(arg)) return arg;
if (ratiop(arg)) return getnumer(arg);
xlbadtype(arg);
return NIL; /* never executes */
}
LVAL xdenominator(V)
{
LVAL arg;
arg = xlgetarg();
xllastarg();
if (integerp (arg)) return cvfixnum((FIXTYPE)1);
if (ratiop(arg)) return getdenom(arg);
xlbadtype(arg);
return NIL; /* never executes */
}
#endif
/* xcharp - is this a character? */
LVAL xcharp(V)
{
LVAL arg;
arg = xlgetarg();
xllastarg();
return (charp(arg) ? s_true : NIL);
}
/* xstringp - is this a string? */
LVAL xstringp(V)
{
LVAL arg;
arg = xlgetarg();
xllastarg();
return (stringp(arg) ? s_true : NIL);
}
/* xstreamp - is this a stream? */
LVAL xstreamp(V)
{
LVAL arg;
arg = xlgetarg();
xllastarg();
return (streamp(arg) || ustreamp(arg) ? s_true : NIL);
}
/* xopenstreamp - is this an open stream? */
LVAL xopenstreamp(V)
{
LVAL arg;
arg = xlgetarg();
xllastarg();
if (ustreamp(arg)) return s_true;
if (streamp(arg)) return (getfile(arg) != CLOSED ? s_true : NIL);
xlbadtype(arg);
return NIL; /* never executes */
}
/* xinputstreamp - is this an input stream? */
LVAL xinputstreamp(V)
{
LVAL arg;
arg = xlgetarg();
xllastarg();
if (ustreamp(arg)) return s_true;
if (streamp(arg))
return (getfile(arg)!=CLOSED && (arg->n_sflags&S_FORREADING)?
s_true : NIL);
xlbadtype(arg);
return NIL; /* never executes */
}
/* xoutputstreamp - is this an output stream? */
LVAL xoutputstreamp(V)
{
LVAL arg;
arg = xlgetarg();
xllastarg();
if (ustreamp(arg)) return s_true;
if (streamp(arg))
return (getfile(arg)!=CLOSED && (arg->n_sflags&S_FORWRITING)?
s_true : NIL);
xlbadtype(arg);
return NIL; /* never executes */
}
/* xobjectp - is this an object? */
LVAL xobjectp(V)
{
LVAL arg;
arg = xlgetarg();
xllastarg();
return (objectp(arg) ? s_true : NIL);
}
/* xboundp - is this a value bound to this symbol? */
LVAL xboundp(V)
{
LVAL sym;
sym = xlgasymbol();
xllastarg();
return (boundp(sym) ? s_true : NIL);
}
/* xfboundp - is this a functional value bound to this symbol? */
LVAL xfboundp(V)
{
LVAL sym;
sym = xlgasymbol();
xllastarg();
return (fboundp(sym) ? s_true : NIL);
}
/* xconstantp - is this constant? TAA addition*/
LVAL xconstantp(V)
{
LVAL arg;
arg = xlgetarg();
xllastarg();
if ((!null(arg)) &&
(((ntype(arg)==CONS) && (car(arg) != s_quote)) ||
((ntype(arg)==SYMBOL) && (!constantp(arg)))))
return (NIL);
return (s_true);
}
/* xspecialp - is the symbol marked special? Luke Tierney 9/93 */
LVAL xspecialp(V)
{
LVAL arg;
arg = xlgetarg();
xllastarg();
return((symbolp(arg) && specialp(arg)) ? s_true : NIL);
}
/* xmarkspecial - mark the symbol as special Luke Tierney 9/93 */
LVAL xmarkspecial(V)
{
LVAL arg, val;
int constant, newvalue;
arg = xlgasymbol();
constant = moreargs() ? ! null(nextarg()) : FALSE;
if (moreargs()) {
newvalue = TRUE;
val = nextarg();
}
else {
newvalue = FALSE;
val = NIL;
}
xllastarg();
if (constant)
setsconstant(arg);
else if (! specialp(arg))
setsspecial(arg);
if (newvalue)
setvalue(arg, val);
return(NIL);
}
/* xnull - is this null? */
LVAL xnull(V)
{
LVAL arg;
arg = xlgetarg();
xllastarg();
return (null(arg) ? s_true : NIL);
}
/* xlistp - is this a list? */
LVAL xlistp(V)
{
LVAL arg;
arg = xlgetarg();
xllastarg();
return (listp(arg) ? s_true : NIL);
}
/* xendp - is this the end of a list? */
LVAL xendp(V)
{
LVAL arg;
arg = xlgalist();
xllastarg();
return (null(arg) ? s_true : NIL);
}
/* xconsp - is this a cons? */
LVAL xconsp(V)
{
LVAL arg;
arg = xlgetarg();
xllastarg();
return (consp(arg) ? s_true : NIL);
}
/* xvectorp - is this a vector? */
LVAL xvectorp(V)
{
LVAL arg;
arg = xlgetarg();
xllastarg();
return ((vectorp(arg) || stringp(arg) || tvecp(arg)) ? s_true : NIL);
}
/* xeq - are these equal? */
LVAL xeq(V)
{
LVAL arg1,arg2;
/* get the two arguments */
arg1 = xlgetarg();
arg2 = xlgetarg();
xllastarg();
/* compare the arguments */
return (arg1 == arg2 ? s_true : NIL);
}
/* xeql - are these equal? */
LVAL xeql(V)
{
LVAL arg1,arg2;
/* get the two arguments */
arg1 = xlgetarg();
arg2 = xlgetarg();
xllastarg();
/* compare the arguments */
return (eql(arg1,arg2) ? s_true : NIL);
}
/* xequal - are these equal? (recursive) */
LVAL xequal(V)
{
LVAL arg1,arg2;
/* get the two arguments */
arg1 = xlgetarg();
arg2 = xlgetarg();
xllastarg();
/* compare the arguments */
return (equal(arg1,arg2) ? s_true : NIL);
}
/* xset - built-in function set */
LVAL xset(V)
{
LVAL sym,val;
/* get the symbol and new value */
sym = xlgasymbol();
val = xlgetarg();
xllastarg();
if (constantp(sym)) {
xlnoassign(sym);
}
/* assign the symbol the value of argument 2 and the return value */
setvalue(sym,val);
/* return the result value */
return (val);
}
/* xgensym - generate a symbol */
LVAL xgensym(V)
{
char sym[STRMAX+11]; /* enough space for prefix and number */
LVAL x;
/* get the prefix or number */
if (moreargs()) {
x = xlgetarg();
switch (null(x)? CONS : ntype(x)) { /* was ntype(x) TAA Mod */
case SYMBOL:
x = getpname(x);
case STRING:
STRNCPY(gsprefix,getstring(x),STRMAX);
gsprefix[STRMAX] = '\0';
break;
case FIXNUM:
gsnumber = getfixnum(x);
break;
default:
xlbadtype(x);
}
}
xllastarg();
/* create the pname of the new symbol */
sprintf(sym,"%s%ld",gsprefix,(long) gsnumber++); /* TAA Fix 2/94 --
originally considered gsnumber
to be an int */
/* make a symbol with this print name */
return (xlmakesym(sym));
}
/* xmakesymbol - make a new uninterned symbol */
LVAL xmakesymbol(V)
{
return (makesymbol(FALSE));
}
/* xintern - make a new interned symbol */
LVAL xintern(V)
{
return (makesymbol(TRUE));
}
/* makesymbol - make a new symbol */
LOCAL LVAL makesymbol P1C(int, iflag)
{
LVAL pname;
#ifdef PACKAGES
LVAL pack = NIL;
#ifdef MULVALS
LVAL sym;
int found;
#endif /* MULVALS */
#endif /* PACKAGES */
int i;
/* get the print name of the symbol to intern */
pname = xlgastring();
#ifdef PACKAGES
if (iflag)
pack = xlgetpackage((moreargs()) ? xlgetarg() : getvalue(s_package));
#endif /* PACKAGES */
xllastarg();
/* check for containing only printable characters */
i = getslength(pname);
if (i >= STRMAX)
xlerror("too long", pname);
while (i-- > 0) if (pname->n_string[i] < 32 )
xlerror("non-printing characters",pname);
/* make the symbol */
#ifdef PACKAGES
#ifdef MULVALS
if (iflag) {
/* TAA fix, 7/97, change order of next two statements and
* added if condition */
found = xlfindsymbol(getstring(pname), pack, &sym);
if (found == SYM_NOT_FOUND)
sym = xlintern(getstring(pname), pack);
xlnumresults = 2;
xlresults[0] = sym;
switch (found) {
case SYM_INTERNAL: xlresults[1] = k_internal; break;
case SYM_EXTERNAL: xlresults[1] = k_external; break;
case SYM_INHERITED: xlresults[1] = k_inherited; break;
default: xlresults[1] = NIL;
}
return(sym);
}
else return(xlmakesym(getstring(pname)));
#else
return (iflag ? xlintern(getstring(pname),pack)
: xlmakesym(getstring(pname)));
#endif /* MULVALS */
#else
return (iflag ? xlenter(getstring(pname))
: xlmakesym(getstring(pname)));
#endif /* PACKAGES */
}
/* xsymname - get the print name of a symbol */
LVAL xsymname(V)
{
LVAL sym;
/* get the symbol */
sym = xlgasymbol();
xllastarg();
/* return the print name */
return (getpname(sym));
}
/* xsymvalue - get the value of a symbol */
LVAL xsymvalue(V)
{
LVAL sym,val;
/* get the symbol */
sym = xlgasymbol();
xllastarg();
/* get the global value */
while ((val = getvalue(sym)) == s_unbound)
xlunbound(sym);
/* return its value */
return (val);
}
/* xsymfunction - get the functional value of a symbol */
LVAL xsymfunction(V)
{
LVAL sym,val;
/* get the symbol */
sym = xlgasymbol();
xllastarg();
/* get the global value */
while ((val = getfunction(sym)) == s_unbound)
xlfunbound(sym);
/* return its value */
return (val);
}
/* xsymplist - get the property list of a symbol */
LVAL xsymplist(V)
{
LVAL sym;
/* get the symbol */
sym = xlgasymbol();
xllastarg();
/* return the property list */
return (getplist(sym));
}
/* xget - get the value of a property */
/* TAA MOD 7/93 -- added default argument */
LVAL xget(V)
{
LVAL sym,prp,dflt=NIL;
/* get the symbol and property */
sym = xlgasymbol();
prp = xlgetarg();
if (moreargs()) dflt = xlgetarg();
xllastarg();
/* retrieve the property value */
return (null(prp = findprop(getplist(sym),prp)) ? dflt : car(prp));
}
/* xgetf - get the value of a property NEW 7/93 */
LVAL xgetf(V)
{
LVAL plist,prp,dflt=NIL;
/* get the plist and property */
plist = xlgalist();
prp = xlgetarg();
if (moreargs()) dflt = xlgetarg();
xllastarg();
/* retrieve the property value */
return (null(prp = findprop(plist,prp)) ? dflt : car(prp));
}
/* xputprop - set the value of a property */
LVAL xputprop(V)
{
LVAL sym,val,prp;
/* get the symbol and property */
sym = xlgasymbol();
val = xlgetarg();
prp = xlgetarg();
xllastarg();
/* set the property value */
xlputprop(sym,val,prp);
/* return the value */
return (val);
}
/* xremprop - remove a property value from a property list */
LVAL xremprop(V)
{
LVAL sym,prp;
/* get the symbol and property */
sym = xlgasymbol();
prp = xlgetarg();
xllastarg();
/* remove the property */
xlremprop(sym,prp);
/* return nil */
return (NIL);
}
/* xhash - compute the hash value of a string or symbol */
/* TAA Modified to hash anything */
LVAL xhash(V)
{
LVAL len,val;
int n;
/* get the object and the table length */
val = xlgetarg();
len = xlgafixnum(); n = (int)getfixnum(len);
xllastarg();
/* check for hash arg out of range */
if (n <= 0) xlbadtype(len);
/* return the hash index */
return (cvfixnum((FIXTYPE)xlhash(val,n)));
}
/* xvector - make a vector */
LVAL xvector(V)
{
LVAL val;
int i;
/* make the vector */
val = newvector(xlargc);
/* store each argument */
for (i = 0; moreargs(); ++i)
setelement(val,i,nextarg());
xllastarg();
/* return the vector */
return (val);
}
#ifdef OLDERRORS /* Normally we don't want to use this code! */
/* xerror - special form 'error' */
LVAL xerror(V)
{
LVAL emsg,arg;
#ifdef CONDITIONS
if (s_condition_hook != NULL && getvalue(s_condition_hook) != NIL)
return(conditionhook(s_error));
#endif /* CONDITIONS */
/* get the error message and the argument */
emsg = xlgastring();
arg = (moreargs() ? xlgetarg() : s_unbound);
xllastarg();
/* signal the error */
return (xlerror(getstring(emsg),arg));
}
/* xcerror - special form 'cerror' */
LVAL xcerror(V)
{
LVAL cmsg,emsg,arg;
#ifdef CONDITIONS
if (s_condition_hook != NULL && getvalue(s_condition_hook) != NIL)
return(conditionhook(s_cerror));
#endif /* CONDITIONS */
/* get the correction message, the error message, and the argument */
cmsg = xlgastring();
emsg = xlgastring();
arg = (moreargs() ? xlgetarg() : s_unbound);
xllastarg();
/* signal the error */
xlcerror(getstring(cmsg),getstring(emsg),arg);
/* return nil */
return (NIL);
}
/* xbreak - special form 'break' */
LVAL xbreak(V)
{
LVAL emsg,arg;
#ifdef CONDITIONS
if (s_condition_hook != NULL && getvalue(s_condition_hook) != NIL)
return(conditionhook(s_break));
#endif /* CONDITIONS */
/* get the error message */
emsg = (moreargs() ? xlgastring() : NIL);
arg = (moreargs() ? xlgetarg() : s_unbound);
xllastarg();
/* enter the break loop */
xlbreak((!null(emsg) ? getstring(emsg) : (char *)"**BREAK**"),arg);
/* return nil */
return (NIL);
}
#else
/* xerror - special form 'error' */
LVAL xerror(V)
{
LVAL emsg;
LVAL val;
#ifdef CONDITIONS
if (s_condition_hook != NULL && getvalue(s_condition_hook) != NIL)
return(conditionhook(s_error));
#endif /* CONDITIONS */
xlsave1(val);
val = newustream();
/* get the error message */
emsg = xlgastring();
xlformat(emsg, val);
val = getstroutput(val);
/* we don't need xlpop here because we don't return! */
/* signal the error */
return (xlerror(getstring(val),s_unbound));
}
/* xcerror - special form 'cerror' */
LVAL xcerror(V)
{
LVAL cmsg, emsg, val1, val2;
LVAL *origargv;
int origargc;
#ifdef CONDITIONS
if (s_condition_hook != NULL && getvalue(s_condition_hook) != NIL)
return(conditionhook(s_cerror));
#endif /* CONDITIONS */
/* create the string streams */
xlstkcheck(2);
xlprotect(val1);
val1 = newustream();
xlprotect(val2);
val2 = newustream();
/* get the correction message and the error message */
cmsg = xlgastring();
emsg = xlgastring();
/* process the message strings */
origargv = xlargv;
origargc = xlargc;
xlformat(cmsg, val1);
val1 = getstroutput(val1);
xlargv = origargv;
xlargc = origargc;
xlformat(emsg, val2);
val2 = getstroutput(val2);
/* signal the error */
xlcerror(getstring(val1),getstring(val2),s_unbound);
xlpopn(2);
/* return nil */
return (NIL);
}
/* xbreak - special form 'break' */
LVAL xbreak(V)
{
LVAL emsg;
LVAL val;
#ifdef CONDITIONS
if (s_condition_hook != NULL && getvalue(s_condition_hook) != NIL)
return(conditionhook(s_break));
#endif /* CONDITIONS */
xlsave1(val);
val = newustream();
/* get the error message */
emsg = xlgastring();
xlformat(emsg, val);
val = getstroutput(val);
/* enter the break loop */
xlbreak(getstring(val), s_unbound);
/* restore stack */
xlpop();
/* return nil */
return (NIL);
}
#endif
#ifdef CONDITIONS
LVAL xsignal(V) { return(conditionhook(s_signal)); }
LVAL xwarn(V) { return(conditionhook(s_warn)); }
LVAL xdebug(V) { return(conditionhook(s_debug)); }
#endif /* CONDITION */
/* xcleanup - special form 'clean-up' */
LVAL xcleanup(V)
{
xllastarg();
xlcleanup();
return (NIL);
}
/* xtoplevel - special form 'top-level' */
LVAL xtoplevel(V)
{
int print;
print = moreargs() ? ! null(nextarg()) : TRUE;
xllastarg();
xltoplevel(print);
return (NIL);
}
/* xcontinue - special form 'continue' */
LVAL xcontinue(V)
{
xllastarg();
xlcontinue();
return (NIL);
}
/* xevalhook - eval hook function */
LVAL xevalhook(V)
{
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 0 /* old way, if env is NIL then uses current environment */
if (!null(newenv)) {
oldenv = xlenv;
oldfenv = xlfenv;
xlenv = car(newenv);
xlfenv = cdr(newenv);
}
#else /* TAA MOD -- if env is NIL then uses global environment */
oldenv = xlenv;
oldfenv = xlfenv;
if (!null(newenv)) {
xlenv = car(newenv);
xlfenv = cdr(newenv);
}
else {
xlenv = xlfenv = NIL;
}
#endif
/* evaluate the expression (bypassing *evalhook*) */
val = xlxeval(expr);
/* restore the old environment */
xlunbind(olddenv);
#if 0
if (!null(newenv)) {
xlenv = oldenv;
xlfenv = oldfenv;
}
#else
xlenv = oldenv;
xlfenv = oldfenv;
#endif
/* restore the stack */
xlpopn(3);
/* return the result */
return (val);
}
#ifdef APPLYHOOK
/* xapplyhook - apply hook function */
LVAL xapplyhook(V)
{
LVAL fcn,args,newehook,newahook,olddenv,val;
/* get the function, arguments, and the new hook functions */
fcn = xlgetarg();
args = xlgetarg();
newehook = xlgetarg();
newahook = xlgetarg();
xllastarg();
/* bind *evalhook* and *applyhook* to the hook functions */
olddenv = xldenv;
xldbind(s_evalhook,newehook);
xldbind(s_applyhook,newahook);
/* apply function (apply always bypasses hooks) */
val = xlapply(pushargs(fcn,args));
/* restore the old environment */
xlunbind(olddenv);
/* return the result */
return (val);
}
#endif
#ifdef MULVALS
LVAL xvalues(V)
{
int i;
if (xlargc > MULVALLIMIT)
xlfail("too many values ");
for (i = 0; i < xlargc; i++)
xlresults[i] = xlargv[i];
xlnumresults = xlargc;
return(xlargc > 0 ? xlargv[0] : NIL);
}
#endif /* MULVALS */
/* CLtL2 - compliant version of FUNCTIONP */
LVAL xfunctionp(V)
{
LVAL x;
x = xlgetarg();
xllastarg();
switch(ntype(x)) {
case SUBR: return(s_true);
case CLOSURE:
return(gettype(x) == s_lambda ? s_true : NIL);
#ifdef BYTECODE
case BCCLOSURE:
return(getbcctype(x) == s_lambda ? s_true : NIL);
#endif /*BYTECODE */
default: return(NIL);
}
}
#ifdef CONDITIONS
LOCAL LVAL conditionhook P1C(LVAL, type)
{
FRAMEP newfp,fp;
LVAL olddenv,val,hook,args;
int argc;
/* rebind the hook functions to nil */
hook = getvalue(s_condition_hook);
olddenv = xldenv;
xldbind(s_condition_hook,NIL);
/* save a pointer */
xlsave1(args);
/* get the arglist */
argc = xlargc + 3;
args = makearglist(xlargc, xlargv);
/* build a new argument stack frame */
newfp = xlsp;
pusharg(cvfixnum((FIXTYPE)(newfp - xlfp)));
pusharg(hook);
pusharg(cvfixnum((FIXTYPE) argc));
/* push the type symbol, the function, and the environments */
pusharg(type);
fp = null(xlfp[0]) ? xlfp : xlfp - getfixnum(*xlfp);
pusharg(null(fp[0]) ? NIL : cvfixnum((FIXTYPE) (fp - xlargstkbase)));
pusharg(cons(xlenv,xlfenv));
/* push each argument */
for (; consp(args); args = cdr(args))
pusharg(car(args));
/* establish the new stack frame */
xlfp = newfp;
/* apply the function */
val = xlapply(argc);
/* restore the stack */
xlpop();
/* unbind the symbols */
xlunbind(olddenv);
return(val);
}
LVAL xstackval(V)
{
LVAL *sp;
sp = xlargstkbase + getfixnum(xlgafixnum());
xllastarg();
if (xlargstkbase <= sp && sp < xlargstktop)
return(*sp);
else return(NIL);
}
#endif /* CONDITIONS */
#if (defined(TIMES) && defined(MULVALS) && defined(BIGNUMS))
LVAL xgetdectime(V)
{
time_t t;
struct tm t_local, t_gm;
long secswest;
xllastarg();
t = time(NULL);
t_local = *localtime(&t);
t_gm = *gmtime(&t);
secswest = difftime(mktime(&t_gm), mktime(&t_local));
xlnumresults = 0;
xlresults[xlnumresults++] = cvfixnum((FIXTYPE) t_local.tm_sec);
xlresults[xlnumresults++] = cvfixnum((FIXTYPE) t_local.tm_min);
xlresults[xlnumresults++] = cvfixnum((FIXTYPE) t_local.tm_hour);
xlresults[xlnumresults++] = cvfixnum((FIXTYPE) t_local.tm_mday);
xlresults[xlnumresults++] = cvfixnum((FIXTYPE) t_local.tm_mon + 1);
xlresults[xlnumresults++] = cvfixnum((FIXTYPE) (t_local.tm_year + 1900));
xlresults[xlnumresults++] = cvfixnum((FIXTYPE) (t_local.tm_wday + 6) % 7);
/* The following treats unknown DST the same as no DST. This means
both may be wrong if DST is in effect and mktime can't figure
this out. */
xlresults[xlnumresults++] = t_local.tm_isdst > 0 ? s_true : NIL;
xlresults[xlnumresults++] = cvratio((FIXTYPE) secswest, (FIXTYPE) 3600);
return xlresults[0];
}
#endif
syntax highlighted by Code2HTML, v. 0.9.1