sources-request@mirror.UUCP (08/13/86)
Submitted by: seismo!utah-cs!b-davis (Brad Davis)
Mod.sources: Volume 6, Issue 109
Archive-name: xlisp1.6/Part03
#! /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:
# xlobj.c
# xlprin.c
# xlread.c
# xlstr.c
# xlsubr.c
# xlsym.c
# xlsys.c
# This archive created: Mon Jul 14 10:24:06 1986
export PATH; PATH=/bin:$PATH
if test -f 'xlobj.c'
then
echo shar: will not over-write existing file "'xlobj.c'"
else
cat << \SHAR_EOF > 'xlobj.c'
/* xlobj - xlisp object functions */
/* Copyright (c) 1985, by David Michael Betz
All Rights Reserved
Permission is granted for unrestricted non-commercial use */
#include "xlisp.h"
#ifdef MEGAMAX
overlay "overflow"
#endif
/* external variables */
extern NODE ***xlstack,*xlenv;
extern NODE *s_stdout;
extern NODE *self,*msgclass,*msgcls,*class,*object;
extern NODE *new,*isnew;
/* instance variable numbers for the class 'Class' */
#define MESSAGES 0 /* list of messages */
#define IVARS 1 /* list of instance variable names */
#define CVARS 2 /* list of class variable names */
#define CVALS 3 /* list of class variable values */
#define SUPERCLASS 4 /* pointer to the superclass */
#define IVARCNT 5 /* number of class instance variables */
#define IVARTOTAL 6 /* total number of instance variables */
/* number of instance variables for the class 'Class' */
#define CLASSSIZE 7
/* forward declarations */
FORWARD NODE *entermsg();
FORWARD NODE *findmsg();
FORWARD NODE *sendmsg();
/* xlclass - define a class */
NODE *xlclass(name,vcnt)
char *name; int vcnt;
{
NODE *sym,*cls;
/* create the class */
sym = xlsenter(name);
cls = newobject(class,CLASSSIZE);
setvalue(sym,cls);
/* set the instance variable counts */
setivar(cls,IVARCNT,cvfixnum((FIXNUM)vcnt));
setivar(cls,IVARTOTAL,cvfixnum((FIXNUM)vcnt));
/* set the superclass to 'Object' */
setivar(cls,SUPERCLASS,object);
/* return the new class */
return (cls);
}
/* xladdivar - enter an instance variable */
xladdivar(cls,var)
NODE *cls; char *var;
{
setivar(cls,IVARS,cons(xlsenter(var),getivar(cls,IVARS)));
}
/* xladdmsg - add a message to a class */
xladdmsg(cls,msg,code)
NODE *cls; char *msg; NODE *(*code)();
{
NODE *mptr;
/* enter the message selector */
mptr = entermsg(cls,xlsenter(msg));
/* store the method for this message */
rplacd(mptr,cvsubr(code,SUBR));
}
/* xlsend - send a message to an object (message in arg list) */
NODE *xlsend(obj,args)
NODE *obj,*args;
{
NODE ***oldstk,*arglist,*msg,*val;
/* find the message binding for this message */
if ((msg = findmsg(getclass(obj),xlevmatch(SYM,&args))) == NIL)
xlfail("no method for this message");
/* evaluate the arguments and send the message */
oldstk = xlsave(&arglist,(NODE **)NULL);
arglist = xlevlist(args);
val = sendmsg(obj,msg,arglist);
xlstack = oldstk;
/* return the result */
return (val);
}
/* xlobgetvalue - get the value of an instance variable */
int xlobgetvalue(sym,pval)
NODE *sym,**pval;
{
NODE *obj,*cls,*names;
int ivtotal,n;
/* get the current object and the message class */
obj = xlygetvalue(self);
cls = xlygetvalue(msgclass);
if (!(objectp(obj) && objectp(cls)))
return (FALSE);
/* find the instance or class variable */
for (; objectp(cls); cls = getivar(cls,SUPERCLASS)) {
/* check the instance variables */
names = getivar(cls,IVARS);
ivtotal = getivcnt(cls,IVARTOTAL);
for (n = ivtotal - getivcnt(cls,IVARCNT); n < ivtotal; ++n) {
if (car(names) == sym) {
*pval = getivar(obj,n);
return (TRUE);
}
names = cdr(names);
}
/* check the class variables */
names = getivar(cls,CVARS);
for (n = 0; consp(names); ++n) {
if (car(names) == sym) {
*pval = getelement(getivar(cls,CVALS),n);
return (TRUE);
}
names = cdr(names);
}
}
/* variable not found */
return (FALSE);
}
/* xlobsetvalue - set the value of an instance variable */
int xlobsetvalue(sym,val)
NODE *sym,*val;
{
NODE *obj,*cls,*names;
int ivtotal,n;
/* get the current object and the message class */
obj = xlygetvalue(self);
cls = xlygetvalue(msgclass);
if (!(objectp(obj) && objectp(cls)))
return (FALSE);
/* find the instance or class variable */
for (; objectp(cls); cls = getivar(cls,SUPERCLASS)) {
/* check the instance variables */
names = getivar(cls,IVARS);
ivtotal = getivcnt(cls,IVARTOTAL);
for (n = ivtotal - getivcnt(cls,IVARCNT); n < ivtotal; ++n) {
if (car(names) == sym) {
setivar(obj,n,val);
return (TRUE);
}
names = cdr(names);
}
/* check the class variables */
names = getivar(cls,CVARS);
for (n = 0; consp(names); ++n) {
if (car(names) == sym) {
setelement(getivar(cls,CVALS),n,val);
return (TRUE);
}
names = cdr(names);
}
}
/* variable not found */
return (FALSE);
}
/* obisnew - default 'isnew' method */
LOCAL NODE *obisnew(args)
NODE *args;
{
xllastarg(args);
return (xlygetvalue(self));
}
/* obclass - get the class of an object */
LOCAL NODE *obclass(args)
NODE *args;
{
/* make sure there aren't any arguments */
xllastarg(args);
/* return the object's class */
return (getclass(xlygetvalue(self)));
}
/* obshow - show the instance variables of an object */
LOCAL NODE *obshow(args)
NODE *args;
{
NODE ***oldstk,*fptr,*obj,*cls,*names;
int ivtotal,n;
/* create a new stack frame */
oldstk = xlsave(&fptr,(NODE **)NULL);
/* get the file pointer */
fptr = (args ? xlgetfile(&args) : getvalue(s_stdout));
xllastarg(args);
/* get the object and its class */
obj = xlygetvalue(self);
cls = getclass(obj);
/* print the object and class */
xlputstr(fptr,"Object is ");
xlprint(fptr,obj,TRUE);
xlputstr(fptr,", Class is ");
xlprint(fptr,cls,TRUE);
xlterpri(fptr);
/* print the object's instance variables */
for (cls = getclass(obj); cls; cls = getivar(cls,SUPERCLASS)) {
names = getivar(cls,IVARS);
ivtotal = getivcnt(cls,IVARTOTAL);
for (n = ivtotal - getivcnt(cls,IVARCNT); n < ivtotal; ++n) {
xlputstr(fptr," ");
xlprint(fptr,car(names),TRUE);
xlputstr(fptr," = ");
xlprint(fptr,getivar(obj,n),TRUE);
xlterpri(fptr);
names = cdr(names);
}
}
/* restore the previous stack frame */
xlstack = oldstk;
/* return the object */
return (obj);
}
/* obsendsuper - send a message to an object's superclass */
LOCAL NODE *obsendsuper(args)
NODE *args;
{
NODE *obj,*super,*msg;
/* get the object */
obj = xlygetvalue(self);
/* get the object's superclass */
super = getivar(getclass(obj),SUPERCLASS);
/* find the message binding for this message */
if ((msg = findmsg(super,xlmatch(SYM,&args))) == NIL)
xlfail("no method for this message");
/* send the message */
return (sendmsg(obj,msg,args));
}
/* clnew - create a new object instance */
LOCAL NODE *clnew()
{
NODE *cls;
cls = xlygetvalue(self);
return (newobject(cls,getivcnt(cls,IVARTOTAL)));
}
/* clisnew - initialize a new class */
LOCAL NODE *clisnew(args)
NODE *args;
{
NODE *ivars,*cvars,*super,*cls;
int n;
/* get the ivars, cvars and superclass */
ivars = xlmatch(LIST,&args);
cvars = (args ? xlmatch(LIST,&args) : NIL);
super = (args ? xlmatch(OBJ,&args) : object);
xllastarg(args);
/* get the new class object */
cls = xlygetvalue(self);
/* store the instance and class variable lists and the superclass */
setivar(cls,IVARS,ivars);
setivar(cls,CVARS,cvars);
setivar(cls,CVALS,newvector(listlength(cvars)));
setivar(cls,SUPERCLASS,super);
/* compute the instance variable count */
n = listlength(ivars);
setivar(cls,IVARCNT,cvfixnum((FIXNUM)n));
n += getivcnt(super,IVARTOTAL);
setivar(cls,IVARTOTAL,cvfixnum((FIXNUM)n));
/* return the new class object */
return (cls);
}
/* clanswer - define a method for answering a message */
LOCAL NODE *clanswer(args)
NODE *args;
{
NODE ***oldstk,*arg,*msg,*fargs,*code,*obj,*mptr;
/* create a new stack frame */
oldstk = xlsave(&arg,&msg,&fargs,&code,(NODE **)NULL);
/* initialize */
arg = args;
/* message symbol, formal argument list and code */
msg = xlmatch(SYM,&arg);
fargs = xlmatch(LIST,&arg);
code = xlmatch(LIST,&arg);
xllastarg(arg);
/* get the object node */
obj = xlygetvalue(self);
/* make a new message list entry */
mptr = entermsg(obj,msg);
/* setup the message node */
rplacd(mptr,cons(fargs,code));
/* restore the previous stack frame */
xlstack = oldstk;
/* return the object */
return (obj);
}
/* entermsg - add a message to a class */
LOCAL NODE *entermsg(cls,msg)
NODE *cls,*msg;
{
NODE ***oldstk,*lptr,*mptr;
/* lookup the message */
for (lptr = getivar(cls,MESSAGES); lptr; lptr = cdr(lptr))
if (car(mptr = car(lptr)) == msg)
return (mptr);
/* allocate a new message entry if one wasn't found */
oldstk = xlsave(&mptr,(NODE **)NULL);
mptr = consa(msg);
setivar(cls,MESSAGES,cons(mptr,getivar(cls,MESSAGES)));
xlstack = oldstk;
/* return the symbol node */
return (mptr);
}
/* findmsg - find the message binding given an object and a class */
LOCAL NODE *findmsg(cls,sym)
NODE *cls,*sym;
{
NODE *lptr,*msg;
/* look for the message in the class or superclasses */
for (msgcls = cls; msgcls != NIL; ) {
/* lookup the message in this class */
for (lptr = getivar(msgcls,MESSAGES); lptr != NIL; lptr = cdr(lptr))
if ((msg = car(lptr)) != NIL && car(msg) == sym)
return (msg);
/* look in class's superclass */
msgcls = getivar(msgcls,SUPERCLASS);
}
/* message not found */
return (NIL);
}
/* sendmsg - send a message to an object */
LOCAL NODE *sendmsg(obj,msg,args)
NODE *obj,*msg,*args;
{
NODE ***oldstk,*oldenv,*newenv,*method,*cptr,*val,*isnewmsg;
/* create a new stack frame */
oldstk = xlsave(&oldenv,&newenv,&method,&cptr,&val,(NODE **)NULL);
/* get the method for this message */
method = cdr(msg);
/* make sure its a function or a subr */
if (!subrp(method) && !consp(method))
xlfail("bad method");
/* create a new environment frame */
newenv = xlframe(NIL);
oldenv = xlenv;
/* bind the symbols 'self' and 'msgclass' */
xlbind(self,obj,newenv);
xlbind(msgclass,msgcls,newenv);
/* evaluate the function call */
if (subrp(method)) {
xlenv = newenv;
val = (*getsubr(method))(args);
}
else {
/* bind the formal arguments */
xlabind(car(method),args,newenv);
xlenv = newenv;
/* execute the code */
cptr = cdr(method);
while (cptr)
val = xlevarg(&cptr);
}
/* restore the environment */
xlenv = oldenv;
/* after creating an object, send it the "isnew" message */
if (car(msg) == new && val) {
if ((isnewmsg = findmsg(getclass(val),isnew)) == NIL)
xlfail("no method for the isnew message");
sendmsg(val,isnewmsg,args);
}
/* restore the previous stack frame */
xlstack = oldstk;
/* return the result value */
return (val);
}
/* getivcnt - get the number of instance variables for a class */
LOCAL int getivcnt(cls,ivar)
NODE *cls; int ivar;
{
NODE *cnt;
if ((cnt = getivar(cls,ivar)) == NIL || !fixp(cnt))
xlfail("bad value for instance variable count");
return ((int)getfixnum(cnt));
}
/* listlength - find the length of a list */
LOCAL int listlength(list)
NODE *list;
{
int len;
for (len = 0; consp(list); len++)
list = cdr(list);
return (len);
}
/* xloinit - object function initialization routine */
xloinit()
{
/* don't confuse the garbage collector */
class = object = NIL;
/* enter the object related symbols */
self = xlsenter("SELF");
msgclass = xlsenter("MSGCLASS");
new = xlsenter(":NEW");
isnew = xlsenter(":ISNEW");
/* create the 'Class' object */
class = xlclass("CLASS",CLASSSIZE);
setelement(class,0,class);
/* create the 'Object' object */
object = xlclass("OBJECT",0);
/* finish initializing 'class' */
setivar(class,SUPERCLASS,object);
xladdivar(class,"IVARTOTAL"); /* ivar number 6 */
xladdivar(class,"IVARCNT"); /* ivar number 5 */
xladdivar(class,"SUPERCLASS"); /* ivar number 4 */
xladdivar(class,"CVALS"); /* ivar number 3 */
xladdivar(class,"CVARS"); /* ivar number 2 */
xladdivar(class,"IVARS"); /* ivar number 1 */
xladdivar(class,"MESSAGES"); /* ivar number 0 */
xladdmsg(class,":NEW",clnew);
xladdmsg(class,":ISNEW",clisnew);
xladdmsg(class,":ANSWER",clanswer);
/* finish initializing 'object' */
xladdmsg(object,":ISNEW",obisnew);
xladdmsg(object,":CLASS",obclass);
xladdmsg(object,":SHOW",obshow);
xladdmsg(object,":SENDSUPER",obsendsuper);
}
SHAR_EOF
fi # end of overwriting check
if test -f 'xlprin.c'
then
echo shar: will not over-write existing file "'xlprin.c'"
else
cat << \SHAR_EOF > 'xlprin.c'
/* xlprint - xlisp print routine */
/* Copyright (c) 1985, by David Michael Betz
All Rights Reserved
Permission is granted for unrestricted non-commercial use */
#include "xlisp.h"
#ifdef MEGAMAX
overlay "io"
#endif
/* external variables */
extern char buf[];
/* xlprint - print an xlisp value */
void xlprint(fptr,vptr,flag)
NODE *fptr,*vptr; int flag;
{
NODE *nptr;
NODE *next = NIL;
int n,i;
/* print nil */
if (vptr == NIL) {
xlputstr(fptr,"NIL");
return;
}
/* check value type */
switch (ntype(vptr)) {
case SUBR:
putatm(fptr,"Subr",vptr);
break;
case FSUBR:
putatm(fptr,"FSubr",vptr);
break;
case LIST:
xlputc(fptr,'(');
for (nptr = vptr; nptr != NIL; nptr = next) {
xlprint(fptr,car(nptr),flag);
if (next = cdr(nptr))
if (consp(next))
xlputc(fptr,' ');
else {
xlputstr(fptr," . ");
xlprint(fptr,next,flag);
break;
}
}
xlputc(fptr,')');
break;
case SYM:
xlputstr(fptr,getstring(getpname(vptr)));
break;
case INT:
putdec(fptr,getfixnum(vptr));
break;
case FLOAT:
putfloat(fptr,getflonum(vptr));
break;
case STR:
if (flag)
putstring(fptr,getstring(vptr));
else
xlputstr(fptr,getstring(vptr));
break;
case FPTR:
putatm(fptr,"File",vptr);
break;
case OBJ:
putatm(fptr,"Object",vptr);
break;
case VECT:
xlputc(fptr,'#'); xlputc(fptr,'(');
for (i = 0, n = getsize(vptr); n-- > 0; ) {
xlprint(fptr,getelement(vptr,i++),flag);
if (n) xlputc(fptr,' ');
}
xlputc(fptr,')');
break;
case FREE:
putatm(fptr,"Free",vptr);
break;
default:
putatm(fptr,"Foo",vptr);
break;
}
}
/* xlterpri - terminate the current print line */
xlterpri(fptr)
NODE *fptr;
{
xlputc(fptr,'\n');
}
/* xlputstr - output a string */
xlputstr(fptr,str)
NODE *fptr; char *str;
{
while (*str)
xlputc(fptr,*str++);
}
/* putstring - output a string */
LOCAL putstring(fptr,str)
NODE *fptr; char *str;
{
int ch;
/* output the initial quote */
xlputc(fptr,'"');
/* output each character in the string */
while (ch = *str++)
/* check for a control character */
if (ch < 040 || ch == '\\') {
xlputc(fptr,'\\');
switch (ch) {
case '\033':
xlputc(fptr,'e');
break;
case '\n':
xlputc(fptr,'n');
break;
case '\r':
xlputc(fptr,'r');
break;
case '\t':
xlputc(fptr,'t');
break;
case '\\':
xlputc(fptr,'\\');
break;
default:
putoct(fptr,ch);
break;
}
}
/* output a normal character */
else
xlputc(fptr,ch);
/* output the terminating quote */
xlputc(fptr,'"');
}
/* putatm - output an atom */
LOCAL putatm(fptr,tag,val)
NODE *fptr; char *tag; NODE *val;
{
sprintf(buf,"#<%s: #",tag); xlputstr(fptr,buf);
sprintf(buf,AFMT,val); xlputstr(fptr,buf);
xlputc(fptr,'>');
}
/* putdec - output a decimal number */
LOCAL putdec(fptr,n)
NODE *fptr; FIXNUM n;
{
sprintf(buf,IFMT,n);
xlputstr(fptr,buf);
}
/* putfloat - output a floating point number */
LOCAL putfloat(fptr,n)
NODE *fptr; FLONUM n;
{
sprintf(buf,"%g",n);
xlputstr(fptr,buf);
}
/* putoct - output an octal byte value */
LOCAL putoct(fptr,n)
NODE *fptr; int n;
{
sprintf(buf,"%03o",n);
xlputstr(fptr,buf);
}
SHAR_EOF
fi # end of overwriting check
if test -f 'xlread.c'
then
echo shar: will not over-write existing file "'xlread.c'"
else
cat << \SHAR_EOF > 'xlread.c'
/* xlread - xlisp expression input routine */
/* Copyright (c) 1985, by David Michael Betz
All Rights Reserved
Permission is granted for unrestricted non-commercial use */
#include "xlisp.h"
#ifdef MEGAMAX
overlay "io"
#endif
/* external variables */
extern NODE *s_stdout,*true,*s_dot;
extern NODE *s_quote,*s_function,*s_bquote,*s_comma,*s_comat;
extern NODE *s_rtable,*k_wspace,*k_const,*k_nmacro,*k_tmacro;
extern NODE ***xlstack;
extern int xlplevel;
extern char buf[];
/* external routines */
extern FILE *fopen();
extern double atof();
extern ITYPE;
#define WSPACE "\t \f\r\n"
#define CONST1 "!$%&*+-./0123456789:<=>?@[]^_{}~"
#define CONST2 "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz"
/* forward declarations */
FORWARD NODE *callmacro();
FORWARD NODE *phexnumber(),*pquote(),*plist(),*pvector(),*pname();
FORWARD NODE *tentry();
/* xlload - load a file of xlisp expressions */
int xlload(fname,vflag,pflag)
char *fname; int vflag,pflag;
{
NODE ***oldstk,*fptr,*expr;
char fullname[STRMAX+1];
CONTEXT cntxt;
FILE *fp;
int sts;
/* create a new stack frame */
oldstk = xlsave(&fptr,&expr,(NODE **)NULL);
/* create the full file name */
if (needsextension(fname)) {
strcpy(fullname,fname);
strcat(fullname,".lsp");
fname = fullname;
}
/* allocate a file node */
fptr = cvfile(NULL);
/* print the information line */
if (vflag)
{ sprintf(buf,"; loading \"%s\"\n",fname); stdputstr(buf); }
/* open the file */
if ((fp = fopen(fname,"r")) == NULL) {
xlstack = oldstk;
return (FALSE);
}
setfile(fptr,fp);
/* read, evaluate and possibly print each expression in the file */
xlbegin(&cntxt,CF_ERROR,true);
if (setjmp(cntxt.c_jmpbuf))
sts = FALSE;
else {
while (xlread(fptr,&expr,FALSE)) {
expr = xleval(expr);
if (pflag)
stdprint(expr);
}
sts = TRUE;
}
xlend(&cntxt);
/* close the file */
fclose(getfile(fptr));
setfile(fptr,NULL);
/* restore the previous stack frame */
xlstack = oldstk;
/* return status */
return (sts);
}
/* xlread - read an xlisp expression */
int xlread(fptr,pval,rflag)
NODE *fptr,**pval; int rflag;
{
int sts;
/* reset the paren nesting level */
if (!rflag)
xlplevel = 0;
/* read an expression */
while ((sts = readone(fptr,pval)) == FALSE)
;
/* return status */
return (sts == EOF ? FALSE : TRUE);
}
/* readone - attempt to read a single expression */
int readone(fptr,pval)
NODE *fptr,**pval;
{
NODE *val,*type;
int ch;
/* get a character and check for EOF */
if ((ch = xlgetc(fptr)) == EOF)
return (EOF);
/* handle white space */
if ((type = tentry(ch)) == k_wspace)
return (FALSE);
/* handle symbol constituents */
else if (type == k_const) {
*pval = pname(fptr,ch);
return (TRUE);
}
/* handle read macros */
else if (consp(type)) {
if ((val = callmacro(fptr,ch)) && consp(val)) {
*pval = car(val);
return (TRUE);
}
else
return (FALSE);
}
/* handle illegal characters */
else
xlerror("illegal character",cvfixnum((FIXNUM)ch));
/*NOTREACHED*/
}
/* rmhash - read macro for '#' */
NODE *rmhash(args)
NODE *args;
{
NODE ***oldstk,*fptr,*mch,*val;
int ch;
/* create a new stack frame */
oldstk = xlsave(&fptr,&mch,&val,(NODE **)NULL);
/* get the file and macro character */
fptr = xlgetfile(&args);
mch = xlmatch(INT,&args);
xllastarg(args);
/* make the return value */
val = consa(NIL);
/* check the next character */
switch (ch = xlgetc(fptr)) {
case '\'':
rplaca(val,pquote(fptr,s_function));
break;
case '(':
rplaca(val,pvector(fptr));
break;
case 'x':
case 'X':
rplaca(val,phexnumber(fptr));
break;
case '\\':
rplaca(val,cvfixnum((FIXNUM)xlgetc(fptr)));
break;
default:
xlerror("illegal character after #",cvfixnum((FIXNUM)ch));
}
/* restore the previous stack frame */
xlstack = oldstk;
/* return the value */
return (val);
}
/* rmquote - read macro for '\'' */
NODE *rmquote(args)
NODE *args;
{
NODE ***oldstk,*fptr,*mch,*val;
/* create a new stack frame */
oldstk = xlsave(&fptr,&mch,&val,(NODE **)NULL);
/* get the file and macro character */
fptr = xlgetfile(&args);
mch = xlmatch(INT,&args);
xllastarg(args);
/* make the return value */
val = consa(NIL);
rplaca(val,pquote(fptr,s_quote));
/* restore the previous stack frame */
xlstack = oldstk;
/* return the value */
return (val);
}
/* rmdquote - read macro for '"' */
NODE *rmdquote(args)
NODE *args;
{
NODE ***oldstk,*fptr,*mch,*val;
int ch,i,d1,d2,d3;
/* create a new stack frame */
oldstk = xlsave(&fptr,&mch,&val,(NODE **)NULL);
/* get the file and macro character */
fptr = xlgetfile(&args);
mch = xlmatch(INT,&args);
xllastarg(args);
/* loop looking for a closing quote */
for (i = 0; i < STRMAX && (ch = checkeof(fptr)) != '"'; i++) {
switch (ch) {
case '\\':
switch (ch = checkeof(fptr)) {
case 'f':
ch = '\f';
break;
case 'n':
ch = '\n';
break;
case 'r':
ch = '\r';
break;
case 't':
ch = '\t';
break;
default:
if (ch >= '0' && ch <= '7') {
d1 = ch - '0';
d2 = checkeof(fptr) - '0';
d3 = checkeof(fptr) - '0';
ch = (d1 << 6) + (d2 << 3) + d3;
}
break;
}
}
buf[i] = ch;
}
buf[i] = 0;
/* initialize the node */
val = consa(NIL);
rplaca(val,cvstring(buf));
/* restore the previous stack frame */
xlstack = oldstk;
/* return the new string */
return (val);
}
/* rmbquote - read macro for '`' */
NODE *rmbquote(args)
NODE *args;
{
NODE ***oldstk,*fptr,*mch,*val;
/* create a new stack frame */
oldstk = xlsave(&fptr,&mch,&val,(NODE **)NULL);
/* get the file and macro character */
fptr = xlgetfile(&args);
mch = xlmatch(INT,&args);
xllastarg(args);
/* make the return value */
val = consa(NIL);
rplaca(val,pquote(fptr,s_bquote));
/* restore the previous stack frame */
xlstack = oldstk;
/* return the value */
return (val);
}
/* rmcomma - read macro for ',' */
NODE *rmcomma(args)
NODE *args;
{
NODE ***oldstk,*fptr,*mch,*val,*sym;
/* create a new stack frame */
oldstk = xlsave(&fptr,&mch,&val,(NODE **)NULL);
/* get the file and macro character */
fptr = xlgetfile(&args);
mch = xlmatch(INT,&args);
xllastarg(args);
/* check the next character */
if (xlpeek(fptr) == '@') {
sym = s_comat;
xlgetc(fptr);
}
else
sym = s_comma;
/* make the return value */
val = consa(NIL);
rplaca(val,pquote(fptr,sym));
/* restore the previous stack frame */
xlstack = oldstk;
/* return the value */
return (val);
}
/* rmlpar - read macro for '(' */
NODE *rmlpar(args)
NODE *args;
{
NODE ***oldstk,*fptr,*mch,*val;
/* create a new stack frame */
oldstk = xlsave(&fptr,&mch,&val,(NODE **)NULL);
/* get the file and macro character */
fptr = xlgetfile(&args);
mch = xlmatch(INT,&args);
xllastarg(args);
/* make the return value */
val = consa(NIL);
rplaca(val,plist(fptr));
/* restore the previous stack frame */
xlstack = oldstk;
/* return the value */
return (val);
}
/* rmrpar - read macro for ')' */
NODE *rmrpar(args)
NODE *args;
{
xlfail("misplaced right paren");
}
/* rmsemi - read macro for ';' */
NODE *rmsemi(args)
NODE *args;
{
NODE ***oldstk,*fptr,*mch;
int ch;
/* create a new stack frame */
oldstk = xlsave(&fptr,&mch,(NODE **)NULL);
/* get the file and macro character */
fptr = xlgetfile(&args);
mch = xlmatch(INT,&args);
xllastarg(args);
/* skip to end of line */
while ((ch = xlgetc(fptr)) != EOF && ch != '\n')
;
/* restore the previous stack frame */
xlstack = oldstk;
/* return nil (nothing read) */
return (NIL);
}
/* phexnumber - parse a hexidecimal number */
LOCAL NODE *phexnumber(fptr)
NODE *fptr;
{
long num;
int ch;
num = 0L;
while ((ch = xlpeek(fptr)) != EOF) {
if (islower(ch)) ch = toupper(ch);
if (!isdigit(ch) && !(ch >= 'A' && ch <= 'F'))
break;
xlgetc(fptr);
num = num * 16L + (long)(ch <= '9' ? ch - '0' : ch - 'A' + 10);
}
return (cvfixnum((FIXNUM)num));
}
/* plist - parse a list */
LOCAL NODE *plist(fptr)
NODE *fptr;
{
NODE ***oldstk,*val,*expr,*lastnptr;
NODE *nptr = NIL;
/* create a new stack frame */
oldstk = xlsave(&val,&expr,(NODE **)NULL);
/* increase the paren nesting level */
++xlplevel;
/* keep appending nodes until a closing paren is found */
lastnptr = NIL;
for (lastnptr = NIL; nextch(fptr) != ')'; lastnptr = nptr)
/* get the next expression */
switch (readone(fptr,&expr)) {
case EOF:
badeof(fptr);
case TRUE:
/* check for a dotted tail */
if (expr == s_dot) {
/* make sure there's a node */
if (lastnptr == NIL)
xlfail("invalid dotted pair");
/* parse the expression after the dot */
if (!xlread(fptr,&expr,TRUE))
badeof(fptr);
rplacd(lastnptr,expr);
/* make sure its followed by a close paren */
if (nextch(fptr) != ')')
xlfail("invalid dotted pair");
/* done with this list */
break;
}
/* otherwise, handle a normal list element */
else {
nptr = consa(expr);
if (lastnptr == NIL)
val = nptr;
else
rplacd(lastnptr,nptr);
}
break;
}
/* skip the closing paren */
xlgetc(fptr);
/* decrease the paren nesting level */
--xlplevel;
/* restore the previous stack frame */
xlstack = oldstk;
/* return successfully */
return (val);
}
/* pvector - parse a vector */
LOCAL NODE *pvector(fptr)
NODE *fptr;
{
NODE ***oldstk,*list,*expr,*val,*lastnptr;
NODE *nptr = NIL;
int len,ch,i;
/* create a new stack frame */
oldstk = xlsave(&list,&expr,(NODE **)NULL);
/* keep appending nodes until a closing paren is found */
lastnptr = NIL; len = 0;
for (lastnptr = NIL; (ch = nextch(fptr)) != ')'; lastnptr = nptr) {
/* check for end of file */
if (ch == EOF)
badeof(fptr);
/* get the next expression */
switch (readone(fptr,&expr)) {
case EOF:
badeof(fptr);
case TRUE:
nptr = consa(expr);
if (lastnptr == NIL)
list = nptr;
else
rplacd(lastnptr,nptr);
len++;
break;
}
}
/* skip the closing paren */
xlgetc(fptr);
/* make a vector of the appropriate length */
val = newvector(len);
/* copy the list into the vector */
for (i = 0; i < len; ++i, list = cdr(list))
setelement(val,i,car(list));
/* restore the previous stack frame */
xlstack = oldstk;
/* return successfully */
return (val);
}
/* pquote - parse a quoted expression */
LOCAL NODE *pquote(fptr,sym)
NODE *fptr,*sym;
{
NODE ***oldstk,*val,*p;
/* create a new stack frame */
oldstk = xlsave(&val,(NODE **)NULL);
/* allocate two nodes */
val = consa(sym);
rplacd(val,consa(NIL));
/* initialize the second to point to the quoted expression */
if (!xlread(fptr,&p,TRUE))
badeof(fptr);
rplaca(cdr(val),p);
/* restore the previous stack frame */
xlstack = oldstk;
/* return the quoted expression */
return (val);
}
/* pname - parse a symbol name */
LOCAL NODE *pname(fptr,ch)
NODE *fptr; int ch;
{
NODE *val,*type;
int i;
/* get symbol name */
for (i = 0; ; xlgetc(fptr)) {
if (i < STRMAX)
buf[i++] = (islower(ch) ? toupper(ch) : ch);
if ((ch = xlpeek(fptr)) == EOF ||
((type = tentry(ch)) != k_const &&
!(consp(type) && car(type) == k_nmacro)))
break;
}
buf[i] = 0;
/* check for a number or enter the symbol into the oblist */
return (isnumber(buf,&val) ? val : xlenter(buf,DYNAMIC));
}
/* tentry - get a readtable entry */
LOCAL NODE *tentry(ch)
int ch;
{
NODE *rtable;
rtable = getvalue(s_rtable);
if (!vectorp(rtable) || ch < 0 || ch >= getsize(rtable))
return (NIL);
return (getelement(rtable,ch));
}
/* nextch - look at the next non-blank character */
LOCAL int nextch(fptr)
NODE *fptr;
{
int ch;
/* return and save the next non-blank character */
while ((ch = xlpeek(fptr)) != EOF && isspace(ch))
xlgetc(fptr);
return (ch);
}
/* checkeof - get a character and check for end of file */
LOCAL int checkeof(fptr)
NODE *fptr;
{
int ch;
if ((ch = xlgetc(fptr)) == EOF)
badeof(fptr);
return (ch);
}
/* badeof - unexpected eof */
LOCAL badeof(fptr)
NODE *fptr;
{
xlgetc(fptr);
xlfail("unexpected EOF");
}
/* isnumber - check if this string is a number */
int isnumber(str,pval)
char *str; NODE **pval;
{
int dl,dr;
char *p;
/* initialize */
p = str; dl = dr = 0;
/* check for a sign */
if (*p == '+' || *p == '-')
p++;
/* check for a string of digits */
while (isdigit(*p))
p++, dl++;
/* check for a decimal point */
if (*p == '.') {
p++;
while (isdigit(*p))
p++, dr++;
}
/* check for an exponent */
if ((dl || dr) && *p == 'E') {
p++;
/* check for a sign */
if (*p == '+' || *p == '-')
p++;
/* check for a string of digits */
while (isdigit(*p))
p++, dr++;
}
/* make sure there was at least one digit and this is the end */
if ((dl == 0 && dr == 0) || *p)
return (FALSE);
/* convert the string to an integer and return successfully */
if (*str == '+') ++str;
if (str[strlen(str)-1] == '.') str[strlen(str)-1] = 0;
*pval = (dr ? cvflonum(atof(str)) : cvfixnum(ICNV(str)));
return (TRUE);
}
/* defmacro - define a read macro */
defmacro(ch,type,fun)
int ch; NODE *type,*(*fun)();
{
NODE *p;
p = consa(type);
setelement(getvalue(s_rtable),ch,p);
rplacd(p,cvsubr(fun,SUBR));
}
/* callmacro - call a read macro */
NODE *callmacro(fptr,ch)
NODE *fptr; int ch;
{
NODE ***oldstk,*fun,*args,*val;
/* create a new stack frame */
oldstk = xlsave(&fun,&args,(NODE **)NULL);
/* get the macro function */
fun = cdr(getelement(getvalue(s_rtable),ch));
/* create the argument list */
args = consa(fptr);
rplacd(args,consa(NIL));
rplaca(cdr(args),cvfixnum((FIXNUM)ch));
/* apply the macro function to the arguments */
val = xlapply(fun,args);
/* restore the previous stack frame */
xlstack = oldstk;
/* return the result */
return (val);
}
/* needsextension - determine if a filename needs an extension */
int needsextension(name)
char *name;
{
while (*name)
if (*name++ == '.')
return (FALSE);
return (TRUE);
}
/* xlrinit - initialize the reader */
xlrinit()
{
NODE *rtable;
char *p;
int ch;
/* create the read table */
rtable = newvector(256);
setvalue(s_rtable,rtable);
/* initialize the readtable */
for (p = WSPACE; ch = *p++; )
setelement(rtable,ch,k_wspace);
for (p = CONST1; ch = *p++; )
setelement(rtable,ch,k_const);
for (p = CONST2; ch = *p++; )
setelement(rtable,ch,k_const);
/* install the read macros */
defmacro('#', k_nmacro,rmhash);
defmacro('\'',k_tmacro,rmquote);
defmacro('"', k_tmacro,rmdquote);
defmacro('`', k_tmacro,rmbquote);
defmacro(',', k_tmacro,rmcomma);
defmacro('(', k_tmacro,rmlpar);
defmacro(')', k_tmacro,rmrpar);
defmacro(';', k_tmacro,rmsemi);
}
SHAR_EOF
fi # end of overwriting check
if test -f 'xlstr.c'
then
echo shar: will not over-write existing file "'xlstr.c'"
else
cat << \SHAR_EOF > 'xlstr.c'
/* xlstr - xlisp string builtin 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 NODE ***xlstack;
extern char buf[];
/* external procedures */
extern char *strcat();
/* xstrcat - concatenate a bunch of strings */
NODE *xstrcat(args)
NODE *args;
{
NODE ***oldstk,*val,*p;
char *str;
int len;
/* create a new stack frame */
oldstk = xlsave(&val,(NODE **)NULL);
/* find the length of the new string */
for (p = args, len = 0; p; )
len += strlen(getstring(xlmatch(STR,&p)));
/* create the result string */
val = newstring(len);
str = getstring(val);
*str = 0;
/* combine the strings */
while (args)
strcat(str,getstring(xlmatch(STR,&args)));
/* restore the previous stack frame */
xlstack = oldstk;
/* return the new string */
return (val);
}
/* xsubstr - return a substring */
NODE *xsubstr(args)
NODE *args;
{
NODE ***oldstk,*arg,*src,*val;
int start,forlen,srclen;
char *srcptr,*dstptr;
/* create a new stack frame */
oldstk = xlsave(&arg,&src,&val,(NODE **)NULL);
/* initialize */
arg = args;
/* get string and its length */
src = xlmatch(STR,&arg);
srcptr = getstring(src);
srclen = strlen(srcptr);
/* get starting pos -- must be present */
start = getfixnum(xlmatch(INT,&arg));
/* get length -- if not present use remainder of string */
forlen = (arg ? getfixnum(xlmatch(INT,&arg)) : srclen);
/* make sure there aren't any more arguments */
xllastarg(arg);
/* don't take more than exists */
if (start + forlen > srclen)
forlen = srclen - start + 1;
/* if start beyond string -- return null string */
if (start > srclen) {
start = 1;
forlen = 0; }
/* create return node */
val = newstring(forlen);
dstptr = getstring(val);
/* move string */
for (srcptr += start-1; forlen--; *dstptr++ = *srcptr++)
;
*dstptr = 0;
/* restore the previous stack frame */
xlstack = oldstk;
/* return the substring */
return (val);
}
/* xstring - return a string consisting of a single character */
NODE *xstring(args)
NODE *args;
{
/* get the character (integer) */
buf[0] = getfixnum(xlmatch(INT,&args));
xllastarg(args);
/* make a one character string */
buf[1] = 0;
return (cvstring(buf));
}
/* xchar - extract a character from a string */
NODE *xchar(args)
NODE *args;
{
char *str;
int n;
/* get the string and the index */
str = getstring(xlmatch(STR,&args));
n = getfixnum(xlmatch(INT,&args));
xllastarg(args);
/* range check the index */
if (n < 0 || n >= strlen(str))
xlerror("index out of range",cvfixnum((FIXNUM)n));
/* return the character */
return (cvfixnum((FIXNUM)str[n]));
}
SHAR_EOF
fi # end of overwriting check
if test -f 'xlsubr.c'
then
echo shar: will not over-write existing file "'xlsubr.c'"
else
cat << \SHAR_EOF > 'xlsubr.c'
/* xlsubr - xlisp builtin function support routines */
/* Copyright (c) 1985, by David Michael Betz
All Rights Reserved
Permission is granted for unrestricted non-commercial use */
#include "xlisp.h"
/* external variables */
extern NODE *k_test,*k_tnot,*s_eql;
extern NODE ***xlstack;
/* xlsubr - define a builtin function */
xlsubr(sname,type,subr)
char *sname; int type; NODE *(*subr)();
{
NODE *sym;
/* enter the symbol */
sym = xlsenter(sname);
/* initialize the value */
setvalue(sym,cvsubr(subr,type));
}
/* xlarg - get the next argument */
NODE *xlarg(pargs)
NODE **pargs;
{
NODE *arg;
/* make sure the argument exists */
if (!consp(*pargs))
xlfail("too few arguments");
/* get the argument value */
arg = car(*pargs);
/* move the argument pointer ahead */
*pargs = cdr(*pargs);
/* return the argument */
return (arg);
}
/* xlmatch - get an argument and match its type */
NODE *xlmatch(type,pargs)
int type; NODE **pargs;
{
NODE *arg;
/* get the argument */
arg = xlarg(pargs);
/* check its type */
if (type == LIST) {
if (arg && ntype(arg) != LIST)
xlerror("bad argument type",arg);
}
else {
if (arg == NIL || ntype(arg) != type)
xlerror("bad argument type",arg);
}
/* return the argument */
return (arg);
}
/* xlevarg - get the next argument and evaluate it */
NODE *xlevarg(pargs)
NODE **pargs;
{
NODE ***oldstk,*val;
/* create a new stack frame */
oldstk = xlsave(&val,(NODE **)NULL);
/* get the argument */
val = xlarg(pargs);
/* evaluate the argument */
val = xleval(val);
/* restore the previous stack frame */
xlstack = oldstk;
/* return the argument */
return (val);
}
/* xlevmatch - get an evaluated argument and match its type */
NODE *xlevmatch(type,pargs)
int type; NODE **pargs;
{
NODE *arg;
/* get the argument */
arg = xlevarg(pargs);
/* check its type */
if (type == LIST) {
if (arg && ntype(arg) != LIST)
xlerror("bad argument type",arg);
}
else {
if (arg == NIL || ntype(arg) != type)
xlerror("bad argument type",arg);
}
/* return the argument */
return (arg);
}
/* xltest - get the :test or :test-not keyword argument */
void xltest(pfcn,ptresult,pargs)
NODE **pfcn; int *ptresult; NODE **pargs;
{
NODE *arg;
/* default the argument to eql */
if (!consp(*pargs)) {
*pfcn = getvalue(s_eql);
*ptresult = TRUE;
return;
}
/* get the keyword */
arg = car(*pargs);
/* check the keyword */
if (arg == k_test)
*ptresult = TRUE;
else if (arg == k_tnot)
*ptresult = FALSE;
else
xlfail("expecting :test or :test-not");
/* move the argument pointer ahead */
*pargs = cdr(*pargs);
/* make sure the argument exists */
if (!consp(*pargs))
xlfail("no value for keyword argument");
/* get the argument value */
*pfcn = car(*pargs);
/* if its a symbol, get its value */
if (symbolp(*pfcn))
*pfcn = xleval(*pfcn);
/* move the argument pointer ahead */
*pargs = cdr(*pargs);
}
/* xlgetfile - get a file or stream */
NODE *xlgetfile(pargs)
NODE **pargs;
{
NODE *arg;
/* get a file or stream (cons) or nil */
if (arg = xlarg(pargs)) {
if (filep(arg)) {
if (arg->n_fp == NULL)
xlfail("file not open");
}
else if (!consp(arg))
xlerror("bad argument type",arg);
}
return (arg);
}
/* xllastarg - make sure the remainder of the argument list is empty */
xllastarg(args)
NODE *args;
{
if (args)
xlfail("too many arguments");
}
/* eq - internal eq function */
int eq(arg1,arg2)
NODE *arg1,*arg2;
{
return (arg1 == arg2);
}
/* eql - internal eql function */
int eql(arg1,arg2)
NODE *arg1,*arg2;
{
if (eq(arg1,arg2))
return (TRUE);
else if (fixp(arg1) && fixp(arg2))
return (arg1->n_int == arg2->n_int);
else if (floatp(arg1) && floatp(arg2))
return (arg1->n_float == arg2->n_float);
else if (stringp(arg1) && stringp(arg2))
return (strcmp(arg1->n_str,arg2->n_str) == 0);
else
return (FALSE);
}
/* equal - internal equal function */
int equal(arg1,arg2)
NODE *arg1,*arg2;
{
/* compare the arguments */
if (eql(arg1,arg2))
return (TRUE);
else if (consp(arg1) && consp(arg2))
return (equal(car(arg1),car(arg2)) && equal(cdr(arg1),cdr(arg2)));
else
return (FALSE);
}
SHAR_EOF
fi # end of overwriting check
if test -f 'xlsym.c'
then
echo shar: will not over-write existing file "'xlsym.c'"
else
cat << \SHAR_EOF > 'xlsym.c'
/* xlsym - symbol handling routines */
/* Copyright (c) 1985, by David Michael Betz
All Rights Reserved
Permission is granted for unrestricted non-commercial use */
#include "xlisp.h"
/* external variables */
extern NODE *obarray,*s_unbound,*self;
extern NODE ***xlstack,*xlenv;
/* forward declarations */
FORWARD NODE *findprop();
/* xlenter - enter a symbol into the obarray */
NODE *xlenter(name,type)
char *name; int type;
{
NODE ***oldstk,*sym,*array;
int i;
/* check for nil */
if (strcmp(name,"NIL") == 0)
return (NIL);
/* check for symbol already in table */
array = getvalue(obarray);
i = hash(name,HSIZE);
for (sym = getelement(array,i); sym; sym = cdr(sym))
if (strcmp(name,getstring(getpname(car(sym)))) == 0)
return (car(sym));
/* make a new symbol node and link it into the list */
oldstk = xlsave(&sym,(NODE **)NULL);
sym = consd(getelement(array,i));
rplaca(sym,xlmakesym(name,type));
setelement(array,i,sym);
xlstack = oldstk;
/* return the new symbol */
return (car(sym));
}
/* xlsenter - enter a symbol with a static print name */
NODE *xlsenter(name)
char *name;
{
return (xlenter(name,STATIC));
}
/* xlmakesym - make a new symbol node */
NODE *xlmakesym(name,type)
char *name;
{
NODE *sym;
sym = (type == DYNAMIC ? cvsymbol(name) : cvcsymbol(name));
setvalue(sym,*name == ':' ? sym : s_unbound);
return (sym);
}
/* xlframe - create a new environment frame */
NODE *xlframe(env)
NODE *env;
{
return (consd(env));
}
/* xlbind - bind a value to a symbol */
xlbind(sym,val,env)
NODE *sym,*val,*env;
{
NODE *ptr;
/* create a new environment list entry */
ptr = consd(car(env));
rplaca(env,ptr);
/* create a new variable binding */
rplaca(ptr,cons(sym,val));
}
/* xlgetvalue - get the value of a symbol (checked) */
NODE *xlgetvalue(sym)
NODE *sym;
{
register NODE *val;
while ((val = xlxgetvalue(sym)) == s_unbound)
xlunbound(sym);
return (val);
}
/* xlxgetvalue - get the value of a symbol */
NODE *xlxgetvalue(sym)
NODE *sym;
{
register NODE *fp,*ep;
NODE *val;
/* check for this being an instance variable */
if (getvalue(self) && xlobgetvalue(sym,&val))
return (val);
/* check the environment list */
for (fp = xlenv; fp; fp = cdr(fp))
for (ep = car(fp); ep; ep = cdr(ep))
if (sym == car(car(ep)))
return (cdr(car(ep)));
/* return the global value */
return (getvalue(sym));
}
/* xlygetvalue - get the value of a symbol (no instance variables) */
NODE *xlygetvalue(sym)
NODE *sym;
{
register NODE *fp,*ep;
/* check the environment list */
for (fp = xlenv; fp; fp = cdr(fp))
for (ep = car(fp); ep; ep = cdr(ep))
if (sym == car(car(ep)))
return (cdr(car(ep)));
/* return the global value */
return (getvalue(sym));
}
/* xlsetvalue - set the value of a symbol */
void xlsetvalue(sym,val)
NODE *sym,*val;
{
register NODE *fp,*ep;
/* check for this being an instance variable */
if (getvalue(self) && xlobsetvalue(sym,val))
return;
/* look for the symbol in the environment list */
for (fp = xlenv; fp; fp = cdr(fp))
for (ep = car(fp); ep; ep = cdr(ep))
if (sym == car(car(ep))) {
rplacd(car(ep),val);
return;
}
/* store the global value */
setvalue(sym,val);
}
/* xlgetprop - get the value of a property */
NODE *xlgetprop(sym,prp)
NODE *sym,*prp;
{
NODE *p;
return ((p = findprop(sym,prp)) ? car(p) : NIL);
}
/* xlputprop - put a property value onto the property list */
xlputprop(sym,val,prp)
NODE *sym,*val,*prp;
{
NODE ***oldstk,*p,*pair;
if ((pair = findprop(sym,prp)) == NIL) {
oldstk = xlsave(&p,(NODE **)NULL);
p = consa(prp);
rplacd(p,pair = cons(val,getplist(sym)));
setplist(sym,p);
xlstack = oldstk;
}
rplaca(pair,val);
}
/* xlremprop - remove a property from a property list */
xlremprop(sym,prp)
NODE *sym,*prp;
{
NODE *last,*p;
last = NIL;
for (p = getplist(sym); consp(p) && consp(cdr(p)); p = cdr(last)) {
if (car(p) == prp)
if (last)
rplacd(last,cdr(cdr(p)));
else
setplist(sym,cdr(cdr(p)));
last = cdr(p);
}
}
/* findprop - find a property pair */
LOCAL NODE *findprop(sym,prp)
NODE *sym,*prp;
{
NODE *p;
for (p = getplist(sym); consp(p) && consp(cdr(p)); p = cdr(cdr(p)))
if (car(p) == prp)
return (cdr(p));
return (NIL);
}
/* hash - hash a symbol name string */
int hash(str,len)
char *str;
{
int i;
for (i = 0; *str; )
i = (i << 2) ^ *str++;
i %= len;
return (abs(i));
}
/* xlsinit - symbol initialization routine */
xlsinit()
{
NODE *array,*p;
/* initialize the obarray */
obarray = xlmakesym("*OBARRAY*",STATIC);
array = newvector(HSIZE);
setvalue(obarray,array);
/* add the symbol *OBARRAY* to the obarray */
p = consa(obarray);
setelement(array,hash("*OBARRAY*",HSIZE),p);
/* enter the unbound symbol indicator */
s_unbound = xlsenter("*UNBOUND*");
setvalue(s_unbound,s_unbound);
}
SHAR_EOF
fi # end of overwriting check
if test -f 'xlsys.c'
then
echo shar: will not over-write existing file "'xlsys.c'"
else
cat << \SHAR_EOF > 'xlsys.c'
/* xlsys.c - xlisp builtin system 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 NODE ***xlstack,*xlenv;
extern int anodes;
/* external symbols */
extern NODE *a_subr,*a_fsubr;
extern NODE *a_list,*a_sym,*a_int,*a_float,*a_str,*a_obj,*a_fptr,*a_vect;
extern NODE *true;
/* xload - direct input from a file */
NODE *xload(args)
NODE *args;
{
NODE ***oldstk,*fname,*val;
int vflag,pflag;
char *name;
/* create a new stack frame */
oldstk = xlsave(&fname,(NODE **)NULL);
/* get the file name, verbose flag and print flag */
fname = xlarg(&args);
vflag = (args ? xlarg(&args) != NIL : TRUE);
pflag = (args ? xlarg(&args) != NIL : FALSE);
xllastarg(args);
/* get the filename string */
if (symbolp(fname))
name = getstring(getpname(fname));
else if (stringp(fname))
name = getstring(fname);
else
xlfail("bad argument type",fname);
/* load the file */
val = (xlload(name,vflag,pflag) ? true : NIL);
/* restore the previous stack frame */
xlstack = oldstk;
/* return the status */
return (val);
}
/* xgc - xlisp function to force garbage collection */
NODE *xgc(args)
NODE *args;
{
/* make sure there aren't any arguments */
xllastarg(args);
/* garbage collect */
gc();
/* return nil */
return (NIL);
}
/* xexpand - xlisp function to force memory expansion */
NODE *xexpand(args)
NODE *args;
{
int n,i;
/* get the new number to allocate */
n = (args ? getfixnum(xlmatch(INT,&args)) : 1);
xllastarg(args);
/* allocate more segments */
for (i = 0; i < n; i++)
if (!addseg())
break;
/* return the number of segments added */
return (cvfixnum((FIXNUM)i));
}
/* xalloc - xlisp function to set the number of nodes to allocate */
NODE *xalloc(args)
NODE *args;
{
int n,oldn;
/* get the new number to allocate */
n = getfixnum(xlmatch(INT,&args));
/* make sure there aren't any more arguments */
xllastarg(args);
/* set the new number of nodes to allocate */
oldn = anodes;
anodes = n;
/* return the old number */
return (cvfixnum((FIXNUM)oldn));
}
/* xmem - xlisp function to print memory statistics */
NODE *xmem(args)
NODE *args;
{
/* make sure there aren't any arguments */
xllastarg(args);
/* print the statistics */
stats();
/* return nil */
return (NIL);
}
/* xtype - return type of a thing */
NODE *xtype(args)
NODE *args;
{
NODE *arg;
if (!(arg = xlarg(&args)))
return (NIL);
switch (ntype(arg)) {
case SUBR: return (a_subr);
case FSUBR: return (a_fsubr);
case LIST: return (a_list);
case SYM: return (a_sym);
case INT: return (a_int);
case FLOAT: return (a_float);
case STR: return (a_str);
case OBJ: return (a_obj);
case FPTR: return (a_fptr);
case VECT: return (a_vect);
default: xlfail("bad node type");
}
/*NOTREACHED*/
}
/* xbaktrace - print the trace back stack */
NODE *xbaktrace(args)
NODE *args;
{
int n;
n = (args ? getfixnum(xlmatch(INT,&args)) : -1);
xllastarg(args);
xlbaktrace(n);
return (NIL);
}
/* xexit - get out of xlisp */
NODE *xexit(args)
NODE *args;
{
xllastarg(args);
osfinish ();
exit(0);
}
SHAR_EOF
fi # end of overwriting check
# End of shell archive
exit 0