v06i109: Xlisp version 1.6 (xlisp1.6), Part03/06

sources-request at mirror.UUCP sources-request at mirror.UUCP
Thu Aug 14 02:18:08 AEST 1986


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



More information about the Mod.sources mailing list