🚀 go-pugleaf

#!/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: Sat Jan 18 14:32:30 1986
# By:	Jwahar R. Bammi ()
export PATH; PATH=/bin:$PATH
echo shar: extracting "'xlobj.c'" '(14267 characters)'
if test -f 'xlobj.c'
then
	echo shar: over-writing existing file "'xlobj.c'"
fi
sed 's/^X//' << \SHAR_EOF > 'xlobj.c'
X/* xlobj - xlisp object 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#ifdef MEGAMAX
Xoverlay "overflow"
X#endif
X
X/* external variables */
Xextern NODE *xlstack,*xlenv;
Xextern NODE *s_stdout;
Xextern NODE *self,*msgclass,*msgcls,*class,*object;
Xextern NODE *new,*isnew;
X
X/* instance variable numbers for the class 'Class' */
X#define MESSAGES	0	/* list of messages */
X#define IVARS		1	/* list of instance variable names */
X#define CVARS		2	/* list of class variable names */
X#define CVALS		3	/* list of class variable values */
X#define SUPERCLASS	4	/* pointer to the superclass */
X#define IVARCNT		5	/* number of class instance variables */
X#define IVARTOTAL	6	/* total number of instance variables */
X
X/* number of instance variables for the class 'Class' */
X#define CLASSSIZE	7
X
X/* forward declarations */
XFORWARD NODE *entermsg();
XFORWARD NODE *findmsg();
XFORWARD NODE *sendmsg();
XFORWARD NODE *findvar();
XFORWARD NODE *getivar();
XFORWARD NODE *getcvar();
XFORWARD NODE *makelist();
X
X/* xlgetivar - get the value of an instance variable */
XNODE *xlgetivar(obj,num)
X  NODE *obj; int num;
X{
X    return (car(getivar(obj,num)));
X}
X
X/* xlsetivar - set the value of an instance variable */
Xxlsetivar(obj,num,val)
X  NODE *obj; int num; NODE *val;
X{
X    rplaca(getivar(obj,num),val);
X}
X
X/* xlclass - define a class */
XNODE *xlclass(name,vcnt)
X  char *name; int vcnt;
X{
X    NODE *sym,*cls;
X
X    /* create the class */
X    sym = xlsenter(name);
X    setvalue(sym,cls = newnode(OBJ));
X    cls->n_obclass = class;
X    cls->n_obdata = makelist(CLASSSIZE);
X
X    /* set the instance variable counts */
X    xlsetivar(cls,IVARCNT,cvfixnum((FIXNUM)vcnt));
X    xlsetivar(cls,IVARTOTAL,cvfixnum((FIXNUM)vcnt));
X
X    /* set the superclass to 'Object' */
X    xlsetivar(cls,SUPERCLASS,object);
X
X    /* return the new class */
X    return (cls);
X}
X
X/* xladdivar - enter an instance variable */
Xxladdivar(cls,var)
X  NODE *cls; char *var;
X{
X    NODE *ivar,*lptr;
X
X    /* find the 'ivars' instance variable */
X    ivar = getivar(cls,IVARS);
X
X    /* add the instance variable */
X    lptr = newnode(LIST);
X    rplacd(lptr,car(ivar));
X    rplaca(ivar,lptr);
X    rplaca(lptr,xlsenter(var));
X}
X
X/* xladdmsg - add a message to a class */
Xxladdmsg(cls,msg,code)
X  NODE *cls; char *msg; NODE *(*code)();
X{
X    NODE *mptr;
X
X    /* enter the message selector */
X    mptr = entermsg(cls,xlsenter(msg));
X
X    /* store the method for this message */
X    rplacd(mptr,newnode(SUBR));
X    cdr(mptr)->n_subr = code;
X}
X
X/* xlsend - send a message to an object (message in arg list) */
XNODE *xlsend(obj,args)
X  NODE *obj,*args;
X{
X    NODE *oldstk,arglist,*msg,*val;
X
X    /* find the message binding for this message */
X    if ((msg = findmsg(obj->n_obclass,xlevmatch(SYM,&args))) == NIL)
X	xlfail("no method for this message");
X
X    /* evaluate the arguments and send the message */
X    oldstk = xlsave(&arglist,NULL);
X    arglist.n_ptr = xlevlist(args);
X    val = sendmsg(obj,msg,arglist.n_ptr);
X    xlstack = oldstk;
X
X    /* return the result */
X    return (val);
X}
X
X/* xlobgetvalue - get the value of an instance variable */
Xint xlobgetvalue(sym,pval)
X  NODE *sym,**pval;
X{
X    NODE *bnd;
X    if ((bnd = findvar(sym)) == NIL)
X	return (FALSE);
X    *pval = car(bnd);
X    return (TRUE);
X}
X
X/* xlobsetvalue - set the value of an instance variable */
Xint xlobsetvalue(sym,val)
X  NODE *sym,*val;
X{
X    NODE *bnd;
X    if ((bnd = findvar(sym)) == NIL)
X	return (FALSE);
X    rplaca(bnd,val);
X    return (TRUE);
X}
X
X/* obisnew - default 'isnew' method */
XLOCAL NODE *obisnew(args)
X  NODE *args;
X{
X    xllastarg(args);
X    return (xlygetvalue(self));
X}
X
X/* obclass - get the class of an object */
XLOCAL NODE *obclass(args)
X  NODE *args;
X{
X    /* make sure there aren't any arguments */
X    xllastarg(args);
X
X    /* return the object's class */
X    return (xlygetvalue(self)->n_obclass);
X}
X
X/* obshow - show the instance variables of an object */
XLOCAL NODE *obshow(args)
X  NODE *args;
X{
X    NODE *oldstk,fptr,*obj,*cls,*names;
X    int ivtotal,n;
X
X    /* create a new stack frame */
X    oldstk = xlsave(&fptr,NULL);
X
X    /* get the file pointer */
X    fptr.n_ptr = (args ? xlgetfile(&args) : getvalue(s_stdout));
X    xllastarg(args);
X
X    /* get the object and its class */
X    obj = xlygetvalue(self);
X    cls = obj->n_obclass;
X
X    /* print the object and class */
X    xlputstr(fptr.n_ptr,"Object is ");
X    xlprint(fptr.n_ptr,obj,TRUE);
X    xlputstr(fptr.n_ptr,", Class is ");
X    xlprint(fptr.n_ptr,cls,TRUE);
X    xlterpri(fptr.n_ptr);
X
X    /* print the object's instance variables */
X    for (cls = obj->n_obclass; cls; cls = xlgetivar(cls,SUPERCLASS)) {
X	names = xlgetivar(cls,IVARS);
X	ivtotal = getivcnt(cls,IVARTOTAL);
X	for (n = ivtotal - getivcnt(cls,IVARCNT); n < ivtotal; ++n) {
X	    xlputstr(fptr.n_ptr,"  ");
X	    xlprint(fptr.n_ptr,car(names),TRUE);
X	    xlputstr(fptr.n_ptr," = ");
X	    xlprint(fptr.n_ptr,xlgetivar(obj,n),TRUE);
X	    xlterpri(fptr.n_ptr);
X	    names = cdr(names);
X	}
X    }
X
X    /* restore the previous stack frame */
X    xlstack = oldstk;
X
X    /* return the object */
X    return (obj);
X}
X
X/* obsendsuper - send a message to an object's superclass */
XLOCAL NODE *obsendsuper(args)
X  NODE *args;
X{
X    NODE *obj,*super,*msg;
X
X    /* get the object */
X    obj = xlygetvalue(self);
X
X    /* get the object's superclass */
X    super = xlgetivar(obj->n_obclass,SUPERCLASS);
X
X    /* find the message binding for this message */
X    if ((msg = findmsg(super,xlmatch(SYM,&args))) == NIL)
X	xlfail("no method for this message");
X
X    /* send the message */
X    return (sendmsg(obj,msg,args));
X}
X
X/* clnew - create a new object instance */
XLOCAL NODE *clnew()
X{
X    NODE *oldstk,obj,*cls;
X
X    /* create a new stack frame */
X    oldstk = xlsave(&obj,NULL);
X
X    /* get the class */
X    cls = xlygetvalue(self);
X
X    /* generate a new object */
X    obj.n_ptr = newnode(OBJ);
X    obj.n_ptr->n_obclass = cls;
X    obj.n_ptr->n_obdata = makelist(getivcnt(cls,IVARTOTAL));
X
X    /* restore the previous stack frame */
X    xlstack = oldstk;
X
X    /* return the new object */
X    return (obj.n_ptr);
X}
X
X/* clisnew - initialize a new class */
XLOCAL NODE *clisnew(args)
X  NODE *args;
X{
X    NODE *ivars,*cvars,*super,*cls;
X    int n;
X
X    /* get the ivars, cvars and superclass */
X    ivars = xlmatch(LIST,&args);
X    cvars = (args ? xlmatch(LIST,&args) : NIL);
X    super = (args ? xlmatch(OBJ,&args) : object);
X    xllastarg(args);
X
X    /* get the new class object */
X    cls = xlygetvalue(self);
X
X    /* store the instance and class variable lists and the superclass */
X    xlsetivar(cls,IVARS,ivars);
X    xlsetivar(cls,CVARS,cvars);
X    xlsetivar(cls,CVALS,makelist(listlength(cvars)));
X    xlsetivar(cls,SUPERCLASS,super);
X
X    /* compute the instance variable count */
X    n = listlength(ivars);
X    xlsetivar(cls,IVARCNT,cvfixnum((FIXNUM)n));
X    n += getivcnt(super,IVARTOTAL);
X    xlsetivar(cls,IVARTOTAL,cvfixnum((FIXNUM)n));
X
X    /* return the new class object */
X    return (cls);
X}
X
X/* clanswer - define a method for answering a message */
XLOCAL NODE *clanswer(args)
X  NODE *args;
X{
X    NODE *oldstk,arg,msg,fargs,code;
X    NODE *obj,*mptr,*fptr;
X
X    /* create a new stack frame */
X    oldstk = xlsave(&arg,&msg,&fargs,&code,NULL);
X
X    /* initialize */
X    arg.n_ptr = args;
X
X    /* message symbol, formal argument list and code */
X    msg.n_ptr = xlmatch(SYM,&arg.n_ptr);
X    fargs.n_ptr = xlmatch(LIST,&arg.n_ptr);
X    code.n_ptr = xlmatch(LIST,&arg.n_ptr);
X    xllastarg(arg.n_ptr);
X
X    /* get the object node */
X    obj = xlygetvalue(self);
X
X    /* make a new message list entry */
X    mptr = entermsg(obj,msg.n_ptr);
X
X    /* setup the message node */
X    rplacd(mptr,fptr = newnode(LIST));
X    rplaca(fptr,fargs.n_ptr);
X    rplacd(fptr,code.n_ptr);
X
X    /* restore the previous stack frame */
X    xlstack = oldstk;
X
X    /* return the object */
X    return (obj);
X}
X
X/* entermsg - add a message to a class */
XLOCAL NODE *entermsg(cls,msg)
X  NODE *cls,*msg;
X{
X    NODE *ivar,*lptr,*mptr;
X
X    /* find the 'messages' instance variable */
X    ivar = getivar(cls,MESSAGES);
X
X    /* lookup the message */
X    for (lptr = car(ivar); lptr != NIL; lptr = cdr(lptr))
X	if (car(mptr = car(lptr)) == msg)
X	    return (mptr);
X
X    /* allocate a new message entry if one wasn't found */
X    lptr = newnode(LIST);
X    rplacd(lptr,car(ivar));
X    rplaca(ivar,lptr);
X    rplaca(lptr,mptr = newnode(LIST));
X    rplaca(mptr,msg);
X
X    /* return the symbol node */
X    return (mptr);
X}
X
X/* findmsg - find the message binding given an object and a class */
XLOCAL NODE *findmsg(cls,sym)
X  NODE *cls,*sym;
X{
X    NODE *lptr,*msg;
X
X    /* look for the message in the class or superclasses */
X    for (msgcls = cls; msgcls != NIL; ) {
X
X	/* lookup the message in this class */
X	for (lptr = xlgetivar(msgcls,MESSAGES); lptr != NIL; lptr = cdr(lptr))
X	    if ((msg = car(lptr)) != NIL && car(msg) == sym)
X		return (msg);
X
X	/* look in class's superclass */
X	msgcls = xlgetivar(msgcls,SUPERCLASS);
X    }
X
X    /* message not found */
X    return (NIL);
X}
X
X/* sendmsg - send a message to an object */
XLOCAL NODE *sendmsg(obj,msg,args)
X  NODE *obj,*msg,*args;
X{
X    NODE *oldstk,oldenv,newenv,method,cptr,val,*isnewmsg;
X
X    /* create a new stack frame */
X    oldstk = xlsave(&oldenv,&newenv,&method,&cptr,&val,NULL);
X
X    /* get the method for this message */
X    method.n_ptr = cdr(msg);
X
X    /* make sure its a function or a subr */
X    if (!subrp(method.n_ptr) && !consp(method.n_ptr))
X	xlfail("bad method");
X
X    /* create a new environment frame */
X    newenv.n_ptr = xlframe(NIL);
X    oldenv.n_ptr = xlenv;
X
X    /* bind the symbols 'self' and 'msgclass' */
X    xlbind(self,obj,newenv.n_ptr);
X    xlbind(msgclass,msgcls,newenv.n_ptr);
X
X    /* evaluate the function call */
X    if (subrp(method.n_ptr)) {
X	xlenv = newenv.n_ptr;
X	val.n_ptr = (*method.n_ptr->n_subr)(args);
X    }
X    else {
X
X	/* bind the formal arguments */
X	xlabind(car(method.n_ptr),args,newenv.n_ptr);
X	xlenv = newenv.n_ptr;
X
X	/* execute the code */
X	cptr.n_ptr = cdr(method.n_ptr);
X	while (cptr.n_ptr != NIL)
X	    val.n_ptr = xlevarg(&cptr.n_ptr);
X    }
X
X    /* restore the environment */
X    xlenv = oldenv.n_ptr;
X
X    /* after creating an object, send it the "isnew" message */
X    if (car(msg) == new && val.n_ptr != NIL) {
X	if ((isnewmsg = findmsg(val.n_ptr->n_obclass,isnew)) == NIL)
X	    xlfail("no method for the isnew message");
X	sendmsg(val.n_ptr,isnewmsg,args);
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/* getivcnt - get the number of instance variables for a class */
XLOCAL int getivcnt(cls,ivar)
X  NODE *cls; int ivar;
X{
X    NODE *cnt;
X    if ((cnt = xlgetivar(cls,ivar)) == NIL || !fixp(cnt))
X	xlfail("bad value for instance variable count");
X    return ((int)cnt->n_int);
X}
X
X/* findvar - find a class or instance variable */
XLOCAL NODE *findvar(sym)
X  NODE *sym;
X{
X    NODE *obj,*cls,*names;
X    int ivtotal,n;
X
X    /* get the current object and the message class */
X    obj = xlygetvalue(self);
X    cls = xlygetvalue(msgclass);
X    if (!(objectp(obj) && objectp(cls)))
X	return (NIL);
X
X    /* find the instance or class variable */
X    for (; objectp(cls); cls = xlgetivar(cls,SUPERCLASS)) {
X
X	/* check the instance variables */
X	names = xlgetivar(cls,IVARS);
X	ivtotal = getivcnt(cls,IVARTOTAL);
X	for (n = ivtotal - getivcnt(cls,IVARCNT); n < ivtotal; ++n) {
X	    if (car(names) == sym)
X		return (getivar(obj,n));
X	    names = cdr(names);
X	}
X
X	/* check the class variables */
X	names = xlgetivar(cls,CVARS);
X	for (n = 0; consp(names); ++n) {
X	    if (car(names) == sym)
X		return (getcvar(cls,n));
X	    names = cdr(names);
X	}
X    }
X
X    /* variable not found */
X    return (NIL);
X}
X
X/* getivar - get an instance variable */
XLOCAL NODE *getivar(obj,num)
X  NODE *obj; int num;
X{
X    NODE *ivar;
X
X    /* get the instance variable */
X    for (ivar = obj->n_obdata; num > 0; num--)
X	if (ivar != NIL)
X	    ivar = cdr(ivar);
X	else
X	    xlfail("bad instance variable list");
X
X    /* return the instance variable */
X    return (ivar);
X}
X
X/* getcvar - get a class variable */
XLOCAL NODE *getcvar(cls,num)
X  NODE *cls; int num;
X{
X    NODE *cvar;
X
X    /* get the class variable */
X    for (cvar = xlgetivar(cls,CVALS); num > 0; num--)
X	if (cvar != NIL)
X	    cvar = cdr(cvar);
X	else
X	    xlfail("bad class variable list");
X
X    /* return the class variable */
X    return (cvar);
X}
X
X/* listlength - find the length of a list */
XLOCAL int listlength(list)
X  NODE *list;
X{
X    int len;
X    for (len = 0; consp(list); len++)
X	list = cdr(list);
X    return (len);
X}
X
X/* makelist - make a list of nodes */
XLOCAL NODE *makelist(cnt)
X  int cnt;
X{
X    NODE *oldstk,list,*lnew;
X
X    /* make the list */
X    oldstk = xlsave(&list,NULL);
X    for (; cnt > 0; cnt--) {
X	lnew = newnode(LIST);
X	rplacd(lnew,list.n_ptr);
X	list.n_ptr = lnew;
X    }
X    xlstack = oldstk;
X
X    /* return the list */
X    return (list.n_ptr);
X}
X
X/* xloinit - object function initialization routine */
Xxloinit()
X{
X    /* don't confuse the garbage collector */
X    class = object = NIL;
X
X    /* enter the object related symbols */
X    self	= xlsenter("SELF");
X    msgclass	= xlsenter("MSGCLASS");
X    new		= xlsenter(":NEW");
X    isnew	= xlsenter(":ISNEW");
X
X    /* create the 'Class' object */
X    class = xlclass("CLASS",CLASSSIZE);
X    class->n_obclass = class;
X
X    /* create the 'Object' object */
X    object = xlclass("OBJECT",0);
X
X    /* finish initializing 'class' */
X    xlsetivar(class,SUPERCLASS,object);
X    xladdivar(class,"IVARTOTAL");	/* ivar number 6 */
X    xladdivar(class,"IVARCNT");		/* ivar number 5 */
X    xladdivar(class,"SUPERCLASS");	/* ivar number 4 */
X    xladdivar(class,"CVALS");		/* ivar number 3 */
X    xladdivar(class,"CVARS");		/* ivar number 2 */
X    xladdivar(class,"IVARS");		/* ivar number 1 */
X    xladdivar(class,"MESSAGES");	/* ivar number 0 */
X    xladdmsg(class,":NEW",clnew);
X    xladdmsg(class,":ISNEW",clisnew);
X    xladdmsg(class,":ANSWER",clanswer);
X
X    /* finish initializing 'object' */
X    xladdmsg(object,":ISNEW",obisnew);
X    xladdmsg(object,":CLASS",obclass);
X    xladdmsg(object,":SHOW",obshow);
X    xladdmsg(object,":SENDSUPER",obsendsuper);
X}
SHAR_EOF
if test 14267 -ne "`wc -c 'xlobj.c'`"
then
	echo shar: error transmitting "'xlobj.c'" '(should have been 14267 characters)'
fi
echo shar: extracting "'xlprin.c'" '(3182 characters)'
if test -f 'xlprin.c'
then
	echo shar: over-writing existing file "'xlprin.c'"
fi
sed 's/^X//' << \SHAR_EOF > 'xlprin.c'
X/* xlprint - xlisp print routine */
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#ifdef MEGAMAX
Xoverlay "io"
X#endif
X
X/* external variables */
Xextern NODE *xlstack;
Xextern char buf[];
X
X/* xlprint - print an xlisp value */
Xxlprint(fptr,vptr,flag)
X  NODE *fptr,*vptr; int flag;
X{
X    NODE *nptr,*next;
X
X    /* print nil */
X    if (vptr == NIL) {
X	xlputstr(fptr,"NIL");
X	return;
X    }
X
X    /* check value type */
X    switch (ntype(vptr)) {
X    case SUBR:
X	    putatm(fptr,"Subr",vptr);
X	    break;
X    case FSUBR:
X	    putatm(fptr,"FSubr",vptr);
X	    break;
X    case LIST:
X	    xlputc(fptr,'(');
X	    for (nptr = vptr; nptr != NIL; nptr = next) {
X	        xlprint(fptr,car(nptr),flag);
X		if (next = cdr(nptr))
X		    if (consp(next))
X			xlputc(fptr,' ');
X		    else {
X			xlputstr(fptr," . ");
X			xlprint(fptr,next,flag);
X			break;
X		    }
X	    }
X	    xlputc(fptr,')');
X	    break;
X    case SYM:
X	    xlputstr(fptr,xlsymname(vptr));
X	    break;
X    case INT:
X	    putdec(fptr,vptr->n_int);
X	    break;
X    case FLOAT:
X	    putfloat(fptr,vptr->n_float);
X	    break;
X    case STR:
X	    if (flag)
X		putstring(fptr,vptr->n_str);
X	    else
X		xlputstr(fptr,vptr->n_str);
X	    break;
X    case FPTR:
X	    putatm(fptr,"File",vptr);
X	    break;
X    case OBJ:
X	    putatm(fptr,"Object",vptr);
X	    break;
X    case FREE:
X	    putatm(fptr,"Free",vptr);
X	    break;
X    default:
X	    putatm(fptr,"Foo",vptr);
X	    break;
X    }
X}
X
X/* xlterpri - terminate the current print line */
Xxlterpri(fptr)
X  NODE *fptr;
X{
X    xlputc(fptr,'\n');
X}
X
X/* xlputstr - output a string */
Xxlputstr(fptr,str)
X  NODE *fptr; char *str;
X{
X    while (*str)
X	xlputc(fptr,*str++);
X}
X
X/* putstring - output a string */
XLOCAL putstring(fptr,str)
X  NODE *fptr; char *str;
X{
X    int ch;
X
X    /* output the initial quote */
X    xlputc(fptr,'"');
X
X    /* output each character in the string */
X    while (ch = *str++)
X
X	/* check for a control character */
X	if (ch < 040 || ch == '\\') {
X	    xlputc(fptr,'\\');
X	    switch (ch) {
X	    case '\033':
X		    xlputc(fptr,'e');
X		    break;
X	    case '\n':
X		    xlputc(fptr,'n');
X		    break;
X	    case '\r':
X		    xlputc(fptr,'r');
X		    break;
X	    case '\t':
X		    xlputc(fptr,'t');
X		    break;
X	    case '\\':
X		    xlputc(fptr,'\\');
X		    break;
X	    default:
X		    putoct(fptr,ch);
X		    break;
X	    }
X	}
X
X	/* output a normal character */
X	else
X	    xlputc(fptr,ch);
X
X    /* output the terminating quote */
X    xlputc(fptr,'"');
X}
X
X/* putatm - output an atom */
XLOCAL putatm(fptr,tag,val)
X  NODE *fptr; char *tag; NODE *val;
X{
X    sprintf(buf,"#<%s: #",tag); xlputstr(fptr,buf);
X    sprintf(buf,AFMT,val); xlputstr(fptr,buf);
X    xlputc(fptr,'>');
X}
X
X/* putdec - output a decimal number */
XLOCAL putdec(fptr,n)
X  NODE *fptr; FIXNUM n;
X{
X    sprintf(buf,IFMT,n);
X    xlputstr(fptr,buf);
X}
X
X/* putfloat - output a floating point number */
XLOCAL putfloat(fptr,n)
X  NODE *fptr; FLONUM n;
X{
X    sprintf(buf,FFMT,n);
X    xlputstr(fptr,buf);
X}
X
X/* putoct - output an octal byte value */
XLOCAL putoct(fptr,n)
X  NODE *fptr; int n;
X{
X    sprintf(buf,"%03o",n);
X    xlputstr(fptr,buf);
X}
SHAR_EOF
if test 3182 -ne "`wc -c 'xlprin.c'`"
then
	echo shar: error transmitting "'xlprin.c'" '(should have been 3182 characters)'
fi
echo shar: extracting "'xlread.c'" '(9377 characters)'
if test -f 'xlread.c'
then
	echo shar: over-writing existing file "'xlread.c'"
fi
sed 's/^X//' << \SHAR_EOF > 'xlread.c'
X/* xlread - xlisp expression input routine */
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#ifdef MEGAMAX
Xoverlay "io"
X#endif
X
X/* external variables */
Xextern NODE *s_stdout,*true;
Xextern NODE *s_quote,*s_function,*s_bquote,*s_comma,*s_comat;
Xextern NODE *xlstack;
Xextern int xlplevel;
Xextern char buf[];
X
X/* external routines */
Xextern FILE *fopen();
Xextern ITYPE;
Xextern FTYPE;
X
X/* forward declarations */
XFORWARD NODE *plist();
XFORWARD NODE *phexnumber();
XFORWARD NODE *pstring();
XFORWARD NODE *pquote();
XFORWARD NODE *pname();
X
X/* xlload - load a file of xlisp expressions */
Xint xlload(fname,vflag,pflag)
X  char *fname; int vflag,pflag;
X{
X    NODE *oldstk,fptr,expr;
X    CONTEXT cntxt;
X    int sts;
X
X    /* create a new stack frame */
X    oldstk = xlsave(&fptr,&expr,NULL);
X
X    /* allocate a file node */
X    fptr.n_ptr = newnode(FPTR);
X    fptr.n_ptr->n_fp = NULL;
X    fptr.n_ptr->n_savech = 0;
X
X    /* print the information line */
X    if (vflag)
X	{ sprintf(buf,"; loading \"%s\"\n",fname); stdputstr(buf); }
X
X    /* open the file */
X    if ((fptr.n_ptr->n_fp = fopen(fname,"r")) == NULL) {
X	xlstack = oldstk;
X	return (FALSE);
X    }
X
X    /* read, evaluate and possibly print each expression in the file */
X    xlbegin(&cntxt,CF_ERROR,true);
X    if (setjmp(cntxt.c_jmpbuf))
X	sts = FALSE;
X    else {
X	while (xlread(fptr.n_ptr,&expr.n_ptr)) {
X	    expr.n_ptr = xleval(expr.n_ptr);
X	    if (pflag)
X		stdprint(expr.n_ptr);
X	}
X	sts = TRUE;
X    }
X    xlend(&cntxt);
X
X    /* close the file */
X    fclose(fptr.n_ptr->n_fp);
X    fptr.n_ptr->n_fp = NULL;
X
X    /* restore the previous stack frame */
X    xlstack = oldstk;
X
X    /* return status */
X    return (sts);
X}
X
X/* xlread - read an xlisp expression */
Xint xlread(fptr,pval)
X  NODE *fptr,**pval;
X{
X    /* initialize */
X    xlplevel = 0;
X
X    /* parse an expression */
X    return (parse(fptr,pval));
X}
X
X/* parse - parse an xlisp expression */
XLOCAL int parse(fptr,pval)
X  NODE *fptr,**pval;
X{
X    int ch;
X
X    /* keep looking for a node skipping comments */
X    while (TRUE)
X
X	/* check next character for type of node */
X	switch (ch = nextch(fptr)) {
X	case EOF:
X		xlgetc(fptr);
X		return (FALSE);
X	case '\'':			/* a quoted expression */
X		xlgetc(fptr);
X		*pval = pquote(fptr,s_quote);
X		return (TRUE);
X	case '#':			/* a quoted function */
X		xlgetc(fptr);
X		switch (ch = xlgetc(fptr)) {
X		case '<':
X		    xlfail("unreadable atom");
X		case '\'':
X		    *pval = pquote(fptr,s_function);
X		    break;
X		case 'x':
X		case 'X':
X		    *pval = phexnumber(fptr);
X		    break;
X		case '\\':
X		    *pval = cvfixnum((FIXNUM)xlgetc(fptr));
X		    break;
X		default:
X		    xlfail("unknown character after #");
X		}
X		return (TRUE);
X	case '`':			/* a back quoted expression */
X		xlgetc(fptr);
X		*pval = pquote(fptr,s_bquote);
X		return (TRUE);
X	case ',':			/* a comma or comma-at expression */
X		xlgetc(fptr);
X		if (xlpeek(fptr) == '@') {
X		    xlgetc(fptr);
X		    *pval = pquote(fptr,s_comat);
X		}
X		else
X		    *pval = pquote(fptr,s_comma);
X		return (TRUE);
X	case '(':			/* a sublist */
X		*pval = plist(fptr);
X		return (TRUE);
X	case ')':			/* closing paren - shouldn't happen */
X		xlfail("extra right paren");
X	case '.':			/* dot - shouldn't happen */
X		xlfail("misplaced dot");
X	case ';':			/* a comment */
X		pcomment(fptr);
X		break;
X	case '"':			/* a string */
X		*pval = pstring(fptr);
X		return (TRUE);
X	default:
X		if (issym(ch))		/* a name */
X		    *pval = pname(fptr);
X		else
X		    xlfail("invalid character");
X		return (TRUE);
X	}
X}
X
X/* phexnumber - parse a hexidecimal number */
XLOCAL NODE *phexnumber(fptr)
X  NODE *fptr;
X{
X    long num;
X    int ch;
X    
X    num = 0L;
X    while ((ch = xlpeek(fptr)) != EOF) {
X	if (islower(ch)) ch = toupper(ch);
X	if (!isdigit(ch) && !(ch >= 'A' && ch <= 'F'))
X	    break;
X	xlgetc(fptr);
X	num = num * 16L + (long)(ch <= '9' ? ch - '0' : ch - 'A' + 10);
X    }
X    return (cvfixnum((FIXNUM)num));
X}
X
X/* pcomment - parse a comment */
XLOCAL pcomment(fptr)
X  NODE *fptr;
X{
X    int ch;
X
X    /* skip to end of line */
X    while ((ch = checkeof(fptr)) != EOF && ch != '\n')
X	;
X}
X
X/* plist - parse a list */
XLOCAL NODE *plist(fptr)
X  NODE *fptr;
X{
X    NODE *oldstk,val,*lastnptr,*nptr,*p;
X    int ch;
X
X    /* increment the nesting level */
X    xlplevel += 1;
X
X    /* create a new stack frame */
X    oldstk = xlsave(&val,NULL);
X
X    /* skip the opening paren */
X    xlgetc(fptr);
X
X    /* keep appending nodes until a closing paren is found */
X    lastnptr = NIL;
X    for (lastnptr = NIL; (ch = nextch(fptr)) != ')'; lastnptr = nptr) {
X
X	/* check for end of file */
X	if (ch == EOF)
X	    badeof(fptr);
X
X	/* check for a dotted pair */
X	if (ch == '.') {
X
X	    /* skip the dot */
X	    xlgetc(fptr);
X
X	    /* make sure there's a node */
X	    if (lastnptr == NIL)
X		xlfail("invalid dotted pair");
X
X	    /* parse the expression after the dot */
X	    if (!parse(fptr,&p))
X		badeof(fptr);
X	    rplacd(lastnptr,p);
X
X	    /* make sure its followed by a close paren */
X	    if (nextch(fptr) != ')')
X		xlfail("invalid dotted pair");
X
X	    /* done with this list */
X	    break;
X	}
X
X	/* allocate a new node and link it into the list */
X	nptr = newnode(LIST);
X	if (lastnptr == NIL)
X	    val.n_ptr = nptr;
X	else
X	    rplacd(lastnptr,nptr);
X
X	/* initialize the new node */
X	if (!parse(fptr,&p))
X	    badeof(fptr);
X	rplaca(nptr,p);
X    }
X
X    /* skip the closing paren */
X    xlgetc(fptr);
X
X    /* restore the previous stack frame */
X    xlstack = oldstk;
X
X    /* decrement the nesting level */
X    xlplevel -= 1;
X
X    /* return successfully */
X    return (val.n_ptr);
X}
X
X/* pstring - parse a string */
XLOCAL NODE *pstring(fptr)
X  NODE *fptr;
X{
X    NODE *oldstk,val;
X    char sbuf[STRMAX+1];
X    int ch,i,d1,d2,d3;
X
X    /* create a new stack frame */
X    oldstk = xlsave(&val,NULL);
X
X    /* skip the opening quote */
X    xlgetc(fptr);
X
X    /* loop looking for a closing quote */
X    for (i = 0; i < STRMAX && (ch = checkeof(fptr)) != '"'; i++) {
X	switch (ch) {
X	case EOF:
X		badeof(fptr);
X	case '\\':
X		switch (ch = checkeof(fptr)) {
X		case 'e':
X			ch = '\033';
X			break;
X		case 'n':
X			ch = '\n';
X			break;
X		case 'r':
X			ch = '\r';
X			break;
X		case 't':
X			ch = '\t';
X			break;
X		default:
X			if (ch >= '0' && ch <= '7') {
X			    d1 = ch - '0';
X			    d2 = checkeof(fptr) - '0';
X			    d3 = checkeof(fptr) - '0';
X			    ch = (d1 << 6) + (d2 << 3) + d3;
X			}
X			break;
X		}
X	}
X	sbuf[i] = ch;
X    }
X    sbuf[i] = 0;
X
X    /* initialize the node */
X    val.n_ptr = newnode(STR);
X    val.n_ptr->n_str = strsave(sbuf);
X    val.n_ptr->n_strtype = DYNAMIC;
X
X    /* restore the previous stack frame */
X    xlstack = oldstk;
X
X    /* return the new string */
X    return (val.n_ptr);
X}
X
X/* pquote - parse a quoted expression */
XLOCAL NODE *pquote(fptr,sym)
X  NODE *fptr,*sym;
X{
X    NODE *oldstk,val,*p;
X
X    /* create a new stack frame */
X    oldstk = xlsave(&val,NULL);
X
X    /* allocate two nodes */
X    val.n_ptr = newnode(LIST);
X    rplaca(val.n_ptr,sym);
X    rplacd(val.n_ptr,newnode(LIST));
X
X    /* initialize the second to point to the quoted expression */
X    if (!parse(fptr,&p))
X	badeof(fptr);
X    rplaca(cdr(val.n_ptr),p);
X
X    /* restore the previous stack frame */
X    xlstack = oldstk;
X
X    /* return the quoted expression */
X    return (val.n_ptr);
X}
X
X/* pname - parse a symbol name */
XLOCAL NODE *pname(fptr)
X  NODE *fptr;
X{
X    char sname[STRMAX+1];
X    NODE *val;
X    int ch,i;
X
X    /* get symbol name */
X    for (i = 0; i < STRMAX && (ch = xlpeek(fptr)) != EOF && issym(ch); ) {
X	sname[i++] = (islower(ch) ? toupper(ch) : ch);
X	xlgetc(fptr);
X    }
X    sname[i] = 0;
X
X    /* check for a number or enter the symbol into the oblist */
X    return (isnumber(sname,&val) ? val : xlenter(sname,DYNAMIC));
X}
X
X/* nextch - look at the next non-blank character */
XLOCAL int nextch(fptr)
X  NODE *fptr;
X{
X    int ch;
X
X    /* return and save the next non-blank character */
X    while ((ch = xlpeek(fptr)) != EOF && isspace(ch))
X	xlgetc(fptr);
X    return (ch);
X}
X
X/* checkeof - get a character and check for end of file */
XLOCAL int checkeof(fptr)
X  NODE *fptr;
X{
X    int ch;
X
X    if ((ch = xlgetc(fptr)) == EOF)
X	badeof(fptr);
X    return (ch);
X}
X
X/* badeof - unexpected eof */
XLOCAL badeof(fptr)
X  NODE *fptr;
X{
X    xlgetc(fptr);
X    xlfail("unexpected EOF");
X}
X
X/* isnumber - check if this string is a number */
Xint isnumber(str,pval)
X  char *str; NODE **pval;
X{
X    int dl,dr;
X    char *p;
X
X    /* initialize */
X    p = str; dl = dr = 0;
X
X    /* check for a sign */
X    if (*p == '+' || *p == '-')
X	p++;
X
X    /* check for a string of digits */
X    while (isdigit(*p))
X	p++, dl++;
X
X    /* check for a decimal point */
X    if (*p == '.') {
X	p++;
X	while (isdigit(*p))
X	    p++, dr++;
X    }
X
X    /* make sure there was at least one digit and this is the end */
X    if ((dl == 0 && dr == 0) || *p)
X	return (FALSE);
X
X    /* convert the string to an integer and return successfully */
X    if (*str == '+') ++str;
X    if (str[strlen(str)-1] == '.') str[strlen(str)-1] = 0;
X    *pval = (dr ? cvflonum(FCNV(str)) : cvfixnum(ICNV(str)));
X    return (TRUE);
X}
X
X/* issym - check whether a character if valid in a symbol name */
XLOCAL int issym(ch)
X  int ch;
X{
X    if (ch <= ' ' || ch >= 0177 ||
X    	ch == '(' ||
X    	ch == ')' ||
X    	ch == ';' || 
X	ch == ',' ||
X	ch == '`' ||
X    	ch == '"' ||
X    	ch == '\'')
X	return (FALSE);
X    else
X	return (TRUE);
X}
SHAR_EOF
if test 9377 -ne "`wc -c 'xlread.c'`"
then
	echo shar: error transmitting "'xlread.c'" '(should have been 9377 characters)'
fi
echo shar: extracting "'xlstr.c'" '(3152 characters)'
if test -f 'xlstr.c'
then
	echo shar: over-writing existing file "'xlstr.c'"
fi
sed 's/^X//' << \SHAR_EOF > 'xlstr.c'
X/* xlstr - xlisp string builtin 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;
X
X/* external procedures */
Xextern char *strcat();
X
X/* xstrcat - concatenate a bunch of strings */
XNODE *xstrcat(args)
X  NODE *args;
X{
X    NODE *oldstk,val,*p;
X    char *str;
X    int len;
X
X    /* create a new stack frame */
X    oldstk = xlsave(&val,NULL);
X
X    /* find the length of the new string */
X    for (p = args, len = 0; p; )
X	len += strlen(xlmatch(STR,&p)->n_str);
X
X    /* create the result string */
X    val.n_ptr = newnode(STR);
X    val.n_ptr->n_str = str = stralloc(len);
X    *str = 0;
X
X    /* combine the strings */
X    while (args)
X	strcat(str,xlmatch(STR,&args)->n_str);
X
X    /* restore the previous stack frame */
X    xlstack = oldstk;
X
X    /* return the new string */
X    return (val.n_ptr);
X}
X
X/* xsubstr - return a substring */
XNODE *xsubstr(args)
X  NODE *args;
X{
X    NODE *oldstk,arg,src,val;
X    int start,forlen,srclen;
X    char *srcptr,*dstptr;
X
X    /* create a new stack frame */
X    oldstk = xlsave(&arg,&src,&val,NULL);
X
X    /* initialize */
X    arg.n_ptr = args;
X    
X    /* get string and its length */
X    src.n_ptr = xlmatch(STR,&arg.n_ptr);
X    srcptr = src.n_ptr->n_str;
X    srclen = strlen(srcptr);
X
X    /* get starting pos -- must be present */
X    start = xlmatch(INT,&arg.n_ptr)->n_int;
X
X    /* get length -- if not present use remainder of string */
X    forlen = (arg.n_ptr ? xlmatch(INT,&arg.n_ptr)->n_int : srclen);
X
X    /* make sure there aren't any more arguments */
X    xllastarg(arg.n_ptr);
X
X    /* don't take more than exists */
X    if (start + forlen > srclen)
X	forlen = srclen - start + 1;
X
X    /* if start beyond string -- return null string */
X    if (start > srclen) {
X	start = 1;
X	forlen = 0; }
X	
X    /* create return node */
X    val.n_ptr = newnode(STR);
X    val.n_ptr->n_str = dstptr = stralloc(forlen);
X
X    /* move string */
X    for (srcptr += start-1; forlen--; *dstptr++ = *srcptr++)
X	;
X    *dstptr = 0;
X
X    /* restore the previous stack frame */
X    xlstack = oldstk;
X
X    /* return the substring */
X    return (val.n_ptr);
X}
X
X/* xstring - return a string consisting of a single character */
XNODE *xstring(args)
X  NODE *args;
X{
X    NODE *oldstk,val;
X    char *p;
X    int ch;
X
X    /* get the character (integer) */
X    ch = xlmatch(INT,&args)->n_int;
X    xllastarg(args);
X
X    /* make a one character string */
X    oldstk = xlsave(&val,NULL);
X    val.n_ptr = newnode(STR);
X    val.n_ptr->n_str = p = stralloc(1);
X    *p++ = ch; *p = '\0';
X    xlstack = oldstk;
X
X    /* return the new string */
X    return (val.n_ptr);
X}
X
X/* xchar - extract a character from a string */
XNODE *xchar(args)
X  NODE *args;
X{
X    char *str;
X    int n;
X
X    /* get the string and the index */
X    str = xlmatch(STR,&args)->n_str;
X    n = xlmatch(INT,&args)->n_int;
X    xllastarg(args);
X
X    /* range check the index */
X    if (n < 0 || n >= strlen(str))
X	xlerror("index out of range",cvfixnum((FIXNUM)n));
X
X    /* return the character */
X    return (cvfixnum((FIXNUM)str[n]));
X}
SHAR_EOF
if test 3152 -ne "`wc -c 'xlstr.c'`"
then
	echo shar: error transmitting "'xlstr.c'" '(should have been 3152 characters)'
fi
echo shar: extracting "'xlsubr.c'" '(4445 characters)'
if test -f 'xlsubr.c'
then
	echo shar: over-writing existing file "'xlsubr.c'"
fi
sed 's/^X//' << \SHAR_EOF > 'xlsubr.c'
X/* xlsubr - xlisp builtin function support 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/* external variables */
Xextern NODE *k_test,*k_tnot,*s_eql;
Xextern NODE *xlstack;
X
X/* xlsubr - define a builtin function */
Xxlsubr(sname,type,subr)
X  char *sname; int type; NODE *(*subr)();
X{
X    NODE *sym;
X
X    /* enter the symbol */
X    sym = xlsenter(sname);
X
X    /* initialize the value */
X    sym->n_symvalue = newnode(type);
X    sym->n_symvalue->n_subr = subr;
X}
X
X/* xlarg - get the next argument */
XNODE *xlarg(pargs)
X  NODE **pargs;
X{
X    NODE *arg;
X
X    /* make sure the argument exists */
X    if (!consp(*pargs))
X	xlfail("too few arguments");
X
X    /* get the argument value */
X    arg = car(*pargs);
X
X    /* move the argument pointer ahead */
X    *pargs = cdr(*pargs);
X
X    /* return the argument */
X    return (arg);
X}
X
X/* xlmatch - get an argument and match its type */
XNODE *xlmatch(type,pargs)
X  int type; NODE **pargs;
X{
X    NODE *arg;
X
X    /* get the argument */
X    arg = xlarg(pargs);
X
X    /* check its type */
X    if (type == LIST) {
X	if (arg && ntype(arg) != LIST)
X	    xlerror("bad argument type",arg);
X    }
X    else {
X	if (arg == NIL || ntype(arg) != type)
X	    xlerror("bad argument type",arg);
X    }
X
X    /* return the argument */
X    return (arg);
X}
X
X/* xlevarg - get the next argument and evaluate it */
XNODE *xlevarg(pargs)
X  NODE **pargs;
X{
X    NODE *oldstk,val;
X
X    /* create a new stack frame */
X    oldstk = xlsave(&val,NULL);
X
X    /* get the argument */
X    val.n_ptr = xlarg(pargs);
X
X    /* evaluate the argument */
X    val.n_ptr = xleval(val.n_ptr);
X
X    /* restore the previous stack frame */
X    xlstack = oldstk;
X
X    /* return the argument */
X    return (val.n_ptr);
X}
X
X/* xlevmatch - get an evaluated argument and match its type */
XNODE *xlevmatch(type,pargs)
X  int type; NODE **pargs;
X{
X    NODE *arg;
X
X    /* get the argument */
X    arg = xlevarg(pargs);
X
X    /* check its type */
X    if (type == LIST) {
X	if (arg && ntype(arg) != LIST)
X	    xlerror("bad argument type",arg);
X    }
X    else {
X	if (arg == NIL || ntype(arg) != type)
X	    xlerror("bad argument type",arg);
X    }
X
X    /* return the argument */
X    return (arg);
X}
X
X/* xltest - get the :test or :test-not keyword argument */
Xxltest(pfcn,ptresult,pargs)
X  NODE **pfcn; int *ptresult; NODE **pargs;
X{
X    NODE *arg;
X
X    /* default the argument to eql */
X    if (!consp(*pargs)) {
X	*pfcn = getvalue(s_eql);
X	*ptresult = TRUE;
X	return;
X    }
X
X    /* get the keyword */
X    arg = car(*pargs);
X
X    /* check the keyword */
X    if (arg == k_test)
X	*ptresult = TRUE;
X    else if (arg == k_tnot)
X	*ptresult = FALSE;
X    else
X	xlfail("expecting :test or :test-not");
X
X    /* move the argument pointer ahead */
X    *pargs = cdr(*pargs);
X
X    /* make sure the argument exists */
X    if (!consp(*pargs))
X	xlfail("no value for keyword argument");
X
X    /* get the argument value */
X    *pfcn = car(*pargs);
X
X    /* if its a symbol, get its value */
X    if (symbolp(*pfcn))
X	*pfcn = xleval(*pfcn);
X
X    /* move the argument pointer ahead */
X    *pargs = cdr(*pargs);
X}
X
X/* xlgetfile - get a file or stream */
XNODE *xlgetfile(pargs)
X  NODE **pargs;
X{
X    NODE *arg;
X
X    /* get a file or stream (cons) or nil */
X    if (arg = xlarg(pargs)) {
X	if (filep(arg)) {
X	    if (arg->n_fp == NULL)
X		xlfail("file not open");
X	}
X	else if (!consp(arg))
X	    xlerror("bad argument type",arg);
X    }
X    return (arg);
X}
X
X/* xllastarg - make sure the remainder of the argument list is empty */
Xxllastarg(args)
X  NODE *args;
X{
X    if (args)
X	xlfail("too many arguments");
X}
X
X/* eq - internal eq function */
Xint eq(arg1,arg2)
X  NODE *arg1,*arg2;
X{
X    return (arg1 == arg2);
X}
X
X/* eql - internal eql function */
Xint eql(arg1,arg2)
X  NODE *arg1,*arg2;
X{
X    if (eq(arg1,arg2))
X	return (TRUE);
X    else if (fixp(arg1) && fixp(arg2))
X	return (arg1->n_int == arg2->n_int);
X    else if (floatp(arg1) && floatp(arg2))
X	return (arg1->n_float == arg2->n_float);
X    else if (stringp(arg1) && stringp(arg2))
X	return (strcmp(arg1->n_str,arg2->n_str) == 0);
X    else
X	return (FALSE);
X}
X
X/* equal - internal equal function */
Xint equal(arg1,arg2)
X  NODE *arg1,*arg2;
X{
X    /* compare the arguments */
X    if (eql(arg1,arg2))
X	return (TRUE);
X    else if (consp(arg1) && consp(arg2))
X	return (equal(car(arg1),car(arg2)) && equal(cdr(arg1),cdr(arg2)));
X    else
X	return (FALSE);
X}
SHAR_EOF
if test 4445 -ne "`wc -c 'xlsubr.c'`"
then
	echo shar: error transmitting "'xlsubr.c'" '(should have been 4445 characters)'
fi
echo shar: extracting "'xlsym.c'" '(5794 characters)'
if test -f 'xlsym.c'
then
	echo shar: over-writing existing file "'xlsym.c'"
fi
sed 's/^X//' << \SHAR_EOF > 'xlsym.c'
X/* xlsym - symbol handling 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/* external variables */
Xextern NODE *oblist,*keylist;
Xextern NODE *s_unbound;
Xextern NODE *xlstack;
Xextern NODE *xlenv;
X
X/* forward declarations */
XFORWARD NODE *symenter();
XFORWARD NODE *findprop();
X
X/* xlenter - enter a symbol into the oblist or keylist */
XNODE *xlenter(name,type)
X  char *name;
X{
X    return (symenter(name,type,(*name == ':' ? keylist : oblist)));
X}
X
X/* symenter - enter a symbol into a package */
XLOCAL NODE *symenter(name,type,listsym)
X  char *name; int type; NODE *listsym;
X{
X    NODE *oldstk,*lsym,*nsym,newsym;
X    int cmp;
X
X    /* check for nil */
X    if (strcmp(name,"NIL") == 0)
X	return (NIL);
X
X    /* check for symbol already in table */
X    lsym = NIL;
X    nsym = getvalue(listsym);
X    while (nsym) {
X	if ((cmp = strcmp(name,xlsymname(car(nsym)))) <= 0)
X	    break;
X	lsym = nsym;
X	nsym = cdr(nsym);
X    }
X
X    /* check to see if we found it */
X    if (nsym && cmp == 0)
X	return (car(nsym));
X
X    /* make a new symbol node and link it into the list */
X    oldstk = xlsave(&newsym,NULL);
X    newsym.n_ptr = newnode(LIST);
X    rplaca(newsym.n_ptr,xlmakesym(name,type));
X    rplacd(newsym.n_ptr,nsym);
X    if (lsym)
X	rplacd(lsym,newsym.n_ptr);
X    else
X	setvalue(listsym,newsym.n_ptr);
X    xlstack = oldstk;
X
X    /* return the new symbol */
X    return (car(newsym.n_ptr));
X}
X
X/* xlsenter - enter a symbol with a static print name */
XNODE *xlsenter(name)
X  char *name;
X{
X    return (xlenter(name,STATIC));
X}
X
X/* xlmakesym - make a new symbol node */
XNODE *xlmakesym(name,type)
X  char *name;
X{
X    NODE *oldstk,sym,*str;
X
X    /* create a new stack frame */
X    oldstk = xlsave(&sym,NULL);
X
X    /* make a new symbol node */
X    sym.n_ptr = newnode(SYM);
X    setvalue(sym.n_ptr,*name == ':' ? sym.n_ptr : s_unbound);
X    sym.n_ptr->n_symplist = newnode(LIST);
X    rplaca(sym.n_ptr->n_symplist,str = newnode(STR));
X    str->n_str = (type == DYNAMIC ? strsave(name) : name);
X    str->n_strtype = type;
X
X    /* restore the previous stack frame */
X    xlstack = oldstk;
X
X    /* return the new symbol node */
X    return (sym.n_ptr);
X}
X
X/* xlsymname - return the print name of a symbol */
Xchar *xlsymname(sym)
X  NODE *sym;
X{
X    return (car(sym->n_symplist)->n_str);
X}
X
X/* xlframe - create a new environment frame */
XNODE *xlframe(env)
X  NODE *env;
X{
X    NODE *ptr;
X    ptr = newnode(LIST);
X    rplacd(ptr,env);
X    return (ptr);
X}
X
X/* xlbind - bind a value to a symbol */
Xxlbind(sym,val,env)
X  NODE *sym,*val,*env;
X{
X    NODE *ptr;
X
X    /* create a new environment list entry */
X    ptr = newnode(LIST);
X    rplacd(ptr,car(env));
X    rplaca(env,ptr);
X
X    /* create a new variable binding */
X    rplaca(ptr,newnode(LIST));
X    rplaca(car(ptr),sym);
X    rplacd(car(ptr),val);
X}
X
X/* xlgetvalue - get the value of a symbol (checked) */
XNODE *xlgetvalue(sym)
X  NODE *sym;
X{
X    NODE *val;
X    while ((val = xlxgetvalue(sym)) == s_unbound)
X	xlunbound(sym);
X    return (val);
X}
X
X/* xlxgetvalue - get the value of a symbol */
XNODE *xlxgetvalue(sym)
X  NODE *sym;
X{
X    NODE *val;
X
X    /* check for this being an instance variable */
X    if (xlobgetvalue(sym,&val))
X	return (val);
X
X    /* get the value from the environment list or the global value */
X    return (xlygetvalue(sym));
X}
X
X/* xlygetvalue - get the value of a symbol (no instance variables) */
XNODE *xlygetvalue(sym)
X  NODE *sym;
X{
X    NODE *fp,*ep;
X
X    /* check the environment list */
X    for (fp = xlenv; fp; fp = cdr(fp))
X	for (ep = car(fp); ep; ep = cdr(ep))
X	    if (sym == car(car(ep)))
X		return (cdr(car(ep)));
X
X    /* return the global value */
X    return (getvalue(sym));
X}
X
X/* xlsetvalue - set the value of a symbol */
Xxlsetvalue(sym,val)
X  NODE *sym,*val;
X{
X    NODE *fp,*ep;
X
X    /* check for this being an instance variable */
X    if (xlobsetvalue(sym,val))
X	return;
X
X    /* look for the symbol in the environment list */
X    for (fp = xlenv; fp; fp = cdr(fp))
X	for (ep = car(fp); ep; ep = cdr(ep))
X	    if (sym == car(car(ep))) {
X		rplacd(car(ep),val);
X		return;
X	    }
X
X    /* store the global value */
X    setvalue(sym,val);
X}
X
X/* xlgetprop - get the value of a property */
XNODE *xlgetprop(sym,prp)
X  NODE *sym,*prp;
X{
X    NODE *p;
X    return ((p = findprop(sym,prp)) ? car(p) : NIL);
X}
X
X/* xlputprop - put a property value onto the property list */
Xxlputprop(sym,val,prp)
X  NODE *sym,*val,*prp;
X{
X    NODE *oldstk,p,*pair;
X    if ((pair = findprop(sym,prp)) == NIL) {
X	oldstk = xlsave(&p,NULL);
X	p.n_ptr = newnode(LIST);
X	rplaca(p.n_ptr,prp);
X	rplacd(p.n_ptr,pair = newnode(LIST));
X	rplaca(pair,val);
X	rplacd(pair,cdr(sym->n_symplist));
X	rplacd(sym->n_symplist,p.n_ptr);
X	xlstack = oldstk;
X    }
X    rplaca(pair,val);
X}
X
X/* xlremprop - remove a property from a property list */
Xxlremprop(sym,prp)
X  NODE *sym,*prp;
X{
X    NODE *last,*p;
X    last = NIL;
X    for (p = cdr(sym->n_symplist); consp(p) && consp(cdr(p)); p = cdr(last)) {
X	if (car(p) == prp)
X	    if (last)
X		rplacd(last,cdr(cdr(p)));
X	    else
X		rplacd(sym->n_symplist,cdr(cdr(p)));
X	last = cdr(p);
X    }
X}
X
X/* findprop - find a property pair */
XLOCAL NODE *findprop(sym,prp)
X  NODE *sym,*prp;
X{
X    NODE *p;
X    for (p = cdr(sym->n_symplist); consp(p) && consp(cdr(p)); p = cdr(cdr(p)))
X	if (car(p) == prp)
X	    return (cdr(p));
X    return (NIL);
X}
X
X/* xlsinit - symbol initialization routine */
Xxlsinit()
X{
X    /* initialize the oblist */
X    oblist = xlmakesym("*OBLIST*",STATIC);
X    setvalue(oblist,newnode(LIST));
X    rplaca(getvalue(oblist),oblist);
X
X    /* initialize the keyword list */
X    keylist = xlsenter("*KEYLIST*");
X
X    /* enter the unbound symbol indicator */
X    s_unbound = xlsenter("*UNBOUND*");
X    setvalue(s_unbound,s_unbound);
X}
SHAR_EOF
if test 5794 -ne "`wc -c 'xlsym.c'`"
then
	echo shar: error transmitting "'xlsym.c'" '(should have been 5794 characters)'
fi
echo shar: extracting "'xlsys.c'" '(3738 characters)'
if test -f 'xlsys.c'
then
	echo shar: over-writing existing file "'xlsys.c'"
fi
sed 's/^X//' << \SHAR_EOF > 'xlsys.c'
X/* xlsys.c - xlisp builtin system 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 int anodes;
X
X/* external symbols */
Xextern NODE *a_subr,*a_fsubr;
Xextern NODE *a_list,*a_sym,*a_int,*a_float,*a_str,*a_obj,*a_fptr;
Xextern NODE *true;
X
X/* xload - direct input from a file */
XNODE *xload(args)
X  NODE *args;
X{
X    NODE *oldstk,fname,*val;
X    int vflag,pflag;
X
X    /* create a new stack frame */
X    oldstk = xlsave(&fname,NULL);
X
X    /* get the file name, verbose flag and print flag */
X    fname.n_ptr = xlmatch(STR,&args);
X    vflag = (args ? xlarg(&args) != NIL : TRUE);
X    pflag = (args ? xlarg(&args) != NIL : FALSE);
X    xllastarg(args);
X
X    /* load the file */
X    val = (xlload(fname.n_ptr->n_str,vflag,pflag) ? true : NIL);
X
X    /* restore the previous stack frame */
X    xlstack = oldstk;
X
X    /* return the status */
X    return (val);
X}
X
X/* xgc - xlisp function to force garbage collection */
XNODE *xgc(args)
X  NODE *args;
X{
X    /* make sure there aren't any arguments */
X    xllastarg(args);
X
X    /* garbage collect */
X    gc();
X
X    /* return nil */
X    return (NIL);
X}
X
X/* xexpand - xlisp function to force memory expansion */
XNODE *xexpand(args)
X  NODE *args;
X{
X    int n,i;
X
X    /* get the new number to allocate */
X    n = (args ? xlmatch(INT,&args)->n_int : 1);
X    xllastarg(args);
X
X    /* allocate more segments */
X    for (i = 0; i < n; i++)
X	if (!addseg())
X	    break;
X
X    /* return the number of segments added */
X    return (cvfixnum((FIXNUM)i));
X}
X
X/* xalloc - xlisp function to set the number of nodes to allocate */
XNODE *xalloc(args)
X  NODE *args;
X{
X    int n,oldn;
X
X    /* get the new number to allocate */
X    n = xlmatch(INT,&args)->n_int;
X
X    /* make sure there aren't any more arguments */
X    xllastarg(args);
X
X    /* set the new number of nodes to allocate */
X    oldn = anodes;
X    anodes = n;
X
X    /* return the old number */
X    return (cvfixnum((FIXNUM)oldn));
X}
X
X/* xmem - xlisp function to print memory statistics */
XNODE *xmem(args)
X  NODE *args;
X{
X    /* make sure there aren't any arguments */
X    xllastarg(args);
X
X    /* print the statistics */
X    stats();
X
X    /* return nil */
X    return (NIL);
X}
X
X/* xtype - return type of a thing */
XNODE *xtype(args)
X    NODE *args;
X{
X    NODE *arg;
X
X    if (!(arg = xlarg(&args)))
X	return (NIL);
X
X    switch (ntype(arg)) {
X	case SUBR:	return (a_subr);
X	case FSUBR:	return (a_fsubr);
X	case LIST:	return (a_list);
X	case SYM:	return (a_sym);
X	case INT:	return (a_int);
X	case FLOAT:	return (a_float);
X	case STR:	return (a_str);
X	case OBJ:	return (a_obj);
X	case FPTR:	return (a_fptr);
X	default:	xlfail("bad node type");
X    }
X}
X
X/* xbaktrace - print the trace back stack */
XNODE *xbaktrace(args)
X  NODE *args;
X{
X    int n;
X
X    n = (args ? xlmatch(INT,&args)->n_int : -1);
X    xllastarg(args);
X    xlbaktrace(n);
X    return (NIL);
X}
X
X/* xexit - get out of xlisp */
XNODE *xexit(args)
X  NODE *args;
X{
X    xllastarg(args);
X    exit();
X}
X
X/* xpeek - peek at a location in 68000 memory */
XNODE *xpeek(args)
X  NODE *args;
X{
X    int *adr;
X    adr = (int *)xlmatch(INT,&args)->n_int;
X    xllastarg(args);
X    return (cvfixnum((FIXNUM)*adr));
X}
X
X/* xpoke - poke a location in 68000 memory */
XNODE *xpoke(args)
X  NODE *args;
X{
X    NODE *val;
X    int *adr;
X    adr = (int *)xlmatch(INT,&args)->n_int;
X    val = xlmatch(INT,&args);
X    xllastarg(args);
X    *adr = val->n_int;
X    return (val);
X}
X
X/* xaddressof - return the address of an XLISP node */
XNODE *xaddressof(args)
X  NODE *args;
X{
X    NODE *node;
X    node = xlarg(&args);
X    xllastarg(args);
X    return (cvfixnum((FIXNUM)node));
X}
SHAR_EOF
if test 3738 -ne "`wc -c 'xlsys.c'`"
then
	echo shar: error transmitting "'xlsys.c'" '(should have been 3738 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