home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Power-Programmierung
/
CD1.mdf
/
lisp
/
interpre
/
xlispplu
/
sources
/
xlbfun.c
< prev
next >
Wrap
C/C++ Source or Header
|
1992-02-03
|
19KB
|
906 lines
/* xlbfun.c - xlisp basic built-in functions */
/* Copyright (c) 1985, by David Michael Betz
All Rights Reserved
Permission is granted for unrestricted non-commercial use */
#include "xlisp.h"
/* external variables */
extern LVAL xlenv,xlfenv,xldenv,true;
extern LVAL s_evalhook,s_applyhook;
extern LVAL s_unbound, s_quote;
extern char gsprefix[];
extern FIXTYPE gsnumber;
/* forward declarations */
#ifdef ANSI
LVAL NEAR makesymbol(int iflag);
#else
FORWARD LVAL makesymbol();
#endif
#if 0 /* original version uses current environment */
/* xeval - the built-in function 'eval' */
LVAL xeval()
{
LVAL expr;
/* get the expression to evaluate */
expr = xlgetarg();
xllastarg();
/* evaluate the expression */
return (xleval(expr));
}
#else /* Common Lisp compatible version uses global environment */
/* xeval - the built-in function 'eval' */
LVAL xeval()
{
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);
}
#endif
/* xapply - the built-in function 'apply' */
/* Algorithm based on Luke Tierney's XLISP-STAT */
LVAL xapply()
{
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()
{
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));
}
/* xmacroexpand - expand a macro call repeatedly */
LVAL xmacroexpand()
{
LVAL form;
form = xlgetarg();
xllastarg();
return (xlexpandmacros(form));
}
/* x1macroexpand - expand a macro call */
LVAL x1macroexpand()
{
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);
}
/* xatom - is this an atom? */
LVAL xatom()
{
LVAL arg;
arg = xlgetarg();
xllastarg();
return (atom(arg) ? true : NIL);
}
/* xsymbolp - is this an symbol? */
LVAL xsymbolp()
{
LVAL arg;
arg = xlgetarg();
xllastarg();
return (symbolp(arg) ? true : NIL);
}
/* xnumberp - is this a number? */
LVAL xnumberp()
{
LVAL arg;
arg = xlgetarg();
xllastarg();
#ifdef COMPLX
return (numberp(arg) || complexp(arg) ? true : NIL);
#else
return (fixp(arg) || floatp(arg) ? true : NIL);
#endif
}
#ifdef COMPLX
/* xcomplexp - is this a complex number? */
LVAL xcomplexp()
{
LVAL arg;
arg = xlgetarg();
xllastarg();
return (complexp(arg) ? true : NIL);
}
#endif
/* xintegerp - is this an integer? */
LVAL xintegerp()
{
LVAL arg;
arg = xlgetarg();
xllastarg();
return (fixp(arg) ? true : NIL);
}
/* xfloatp - is this a float? */
LVAL xfloatp()
{
LVAL arg;
arg = xlgetarg();
xllastarg();
return (floatp(arg) ? true : NIL);
}
#ifdef RATIOS
LVAL xrationalp()
{
LVAL arg;
arg = xlgetarg();
xllastarg();
return ((ratiop(arg) || fixp(arg)) ? true : NIL);
}
LVAL xnumerator()
{
LVAL arg;
arg = xlgetarg();
xllastarg();
if (fixp(arg)) return cvfixnum(getfixnum(arg));
if (ratiop(arg)) return cvfixnum(getnumer(arg));
xlbadtype(arg);
return NIL; /* never executes */
}
LVAL xdenominator()
{
LVAL arg;
arg = xlgetarg();
xllastarg();
if (fixp (arg)) return cvfixnum((FIXTYPE)1);
if (ratiop(arg)) return cvfixnum(getdenom(arg));
xlbadtype(arg);
return NIL; /* never executes */
}
#endif
/* xcharp - is this a character? */
LVAL xcharp()
{
LVAL arg;
arg = xlgetarg();
xllastarg();
return (charp(arg) ? true : NIL);
}
/* xstringp - is this a string? */
LVAL xstringp()
{
LVAL arg;
arg = xlgetarg();
xllastarg();
return (stringp(arg) ? true : NIL);
}
/* xarrayp - is this an array? */
LVAL xarrayp()
{
LVAL arg;
arg = xlgetarg();
xllastarg();
return (vectorp(arg) ? true : NIL);
}
/* xstreamp - is this a stream? */
LVAL xstreamp()
{
LVAL arg;
arg = xlgetarg();
xllastarg();
return (streamp(arg) || ustreamp(arg) ? true : NIL);
}
/* xopenstreamp - is this an open stream? */
LVAL xopenstreamp()
{
LVAL arg;
arg = xlgetarg();
xllastarg();
if (ustreamp(arg)) return true;
if (streamp(arg)) return (getfile(arg) != CLOSED ? true : NIL);
xlbadtype(arg);
return NIL; /* never executes */
}
/* xinputstreamp - is this an input stream? */
LVAL xinputstreamp()
{
LVAL arg;
arg = xlgetarg();
xllastarg();
if (ustreamp(arg)) return true;
if (streamp(arg))
return (getfile(arg)!=CLOSED && (arg->n_sflags&S_FORREADING)?
true : NIL);
xlbadtype(arg);
return NIL; /* never executes */
}
/* xoutputstreamp - is this an output stream? */
LVAL xoutputstreamp()
{
LVAL arg;
arg = xlgetarg();
xllastarg();
if (ustreamp(arg)) return true;
if (streamp(arg))
return (getfile(arg)!=CLOSED && (arg->n_sflags&S_FORWRITING)?
true : NIL);
xlbadtype(arg);
return NIL; /* never executes */
}
/* xobjectp - is this an object? */
LVAL xobjectp()
{
LVAL arg;
arg = xlgetarg();
xllastarg();
return (objectp(arg) ? true : NIL);
}
/* xboundp - is this a value bound to this symbol? */
LVAL xboundp()
{
LVAL sym;
sym = xlgasymornil(); /* TAA fix */
xllastarg();
return (boundp(sym) ? true : NIL);
}
/* xfboundp - is this a functional value bound to this symbol? */
LVAL xfboundp()
{
LVAL sym;
sym = xlgasymornil(); /* TAA fix */
xllastarg();
return (fboundp(sym) ? true : NIL);
}
/* xconstantp - is this constant? TAA addition*/
LVAL xconstantp()
{
LVAL arg;
arg = xlgetarg();
xllastarg();
if ((!null(arg)) &&
(((ntype(arg)==CONS) && (car(arg) != s_quote)) ||
((ntype(arg)==SYMBOL) && (!constantp(arg)))))
return (NIL);
return (true);
}
/* xnull - is this null? */
LVAL xnull()
{
LVAL arg;
arg = xlgetarg();
xllastarg();
return (null(arg) ? true : NIL);
}
/* xlistp - is this a list? */
LVAL xlistp()
{
LVAL arg;
arg = xlgetarg();
xllastarg();
return (listp(arg) ? true : NIL);
}
/* xendp - is this the end of a list? */
LVAL xendp()
{
LVAL arg;
arg = xlgalist();
xllastarg();
return (null(arg) ? true : NIL);
}
/* xconsp - is this a cons? */
LVAL xconsp()
{
LVAL arg;
arg = xlgetarg();
xllastarg();
return (consp(arg) ? true : NIL);
}
/* xeq - are these equal? */
LVAL xeq()
{
LVAL arg1,arg2;
/* get the two arguments */
arg1 = xlgetarg();
arg2 = xlgetarg();
xllastarg();
/* compare the arguments */
return (arg1 == arg2 ? true : NIL);
}
/* xeql - are these equal? */
LVAL xeql()
{
LVAL arg1,arg2;
/* get the two arguments */
arg1 = xlgetarg();
arg2 = xlgetarg();
xllastarg();
/* compare the arguments */
return (eql(arg1,arg2) ? true : NIL);
}
/* xequal - are these equal? (recursive) */
LVAL xequal()
{
LVAL arg1,arg2;
/* get the two arguments */
arg1 = xlgetarg();
arg2 = xlgetarg();
xllastarg();
/* compare the arguments */
return (equal(arg1,arg2) ? true : NIL);
}
/* xset - built-in function set */
LVAL xset()
{
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()
{
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%d",gsprefix,gsnumber++);
/* make a symbol with this print name */
return (xlmakesym(sym));
}
/* xmakesymbol - make a new uninterned symbol */
LVAL xmakesymbol()
{
return (makesymbol(FALSE));
}
/* xintern - make a new interned symbol */
LVAL xintern()
{
return (makesymbol(TRUE));
}
/* makesymbol - make a new symbol */
LOCAL LVAL NEAR makesymbol(iflag)
int iflag;
{
LVAL pname;
int i;
/* get the print name of the symbol to intern */
pname = xlgastring();
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 MEDMEM
STRCPY(buf, getstring(pname));
return (iflag ? xlenter(buf)
: xlmakesym(buf));
#else
return (iflag ? xlenter(getstring(pname))
: xlmakesym(getstring(pname)));
#endif
}
/* xsymname - get the print name of a symbol */
LVAL xsymname()
{
LVAL sym;
/* get the symbol */
sym = xlgasymornil(); /* TAA fix */
xllastarg();
/* return the print name */
return (getpname(sym));
}
/* xsymvalue - get the value of a symbol */
LVAL xsymvalue()
{
LVAL sym,val;
/* get the symbol */
sym = xlgasymornil(); /* TAA fix */
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()
{
LVAL sym,val;
/* get the symbol */
sym = xlgasymornil(); /* TAA fix */
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()
{
LVAL sym;
/* get the symbol */
sym = xlgasymornil(); /* TAA fix */
xllastarg();
/* return the property list */
return (getplist(sym));
}
/* xget - get the value of a property */
LVAL xget()
{
LVAL sym,prp;
/* get the symbol and property */
sym = xlgasymbol();
prp = xlgetarg();
xllastarg();
/* retrieve the property value */
return (xlgetprop(sym,prp));
}
/* xputprop - set the value of a property */
LVAL xputprop()
{
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()
{
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()
{
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)));
}
/* xaref - array reference function */
LVAL xaref()
{
LVAL array,index;
FIXTYPE i; /* TAA fix */
/* get the array (may be a string) and the index */
array = xlgetarg();
array = xlgavector();
index = xlgafixnum();
i = getfixnum(index); /* TAA fix */
xllastarg();
if (stringp(array)) { /* extension -- allow fetching chars from string*/
if (i < 0 || i >= getslength(array))
xlerror("string index out of bounds",index);
return (cvchar(getstringch(array,(int)i)));
}
if (!vectorp(array)) xlbadtype(array); /* type must be array */
/* range check the index */
if (i < 0 || i >= getsize(array))
xlerror("array index out of bounds",index);
/* return the array element */
return (getelement(array,(int)i)); /* TAA fix -- casting */
}
/* xmkarray - make a new array */
LVAL xmkarray()
{
LVAL size;
FIXTYPE n;
/* get the size of the array */
size = xlgafixnum() ; n = getfixnum(size);
if (n < 0 || n > MAXSLEN )
xlerror("out of range",size);
xllastarg();
/* create the array */
return (newvector((unsigned)n));
}
/* xvector - make a vector */
LVAL xvector()
{
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);
}
/* xerror - special form 'error' */
LVAL xerror()
{
LVAL emsg,arg;
/* 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()
{
LVAL cmsg,emsg,arg;
/* 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()
{
LVAL emsg,arg;
/* get the error message */
emsg = (moreargs() ? xlgastring() : NIL);
arg = (moreargs() ? xlgetarg() : s_unbound);
xllastarg();
/* enter the break loop */
xlbreak((!null(emsg) ? getstring(emsg) : (char FAR *)"**BREAK**"),arg);
/* return nil */
return (NIL);
}
/* xcleanup - special form 'clean-up' */
LVAL xcleanup()
{
xllastarg();
xlcleanup();
return (NIL);
}
/* xtoplevel - special form 'top-level' */
LVAL xtoplevel()
{
xllastarg();
xltoplevel();
return (NIL);
}
/* xcontinue - special form 'continue' */
LVAL xcontinue()
{
xllastarg();
xlcontinue();
return (NIL);
}
/* xevalhook - eval hook function */
LVAL xevalhook()
{
LVAL expr,newehook,newahook,newenv,oldenv,oldfenv,olddenv,val;
/* protect some pointers */
xlstkcheck(3);
#if 0 /* old way (see below) */
xlsave(oldenv);
xlsave(oldfenv);
xlsave(newenv);
#else /* TAA MOD -- see below */
xlprotect(oldenv);
xlprotect(oldfenv);
xlprotect(newenv);
#endif
/* 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()
{
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