betz (04/01/83)
<<<<<<<<<< xlio.c >>>>>>>>>>
/* xlio - xlisp i/o routines */
#include <stdio.h>
#include "xlisp.h"
/* global variables */
int (*xlgetc)();
int xlpvals;
int xlplevel;
/* local variables */
static int prompt;
static FILE *ifp;
/* tgetc - get a character from the terminal */
static int tgetc()
{
int ch;
/* prompt if necessary */
if (prompt) {
if (xlplevel > 0)
printf("%d> ",xlplevel);
else
printf("> ");
prompt = FALSE;
}
/* get the character */
if ((ch = getchar()) == '\n')
prompt = TRUE;
/* return the character */
return (ch);
}
/* xltin - setup terminal input */
int xltin(flag)
int flag;
{
/* flush line if flag is set */
if (flag & !prompt)
while (tgetc() != '\n')
;
/* initialize */
prompt = TRUE;
xlplevel = 0;
xlgetc = tgetc;
xlpvals = TRUE;
}
/* fgetcx - get a character from a file */
static int fgetcx()
{
int ch;
/* get a character */
if ((ch = getc(ifp)) <= 0) {
xlgetc = tgetc;
xlpvals = TRUE;
return (tgetc());
}
/* return it */
return (ch);
}
/* xlfin - setup file input */
xlfin(str)
char *str;
{
#ifdef DEFEXT
char fname[100];
/* create the file name */
strcpy(fname,str);
/* check for extension */
if (strchr(fname,'.') == 0)
strcat(fname,".lsp");
#else
#define fname str
#endif
/* open the input file */
if ((ifp = fopen(fname,"r")) == NULL) {
printf("can't open \"%s\" for input\n",fname);
return;
}
/* setup input from the file */
xlgetc = fgetcx;
xlpvals = FALSE;
}
<<<<<<<<<< xlisp.c >>>>>>>>>>
/* xlisp - a small subset of lisp */
#include <stdio.h>
#include <setjmp.h>
#include "xlisp.h"
/* global variables */
jmp_buf xljmpbuf;
/* external variables */
extern struct node *xlenv;
extern struct node *xlstack;
extern int xlpvals;
/* main - the main routine */
main(argc,argv)
int argc; char *argv[];
{
struct node expr;
/* initialize the dynamic memory module (must be first) */
xldmeminit();
/* initialize xlisp */
xlinit();
xleinit(); xllinit(); xlminit();
xloinit(); xlsinit(); xlfinit();
xlpinit(); xlkinit();
/* initialize terminal input */
xltin(FALSE);
/* read the input file if specified */
if (argc > 1)
xlfin(argv[1]);
else
printf("XLISP version 1.0\n");
/* main command processing loop */
while (TRUE) {
/* setup the error return */
setjmp(xljmpbuf);
/* free any previous expression and leftover context */
xlstack = xlenv = NULL;
/* create a new stack frame */
xlsave(&expr,NULL);
/* read an expression */
expr.n_ptr = xlread();
/* evaluate the expression */
expr.n_ptr = xleval(expr.n_ptr);
/* print it if necessary */
if (xlpvals) {
xlprint(expr.n_ptr,TRUE);
putchar('\n');
}
}
}
<<<<<<<<<< xlkmap.c >>>>>>>>>>
/* xlkmap - xlisp key map functions */
#include <stdio.h>
#include "xlisp.h"
/* external variables */
extern struct node *xlstack;
extern struct node *xlenv;
extern struct node *self;
/* local definitions */
#define KMSIZE 256 /* number of characters in a keymap */
#define KMAX 20 /* maximum number of characters in a key sequence */
#define KEYMAP 0 /* instance variable number for 'keymap' */
/* local variables */
static struct node *currentenv;
/* forward declarations (the extern hack is because of decusc) */
extern struct node *sendmsg();
/* isnew - initialize a new keymap */
static struct node *isnew(args)
struct node *args;
{
/* make sure there aren't any arguments */
xllastarg(args);
/* create a keymap node */
xlivar(self->n_symvalue,KEYMAP)->n_listvalue = newnode(KMAP);
/* return the keymap object */
return (self->n_symvalue);
}
/* newkmap - allocate memory for a new key map vector */
static struct node *(*newkmap())[]
{
struct node *(*map)[];
/* allocate the vector */
if ((map = (struct node *(*)[]) calloc(1,sizeof(struct node *) * KMSIZE))
== NULL) {
printf("insufficient memory");
exit();
}
/* return the new vector */
return (map);
}
/* key - define a key */
static struct node *key(args)
struct node *args;
{
struct node *oldstk,arg,kstr,ksym,*kmap,*kmptr;
struct node *(*map)[];
char *sptr;
int ch;
/* create a new stack frame */
oldstk = xlsave(&arg,&kstr,&ksym,NULL);
/* initialize */
arg.n_ptr = args;
/* get the keymap */
kmap = xlivar(self->n_symvalue,KEYMAP)->n_listvalue;
if (kmap == NULL && kmap->n_type != KMAP)
xlfail("bad keymap object");
/* get the key string */
kstr.n_ptr = xlevmatch(STR,&arg.n_ptr);
/* get the key symbol */
ksym.n_ptr = xlevmatch(SYM,&arg.n_ptr);
/* make sure there aren't any more arguments */
xllastarg(arg.n_ptr);
/* process each character in the key string */
for (kmptr = kmap, sptr = kstr.n_ptr->n_str;
*sptr != 0;
kmptr = (*map)[ch]) {
/* get a character */
ch = *sptr++;
/* allocate a key map vector if non currently exists */
if ((map = kmptr->n_kmap) == NULL)
map = kmptr->n_kmap = newkmap();
/* check for this being the last character in the string */
if (*sptr == 0)
(*map)[ch] = ksym.n_ptr;
else
if ((*map)[ch] == NULL || (*map)[ch]->n_type != KMAP) {
(*map)[ch] = newnode(KMAP);
(*map)[ch]->n_kmap = newkmap();
}
}
/* restore the previous stack frame */
xlstack = oldstk;
/* return the keymap object */
return (self->n_symvalue);
}
/* process - process input characters using a key map */
static struct node *process(args)
struct node *args;
{
struct node *oldstk,arg,env,margs,*kmap,*kmptr,*nptr,*oldenv;
struct node *(*map)[];
char keys[KMAX+1];
int ch,kndx;
/* create a new stack frame */
oldstk = xlsave(&arg,&env,&margs,NULL);
/* initialize */
arg.n_ptr = args;
/* get the keymap */
kmap = xlivar(self->n_symvalue,KEYMAP)->n_listvalue;
if (kmap == NULL && kmap->n_type != KMAP)
xlfail("bad keymap object");
/* get the environment */
env.n_ptr = xlevmatch(LIST,&arg.n_ptr);
/* make sure there aren't any more arguments */
xllastarg(arg.n_ptr);
/* bind the current environment variable */
oldenv = xlenv;
xlbind(currentenv,env.n_ptr);
xlfixbindings(oldenv);
/* make sure the key map is defined */
if (kmap->n_kmap == NULL)
xlfail("empty keymap");
/* create an argument list to send with key messages */
margs.n_ptr = newnode(LIST);
margs.n_ptr->n_listvalue = newnode(STR);
margs.n_ptr->n_listvalue->n_str = keys;
margs.n_ptr->n_listvalue->n_strtype = STATIC;
/* character processing loop */
for (kmptr = kmap, kndx = 0; TRUE; ) {
/* flush pending output */
fflush(stdout);
/* get a character */
if ((ch = kbin()) < 0)
break;
/* put it in the key sequence */
if (kndx < KMAX)
keys[kndx++] = ch;
else
xlfail("key sequence too long");
/* dispatch on character code */
if ((map = kmptr->n_kmap) == NULL)
xlfail("bad keymap");
else if ((nptr = (*map)[ch]) == NULL) {
kmptr = kmap;
kndx = 0;
}
else if (nptr->n_type == KMAP)
kmptr = (*map)[ch];
else if (nptr->n_type == SYM) {
keys[kndx] = 0;
if (sendmsg(nptr,currentenv->n_symvalue,margs.n_ptr) == NULL)
break;
kmptr = kmap;
kndx = 0;
}
else
xlfail("bad keymap");
}
/* unbind */
xlunbind(oldenv);
/* restore the previous stack frame */
xlstack = oldstk;
/* return the keymap object */
return (self->n_symvalue);
}
/* sendmsg - send a message given an environment list */
static struct node *sendmsg(msym,env,args)
struct node *msym,*env,*args;
{
struct node *eptr,*obj,*msg;
/* look for an object that answers the message */
for (eptr = env; eptr != NULL; eptr = eptr->n_listnext)
if ((obj = eptr->n_listvalue) != NULL && obj->n_type == OBJ)
if ((msg = xlmfind(obj,msym)) != NULL)
return (xlxsend(obj,msg,args));
/* return the message if no object answered it */
return (msym);
}
/* xlkmmark - mark a keymap */
xlkmmark(km)
struct node *km;
{
struct node *(*map)[];
int i;
/* mark the keymap node */
km->n_flags |= MARK;
/* check for a null keymap */
if ((map = km->n_kmap) == NULL)
return;
/* loop through each keymap entry */
for (i = 0; i < KMSIZE; i++)
if (((*map)[i] != NULL) && (*map)[i]->n_type == KMAP)
xlkmmark((*map)[i]);
}
/* xlkmfree - free a keymap */
xlkmfree(km)
struct node *km;
{
struct node *(*map)[];
int i;
/* check for a null keymap */
if ((map = km->n_kmap) == NULL)
return;
/* loop through each keymap entry */
for (i = 0; i < KMSIZE; i++)
if (((*map)[i] != NULL) && (*map)[i]->n_type == KMAP)
xlkmfree((*map)[i]);
/* free this keymap */
free(km->n_kmap);
}
/* xlkinit - key map function initialization routine */
xlkinit()
{
struct node *keymap;
/* define the xlisp variables */
currentenv = xlenter("currentenv");
/* define the keymap class */
keymap = xlclass("Keymap",1);
xladdivar(keymap,"keymap");
xladdmsg(keymap,"isnew",isnew);
xladdmsg(keymap,"key",key);
xladdmsg(keymap,"process",process);
}
<<<<<<<<<< xllist.c >>>>>>>>>>
/* xllist - xlisp list builtin functions */
#include <stdio.h>
#include "xlisp.h"
/* external variables */
extern struct node *xlstack;
/* local variables */
static struct node *t;
/* xlist - builtin function list */
static struct node *xlist(args)
struct node *args;
{
struct node *oldstk,arg,list,val,*last,*lptr;
/* create a new stack frame */
oldstk = xlsave(&arg,&list,&val,NULL);
/* initialize */
arg.n_ptr = args;
/* evaluate and append each argument */
for (last = NULL; arg.n_ptr != NULL; last = lptr) {
/* evaluate the next argument */
val.n_ptr = xlevarg(&arg.n_ptr);
/* append this argument to the end of the list */
lptr = newnode(LIST);
if (last == NULL)
list.n_ptr = lptr;
else
last->n_listnext = lptr;
lptr->n_listvalue = val.n_ptr;
}
/* restore the previous stack frame */
xlstack = oldstk;
/* return the list */
return (list.n_ptr);
}
/* cond - builtin function cond */
static struct node *cond(args)
struct node *args;
{
struct node *oldstk,arg,list,*val;
/* create a new stack frame */
oldstk = xlsave(&arg,&list,NULL);
/* initialize */
arg.n_ptr = args;
/* initialize the return value */
val = NULL;
/* find a predicate that is true */
while (arg.n_ptr != NULL) {
/* get the next conditional */
list.n_ptr = xlmatch(LIST,&arg.n_ptr);
/* evaluate the predicate part */
if (xlevarg(&list.n_ptr) != NULL) {
/* evaluate each expression */
while (list.n_ptr != NULL)
val = xlevarg(&list.n_ptr);
/* exit the loop */
break;
}
}
/* restore the previous stack frame */
xlstack = oldstk;
/* return the value */
return (val);
}
/* atom - is this an atom? */
static struct node *atom(args)
struct node *args;
{
struct node *arg;
/* get the argument */
if ((arg = xlevarg(&args)) == NULL || arg->n_type != LIST)
return (t);
else
return (NULL);
}
/* null - is this null? */
static struct node *null(args)
struct node *args;
{
/* get the argument */
if (xlevarg(&args) == NULL)
return (t);
else
return (NULL);
}
/* listp - is this a list? */
static struct node *listp(args)
struct node *args;
{
/* get the argument */
if (xlistp(xlevarg(&args)))
return (t);
else
return (NULL);
}
/* xlistp - internal listp function */
static int xlistp(arg)
struct node *arg;
{
return (arg == NULL || arg->n_type == LIST);
}
/* eq - are these equal? */
static struct node *eq(args)
struct node *args;
{
struct node *oldstk,arg,arg1,arg2,*val;
/* create a new stack frame */
oldstk = xlsave(&arg,&arg1,&arg2,NULL);
/* initialize */
arg.n_ptr = args;
/* first argument */
arg1.n_ptr = xlevarg(&arg.n_ptr);
/* second argument */
arg2.n_ptr = xlevarg(&arg.n_ptr);
/* make sure there aren't any more arguments */
xllastarg(arg.n_ptr);
/* compare the arguments */
if (xeq(arg1.n_ptr,arg2.n_ptr))
val = t;
else
val = NULL;
/* restore the previous stack frame */
xlstack = oldstk;
/* return the result */
return (val);
}
/* xeq - internal eq function */
static int xeq(arg1,arg2)
struct node *arg1,*arg2;
{
/* compare the arguments */
if (arg1 != NULL && arg1->n_type == INT &&
arg2 != NULL && arg2->n_type == INT)
return (arg1->n_int == arg2->n_int);
else
return (arg1 == arg2);
}
/* equal - are these equal? */
static struct node *equal(args)
struct node *args;
{
struct node *oldstk,arg,arg1,arg2,*val;
/* create a new stack frame */
oldstk = xlsave(&arg,&arg1,&arg2,NULL);
/* initialize */
arg.n_ptr = args;
/* first argument */
arg1.n_ptr = xlevarg(&arg.n_ptr);
/* second argument */
arg2.n_ptr = xlevarg(&arg.n_ptr);
/* make sure there aren't any more arguments */
xllastarg(arg.n_ptr);
/* compare the arguments */
if (xequal(arg1.n_ptr,arg2.n_ptr))
val = t;
else
val = NULL;
/* restore the previous stack frame */
xlstack = oldstk;
/* return the result */
return (val);
}
/* xequal - internal equal function */
static int xequal(arg1,arg2)
struct node *arg1,*arg2;
{
/* compare the arguments */
if (xeq(arg1,arg2))
return (TRUE);
else if (xlistp(arg1) && xlistp(arg2))
return (xequal(arg1->n_listvalue,arg2->n_listvalue) &&
xequal(arg1->n_listnext, arg2->n_listnext));
else
return (FALSE);
}
/* head - return the head of a list */
static struct node *head(args)
struct node *args;
{
struct node *list;
/* get the list */
if ((list = xlevmatch(LIST,&args)) == NULL)
xlfail("null list");
/* make sure this is the only argument */
xllastarg(args);
/* return the head of the list */
return (list->n_listvalue);
}
/* tail - return the tail of a list */
static struct node *tail(args)
struct node *args;
{
struct node *list;
/* get the list */
if ((list = xlevmatch(LIST,&args)) == NULL)
xlfail("null list");
/* make sure this is the only argument */
xllastarg(args);
/* return the tail of the list */
return (list->n_listnext);
}
/* nth - return the nth element of a list */
static struct node *nth(args)
struct node *args;
{
struct node *oldstk,arg,list;
int n;
/* create a new stack frame */
oldstk = xlsave(&arg,&list,NULL);
/* initialize */
arg.n_ptr = args;
/* get n */
if ((n = xlevmatch(INT,&arg.n_ptr)->n_int) < 1)
xlfail("invalid argument");
/* get the list */
if ((list.n_ptr = xlevmatch(LIST,&arg.n_ptr)) == NULL)
xlfail("invalid argument");
/* make sure this is the only argument */
xllastarg(arg.n_ptr);
/* find the nth element */
for (; n > 1; n--) {
list.n_ptr = list.n_ptr->n_listnext;
if (list.n_ptr == NULL || list.n_ptr->n_type != LIST)
xlfail("invalid argument");
}
/* restore the previous stack frame */
xlstack = oldstk;
/* return the list nth list element */
return (list.n_ptr->n_listvalue);
}
/* length - return the length of a list */
static struct node *length(args)
struct node *args;
{
struct node *oldstk,list,*val;
int n;
/* create a new stack frame */
oldstk = xlsave(&list,NULL);
/* get the list */
list.n_ptr = xlevmatch(LIST,&args);
/* make sure this is the only argument */
xllastarg(args);
/* find the length */
for (n = 0; list.n_ptr != NULL; n++)
list.n_ptr = list.n_ptr->n_listnext;
/* restore the previous stack frame */
xlstack = oldstk;
/* create the value node */
val = newnode(INT);
val->n_int = n;
/* return the length */
return (val);
}
/* append - builtin function append */
static struct node *append(args)
struct node *args;
{
struct node *oldstk,arg,list,last,val,*lptr;
/* create a new stack frame */
oldstk = xlsave(&arg,&list,&last,&val,NULL);
/* initialize */
arg.n_ptr = args;
/* evaluate and append each argument */
while (arg.n_ptr != NULL) {
/* evaluate the next argument */
list.n_ptr = xlevmatch(LIST,&arg.n_ptr);
/* append each element of this list to the result list */
while (list.n_ptr != NULL && list.n_ptr->n_type == LIST) {
/* append this element */
lptr = newnode(LIST);
if (last.n_ptr == NULL)
val.n_ptr = lptr;
else
last.n_ptr->n_listnext = lptr;
lptr->n_listvalue = list.n_ptr->n_listvalue;
/* save the new last element */
last.n_ptr = lptr;
/* move to the next element */
list.n_ptr = list.n_ptr->n_listnext;
}
/* make sure the list ended in a nil */
if (list.n_ptr != NULL)
xlfail("bad list");
}
/* restore previous stack frame */
xlstack = oldstk;
/* return the list */
return (val.n_ptr);
}
/* reverse - builtin function reverse */
static struct node *reverse(args)
struct node *args;
{
struct node *oldstk,list,val,*lptr;
/* create a new stack frame */
oldstk = xlsave(&list,&val,NULL);
/* get the list to reverse */
list.n_ptr = xlevmatch(LIST,&args);
/* make sure there aren't any more arguments */
xllastarg(args);
/* append each element of this list to the result list */
while (list.n_ptr != NULL && list.n_ptr->n_type == LIST) {
/* append this element */
lptr = newnode(LIST);
lptr->n_listvalue = list.n_ptr->n_listvalue;
lptr->n_listnext = val.n_ptr;
val.n_ptr = lptr;
/* move to the next element */
list.n_ptr = list.n_ptr->n_listnext;
}
/* make sure the list ended in a nil */
if (list.n_ptr != NULL)
xlfail("bad list");
/* restore previous stack frame */
xlstack = oldstk;
/* return the list */
return (val.n_ptr);
}
/* cons - construct a new list cell */
static struct node *cons(args)
struct node *args;
{
struct node *oldstk,arg,arg1,arg2,*lptr;
/* create a new stack frame */
oldstk = xlsave(&arg,&arg1,&arg2,NULL);
/* initialize */
arg.n_ptr = args;
/* first argument */
arg1.n_ptr = xlevarg(&arg.n_ptr);
/* second argument */
arg2.n_ptr = xlevarg(&arg.n_ptr);
/* make sure there aren't any more arguments */
xllastarg(arg.n_ptr);
/* construct a new list element */
lptr = newnode(LIST);
lptr->n_listvalue = arg1.n_ptr;
lptr->n_listnext = arg2.n_ptr;
/* restore the previous stack frame */
xlstack = oldstk;
/* return the list */
return (lptr);
}
/* xllinit - xlisp list initialization routine */
xllinit()
{
/* define some symbols */
t = xlenter("t");
/* functions with reasonable names */
xlsubr("head",head);
xlsubr("tail",tail);
xlsubr("nth",nth);
/* real lisp functions */
xlsubr("atom",atom);
xlsubr("eq",eq);
xlsubr("equal",equal);
xlsubr("null",null);
xlsubr("listp",listp);
xlsubr("cond",cond);
xlsubr("list",xlist);
xlsubr("cons",cons);
xlsubr("car",head);
xlsubr("cdr",tail);
xlsubr("append",append);
xlsubr("reverse",reverse);
xlsubr("length",length);
}
<<<<<<<<<< xlmath.c >>>>>>>>>>
/* xlmath - xlisp builtin arithmetic functions */
#include <stdio.h>
#include "xlisp.h"
/* external variables */
extern struct node *xlstack;
/* local variables */
static struct node *true;
/* forward declarations (the extern hack is for decusc) */
extern struct node *arith();
extern struct node *compare();
/* add - builtin function for addition */
static int xadd(val,arg)
int val,arg;
{
return (val + arg);
}
static struct node *add(args)
struct node *args;
{
return (arith(args,xadd));
}
/* sub - builtin function for subtraction */
static int xsub(val,arg)
int val,arg;
{
return (val - arg);
}
static struct node *sub(args)
struct node *args;
{
return (arith(args,xsub));
}
/* mul - builtin function for multiplication */
static int xmul(val,arg)
int val,arg;
{
return (val * arg);
}
static struct node *mul(args)
struct node *args;
{
return (arith(args,xmul));
}
/* div - builtin function for division */
static int xdiv(val,arg)
int val,arg;
{
return (val / arg);
}
static struct node *div(args)
struct node *args;
{
return (arith(args,xdiv));
}
/* mod - builtin function for modulus */
static int xmod(val,arg)
int val,arg;
{
return (val % arg);
}
static struct node *mod(args)
struct node *args;
{
return (arith(args,xmod));
}
/* and - builtin function for modulus */
static int xand(val,arg)
int val,arg;
{
return (val & arg);
}
static struct node *and(args)
struct node *args;
{
return (arith(args,xand));
}
/* or - builtin function for modulus */
static int xor(val,arg)
int val,arg;
{
return (val | arg);
}
static struct node *or(args)
struct node *args;
{
return (arith(args,xor));
}
/* not - bitwise not */
static struct node *not(args)
struct node *args;
{
struct node *rval;
int val;
/* evaluate the argument */
val = xlevmatch(INT,&args)->n_int;
/* make sure there aren't any more arguments */
xllastarg(args);
/* convert and check the value */
rval = newnode(INT);
rval->n_int = ~val;
/* return the result value */
return (rval);
}
/* abs - absolute value */
static struct node *abs(args)
struct node *args;
{
struct node *rval;
int val;
/* evaluate the argument */
val = xlevmatch(INT,&args)->n_int;
/* make sure there aren't any more arguments */
xllastarg(args);
/* convert and check the value */
rval = newnode(INT);
rval->n_int = val >= 0 ? val : -val ;
/* return the result value */
return (rval);
}
/* min - builtin function for minimum */
static int xmin(val,arg)
int val,arg;
{
return (val < arg ? val : arg);
}
static struct node *min(args)
struct node *args;
{
return (arith(args,xmin));
}
/* max - builtin function for maximum */
static int xmax(val,arg)
int val,arg;
{
return (val > arg ? val : arg);
}
static struct node *max(args)
struct node *args;
{
return (arith(args,xmax));
}
/* arith - common arithmetic function */
static struct node *arith(args,funct)
struct node *args; int (*funct)();
{
struct node *oldstk,arg,*val;
int first,ival,iarg;
/* create a new stack frame */
oldstk = xlsave(&arg,NULL);
/* initialize */
arg.n_ptr = args;
first = TRUE;
ival = 0;
/* evaluate and sum each argument */
while (arg.n_ptr != NULL) {
/* get the next argument */
iarg = xlevmatch(INT,&arg.n_ptr)->n_int;
/* accumulate the result value */
if (first) {
ival = iarg;
first = FALSE;
}
else
ival = (*funct)(ival,iarg);
}
/* initialize value */
val = newnode(INT);
val->n_int = ival;
/* restore the previous stack frame */
xlstack = oldstk;
/* return the result value */
return (val);
}
/* land - logical and */
static struct node *land(args)
struct node *args;
{
struct node *oldstk,arg,*val;
/* create a new stack frame */
oldstk = xlsave(&arg,NULL);
/* initialize */
arg.n_ptr = args;
val = true;
/* evaluate each argument */
while (arg.n_ptr != NULL)
/* get the next argument */
if (xlevarg(&arg.n_ptr) == NULL) {
val = NULL;
break;
}
/* restore the previous stack frame */
xlstack = oldstk;
/* return the result value */
return (val);
}
/* lor - logical or */
static struct node *lor(args)
struct node *args;
{
struct node *oldstk,arg,*val;
/* create a new stack frame */
oldstk = xlsave(&arg,NULL);
/* initialize */
arg.n_ptr = args;
val = NULL;
/* evaluate each argument */
while (arg.n_ptr != NULL)
if (xlevarg(&arg.n_ptr) != NULL) {
val = true;
break;
}
/* restore the previous stack frame */
xlstack = oldstk;
/* return the result value */
return (val);
}
/* lnot - logical not */
static struct node *lnot(args)
struct node *args;
{
struct node *val;
/* evaluate the argument */
val = xlevarg(&args);
/* make sure there aren't any more arguments */
xllastarg(args);
/* convert and check the value */
if (val == NULL)
return (true);
else
return (NULL);
}
/* lss - builtin function for < */
static int xlss(cmp)
int cmp;
{
return (cmp < 0);
}
static struct node *lss(args)
struct node *args;
{
return (compare(args,xlss));
}
/* leq - builtin function for <= */
static int xleq(cmp)
int cmp;
{
return (cmp <= 0);
}
static struct node *leq(args)
struct node *args;
{
return (compare(args,xleq));
}
/* eql - builtin function for == */
static int xeql(cmp)
int cmp;
{
return (cmp == 0);
}
static struct node *eql(args)
struct node *args;
{
return (compare(args,xeql));
}
/* neq - builtin function for != */
static int xneq(cmp)
int cmp;
{
return (cmp != 0);
}
static struct node *neq(args)
struct node *args;
{
return (compare(args,xneq));
}
/* geq - builtin function for >= */
static int xgeq(cmp)
int cmp;
{
return (cmp >= 0);
}
static struct node *geq(args)
struct node *args;
{
return (compare(args,xgeq));
}
/* gtr - builtin function for > */
static int xgtr(cmp)
int cmp;
{
return (cmp > 0);
}
static struct node *gtr(args)
struct node *args;
{
return (compare(args,xgtr));
}
/* compare - common compare function */
static struct node *compare(args,funct)
struct node *args; int (*funct)();
{
struct node *oldstk,arg,arg1,arg2;
int type1,type2,cmp;
/* create a new stack frame */
oldstk = xlsave(&arg,&arg1,&arg2,NULL);
/* initialize */
arg.n_ptr = args;
/* get argument 1 */
arg1.n_ptr = xlevarg(&arg.n_ptr);
type1 = gettype(arg1.n_ptr);
/* get argument 2 */
arg2.n_ptr = xlevarg(&arg.n_ptr);
type2 = gettype(arg2.n_ptr);
/* make sure there aren't any more arguments */
xllastarg(arg.n_ptr);
/* do the compare */
if (type1 == STR && type2 == STR)
cmp = strcmp(arg1.n_ptr->n_str,arg2.n_ptr->n_str);
else if (type1 == INT && type2 == INT)
cmp = arg1.n_ptr->n_int - arg2.n_ptr->n_int;
else
cmp = arg1.n_ptr - arg2.n_ptr;
/* restore the previous stack frame */
xlstack = oldstk;
/* return result of the compare */
if ((*funct)(cmp))
return (true);
else
return (NULL);
}
/* gettype - return the type of an argument */
static int gettype(arg)
struct node *arg;
{
if (arg == NULL)
return (LIST);
else
return (arg->n_type);
}
/* xlminit - xlisp math initialization routine */
xlminit()
{
xlsubr("+",add);
xlsubr("-",sub);
xlsubr("*",mul);
xlsubr("/",div);
xlsubr("%",mod);
xlsubr("&",and);
xlsubr("|",or);
xlsubr("~",not);
xlsubr("<",lss);
xlsubr("<=",leq);
xlsubr("==",eql);
xlsubr("!=",neq);
xlsubr(">=",geq);
xlsubr(">",gtr);
xlsubr("&&",land);
xlsubr("||",lor);
xlsubr("!",lnot);
xlsubr("min",min);
xlsubr("max",max);
xlsubr("abs",abs);
true = xlenter("t");
true->n_symvalue = true;
}