Thread View: net.micro.atari
1 messages
1 total messages
Started by Jwahar R. Bammi
Sat, 18 Jan 1986 20:01
xlisp (PART 4 of 6)
Author: Jwahar R. Bammi
Date: Sat, 18 Jan 1986 20:01
Date: Sat, 18 Jan 1986 20:01
3009 lines
71892 bytes
71892 bytes
#!/bin/sh
# This is a shell archive, meaning:
# 1. Remove everything above the #!/bin/sh line.
# 2. Save the resulting text in a file.
# 3. Execute the file with /bin/sh (not csh) to create the files:
# ststuff.c
# xlbfun.c
# xlcont.c
# xldbug.c
# xldmem.c
# xleval.c
# xlfio.c
# xlftab1.c
# This archive created: Sat Jan 18 14:32:22 1986
# By: Jwahar R. Bammi ()
export PATH; PATH=/bin:$PATH
echo shar: extracting "'ststuff.c'" '(2963 characters)'
if test -f 'ststuff.c'
then
echo shar: over-writing existing file "'ststuff.c'"
fi
sed 's/^X//' << \SHAR_EOF > 'ststuff.c'
X/* ststuff.c - atari 520st specific routines */
X
X#include <stdio.h>
X#include <osbind.h>
X
X#define LBSIZE 200
X
X/* line buffer variables */
Xstatic char lbuf[LBSIZE];
Xstatic int lpos[LBSIZE];
Xstatic int lindex = 0;
Xstatic int lcount = 0;
Xstatic int lposition = 0;
X
X/* external variables */
Xextern int prompt;
X
X/* external routines */
Xextern double sin(),cos();
X
X/* tan - tangent */
Xdouble tan(x)
X double x;
X{
X return (sin(x) / cos(x));
X}
X
X/* stcheck - check for a control key */
Xint stcheck()
X{
X return (xcheck());
X}
X
X/* stgetc - get a character from the terminal */
Xint stgetc(fp)
X FILE *fp;
X{
X int ch;
X
X /* check for input from a file other than stdin */
X if (fp != stdin)
X return (getc(fp));
X
X /* check for a buffered character */
X if (lcount--)
X return (lbuf[lindex++]);
X
X /* get an input line */
X for (lcount = 0; ; )
X switch (ch = xgetc()) {
X case '\r':
X stputc('\n',stdout);
X lbuf[lcount++] = '\n';
X lindex = 0; lcount--;
X return (lbuf[lindex++]);
X case '\010':
X case '\177':
X if (lcount) {
X lcount--;
X while (lposition && lposition > lpos[lcount]) {
X stputc('\010',stdout);
X stputc(' ',stdout);
X stputc('\010',stdout);
X }
X }
X break;
X default:
X
X /* check for normal printing characters */
X if (ch == '\t' || (ch >= ' ' && ch < '\177')) {
X lbuf[lcount] = ch;
X lpos[lcount] = lposition;
X stputc(ch,stdout);
X lcount++;
X }
X
X /* check for control codes */
X else {
X stflush();
X if (ch == '\003') /* control-c (exit) */
X exit();
X else if (ch == '\007') /* control-g (clean-up) */
X xlcleanup();
X else if (ch == '\020') /* control-p (continue) */
X xlcontinue();
X else if (ch == '\032') /* control-z (eof) */
X return (EOF);
X return (ch);
X }
X }
X}
X
X/* stputc - put a character to the terminal */
Xstputc(ch,fp)
X int ch; FILE *fp;
X{
X /* check for output to something other than stdout */
X if (fp != stdout)
X return (putc(ch,fp));
X
X /* check for newline */
X if (ch == '\n') {
X lposition = 0;
X xputc('\r');
X xputc('\n');
X }
X
X /* otherwise, check for tab */
X else if (ch == '\t') {
X do {
X stputc(' ',stdout);
X } while (lposition & 7);
X }
X
X /* otherwise, check for a backspace */
X else if (ch == '\010') {
X lposition--;
X xputc(ch);
X }
X
X /* otherwise, check for a printing character */
X else if (ch >= ' ' && ch < '\177') {
X xputc(ch);
X if (++lposition >= 80)
X stputc('\n',stdout);
X }
X
X /* otherwise, it must be a nonprinting character */
X else
X xputc(ch);
X}
X
X/* stflush - flush the input buffer */
Xstflush()
X{
X lcount = lindex = 0;
X stputc('\n',stdout);
X prompt = 1;
X}
X
X/* xgetc - get a character from the terminal without echo */
Xstatic int xgetc()
X{
X return (Crawcin() & 0xFF);
X}
X
X/* xputc - put a character to the terminal */
Xstatic xputc(ch)
X int ch;
X{
X Crawio(ch);
X}
X
X/* xcheck - get a character if one is available */
Xstatic int xcheck()
X{
X return (Crawio(0xFF) & 0xFF);
X}
SHAR_EOF
if test 2963 -ne "`wc -c 'ststuff.c'`"
then
echo shar: error transmitting "'ststuff.c'" '(should have been 2963 characters)'
fi
echo shar: extracting "'xlbfun.c'" '(11528 characters)'
if test -f 'xlbfun.c'
then
echo shar: over-writing existing file "'xlbfun.c'"
fi
sed 's/^X//' << \SHAR_EOF > 'xlbfun.c'
X/* xlbfun.c - xlisp basic built-in functions */
X/* Copyright (c) 1985, by David Michael Betz
X All Rights Reserved
X Permission is granted for unrestricted non-commercial use */
X
X#include "xlisp.h"
X
X/* external variables */
Xextern NODE *xlstack,*xlenv;
Xextern NODE *s_car,*s_cdr,*s_get,*s_svalue,*s_splist;
Xextern NODE *s_lambda,*s_macro;
Xextern NODE *s_comma,*s_comat;
Xextern char gsprefix[];
Xextern int gsnumber;
X
X/* forward declarations */
XFORWARD NODE *bquote1();
XFORWARD NODE *defun();
XFORWARD NODE *makesymbol();
X
X/* xeval - the built-in function 'eval' */
XNODE *xeval(args)
X NODE *args;
X{
X NODE *oldstk,expr,*val;
X
X /* create a new stack frame */
X oldstk = xlsave(&expr,NULL);
X
X /* get the expression to evaluate */
X expr.n_ptr = xlarg(&args);
X xllastarg(args);
X
X /* evaluate the expression */
X val = xleval(expr.n_ptr);
X
X /* restore the previous stack frame */
X xlstack = oldstk;
X
X /* return the expression evaluated */
X return (val);
X}
X
X/* xapply - the built-in function 'apply' */
XNODE *xapply(args)
X NODE *args;
X{
X NODE *oldstk,fun,arglist,*val;
X
X /* create a new stack frame */
X oldstk = xlsave(&fun,&arglist,NULL);
X
X /* get the function and argument list */
X fun.n_ptr = xlarg(&args);
X arglist.n_ptr = xlmatch(LIST,&args);
X xllastarg(args);
X
X /* if the function is a symbol, get its value */
X if (symbolp(fun.n_ptr))
X fun.n_ptr = xleval(fun.n_ptr);
X
X /* apply the function to the arguments */
X val = xlapply(fun.n_ptr,arglist.n_ptr);
X
X /* restore the previous stack frame */
X xlstack = oldstk;
X
X /* return the expression evaluated */
X return (val);
X}
X
X/* xfuncall - the built-in function 'funcall' */
XNODE *xfuncall(args)
X NODE *args;
X{
X NODE *oldstk,fun,arglist,*val;
X
X /* create a new stack frame */
X oldstk = xlsave(&fun,&arglist,NULL);
X
X /* get the function and argument list */
X fun.n_ptr = xlarg(&args);
X arglist.n_ptr = args;
X
X /* if the function is a symbol, get its value */
X if (symbolp(fun.n_ptr))
X fun.n_ptr = xleval(fun.n_ptr);
X
X /* apply the function to the arguments */
X val = xlapply(fun.n_ptr,arglist.n_ptr);
X
X /* restore the previous stack frame */
X xlstack = oldstk;
X
X /* return the expression evaluated */
X return (val);
X}
X
X/* xquote - built-in function to quote an expression */
XNODE *xquote(args)
X NODE *args;
X{
X NODE *val;
X
X /* get the argument */
X val = xlarg(&args);
X xllastarg(args);
X
X /* return the quoted expression */
X return (val);
X}
X
X/* xfunction - built-in function to quote a function */
XNODE *xfunction(args)
X NODE *args;
X{
X NODE *val,*n;
X
X /* get the argument */
X val = xlarg(&args);
X xllastarg(args);
X
X /* create a closure for lambda expressions */
X if (consp(val) && car(val) == s_lambda) {
X n = newnode(LIST);
X rplaca(n,val);
X rplacd(n,xlenv);
X val = n;
X }
X
X /* otherwise, get the value of a symbol */
X else if (symbolp(val))
X val = xlgetvalue(val);
X
X /* otherwise, its an error */
X else
X xlerror("not a function",val);
X
X /* return the function */
X return (val);
X}
X
X/* xbquote - back quote function */
XNODE *xbquote(args)
X NODE *args;
X{
X NODE *oldstk,expr,*val;
X
X /* create a new stack frame */
X oldstk = xlsave(&expr,NULL);
X
X /* get the expression */
X expr.n_ptr = xlarg(&args);
X xllastarg(args);
X
X /* fill in the template */
X val = bquote1(expr.n_ptr);
X
X /* restore the previous stack frame */
X xlstack = oldstk;
X
X /* return the result */
X return (val);
X}
X
X/* bquote1 - back quote helper function */
XLOCAL NODE *bquote1(expr)
X NODE *expr;
X{
X NODE *oldstk,val,list,*last,*new;
X
X /* handle atoms */
X if (atom(expr))
X val.n_ptr = expr;
X
X /* handle (comma <expr>) */
X else if (car(expr) == s_comma) {
X if (atom(cdr(expr)))
X xlfail("bad comma expression");
X val.n_ptr = xleval(car(cdr(expr)));
X }
X
X /* handle ((comma-at <expr>) ... ) */
X else if (consp(car(expr)) && car(car(expr)) == s_comat) {
X oldstk = xlsave(&list,&val,NULL);
X if (atom(cdr(car(expr))))
X xlfail("bad comma-at expression");
X list.n_ptr = xleval(car(cdr(car(expr))));
X for (last = NIL; consp(list.n_ptr); list.n_ptr = cdr(list.n_ptr)) {
X new = newnode(LIST);
X rplaca(new,car(list.n_ptr));
X if (last)
X rplacd(last,new);
X else
X val.n_ptr = new;
X last = new;
X }
X if (last)
X rplacd(last,bquote1(cdr(expr)));
X else
X val.n_ptr = bquote1(cdr(expr));
X xlstack = oldstk;
X }
X
X /* handle any other list */
X else {
X oldstk = xlsave(&val,NULL);
X val.n_ptr = newnode(LIST);
X rplaca(val.n_ptr,bquote1(car(expr)));
X rplacd(val.n_ptr,bquote1(cdr(expr)));
X xlstack = oldstk;
X }
X
X /* return the result */
X return (val.n_ptr);
X}
X
X/* xset - built-in function set */
XNODE *xset(args)
X NODE *args;
X{
X NODE *sym,*val;
X
X /* get the symbol and new value */
X sym = xlmatch(SYM,&args);
X val = xlarg(&args);
X xllastarg(args);
X
X /* assign the symbol the value of argument 2 and the return value */
X xlsetvalue(sym,val);
X
X /* return the result value */
X return (val);
X}
X
X/* xsetq - built-in function setq */
XNODE *xsetq(args)
X NODE *args;
X{
X NODE *oldstk,arg,sym,val;
X
X /* create a new stack frame */
X oldstk = xlsave(&arg,&sym,&val,NULL);
X
X /* initialize */
X arg.n_ptr = args;
X
X /* handle each pair of arguments */
X while (arg.n_ptr) {
X sym.n_ptr = xlmatch(SYM,&arg.n_ptr);
X val.n_ptr = xlevarg(&arg.n_ptr);
X xlsetvalue(sym.n_ptr,val.n_ptr);
X }
X
X /* restore the previous stack frame */
X xlstack = oldstk;
X
X /* return the result value */
X return (val.n_ptr);
X}
X
X/* xsetf - built-in function 'setf' */
XNODE *xsetf(args)
X NODE *args;
X{
X NODE *oldstk,arg,place,value;
X
X /* create a new stack frame */
X oldstk = xlsave(&arg,&place,&value,NULL);
X
X /* initialize */
X arg.n_ptr = args;
X
X /* handle each pair of arguments */
X while (arg.n_ptr) {
X
X /* get place and value */
X place.n_ptr = xlarg(&arg.n_ptr);
X value.n_ptr = xlevarg(&arg.n_ptr);
X
X /* check the place form */
X if (symbolp(place.n_ptr))
X xlsetvalue(place.n_ptr,value.n_ptr);
X else if (consp(place.n_ptr))
X placeform(place.n_ptr,value.n_ptr);
X else
X xlfail("bad place form");
X }
X
X /* restore the previous stack frame */
X xlstack = oldstk;
X
X /* return the value */
X return (value.n_ptr);
X}
X
X/* placeform - handle a place form other than a symbol */
XLOCAL placeform(place,value)
X NODE *place,*value;
X{
X NODE *fun,*oldstk,arg1,arg2;
X
X /* check the function name */
X if ((fun = xlmatch(SYM,&place)) == s_get) {
X oldstk = xlsave(&arg1,&arg2,NULL);
X arg1.n_ptr = xlevmatch(SYM,&place);
X arg2.n_ptr = xlevmatch(SYM,&place);
X xllastarg(place);
X xlputprop(arg1.n_ptr,value,arg2.n_ptr);
X xlstack = oldstk;
X }
X else if (fun == s_svalue || fun == s_splist) {
X oldstk = xlsave(&arg1,NULL);
X arg1.n_ptr = xlevmatch(SYM,&place);
X xllastarg(place);
X if (fun == s_svalue)
X setvalue(arg1.n_ptr,value);
X else
X rplacd(arg1.n_ptr->n_symplist,value);
X xlstack = oldstk;
X }
X else if (fun == s_car || fun == s_cdr) {
X oldstk = xlsave(&arg1,NULL);
X arg1.n_ptr = xlevmatch(LIST,&place);
X xllastarg(place);
X if (consp(arg1.n_ptr))
X if (fun == s_car)
X rplaca(arg1.n_ptr,value);
X else
X rplacd(arg1.n_ptr,value);
X xlstack = oldstk;
X }
X else
X xlfail("bad place form");
X}
X
X/* xdefun - built-in function 'defun' */
XNODE *xdefun(args)
X NODE *args;
X{
X return (defun(args,s_lambda));
X}
X
X/* xdefmacro - built-in function 'defmacro' */
XNODE *xdefmacro(args)
X NODE *args;
X{
X return (defun(args,s_macro));
X}
X
X/* defun - internal function definition routine */
XLOCAL NODE *defun(args,type)
X NODE *args,*type;
X{
X NODE *oldstk,sym,fargs,closure,*fun;
X
X /* create a new stack frame */
X oldstk = xlsave(&sym,&fargs,&closure,NULL);
X
X /* get the function symbol and formal argument list */
X sym.n_ptr = xlmatch(SYM,&args);
X fargs.n_ptr = xlmatch(LIST,&args);
X
X /* create a new function definition */
X closure.n_ptr = newnode(LIST);
X rplaca(closure.n_ptr,fun = newnode(LIST));
X rplacd(closure.n_ptr,xlenv);
X rplaca(fun,type);
X rplacd(fun,newnode(LIST));
X rplaca(cdr(fun),fargs.n_ptr);
X rplacd(cdr(fun),args);
X
X /* make the symbol point to a new function definition */
X xlsetvalue(sym.n_ptr,closure.n_ptr);
X
X /* restore the previous stack frame */
X xlstack = oldstk;
X
X /* return the function symbol */
X return (sym.n_ptr);
X}
X
X/* xgensym - generate a symbol */
XNODE *xgensym(args)
X NODE *args;
X{
X char sym[STRMAX+1];
X NODE *x;
X
X /* get the prefix or number */
X if (args) {
X x = xlarg(&args);
X switch (ntype(x)) {
X case STR:
X strcpy(gsprefix,x->n_str);
X break;
X case INT:
X gsnumber = x->n_int;
X break;
X default:
X xlerror("bad argument type",x);
X }
X }
X xllastarg(args);
X
X /* create the pname of the new symbol */
X sprintf(sym,"%s%d",gsprefix,gsnumber++);
X
X /* make a symbol with this print name */
X return (xlmakesym(sym,DYNAMIC));
X}
X
X/* xmakesymbol - make a new uninterned symbol */
XNODE *xmakesymbol(args)
X NODE *args;
X{
X return (makesymbol(args,FALSE));
X}
X
X/* xintern - make a new interned symbol */
XNODE *xintern(args)
X NODE *args;
X{
X return (makesymbol(args,TRUE));
X}
X
X/* makesymbol - make a new symbol */
XLOCAL NODE *makesymbol(args,iflag)
X NODE *args; int iflag;
X{
X NODE *oldstk,pname,*val;
X char *str;
X
X /* create a new stack frame */
X oldstk = xlsave(&pname,NULL);
X
X /* get the print name of the symbol to intern */
X pname.n_ptr = xlmatch(STR,&args);
X xllastarg(args);
X
X /* make the symbol */
X str = pname.n_ptr->n_str;
X val = (iflag ? xlenter(str,DYNAMIC) : xlmakesym(str,DYNAMIC));
X
X /* restore the previous stack frame */
X xlstack = oldstk;
X
X /* return the symbol */
X return (val);
X}
X
X/* xsymname - get the print name of a symbol */
XNODE *xsymname(args)
X NODE *args;
X{
X NODE *sym;
X
X /* get the symbol */
X sym = xlmatch(SYM,&args);
X xllastarg(args);
X
X /* return the print name */
X return (car(sym->n_symplist));
X}
X
X/* xsymvalue - get the value of a symbol */
XNODE *xsymvalue(args)
X NODE *args;
X{
X NODE *sym;
X
X /* get the symbol */
X sym = xlmatch(SYM,&args);
X xllastarg(args);
X
X /* return its value */
X return (xlgetvalue(sym));
X}
X
X/* xsymplist - get the property list of a symbol */
XNODE *xsymplist(args)
X NODE *args;
X{
X NODE *sym;
X
X /* get the symbol */
X sym = xlmatch(SYM,&args);
X xllastarg(args);
X
X /* return the property list */
X return (cdr(sym->n_symplist));
X}
X
X/* xget - get the value of a property */
XNODE *xget(args)
X NODE *args;
X{
X NODE *sym,*prp;
X
X /* get the symbol and property */
X sym = xlmatch(SYM,&args);
X prp = xlmatch(SYM,&args);
X xllastarg(args);
X
X /* retrieve the property value */
X return (xlgetprop(sym,prp));
X}
X
X/* xputprop - set the value of a property */
XNODE *xputprop(args)
X NODE *args;
X{
X NODE *sym,*val,*prp;
X
X /* get the symbol and property */
X sym = xlmatch(SYM,&args);
X val = xlarg(&args);
X prp = xlmatch(SYM,&args);
X xllastarg(args);
X
X /* set the property value */
X xlputprop(sym,val,prp);
X
X /* return the value */
X return (val);
X}
X
X/* xremprop - remove a property value from a property list */
XNODE *xremprop(args)
X NODE *args;
X{
X NODE *sym,*prp;
X
X /* get the symbol and property */
X sym = xlmatch(SYM,&args);
X prp = xlmatch(SYM,&args);
X xllastarg(args);
X
X /* remove the property */
X xlremprop(sym,prp);
X
X /* return nil */
X return (NIL);
X}
SHAR_EOF
if test 11528 -ne "`wc -c 'xlbfun.c'`"
then
echo shar: error transmitting "'xlbfun.c'" '(should have been 11528 characters)'
fi
echo shar: extracting "'xlcont.c'" '(17682 characters)'
if test -f 'xlcont.c'
then
echo shar: over-writing existing file "'xlcont.c'"
fi
sed 's/^X//' << \SHAR_EOF > 'xlcont.c'
X/* xlcont - xlisp control built-in functions */
X/* Copyright (c) 1985, by David Michael Betz
X All Rights Reserved
X Permission is granted for unrestricted non-commercial use */
X
X#include "xlisp.h"
X
X/* external variables */
Xextern NODE *xlstack,*xlenv,*xlvalue;
Xextern NODE *s_unbound;
Xextern NODE *s_evalhook,*s_applyhook;
Xextern NODE *true;
X
X/* external routines */
Xextern NODE *xlxeval();
X
X/* forward declarations */
XFORWARD NODE *let();
XFORWARD NODE *prog();
XFORWARD NODE *progx();
XFORWARD NODE *doloop();
X
X/* xcond - built-in function 'cond' */
XNODE *xcond(args)
X NODE *args;
X{
X NODE *oldstk,arg,list,*val;
X
X /* create a new stack frame */
X oldstk = xlsave(&arg,&list,NULL);
X
X /* initialize */
X arg.n_ptr = args;
X
X /* initialize the return value */
X val = NIL;
X
X /* find a predicate that is true */
X while (arg.n_ptr) {
X
X /* get the next conditional */
X list.n_ptr = xlmatch(LIST,&arg.n_ptr);
X
X /* evaluate the predicate part */
X if (xlevarg(&list.n_ptr)) {
X
X /* evaluate each expression */
X while (list.n_ptr)
X val = xlevarg(&list.n_ptr);
X
X /* exit the loop */
X break;
X }
X }
X
X /* restore the previous stack frame */
X xlstack = oldstk;
X
X /* return the value */
X return (val);
X}
X
X/* xand - built-in function 'and' */
XNODE *xand(args)
X NODE *args;
X{
X NODE *oldstk,arg,*val;
X
X /* create a new stack frame */
X oldstk = xlsave(&arg,NULL);
X
X /* initialize */
X arg.n_ptr = args;
X val = true;
X
X /* evaluate each argument */
X while (arg.n_ptr)
X
X /* get the next argument */
X if ((val = xlevarg(&arg.n_ptr)) == NIL)
X break;
X
X /* restore the previous stack frame */
X xlstack = oldstk;
X
X /* return the result value */
X return (val);
X}
X
X/* xor - built-in function 'or' */
XNODE *xor(args)
X NODE *args;
X{
X NODE *oldstk,arg,*val;
X
X /* create a new stack frame */
X oldstk = xlsave(&arg,NULL);
X
X /* initialize */
X arg.n_ptr = args;
X val = NIL;
X
X /* evaluate each argument */
X while (arg.n_ptr)
X if ((val = xlevarg(&arg.n_ptr)))
X break;
X
X /* restore the previous stack frame */
X xlstack = oldstk;
X
X /* return the result value */
X return (val);
X}
X
X/* xif - built-in function 'if' */
XNODE *xif(args)
X NODE *args;
X{
X NODE *oldstk,testexpr,thenexpr,elseexpr,*val;
X
X /* create a new stack frame */
X oldstk = xlsave(&testexpr,&thenexpr,&elseexpr,NULL);
X
X /* get the test expression, then clause and else clause */
X testexpr.n_ptr = xlarg(&args);
X thenexpr.n_ptr = xlarg(&args);
X elseexpr.n_ptr = (args ? xlarg(&args) : NIL);
X xllastarg(args);
X
X /* evaluate the appropriate clause */
X val = xleval(xleval(testexpr.n_ptr) ? thenexpr.n_ptr : elseexpr.n_ptr);
X
X /* restore the previous stack frame */
X xlstack = oldstk;
X
X /* return the last value */
X return (val);
X}
X
X/* xlet - built-in function 'let' */
XNODE *xlet(args)
X NODE *args;
X{
X return (let(args,TRUE));
X}
X
X/* xletstar - built-in function 'let*' */
XNODE *xletstar(args)
X NODE *args;
X{
X return (let(args,FALSE));
X}
X
X/* let - common let routine */
XLOCAL NODE *let(args,pflag)
X NODE *args; int pflag;
X{
X NODE *oldstk,newenv,arg,*val;
X
X /* create a new stack frame */
X oldstk = xlsave(&newenv,&arg,NULL);
X
X /* initialize */
X arg.n_ptr = args;
X
X /* create a new environment frame */
X newenv.n_ptr = xlframe(xlenv);
X
X /* get the list of bindings and bind the symbols */
X if (!pflag) xlenv = newenv.n_ptr;
X dobindings(xlmatch(LIST,&arg.n_ptr),newenv.n_ptr);
X if (pflag) xlenv = newenv.n_ptr;
X
X /* execute the code */
X for (val = NIL; arg.n_ptr; )
X val = xlevarg(&arg.n_ptr);
X
X /* unbind the arguments */
X xlenv = cdr(xlenv);
X
X /* restore the previous stack frame */
X xlstack = oldstk;
X
X /* return the result */
X return (val);
X}
X
X/* xprog - built-in function 'prog' */
XNODE *xprog(args)
X NODE *args;
X{
X return (prog(args,TRUE));
X}
X
X/* xprogstar - built-in function 'prog*' */
XNODE *xprogstar(args)
X NODE *args;
X{
X return (prog(args,FALSE));
X}
X
X/* prog - common prog routine */
XLOCAL NODE *prog(args,pflag)
X NODE *args; int pflag;
X{
X NODE *oldstk,newenv,arg,*val;
X
X /* create a new stack frame */
X oldstk = xlsave(&newenv,&arg,NULL);
X
X /* initialize */
X arg.n_ptr = args;
X
X /* create a new environment frame */
X newenv.n_ptr = xlframe(xlenv);
X
X /* get the list of bindings and bind the symbols */
X if (!pflag) xlenv = newenv.n_ptr;
X dobindings(xlmatch(LIST,&arg.n_ptr),newenv.n_ptr);
X if (pflag) xlenv = newenv.n_ptr;
X
X /* execute the code */
X tagblock(arg.n_ptr,&val);
X
X /* unbind the arguments */
X xlenv = cdr(xlenv);
X
X /* restore the previous stack frame */
X xlstack = oldstk;
X
X /* return the result */
X return (val);
X}
X
X/* xgo - built-in function 'go' */
XNODE *xgo(args)
X NODE *args;
X{
X NODE *label;
X
X /* get the target label */
X label = xlarg(&args);
X xllastarg(args);
X
X /* transfer to the label */
X xlgo(label);
X}
X
X/* xreturn - built-in function 'return' */
XNODE *xreturn(args)
X NODE *args;
X{
X NODE *val;
X
X /* get the return value */
X val = (args ? xlarg(&args) : NIL);
X xllastarg(args);
X
X /* return from the inner most block */
X xlreturn(val);
X}
X
X/* xprog1 - built-in function 'prog1' */
XNODE *xprog1(args)
X NODE *args;
X{
X return (progx(args,1));
X}
X
X/* xprog2 - built-in function 'prog2' */
XNODE *xprog2(args)
X NODE *args;
X{
X return (progx(args,2));
X}
X
X/* progx - common progx code */
XLOCAL NODE *progx(args,n)
X NODE *args; int n;
X{
X NODE *oldstk,arg,val;
X
X /* create a new stack frame */
X oldstk = xlsave(&arg,&val,NULL);
X
X /* initialize */
X arg.n_ptr = args;
X
X /* evaluate the first n expressions */
X while (n--)
X val.n_ptr = xlevarg(&arg.n_ptr);
X
X /* evaluate each remaining argument */
X while (arg.n_ptr)
X xlevarg(&arg.n_ptr);
X
X /* restore the previous stack frame */
X xlstack = oldstk;
X
X /* return the last test expression value */
X return (val.n_ptr);
X}
X
X/* xprogn - built-in function 'progn' */
XNODE *xprogn(args)
X NODE *args;
X{
X NODE *oldstk,arg,*val;
X
X /* create a new stack frame */
X oldstk = xlsave(&arg,NULL);
X
X /* initialize */
X arg.n_ptr = args;
X
X /* evaluate each remaining argument */
X for (val = NIL; arg.n_ptr; )
X val = xlevarg(&arg.n_ptr);
X
X /* restore the previous stack frame */
X xlstack = oldstk;
X
X /* return the last test expression value */
X return (val);
X}
X
X/* xdo - built-in function 'do' */
XNODE *xdo(args)
X NODE *args;
X{
X return (doloop(args,TRUE));
X}
X
X/* xdostar - built-in function 'do*' */
XNODE *xdostar(args)
X NODE *args;
X{
X return (doloop(args,FALSE));
X}
X
X/* doloop - common do routine */
XLOCAL NODE *doloop(args,pflag)
X NODE *args; int pflag;
X{
X NODE *oldstk,newenv,arg,blist,clist,test,*rval;
X int rbreak;
X
X /* create a new stack frame */
X oldstk = xlsave(&newenv,&arg,&blist,&clist,&test,NULL);
X
X /* initialize */
X arg.n_ptr = args;
X
X /* get the list of bindings */
X blist.n_ptr = xlmatch(LIST,&arg.n_ptr);
X
X /* create a new environment frame */
X newenv.n_ptr = xlframe(xlenv);
X
X /* bind the symbols */
X if (!pflag) xlenv = newenv.n_ptr;
X dobindings(blist.n_ptr,newenv.n_ptr);
X if (pflag) xlenv = newenv.n_ptr;
X
X /* get the exit test and result forms */
X clist.n_ptr = xlmatch(LIST,&arg.n_ptr);
X test.n_ptr = xlarg(&clist.n_ptr);
X
X /* execute the loop as long as the test is false */
X rbreak = FALSE;
X while (xleval(test.n_ptr) == NIL) {
X
X /* execute the body of the loop */
X if (tagblock(arg.n_ptr,&rval)) {
X rbreak = TRUE;
X break;
X }
X
X /* update the looping variables */
X doupdates(blist.n_ptr,pflag);
X }
X
X /* evaluate the result expression */
X if (!rbreak)
X for (rval = NIL; consp(clist.n_ptr); )
X rval = xlevarg(&clist.n_ptr);
X
X /* unbind the arguments */
X xlenv = cdr(xlenv);
X
X /* restore the previous stack frame */
X xlstack = oldstk;
X
X /* return the result */
X return (rval);
X}
X
X/* xdolist - built-in function 'dolist' */
XNODE *xdolist(args)
X NODE *args;
X{
X NODE *oldstk,arg,clist,sym,list,val,*rval;
X int rbreak;
X
X /* create a new stack frame */
X oldstk = xlsave(&arg,&clist,&sym,&list,&val,NULL);
X
X /* initialize */
X arg.n_ptr = args;
X
X /* get the control list (sym list result-expr) */
X clist.n_ptr = xlmatch(LIST,&arg.n_ptr);
X sym.n_ptr = xlmatch(SYM,&clist.n_ptr);
X list.n_ptr = xlevmatch(LIST,&clist.n_ptr);
X val.n_ptr = (clist.n_ptr ? xlarg(&clist.n_ptr) : NIL);
X
X /* initialize the local environment */
X xlenv = xlframe(xlenv);
X xlbind(sym.n_ptr,NIL,xlenv);
X
X /* loop through the list */
X rbreak = FALSE;
X for (; consp(list.n_ptr); list.n_ptr = cdr(list.n_ptr)) {
X
X /* bind the symbol to the next list element */
X xlsetvalue(sym.n_ptr,car(list.n_ptr));
X
X /* execute the loop body */
X if (tagblock(arg.n_ptr,&rval)) {
X rbreak = TRUE;
X break;
X }
X }
X
X /* evaluate the result expression */
X if (!rbreak) {
X xlsetvalue(sym.n_ptr,NIL);
X rval = xleval(val.n_ptr);
X }
X
X /* unbind the arguments */
X xlenv = cdr(xlenv);
X
X /* restore the previous stack frame */
X xlstack = oldstk;
X
X /* return the result */
X return (rval);
X}
X
X/* xdotimes - built-in function 'dotimes' */
XNODE *xdotimes(args)
X NODE *args;
X{
X NODE *oldstk,arg,clist,sym,val,*rval;
X int rbreak,cnt,i;
X
X /* create a new stack frame */
X oldstk = xlsave(&arg,&clist,&sym,&val,NULL);
X
X /* initialize */
X arg.n_ptr = args;
X
X /* get the control list (sym list result-expr) */
X clist.n_ptr = xlmatch(LIST,&arg.n_ptr);
X sym.n_ptr = xlmatch(SYM,&clist.n_ptr);
X cnt = xlevmatch(INT,&clist.n_ptr)->n_int;
X val.n_ptr = (clist.n_ptr ? xlarg(&clist.n_ptr) : NIL);
X
X /* initialize the local environment */
X xlenv = xlframe(xlenv);
X xlbind(sym.n_ptr,NIL,xlenv);
X
X /* loop through for each value from zero to cnt-1 */
X rbreak = FALSE;
X for (i = 0; i < cnt; i++) {
X
X /* bind the symbol to the next list element */
X xlsetvalue(sym.n_ptr,cvfixnum((FIXNUM)i));
X
X /* execute the loop body */
X if (tagblock(arg.n_ptr,&rval)) {
X rbreak = TRUE;
X break;
X }
X }
X
X /* evaluate the result expression */
X if (!rbreak) {
X xlsetvalue(sym.n_ptr,cvfixnum((FIXNUM)cnt));
X rval = xleval(val.n_ptr);
X }
X
X /* unbind the arguments */
X xlenv = cdr(xlenv);
X
X /* restore the previous stack frame */
X xlstack = oldstk;
X
X /* return the result */
X return (rval);
X}
X
X/* xcatch - built-in function 'catch' */
XNODE *xcatch(args)
X NODE *args;
X{
X NODE *oldstk,tag,arg,*val;
X CONTEXT cntxt;
X
X /* create a new stack frame */
X oldstk = xlsave(&tag,&arg,NULL);
X
X /* initialize */
X tag.n_ptr = xlevarg(&args);
X arg.n_ptr = args;
X val = NIL;
X
X /* establish an execution context */
X xlbegin(&cntxt,CF_THROW,tag.n_ptr);
X
X /* check for 'throw' */
X if (setjmp(cntxt.c_jmpbuf))
X val = xlvalue;
X
X /* otherwise, evaluate the remainder of the arguments */
X else {
X while (arg.n_ptr)
X val = xlevarg(&arg.n_ptr);
X }
X xlend(&cntxt);
X
X /* restore the previous stack frame */
X xlstack = oldstk;
X
X /* return the result */
X return (val);
X}
X
X/* xthrow - built-in function 'throw' */
XNODE *xthrow(args)
X NODE *args;
X{
X NODE *tag,*val;
X
X /* get the tag and value */
X tag = xlarg(&args);
X val = (args ? xlarg(&args) : NIL);
X xllastarg(args);
X
X /* throw the tag */
X xlthrow(tag,val);
X}
X
X/* xerror - built-in function 'error' */
XNODE *xerror(args)
X NODE *args;
X{
X char *emsg; NODE *arg;
X
X /* get the error message and the argument */
X emsg = xlmatch(STR,&args)->n_str;
X arg = (args ? xlarg(&args) : s_unbound);
X xllastarg(args);
X
X /* signal the error */
X xlerror(emsg,arg);
X}
X
X/* xcerror - built-in function 'cerror' */
XNODE *xcerror(args)
X NODE *args;
X{
X char *cmsg,*emsg; NODE *arg;
X
X /* get the correction message, the error message, and the argument */
X cmsg = xlmatch(STR,&args)->n_str;
X emsg = xlmatch(STR,&args)->n_str;
X arg = (args ? xlarg(&args) : s_unbound);
X xllastarg(args);
X
X /* signal the error */
X xlcerror(cmsg,emsg,arg);
X
X /* return nil */
X return (NIL);
X}
X
X/* xbreak - built-in function 'break' */
XNODE *xbreak(args)
X NODE *args;
X{
X char *emsg; NODE *arg;
X
X /* get the error message */
X emsg = (args ? xlmatch(STR,&args)->n_str : "**BREAK**");
X arg = (args ? xlarg(&args) : s_unbound);
X xllastarg(args);
X
X /* enter the break loop */
X xlbreak(emsg,arg);
X
X /* return nil */
X return (NIL);
X}
X
X/* xcleanup - built-in function 'clean-up' */
XNODE *xcleanup(args)
X NODE *args;
X{
X xllastarg(args);
X xlcleanup();
X}
X
X/* xcontinue - built-in function 'continue' */
XNODE *xcontinue(args)
X NODE *args;
X{
X xllastarg(args);
X xlcontinue();
X}
X
X/* xerrset - built-in function 'errset' */
XNODE *xerrset(args)
X NODE *args;
X{
X NODE *oldstk,expr,flag,*val;
X CONTEXT cntxt;
X
X /* create a new stack frame */
X oldstk = xlsave(&expr,&flag,NULL);
X
X /* get the expression and the print flag */
X expr.n_ptr = xlarg(&args);
X flag.n_ptr = (args ? xlarg(&args) : true);
X xllastarg(args);
X
X /* establish an execution context */
X xlbegin(&cntxt,CF_ERROR,flag.n_ptr);
X
X /* check for error */
X if (setjmp(cntxt.c_jmpbuf))
X val = NIL;
X
X /* otherwise, evaluate the expression */
X else {
X expr.n_ptr = xleval(expr.n_ptr);
X val = newnode(LIST);
X rplaca(val,expr.n_ptr);
X }
X xlend(&cntxt);
X
X /* restore the previous stack frame */
X xlstack = oldstk;
X
X /* return the result */
X return (val);
X}
X
X/* xevalhook - eval hook function */
XNODE *xevalhook(args)
X NODE *args;
X{
X NODE *oldstk,expr,ehook,ahook,env,newehook,newahook,newenv,*val;
X
X /* create a new stack frame */
X oldstk = xlsave(&expr,&ehook,&ahook,&env,&newehook,&newahook,&newenv,NULL);
X
X /* get the expression, the new hook functions and the environment */
X expr.n_ptr = xlarg(&args);
X newehook.n_ptr = xlarg(&args);
X newahook.n_ptr = xlarg(&args);
X newenv.n_ptr = (args ? xlarg(&args) : xlenv);
X xllastarg(args);
X
X /* bind *evalhook* and *applyhook* to the hook functions */
X ehook.n_ptr = getvalue(s_evalhook);
X setvalue(s_evalhook,newehook.n_ptr);
X ahook.n_ptr = getvalue(s_applyhook);
X setvalue(s_applyhook,newahook.n_ptr);
X env.n_ptr = xlenv;
X xlenv = newenv.n_ptr;
X
X /* evaluate the expression (bypassing *evalhook*) */
X val = xlxeval(expr.n_ptr);
X
X /* unbind the hook variables */
X setvalue(s_evalhook,ehook.n_ptr);
X setvalue(s_applyhook,ahook.n_ptr);
X xlenv = env.n_ptr;
X
X /* restore the previous stack frame */
X xlstack = oldstk;
X
X /* return the result */
X return (val);
X}
X
X/* dobindings - handle bindings for let/let*, prog/prog*, do/do* */
XLOCAL dobindings(blist,env)
X NODE *blist,*env;
X{
X NODE *oldstk,list,bnd,sym,val;
X
X /* create a new stack frame */
X oldstk = xlsave(&list,&bnd,&sym,&val,NULL);
X
X /* bind each symbol in the list of bindings */
X for (list.n_ptr = blist; consp(list.n_ptr); list.n_ptr = cdr(list.n_ptr)) {
X
X /* get the next binding */
X bnd.n_ptr = car(list.n_ptr);
X
X /* handle a symbol */
X if (symbolp(bnd.n_ptr)) {
X sym.n_ptr = bnd.n_ptr;
X val.n_ptr = NIL;
X }
X
X /* handle a list of the form (symbol expr) */
X else if (consp(bnd.n_ptr)) {
X sym.n_ptr = xlmatch(SYM,&bnd.n_ptr);
X val.n_ptr = xlevarg(&bnd.n_ptr);
X }
X else
X xlfail("bad binding");
X
X /* bind the value to the symbol */
X xlbind(sym.n_ptr,val.n_ptr,env);
X }
X
X /* restore the previous stack frame */
X xlstack = oldstk;
X}
X
X/* doupdates - handle updates for do/do* */
Xdoupdates(blist,pflag)
X NODE *blist; int pflag;
X{
X NODE *oldstk,plist,list,bnd,sym,val,*p;
X
X /* create a new stack frame */
X oldstk = xlsave(&plist,&list,&bnd,&sym,&val,NULL);
X
X /* bind each symbol in the list of bindings */
X for (list.n_ptr = blist; consp(list.n_ptr); list.n_ptr = cdr(list.n_ptr)) {
X
X /* get the next binding */
X bnd.n_ptr = car(list.n_ptr);
X
X /* handle a list of the form (symbol expr) */
X if (consp(bnd.n_ptr)) {
X sym.n_ptr = xlmatch(SYM,&bnd.n_ptr);
X bnd.n_ptr = cdr(bnd.n_ptr);
X if (bnd.n_ptr) {
X val.n_ptr = xlevarg(&bnd.n_ptr);
X if (pflag) {
X p = newnode(LIST);
X rplacd(p,plist.n_ptr);
X plist.n_ptr = p;
X rplaca(p,newnode(LIST));
X rplaca(car(p),sym.n_ptr);
X rplacd(car(p),val.n_ptr);
X }
X else
X xlsetvalue(sym.n_ptr,val.n_ptr);
X }
X }
X }
X
X /* set the values for parallel updates */
X for (; plist.n_ptr; plist.n_ptr = cdr(plist.n_ptr))
X xlsetvalue(car(car(plist.n_ptr)),cdr(car(plist.n_ptr)));
X
X /* restore the previous stack frame */
X xlstack = oldstk;
X}
X
X/* tagblock - execute code within a block and tagbody */
Xint tagblock(code,pval)
X NODE *code,**pval;
X{
X NODE *oldstk,arg;
X CONTEXT cntxt;
X int type,sts;
X
X /* create a new stack frame */
X oldstk = xlsave(&arg,NULL);
X
X /* initialize */
X arg.n_ptr = code;
X
X /* establish an execution context */
X xlbegin(&cntxt,CF_GO|CF_RETURN,arg.n_ptr);
X
X /* check for a 'return' */
X if ((type = setjmp(cntxt.c_jmpbuf)) == CF_RETURN) {
X *pval = xlvalue;
X sts = TRUE;
X }
X
X /* otherwise, enter the body */
X else {
X
X /* check for a 'go' */
X if (type == CF_GO)
X arg.n_ptr = xlvalue;
X
X /* evaluate each expression in the body */
X while (consp(arg.n_ptr))
X if (consp(car(arg.n_ptr)))
X xlevarg(&arg.n_ptr);
X else
X arg.n_ptr = cdr(arg.n_ptr);
X
X /* fell out the bottom of the loop */
X *pval = NIL;
X sts = FALSE;
X }
X xlend(&cntxt);
X
X /* restore the previous stack frame */
X xlstack = oldstk;
X
X /* return status */
X return (sts);
X}
SHAR_EOF
if test 17682 -ne "`wc -c 'xlcont.c'`"
then
echo shar: error transmitting "'xlcont.c'" '(should have been 17682 characters)'
fi
echo shar: extracting "'xldbug.c'" '(4177 characters)'
if test -f 'xldbug.c'
then
echo shar: over-writing existing file "'xldbug.c'"
fi
sed 's/^X//' << \SHAR_EOF > 'xldbug.c'
X/* xldebug - xlisp debugging support */
X/* Copyright (c) 1985, by David Michael Betz
X All Rights Reserved
X Permission is granted for unrestricted non-commercial use */
X
X#include "xlisp.h"
X
X/* external variables */
Xextern long total;
Xextern int xldebug;
Xextern int xltrace;
Xextern NODE *s_unbound;
Xextern NODE *s_stdin,*s_stdout;
Xextern NODE *s_tracenable,*s_tlimit,*s_breakenable;
Xextern NODE *xlstack;
Xextern NODE *true;
Xextern NODE **trace_stack;
Xextern char buf[];
X
X/* external routines */
Xextern char *malloc();
X
X/* forward declarations */
XFORWARD NODE *stacktop();
X
X/* xlfail - xlisp error handler */
Xxlfail(emsg)
X char *emsg;
X{
X xlerror(emsg,stacktop());
X}
X
X/* xlabort - xlisp serious error handler */
Xxlabort(emsg)
X char *emsg;
X{
X xlsignal(emsg,s_unbound);
X}
X
X/* xlbreak - enter a break loop */
Xxlbreak(emsg,arg)
X char *emsg; NODE *arg;
X{
X breakloop("break",NULL,emsg,arg,TRUE);
X}
X
X/* xlerror - handle a fatal error */
Xxlerror(emsg,arg)
X char *emsg; NODE *arg;
X{
X doerror(NULL,emsg,arg,FALSE);
X}
X
X/* xlcerror - handle a recoverable error */
Xxlcerror(cmsg,emsg,arg)
X char *cmsg,*emsg; NODE *arg;
X{
X doerror(cmsg,emsg,arg,TRUE);
X}
X
X/* xlerrprint - print an error message */
Xxlerrprint(hdr,cmsg,emsg,arg)
X char *hdr,*cmsg,*emsg; NODE *arg;
X{
X sprintf(buf,"%s: %s",hdr,emsg); stdputstr(buf);
X if (arg != s_unbound) { stdputstr(" - "); stdprint(arg); }
X else xlterpri(s_stdout->n_symvalue);
X if (cmsg) { sprintf(buf,"if continued: %s\n",cmsg); stdputstr(buf); }
X}
X
X/* doerror - handle xlisp errors */
XLOCAL doerror(cmsg,emsg,arg,cflag)
X char *cmsg,*emsg; NODE *arg; int cflag;
X{
X /* make sure the break loop is enabled */
X if (getvalue(s_breakenable) == NIL)
X xlsignal(emsg,arg);
X
X /* call the debug read-eval-print loop */
X breakloop("error",cmsg,emsg,arg,cflag);
X}
X
X/* breakloop - the debug read-eval-print loop */
XLOCAL int breakloop(hdr,cmsg,emsg,arg,cflag)
X char *hdr,*cmsg,*emsg; NODE *arg; int cflag;
X{
X NODE *oldstk,expr,*val;
X CONTEXT cntxt;
X int type;
X
X /* print the error message */
X xlerrprint(hdr,cmsg,emsg,arg);
X
X /* flush the input buffer */
X xlflush();
X
X /* do the back trace */
X if (getvalue(s_tracenable)) {
X val = getvalue(s_tlimit);
X xlbaktrace(fixp(val) ? (int)val->n_int : -1);
X }
X
X /* create a new stack frame */
X oldstk = xlsave(&expr,NULL);
X
X /* increment the debug level */
X xldebug++;
X
X /* debug command processing loop */
X xlbegin(&cntxt,CF_ERROR|CF_CLEANUP|CF_CONTINUE,true);
X for (type = 0; type == 0; ) {
X
X /* setup the continue trap */
X if (type = setjmp(cntxt.c_jmpbuf))
X switch (type) {
X case CF_ERROR:
X xlflush();
X type = 0;
X continue;
X case CF_CLEANUP:
X continue;
X case CF_CONTINUE:
X if (cflag) continue;
X else xlabort("this error can't be continued");
X }
X
X /* read an expression and check for eof */
X if (!xlread(getvalue(s_stdin),&expr.n_ptr)) {
X type = CF_CLEANUP;
X break;
X }
X
X /* evaluate the expression */
X expr.n_ptr = xleval(expr.n_ptr);
X
X /* print it */
X xlprint(getvalue(s_stdout),expr.n_ptr,TRUE);
X xlterpri(getvalue(s_stdout));
X }
X xlend(&cntxt);
X
X /* decrement the debug level */
X xldebug--;
X
X /* restore the previous stack frame */
X xlstack = oldstk;
X
X /* continue the next higher break loop on clean-up */
X if (type == CF_CLEANUP)
X xlsignal("quit from break loop",s_unbound);
X}
X
X/* tpush - add an entry to the trace stack */
Xxltpush(nptr)
X NODE *nptr;
X{
X if (++xltrace < TDEPTH)
X trace_stack[xltrace] = nptr;
X}
X
X/* tpop - pop an entry from the trace stack */
Xxltpop()
X{
X xltrace--;
X}
X
X/* stacktop - return the top node on the stack */
XLOCAL NODE *stacktop()
X{
X return (xltrace >= 0 && xltrace < TDEPTH ? trace_stack[xltrace] : s_unbound);
X}
X
X/* baktrace - do a back trace */
Xxlbaktrace(n)
X int n;
X{
X int i;
X
X for (i = xltrace; (n < 0 || n--) && i >= 0; i--)
X if (i < TDEPTH)
X stdprint(trace_stack[i]);
X}
X
X/* xldinit - debug initialization routine */
Xxldinit()
X{
X if ((trace_stack = (NODE **) malloc(TSTKSIZE)) == NULL)
X xlabort("insufficient memory");
X total += (long) TSTKSIZE;
X xltrace = -1;
X xldebug = 0;
X}
SHAR_EOF
if test 4177 -ne "`wc -c 'xldbug.c'`"
then
echo shar: error transmitting "'xldbug.c'" '(should have been 4177 characters)'
fi
echo shar: extracting "'xldmem.c'" '(7170 characters)'
if test -f 'xldmem.c'
then
echo shar: over-writing existing file "'xldmem.c'"
fi
sed 's/^X//' << \SHAR_EOF > 'xldmem.c'
X/* xldmem - xlisp dynamic memory management routines */
X/* Copyright (c) 1985, by David Michael Betz
X All Rights Reserved
X Permission is granted for unrestricted non-commercial use */
X
X#include "xlisp.h"
X
X/* useful definitions */
X#define ALLOCSIZE (sizeof(struct segment) + (anodes-1) * sizeof(NODE))
X
X/* external variables */
Xextern NODE *oblist,*keylist;
Xextern NODE *xlstack;
Xextern NODE *xlenv;
Xextern long total;
Xextern int anodes,nnodes,nsegs,nfree,gccalls;
Xextern struct segment *segs;
Xextern NODE *fnodes;
Xextern char buf[];
X
X/* external procedures */
Xextern char *malloc();
Xextern char *calloc();
X
X/* newnode - allocate a new node */
XNODE *newnode(type)
X int type;
X{
X NODE *nnode;
X
X /* get a free node */
X if ((nnode = fnodes) == NIL) {
X gc();
X if ((nnode = fnodes) == NIL)
X xlabort("insufficient node space");
X }
X
X /* unlink the node from the free list */
X fnodes = cdr(nnode);
X nfree -= 1;
X
X /* initialize the new node */
X nnode->n_type = type;
X rplacd(nnode,NIL);
X
X /* return the new node */
X return (nnode);
X}
X
X/* cvfixnum - convert an integer to a fixnum node */
XNODE *cvfixnum(n)
X FIXNUM n;
X{
X NODE *val;
X val = newnode(INT);
X val->n_int = n;
X return (val);
X}
X
X/* cvflonum - convert a floating point number to a flonum node */
XNODE *cvflonum(n)
X FLONUM n;
X{
X NODE *val;
X val = newnode(FLOAT);
X val->n_float = n;
X return (val);
X}
X
X/* stralloc - allocate memory for a string adding a byte for the terminator */
Xchar *stralloc(size)
X int size;
X{
X char *sptr;
X
X /* allocate memory for the string copy */
X if ((sptr = malloc(size+1)) == NULL) {
X gc();
X if ((sptr = malloc(size+1)) == NULL)
X xlfail("insufficient string space");
X }
X total += (long) (size+1);
X
X /* return the new string memory */
X return (sptr);
X}
X
X/* strsave - generate a dynamic copy of a string */
Xchar *strsave(str)
X char *str;
X{
X char *sptr;
X
X /* create a new string */
X sptr = stralloc(strlen(str));
X strcpy(sptr,str);
X
X /* return the new string */
X return (sptr);
X}
X
X/* strfree - free string memory */
Xstrfree(str)
X char *str;
X{
X total -= (long) (strlen(str)+1);
X free(str);
X}
X
X/* gc - garbage collect */
Xgc()
X{
X NODE *p;
X
X /* mark all accessible nodes */
X mark(oblist); mark(keylist);
X mark(xlenv);
X
X /* mark the evaluation stack */
X for (p = xlstack; p; p = cdr(p))
X mark(car(p));
X
X /* sweep memory collecting all unmarked nodes */
X sweep();
X
X /* if there's still nothing available, allocate more memory */
X if (fnodes == NIL)
X addseg();
X
X /* count the gc call */
X gccalls++;
X}
X
X/* mark - mark all accessible nodes */
XLOCAL mark(ptr)
X NODE *ptr;
X{
X NODE *this,*prev,*tmp;
X
X /* just return on nil */
X if (ptr == NIL)
X return;
X
X /* initialize */
X prev = NIL;
X this = ptr;
X
X /* mark this list */
X while (TRUE) {
X
X /* descend as far as we can */
X while (TRUE) {
X
X /* check for this node being marked */
X if (this->n_flags & MARK)
X break;
X
X /* mark it and its descendants */
X else {
X
X /* mark the node */
X this->n_flags |= MARK;
X
X /* follow the left sublist if there is one */
X if (livecar(this)) {
X this->n_flags |= LEFT;
X tmp = prev;
X prev = this;
X this = car(prev);
X rplaca(prev,tmp);
X }
X
X /* otherwise, follow the right sublist if there is one */
X else if (livecdr(this)) {
X this->n_flags &= ~LEFT;
X tmp = prev;
X prev = this;
X this = cdr(prev);
X rplacd(prev,tmp);
X }
X else
X break;
X }
X }
X
X /* backup to a point where we can continue descending */
X while (TRUE) {
X
X /* check for termination condition */
X if (prev == NIL)
X return;
X
X /* check for coming from the left side */
X if (prev->n_flags & LEFT)
X if (livecdr(prev)) {
X prev->n_flags &= ~LEFT;
X tmp = car(prev);
X rplaca(prev,this);
X this = cdr(prev);
X rplacd(prev,tmp);
X break;
X }
X else {
X tmp = prev;
X prev = car(tmp);
X rplaca(tmp,this);
X this = tmp;
X }
X
X /* otherwise, came from the right side */
X else {
X tmp = prev;
X prev = cdr(tmp);
X rplacd(tmp,this);
X this = tmp;
X }
X }
X }
X}
X
X/* sweep - sweep all unmarked nodes and add them to the free list */
XLOCAL sweep()
X{
X struct segment *seg;
X NODE *p;
X int n;
X
X /* empty the free list */
X fnodes = NIL;
X nfree = 0;
X
X /* add all unmarked nodes */
X for (seg = segs; seg != NULL; seg = seg->sg_next) {
X p = &seg->sg_nodes[0];
X for (n = seg->sg_size; n--; p++)
X if (!(p->n_flags & MARK)) {
X switch (ntype(p)) {
X case STR:
X if (p->n_strtype == DYNAMIC && p->n_str != NULL)
X strfree(p->n_str);
X break;
X case FPTR:
X if (p->n_fp)
X fclose(p->n_fp);
X break;
X }
X p->n_type = FREE;
X p->n_flags = 0;
X rplaca(p,NIL);
X rplacd(p,fnodes);
X fnodes = p;
X nfree++;
X }
X else
X p->n_flags &= ~(MARK | LEFT);
X }
X}
X
X/* addseg - add a segment to the available memory */
Xint addseg()
X{
X struct segment *newseg;
X NODE *p;
X int n;
X
X /* check for zero allocation */
X if (anodes == 0)
X return (FALSE);
X
X /* allocate a new segment */
X if ((newseg = (struct segment *) calloc(1,ALLOCSIZE)) != NULL) {
X
X /* initialize the new segment */
X newseg->sg_size = anodes;
X newseg->sg_next = segs;
X segs = newseg;
X
X /* add each new node to the free list */
X p = &newseg->sg_nodes[0];
X for (n = anodes; n--; ) {
X rplacd(p,fnodes);
X fnodes = p++;
X }
X
X /* update the statistics */
X total += (long) ALLOCSIZE;
X nnodes += anodes;
X nfree += anodes;
X nsegs++;
X
X /* return successfully */
X return (TRUE);
X }
X else
X return (FALSE);
X}
X
X/* livecar - do we need to follow the car? */
XLOCAL int livecar(n)
X NODE *n;
X{
X switch (ntype(n)) {
X case SUBR:
X case FSUBR:
X case INT:
X case FLOAT:
X case STR:
X case FPTR:
X return (FALSE);
X case SYM:
X case LIST:
X case OBJ:
X return (car(n) != NIL);
X default:
X printf("bad node type (%d) found during left scan\n",ntype(n));
X exit();
X }
X}
X
X/* livecdr - do we need to follow the cdr? */
XLOCAL int livecdr(n)
X NODE *n;
X{
X switch (ntype(n)) {
X case SUBR:
X case FSUBR:
X case INT:
X case FLOAT:
X case STR:
X case FPTR:
X return (FALSE);
X case SYM:
X case LIST:
X case OBJ:
X return (cdr(n) != NIL);
X default:
X printf("bad node type (%d) found during right scan\n",ntype(n));
X exit();
X }
X}
X
X/* stats - print memory statistics */
Xstats()
X{
X sprintf(buf,"Nodes: %d\n",nnodes); stdputstr(buf);
X sprintf(buf,"Free nodes: %d\n",nfree); stdputstr(buf);
X sprintf(buf,"Segments: %d\n",nsegs); stdputstr(buf);
X sprintf(buf,"Allocate: %d\n",anodes); stdputstr(buf);
X sprintf(buf,"Total: %ld\n",total); stdputstr(buf);
X sprintf(buf,"Collections: %d\n",gccalls); stdputstr(buf);
X}
X
X/* xlminit - initialize the dynamic memory module */
Xxlminit()
X{
X /* initialize our internal variables */
X anodes = NNODES;
X total = 0L;
X nnodes = nsegs = nfree = gccalls = 0;
X fnodes = NIL;
X segs = NULL;
X
X /* initialize structures that are marked by the collector */
X xlstack = xlenv = oblist = keylist = NIL;
X}
SHAR_EOF
if test 7170 -ne "`wc -c 'xldmem.c'`"
then
echo shar: error transmitting "'xldmem.c'" '(should have been 7170 characters)'
fi
echo shar: extracting "'xleval.c'" '(7937 characters)'
if test -f 'xleval.c'
then
echo shar: over-writing existing file "'xleval.c'"
fi
sed 's/^X//' << \SHAR_EOF > 'xleval.c'
X/* xleval - xlisp evaluator */
X/* Copyright (c) 1985, by David Michael Betz
X All Rights Reserved
X Permission is granted for unrestricted non-commercial use */
X
X#include "xlisp.h"
X
X/* external variables */
Xextern NODE *xlstack,*xlenv;
Xextern NODE *s_lambda,*s_macro;
Xextern NODE *k_optional,*k_rest,*k_aux;
Xextern NODE *s_evalhook,*s_applyhook;
Xextern NODE *s_unbound;
Xextern NODE *s_stdout;
X
X/* forward declarations */
XFORWARD NODE *xlxeval();
XFORWARD NODE *evalhook();
XFORWARD NODE *evform();
XFORWARD NODE *evfun();
X
X/* xleval - evaluate an xlisp expression (checking for *evalhook*) */
XNODE *xleval(expr)
X NODE *expr;
X{
X return (getvalue(s_evalhook) ? evalhook(expr) : xlxeval(expr));
X}
X
X/* xlxeval - evaluate an xlisp expression (bypassing *evalhook*) */
XNODE *xlxeval(expr)
X NODE *expr;
X{
X#ifdef MEGAMAX
X macidle();
X#endif
X
X /* evaluate nil to itself */
X if (expr == NIL)
X return (NIL);
X
X /* add trace entry */
X xltpush(expr);
X
X /* check type of value */
X if (consp(expr))
X expr = evform(expr);
X else if (symbolp(expr))
X expr = xlgetvalue(expr);
X
X /* remove trace entry */
X xltpop();
X
X /* return the value */
X return (expr);
X}
X
X/* xlapply - apply a function to a list of arguments */
XNODE *xlapply(fun,args)
X NODE *fun,*args;
X{
X NODE *env,*val;
X
X /* check for a null function */
X if (fun == NIL)
X xlfail("bad function");
X
X /* evaluate the function */
X if (subrp(fun))
X val = (*fun->n_subr)(args);
X else if (consp(fun)) {
X if (consp(car(fun))) {
X env = cdr(fun);
X fun = car(fun);
X }
X else
X env = xlenv;
X if (car(fun) != s_lambda)
X xlfail("bad function type");
X val = evfun(fun,args,env);
X }
X else
X xlfail("bad function");
X
X /* return the result value */
X return (val);
X}
X
X/* evform - evaluate a form */
XLOCAL NODE *evform(expr)
X NODE *expr;
X{
X NODE *oldstk,fun,args,*env,*val,*type;
X
X /* create a stack frame */
X oldstk = xlsave(&fun,&args,NULL);
X
X /* get the function and the argument list */
X fun.n_ptr = car(expr);
X args.n_ptr = cdr(expr);
X
X /* evaluate the first expression */
X if ((fun.n_ptr = xleval(fun.n_ptr)) == NIL)
X xlfail("bad function");
X
X /* evaluate the function */
X if (subrp(fun.n_ptr) || fsubrp(fun.n_ptr)) {
X if (subrp(fun.n_ptr))
X args.n_ptr = xlevlist(args.n_ptr);
X val = (*fun.n_ptr->n_subr)(args.n_ptr);
X }
X else if (consp(fun.n_ptr)) {
X if (consp(car(fun.n_ptr))) {
X env = cdr(fun.n_ptr);
X fun.n_ptr = car(fun.n_ptr);
X }
X else
X env = xlenv;
X if ((type = car(fun.n_ptr)) == s_lambda) {
X args.n_ptr = xlevlist(args.n_ptr);
X val = evfun(fun.n_ptr,args.n_ptr,env);
X }
X else if (type == s_macro) {
X args.n_ptr = evfun(fun.n_ptr,args.n_ptr,env);
X val = xleval(args.n_ptr);
X }
X else
X xlfail("bad function type");
X }
X else if (objectp(fun.n_ptr))
X val = xlsend(fun.n_ptr,args.n_ptr);
X else
X xlfail("bad function");
X
X /* restore the previous stack frame */
X xlstack = oldstk;
X
X /* return the result value */
X return (val);
X}
X
X/* evalhook - call the evalhook function */
XLOCAL NODE *evalhook(expr)
X NODE *expr;
X{
X NODE *oldstk,ehook,ahook,args,*val;
X
X /* create a new stack frame */
X oldstk = xlsave(&ehook,&ahook,&args,NULL);
X
X /* make an argument list */
X args.n_ptr = newnode(LIST);
X rplaca(args.n_ptr,expr);
X rplacd(args.n_ptr,newnode(LIST));
X rplaca(cdr(args.n_ptr),xlenv);
X
X /* rebind the hook functions to nil */
X ehook.n_ptr = getvalue(s_evalhook);
X setvalue(s_evalhook,NIL);
X ahook.n_ptr = getvalue(s_applyhook);
X setvalue(s_applyhook,NIL);
X
X /* call the hook function */
X val = xlapply(ehook.n_ptr,args.n_ptr);
X
X /* unbind the symbols */
X setvalue(s_evalhook,ehook.n_ptr);
X setvalue(s_applyhook,ahook.n_ptr);
X
X /* restore the previous stack frame */
X xlstack = oldstk;
X
X /* return the value */
X return (val);
X}
X
X/* xlevlist - evaluate a list of arguments */
XNODE *xlevlist(args)
X NODE *args;
X{
X NODE *oldstk,src,dst,*new,*last,*val;
X
X /* create a stack frame */
X oldstk = xlsave(&src,&dst,NULL);
X
X /* initialize */
X src.n_ptr = args;
X
X /* evaluate each argument */
X for (val = NIL; src.n_ptr; src.n_ptr = cdr(src.n_ptr)) {
X
X /* check this entry */
X if (!consp(src.n_ptr))
X xlfail("bad argument list");
X
X /* allocate a new list entry */
X new = newnode(LIST);
X if (val)
X rplacd(last,new);
X else
X val = dst.n_ptr = new;
X rplaca(new,xleval(car(src.n_ptr)));
X last = new;
X }
X
X /* restore the previous stack frame */
X xlstack = oldstk;
X
X /* return the new list */
X return (val);
X}
X
X/* xlunbound - signal an unbound variable error */
Xxlunbound(sym)
X NODE *sym;
X{
X xlcerror("try evaluating symbol again","unbound variable",sym);
X}
X
X/* evfun - evaluate a function */
XLOCAL NODE *evfun(fun,args,env)
X NODE *fun,*args,*env;
X{
X NODE *oldstk,oldenv,newenv,cptr,*fargs,*val;
X
X /* create a stack frame */
X oldstk = xlsave(&oldenv,&newenv,&cptr,NULL);
X
X /* skip the function type */
X if ((fun = cdr(fun)) == NIL || !consp(fun))
X xlfail("bad function definition");
X
X /* get the formal argument list */
X if ((fargs = car(fun)) && !consp(fargs))
X xlfail("bad formal argument list");
X
X /* create a new environment frame */
X newenv.n_ptr = xlframe(env);
X oldenv.n_ptr = xlenv;
X
X /* bind the formal parameters */
X xlabind(fargs,args,newenv.n_ptr);
X xlenv = newenv.n_ptr;
X
X /* execute the code */
X for (cptr.n_ptr = cdr(fun); cptr.n_ptr != NIL; )
X val = xlevarg(&cptr.n_ptr);
X
X /* restore the environment */
X xlenv = oldenv.n_ptr;
X
X /* restore the previous stack frame */
X xlstack = oldstk;
X
X /* return the result value */
X return (val);
X}
X
X/* xlabind - bind the arguments for a function */
Xxlabind(fargs,aargs,env)
X NODE *fargs,*aargs,*env;
X{
X NODE *arg;
X
X /* evaluate and bind each required argument */
X while (consp(fargs) && !iskeyword(arg = car(fargs)) && consp(aargs)) {
X
X /* bind the formal variable to the argument value */
X xlbind(arg,car(aargs),env);
X
X /* move the argument list pointers ahead */
X fargs = cdr(fargs);
X aargs = cdr(aargs);
X }
X
X /* check for the '&optional' keyword */
X if (consp(fargs) && car(fargs) == k_optional) {
X fargs = cdr(fargs);
X
X /* bind the arguments that were supplied */
X while (consp(fargs) && !iskeyword(arg = car(fargs)) && consp(aargs)) {
X
X /* bind the formal variable to the argument value */
X xlbind(arg,car(aargs),env);
X
X /* move the argument list pointers ahead */
X fargs = cdr(fargs);
X aargs = cdr(aargs);
X }
X
X /* bind the rest to nil */
X while (consp(fargs) && !iskeyword(arg = car(fargs))) {
X
X /* bind the formal variable to nil */
X xlbind(arg,NIL,env);
X
X /* move the argument list pointer ahead */
X fargs = cdr(fargs);
X }
X }
X
X /* check for the '&rest' keyword */
X if (consp(fargs) && car(fargs) == k_rest) {
X fargs = cdr(fargs);
X if (consp(fargs) && (arg = car(fargs)) && !iskeyword(arg))
X xlbind(arg,aargs,env);
X else
X xlfail("symbol missing after &rest");
X fargs = cdr(fargs);
X aargs = NIL;
X }
X
X /* check for the '&aux' keyword */
X if (consp(fargs) && car(fargs) == k_aux)
X while ((fargs = cdr(fargs)) != NIL && consp(fargs))
X xlbind(car(fargs),NIL,env);
X
X /* make sure the correct number of arguments were supplied */
X if (fargs != aargs)
X xlfail(fargs ? "too few arguments" : "too many arguments");
X}
X
X/* iskeyword - check to see if a symbol is a keyword */
XLOCAL int iskeyword(sym)
X NODE *sym;
X{
X return (sym == k_optional || sym == k_rest || sym == k_aux);
X}
X
X/* xlsave - save nodes on the stack */
XNODE *xlsave(n)
X NODE *n;
X{
X NODE **nptr,*oldstk;
X
X /* save the old stack pointer */
X oldstk = xlstack;
X
X /* save each node */
X for (nptr = &n; *nptr != NULL; nptr++) {
X rplaca(*nptr,NIL);
X rplacd(*nptr,xlstack);
X xlstack = *nptr;
X }
X
X /* return the old stack pointer */
X return (oldstk);
X}
SHAR_EOF
if test 7937 -ne "`wc -c 'xleval.c'`"
then
echo shar: error transmitting "'xleval.c'" '(should have been 7937 characters)'
fi
echo shar: extracting "'xlfio.c'" '(6777 characters)'
if test -f 'xlfio.c'
then
echo shar: over-writing existing file "'xlfio.c'"
fi
sed 's/^X//' << \SHAR_EOF > 'xlfio.c'
X/* xlfio.c - xlisp file i/o */
X/* Copyright (c) 1985, by David Michael Betz
X All Rights Reserved
X Permission is granted for unrestricted non-commercial use */
X
X#include "xlisp.h"
X
X/* external variables */
Xextern NODE *s_stdin,*s_stdout;
Xextern NODE *xlstack;
Xextern int xlfsize;
Xextern char buf[];
X
X/* external routines */
Xextern FILE *fopen();
X
X/* forward declarations */
XFORWARD NODE *printit();
XFORWARD NODE *flatsize();
XFORWARD NODE *openit();
X
X/* xread - read an expression */
XNODE *xread(args)
X NODE *args;
X{
X NODE *oldstk,fptr,eof,*val;
X
X /* create a new stack frame */
X oldstk = xlsave(&fptr,&eof,NULL);
X
X /* get file pointer and eof value */
X fptr.n_ptr = (args ? xlgetfile(&args) : getvalue(s_stdin));
X eof.n_ptr = (args ? xlarg(&args) : NIL);
X xllastarg(args);
X
X /* read an expression */
X if (!xlread(fptr.n_ptr,&val))
X val = eof.n_ptr;
X
X /* restore the previous stack frame */
X xlstack = oldstk;
X
X /* return the expression */
X return (val);
X}
X
X/* xprint - builtin function 'print' */
XNODE *xprint(args)
X NODE *args;
X{
X return (printit(args,TRUE,TRUE));
X}
X
X/* xprin1 - builtin function 'prin1' */
XNODE *xprin1(args)
X NODE *args;
X{
X return (printit(args,TRUE,FALSE));
X}
X
X/* xprinc - builtin function princ */
XNODE *xprinc(args)
X NODE *args;
X{
X return (printit(args,FALSE,FALSE));
X}
X
X/* xterpri - terminate the current print line */
XNODE *xterpri(args)
X NODE *args;
X{
X NODE *fptr;
X
X /* get file pointer */
X fptr = (args ? xlgetfile(&args) : getvalue(s_stdout));
X xllastarg(args);
X
X /* terminate the print line and return nil */
X xlterpri(fptr);
X return (NIL);
X}
X
X/* printit - common print function */
XLOCAL NODE *printit(args,pflag,tflag)
X NODE *args; int pflag,tflag;
X{
X NODE *oldstk,fptr,val;
X
X /* create a new stack frame */
X oldstk = xlsave(&fptr,&val,NULL);
X
X /* get expression to print and file pointer */
X val.n_ptr = xlarg(&args);
X fptr.n_ptr = (args ? xlgetfile(&args) : getvalue(s_stdout));
X xllastarg(args);
X
X /* print the value */
X xlprint(fptr.n_ptr,val.n_ptr,pflag);
X
X /* terminate the print line if necessary */
X if (tflag)
X xlterpri(fptr.n_ptr);
X
X /* restore the previous stack frame */
X xlstack = oldstk;
X
X /* return the result */
X return (val.n_ptr);
X}
X
X/* xflatsize - compute the size of a printed representation using prin1 */
XNODE *xflatsize(args)
X NODE *args;
X{
X return (flatsize(args,TRUE));
X}
X
X/* xflatc - compute the size of a printed representation using princ */
XNODE *xflatc(args)
X NODE *args;
X{
X return (flatsize(args,FALSE));
X}
X
X/* flatsize - compute the size of a printed expression */
XLOCAL NODE *flatsize(args,pflag)
X NODE *args; int pflag;
X{
X NODE *oldstk,val;
X
X /* create a new stack frame */
X oldstk = xlsave(&val,NULL);
X
X /* get the expression */
X val.n_ptr = xlarg(&args);
X xllastarg(args);
X
X /* print the value to compute its size */
X xlfsize = 0;
X xlprint(NIL,val.n_ptr,pflag);
X
X /* restore the previous stack frame */
X xlstack = oldstk;
X
X /* return the length of the expression */
X return (cvfixnum((FIXNUM)xlfsize));
X}
X
X/* xopeni - open an input file */
XNODE *xopeni(args)
X NODE *args;
X{
X return (openit(args,"r"));
X}
X
X/* xopeno - open an output file */
XNODE *xopeno(args)
X NODE *args;
X{
X return (openit(args,"w"));
X}
X
X/* openit - common file open routine */
XLOCAL NODE *openit(args,mode)
X NODE *args; char *mode;
X{
X NODE *fname,*val;
X FILE *fp;
X
X /* get the file name */
X fname = xlmatch(STR,&args);
X xllastarg(args);
X
X /* try to open the file */
X if ((fp = fopen(fname->n_str,mode)) != NULL) {
X val = newnode(FPTR);
X val->n_fp = fp;
X val->n_savech = 0;
X }
X else
X val = NIL;
X
X /* return the file pointer */
X return (val);
X}
X
X/* xclose - close a file */
XNODE *xclose(args)
X NODE *args;
X{
X NODE *fptr;
X
X /* get file pointer */
X fptr = xlmatch(FPTR,&args);
X xllastarg(args);
X
X /* make sure the file exists */
X if (fptr->n_fp == NULL)
X xlfail("file not open");
X
X /* close the file */
X fclose(fptr->n_fp);
X fptr->n_fp = NULL;
X
X /* return nil */
X return (NIL);
X}
X
X/* xrdchar - read a character from a file */
XNODE *xrdchar(args)
X NODE *args;
X{
X NODE *fptr;
X int ch;
X
X /* get file pointer */
X fptr = (args ? xlgetfile(&args) : getvalue(s_stdin));
X xllastarg(args);
X
X /* get character and check for eof */
X return ((ch = xlgetc(fptr)) == EOF ? NIL : cvfixnum((FIXNUM)ch));
X}
X
X/* xpkchar - peek at a character from a file */
XNODE *xpkchar(args)
X NODE *args;
X{
X NODE *flag,*fptr;
X int ch;
X
X /* peek flag and get file pointer */
X flag = (args ? xlarg(&args) : NIL);
X fptr = (args ? xlgetfile(&args) : getvalue(s_stdin));
X xllastarg(args);
X
X /* skip leading white space and get a character */
X if (flag)
X while ((ch = xlpeek(fptr)) != EOF && isspace(ch))
X xlgetc(fptr);
X else
X ch = xlpeek(fptr);
X
X /* return the character */
X return (ch == EOF ? NIL : cvfixnum((FIXNUM)ch));
X}
X
X/* xwrchar - write a character to a file */
XNODE *xwrchar(args)
X NODE *args;
X{
X NODE *fptr,*chr;
X
X /* get the character and file pointer */
X chr = xlmatch(INT,&args);
X fptr = (args ? xlgetfile(&args) : getvalue(s_stdout));
X xllastarg(args);
X
X /* put character to the file */
X xlputc(fptr,(int)chr->n_int);
X
X /* return the character */
X return (chr);
X}
X
X/* xreadline - read a line from a file */
XNODE *xreadline(args)
X NODE *args;
X{
X NODE *oldstk,fptr,str;
X char *p,*sptr;
X int len,ch;
X
X /* create a new stack frame */
X oldstk = xlsave(&fptr,&str,NULL);
X
X /* get file pointer */
X fptr.n_ptr = (args ? xlgetfile(&args) : getvalue(s_stdin));
X xllastarg(args);
X
X /* make a string node */
X str.n_ptr = newnode(STR);
X str.n_ptr->n_strtype = DYNAMIC;
X
X /* get character and check for eof */
X len = 0; p = buf;
X while ((ch = xlgetc(fptr.n_ptr)) != EOF && ch != '\n') {
X
X /* check for buffer overflow */
X if ((int)(p - buf) == STRMAX) {
X *p = 0;
X sptr = stralloc(len + STRMAX); *sptr = 0;
X if (len) {
X strcpy(sptr,str.n_ptr->n_str);
X strfree(str.n_ptr->n_str);
X }
X str.n_ptr->n_str = sptr;
X strcat(sptr,buf);
X len += STRMAX;
X p = buf;
X }
X
X /* store the character */
X *p++ = ch;
X }
X
X /* check for end of file */
X if (len == 0 && p == buf && ch == EOF) {
X xlstack = oldstk;
X return (NIL);
X }
X
X /* append the last substring */
X *p = 0;
X sptr = stralloc(len + (int)(p - buf)); *sptr = 0;
X if (len) {
X strcpy(sptr,str.n_ptr->n_str);
X strfree(str.n_ptr->n_str);
X }
X str.n_ptr->n_str = sptr;
X strcat(sptr,buf);
X
X /* restore the previous stack frame */
X xlstack = oldstk;
X
X /* return the string */
X return (str.n_ptr);
X}
SHAR_EOF
if test 6777 -ne "`wc -c 'xlfio.c'`"
then
echo shar: error transmitting "'xlfio.c'" '(should have been 6777 characters)'
fi
echo shar: extracting "'xlftab1.c'" '(4118 characters)'
if test -f 'xlftab1.c'
then
echo shar: over-writing existing file "'xlftab1.c'"
fi
sed 's/^X//' << \SHAR_EOF > 'xlftab1.c'
X/* xlftab1.c - xlisp function table - part 1 */
X/* Copyright (c) 1985, by David Michael Betz
X All Rights Reserved
X Permission is granted for unrestricted non-commercial use */
X
X#include "xlisp.h"
X
X/* external functions */
Xextern NODE
X *xeval(),*xapply(),*xfuncall(),*xquote(),*xfunction(),*xbquote(),
X *xset(),*xsetq(),*xsetf(),*xdefun(),*xdefmacro(),
X *xgensym(),*xmakesymbol(),*xintern(),
X *xsymname(),*xsymvalue(),*xsymplist(),*xget(),*xputprop(),*xremprop(),
X *xcar(),*xcaar(),*xcadr(),*xcdr(),*xcdar(),*xcddr(),
X *xcons(),*xlist(),*xappend(),*xreverse(),*xlast(),*xnth(),*xnthcdr(),
X *xmember(),*xassoc(),*xsubst(),*xsublis(),*xremove(),*xlength(),
X *xmapc(),*xmapcar(),*xmapl(),*xmaplist(),
X *xrplca(),*xrplcd(),*xnconc(),*xdelete(),
X *xatom(),*xsymbolp(),*xnumberp(),*xboundp(),*xnull(),*xlistp(),*xconsp(),
X *xeq(),*xeql(),*xequal(),
X *xcond(),*xand(),*xor(),*xlet(),*xletstar(),*xif(),
X *xprog(),*xprogstar(),*xprog1(),*xprog2(),*xprogn(),*xgo(),*xreturn(),
X *xcatch(),*xthrow(),
X *xerror(),*xcerror(),*xbreak(),*xcleanup(),*xcontinue(),*xerrset(),
X *xbaktrace(),*xevalhook(),
X *xdo(),*xdostar(),*xdolist(),*xdotimes(),
X *xminusp(),*xzerop(),*xplusp(),*xevenp(),*xoddp();
X
X/* the function table */
Xstruct fdef ftab1[] = {
X
X /* evaluator functions */
X{ "EVAL", SUBR, xeval },
X{ "APPLY", SUBR, xapply },
X{ "FUNCALL", SUBR, xfuncall },
X{ "QUOTE", FSUBR, xquote },
X{ "FUNCTION", FSUBR, xfunction },
X{ "BACKQUOTE", FSUBR, xbquote },
X
X /* symbol functions */
X{ "SET", SUBR, xset },
X{ "SETQ", FSUBR, xsetq },
X{ "SETF", FSUBR, xsetf },
X{ "DEFUN", FSUBR, xdefun },
X{ "DEFMACRO", FSUBR, xdefmacro },
X{ "GENSYM", SUBR, xgensym },
X{ "MAKE-SYMBOL", SUBR, xmakesymbol },
X{ "INTERN", SUBR, xintern },
X{ "SYMBOL-NAME", SUBR, xsymname },
X{ "SYMBOL-VALUE", SUBR, xsymvalue },
X{ "SYMBOL-PLIST", SUBR, xsymplist },
X{ "GET", SUBR, xget },
X{ "PUTPROP", SUBR, xputprop },
X{ "REMPROP", SUBR, xremprop },
X
X /* list functions */
X{ "CAR", SUBR, xcar },
X{ "CAAR", SUBR, xcaar },
X{ "CADR", SUBR, xcadr },
X{ "CDR", SUBR, xcdr },
X{ "CDAR", SUBR, xcdar },
X{ "CDDR", SUBR, xcddr },
X{ "CONS", SUBR, xcons },
X{ "LIST", SUBR, xlist },
X{ "APPEND", SUBR, xappend },
X{ "REVERSE", SUBR, xreverse },
X{ "LAST", SUBR, xlast },
X{ "NTH", SUBR, xnth },
X{ "NTHCDR", SUBR, xnthcdr },
X{ "MEMBER", SUBR, xmember },
X{ "ASSOC", SUBR, xassoc },
X{ "SUBST", SUBR, xsubst },
X{ "SUBLIS", SUBR, xsublis },
X{ "REMOVE", SUBR, xremove },
X{ "LENGTH", SUBR, xlength },
X{ "MAPC", SUBR, xmapc },
X{ "MAPCAR", SUBR, xmapcar },
X{ "MAPL", SUBR, xmapl },
X{ "MAPLIST", SUBR, xmaplist },
X
X /* destructive list functions */
X{ "RPLACA", SUBR, xrplca },
X{ "RPLACD", SUBR, xrplcd },
X{ "NCONC", SUBR, xnconc },
X{ "DELETE", SUBR, xdelete },
X
X /* predicate functions */
X{ "ATOM", SUBR, xatom },
X{ "SYMBOLP", SUBR, xsymbolp },
X{ "NUMBERP", SUBR, xnumberp },
X{ "BOUNDP", SUBR, xboundp },
X{ "NULL", SUBR, xnull },
X{ "NOT", SUBR, xnull },
X{ "LISTP", SUBR, xlistp },
X{ "CONSP", SUBR, xconsp },
X{ "MINUSP", SUBR, xminusp },
X{ "ZEROP", SUBR, xzerop },
X{ "PLUSP", SUBR, xplusp },
X{ "EVENP", SUBR, xevenp },
X{ "ODDP", SUBR, xoddp },
X{ "EQ", SUBR, xeq },
X{ "EQL", SUBR, xeql },
X{ "EQUAL", SUBR, xequal },
X
X /* control functions */
X{ "COND", FSUBR, xcond },
X{ "AND", FSUBR, xand },
X{ "OR", FSUBR, xor },
X{ "LET", FSUBR, xlet },
X{ "LET*", FSUBR, xletstar },
X{ "IF", FSUBR, xif },
X{ "PROG", FSUBR, xprog },
X{ "PROG*", FSUBR, xprogstar },
X{ "PROG1", FSUBR, xprog1 },
X{ "PROG2", FSUBR, xprog2 },
X{ "PROGN", FSUBR, xprogn },
X{ "GO", FSUBR, xgo },
X{ "RETURN", SUBR, xreturn },
X{ "DO", FSUBR, xdo },
X{ "DO*", FSUBR, xdostar },
X{ "DOLIST", FSUBR, xdolist },
X{ "DOTIMES", FSUBR, xdotimes },
X{ "CATCH", FSUBR, xcatch },
X{ "THROW", SUBR, xthrow },
X
X /* debugging and error handling functions */
X{ "ERROR", SUBR, xerror },
X{ "CERROR", SUBR, xcerror },
X{ "BREAK", SUBR, xbreak },
X{ "CLEAN-UP", SUBR, xcleanup },
X{ "CONTINUE", SUBR, xcontinue },
X{ "ERRSET", FSUBR, xerrset },
X{ "BAKTRACE", SUBR, xbaktrace },
X{ "EVALHOOK", SUBR, xevalhook },
X
X{ 0 }
X};
SHAR_EOF
if test 4118 -ne "`wc -c 'xlftab1.c'`"
then
echo shar: error transmitting "'xlftab1.c'" '(should have been 4118 characters)'
fi
# End of shell archive
exit 0
--
Jwahar R. Bammi
Usenet: .....!decvax!cwruecmp!bammi
CSnet: bammi@case
Arpa: bammi%case@csnet-relay
CompuServe: 71515,155
Thread Navigation
This is a paginated view of messages in the thread with full content displayed inline.
Messages are displayed in chronological order, with the original post highlighted in green.
Use pagination controls to navigate through all messages in large threads.
Back to All Threads