[net.sources] Resubmission of xlisp3.txt

betz (04/08/83)

This file is xlisp3.txt
<<<<<<<<<< xlobj.c >>>>>>>>>>
/* xlobj - xlisp object functions */

#include <stdio.h>
#include "xlisp.h"

/* global variables */
struct node *self;

/* external variables */
extern struct node *xlstack;
extern struct node *xlenv;

/* local variables */
static struct node *class;
static struct node *object;
static struct node *new;
static struct node *isnew;
static struct node *msgcls;
static struct node *msgclass;
static int varcnt;

/* 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 (the extern hack is because of decusc) */
extern struct node *findmsg();
extern struct node *findvar();
extern struct node *defvars();
extern struct node *makelist();

/* xlclass - define a class */
struct node *xlclass(name,vcnt)
  char *name; int vcnt;
{
    struct node *cls;

    /* create the class */
    cls = xlenter(name)->n_symvalue = newnode(OBJ);
    cls->n_obclass = class;
    cls->n_obdata = makelist(CLASSSIZE);

    /* set the instance variable counts */
    if (vcnt > 0) {
	(xlivar(cls,IVARCNT)->n_listvalue = newnode(INT))->n_int = vcnt;
	(xlivar(cls,IVARTOTAL)->n_listvalue = newnode(INT))->n_int = vcnt;
    }

    /* set the superclass to 'Object' */
    xlivar(cls,SUPERCLASS)->n_listvalue = object;

    /* return the new class */
    return (cls);
}

/* xlmfind - find the message binding for a message to an object */
struct node *xlmfind(obj,msym)
  struct node *obj,*msym;
{
    return (findmsg(obj->n_obclass,msym));
}

/* xlxsend - send a message to an object */
struct node *xlxsend(obj,msg,args)
  struct node *obj,*msg,*args;
{
    struct node *oldstk,method,cptr,val,*isnewmsg,*oldenv;

    /* save the old environment */
    oldenv = xlenv;

    /* create a new stack frame */
    oldstk = xlsave(&method,&cptr,&val,NULL);

    /* get the method for this message */
    method.n_ptr = msg->n_msgcode;

    /* make sure its a function or a subr */
    if (method.n_ptr->n_type != SUBR && method.n_ptr->n_type != LIST)
	xlfail("bad method");

    /* bind the symbols 'self' and 'msgclass' */
    xlbind(self,obj);
    xlbind(msgclass,msgcls);

    /* evaluate the function call */
    if (method.n_ptr->n_type == SUBR) {
	xlfixbindings(oldenv);
	val.n_ptr = (*method.n_ptr->n_subr)(args);
    }
    else {

	/* bind the formal arguments */
	xlabind(method.n_ptr->n_listvalue,args);
	xlfixbindings(oldenv);

	/* execute the code */
	cptr.n_ptr = method.n_ptr->n_listnext;
	while (cptr.n_ptr != NULL)
	    val.n_ptr = xlevarg(&cptr.n_ptr);
    }

    /* restore the environment */
    xlunbind(oldenv);

    /* after creating an object, send it the "isnew" message */
    if (msg->n_msg == new && val.n_ptr != NULL) {
	if ((isnewmsg = xlmfind(val.n_ptr,isnew)) == NULL)
	    xlfail("no method for the isnew message");
	val.n_ptr = xlxsend(val.n_ptr,isnewmsg,args);
    }

    /* restore the previous stack frame */
    xlstack = oldstk;

    /* return the result value */
    return (val.n_ptr);
}

/* xlsend - send a message to an object (message in arg list) */
struct node *xlsend(obj,args)
  struct node *obj,*args;
{
    struct node *msg;

    /* find the message binding for this message */
    if ((msg = xlmfind(obj,xlevmatch(SYM,&args))) == NULL)
	xlfail("no method for this message");

    /* send the message */
    return (xlxsend(obj,msg,args));
}

/* xlobsym - find a class or instance variable for the current object */
struct node *xlobsym(sym)
  struct node *sym;
{
    struct node *obj;

    if ((obj = self->n_symvalue) != NULL && obj->n_type == OBJ)
	return (findvar(obj,sym));
    else
	return (NULL);
}

/* mnew - create a new object instance */
static struct node *mnew()
{
    struct node *oldstk,obj,*cls;

    /* create a new stack frame */
    oldstk = xlsave(&obj,NULL);

    /* get the class */
    cls = self->n_symvalue;

    /* generate a new object */
    obj.n_ptr = newnode(OBJ);
    obj.n_ptr->n_obclass = cls;
    obj.n_ptr->n_obdata = makelist(getivcnt(cls,IVARTOTAL));

    /* restore the previous stack frame */
    xlstack = oldstk;

    /* return the new object */
    return (obj.n_ptr);
}

/* misnew - initialize a new class */
static struct node *misnew(args)
  struct node *args;
{
    struct node *oldstk,super,*obj;

    /* create a new stack frame */
    oldstk = xlsave(&super,NULL);

    /* get the superclass if there is one */
    if (args != NULL)
	super.n_ptr = xlevmatch(OBJ,&args);
    else
	super.n_ptr = object;

    /* make sure there aren't any more arguments */
    xllastarg(args);

    /* get the object */
    obj = self->n_symvalue;

    /* store the superclass */
    xlivar(obj,SUPERCLASS)->n_listvalue = super.n_ptr;
    (xlivar(obj,IVARTOTAL)->n_listvalue = newnode(INT))->n_int =
    	 getivcnt(super.n_ptr,IVARTOTAL);

    /* restore the previous stack frame */
    xlstack = oldstk;

    /* return the new object */
    return (obj);
}

/* xladdivar - enter an instance variable */
xladdivar(cls,var)
  struct node *cls; char *var;
{
    struct node *ivar,*lptr;

    /* find the 'ivars' instance variable */
    ivar = xlivar(cls,IVARS);

    /* add the instance variable */
    lptr = newnode(LIST);
    lptr->n_listnext = ivar->n_listvalue;
    ivar->n_listvalue = lptr;
    lptr->n_listvalue = xlenter(var);
}

/* entermsg - add a message to a class */
static struct node *entermsg(cls,msg)
  struct node *cls,*msg;
{
    struct node *ivar,*lptr,*mptr;

    /* find the 'messages' instance variable */
    ivar = xlivar(cls,MESSAGES);

    /* lookup the message */
    for (lptr = ivar->n_listvalue; lptr != NULL; lptr = lptr->n_listnext)
	if ((mptr = lptr->n_listvalue)->n_msg == msg)
	    return (mptr);

    /* allocate a new message entry if one wasn't found */
    lptr = newnode(LIST);
    lptr->n_listnext = ivar->n_listvalue;
    ivar->n_listvalue = lptr;
    lptr->n_listvalue = mptr = newnode(LIST);
    mptr->n_msg = msg;

    /* return the symbol node */
    return (mptr);
}

/* answer - define a method for answering a message */
static struct node *answer(args)
  struct node *args;
{
    struct node *oldstk,arg,msg,fargs,code;
    struct node *obj,*mptr,*fptr;

    /* create a new stack frame */
    oldstk = xlsave(&arg,&msg,&fargs,&code,NULL);

    /* initialize */
    arg.n_ptr = args;

    /* message symbol */
    msg.n_ptr = xlevmatch(SYM,&arg.n_ptr);

    /* get the formal argument list */
    fargs.n_ptr = xlevmatch(LIST,&arg.n_ptr);

    /* get the code */
    code.n_ptr = xlevmatch(LIST,&arg.n_ptr);

    /* make sure there aren't any more arguments */
    xllastarg(arg.n_ptr);

    /* get the object node */
    obj = self->n_symvalue;

    /* make a new message list entry */
    mptr = entermsg(obj,msg.n_ptr);

    /* setup the message node */
    mptr->n_msgcode = fptr = newnode(LIST);
    fptr->n_listvalue = fargs.n_ptr;
    fptr->n_listnext = code.n_ptr;

    /* restore the previous stack frame */
    xlstack = oldstk;

    /* return the object */
    return (obj);
}

/* mivars - define the list of instance variables */
static struct node *mivars(args)
  struct node *args;
{
    struct node *cls,*super;
    int scnt;

    /* define the list of instance variables */
    cls = defvars(args,IVARS);

    /* get the superclass instance variable count */
    if ((super = xlivar(cls,SUPERCLASS)->n_listvalue) != NULL)
	scnt = getivcnt(super,IVARTOTAL);
    else
	scnt = 0;

    /* save the number of instance variables */
    (xlivar(cls,IVARCNT)->n_listvalue = newnode(INT))->n_int = varcnt;
    (xlivar(cls,IVARTOTAL)->n_listvalue = newnode(INT))->n_int = scnt+varcnt;

    /* return the class */
    return (cls);
}

/* getivcnt - get the number of instance variables for a class */
static int getivcnt(cls,ivar)
  struct node *cls; int ivar;
{
    struct node *cnt;

    if ((cnt = xlivar(cls,ivar)->n_listvalue) != NULL)
	if (cnt->n_type == INT)
	    return (cnt->n_int);
	else
	    xlfail("bad value for instance variable count");
    else
	return (0);
}

/* mcvars - define the list of class variables */
static struct node *mcvars(args)
  struct node *args;
{
    struct node *cls;

    /* define the list of class variables */
    cls = defvars(args,CVARS);

    /* make a new list of values */
    xlivar(cls,CVALS)->n_listvalue = makelist(varcnt);

    /* return the class */
    return (cls);
}

/* defvars - define a class or instance variable list */
static struct node *defvars(args,varnum)
  struct node *args; int varnum;
{
    struct node *oldstk,vars,*vptr,*cls,*sym;

    /* create a new stack frame */
    oldstk = xlsave(&vars,NULL);

    /* get ivar list */
    vars.n_ptr = xlevmatch(LIST,&args);

    /* make sure there aren't any more arguments */
    xllastarg(args);

    /* get the class node */
    cls = self->n_symvalue;

    /* check each variable in the list */
    varcnt = 0;
    for (vptr = vars.n_ptr;
	 vptr != NULL && vptr->n_type == LIST;
	 vptr = vptr->n_listnext) {

	/* make sure this is a valid symbol in the list */
	if ((sym = vptr->n_listvalue) == NULL || sym->n_type != SYM)
	    xlfail("bad variable list");

	/* make sure its not already defined */
	if (checkvar(cls,sym))
	    xlfail("multiply defined variable");

	/* count the variable */
	varcnt++;
    }

    /* make sure the list ended properly */
    if (vptr != NULL)
	xlfail("bad variable list");

    /* define the new variable list */
    xlivar(cls,varnum)->n_listvalue = vars.n_ptr;

    /* restore the previous stack frame */
    xlstack = oldstk;

    /* return the class */
    return (cls);
}

/* xladdmsg - add a message to a class */
xladdmsg(cls,msg,code)
  struct node *cls; char *msg; struct node *(*code)();
{
    struct node *mptr;

    /* enter the message selector */
    mptr = entermsg(cls,xlenter(msg));

    /* store the method for this message */
    mptr->n_msgcode = newnode(SUBR);
    mptr->n_msgcode->n_subr = code;
}

/* getclass - get the class of an object */
static struct node *getclass(args)
  struct node *args;
{
    /* make sure there aren't any arguments */
    xllastarg(args);

    /* return the object's class */
    return (self->n_symvalue->n_obclass);
}

/* obprint - print an object */
static struct node *obprint(args)
  struct node *args;
{
    /* make sure there aren't any arguments */
    xllastarg(args);

    /* print the object */
    printf("<Object: #%o>",self->n_symvalue);

    /* return the object */
    return (self->n_symvalue);
}

/* obshow - show the instance variables of an object */
static struct node *obshow(args)
  struct node *args;
{
    /* make sure there aren't any arguments */
    xllastarg(args);

    /* print the object's instance variables */
    xlprint(self->n_symvalue->n_obdata,TRUE);

    /* return the object */
    return (self->n_symvalue);
}

/* defisnew - default 'isnew' method */
static struct node *defisnew(args)
  struct node *args;
{
    /* make sure there aren't any arguments */
    xllastarg(args);

    /* return the object */
    return (self->n_symvalue);
}

/* sendsuper - send a message to an object's superclass */
static struct node *sendsuper(args)
  struct node *args;
{
    struct node *obj,*super,*msg;

    /* get the object */
    obj = self->n_symvalue;

    /* get the object's superclass */
    super = xlivar(obj->n_obclass,SUPERCLASS)->n_listvalue;

    /* find the message binding for this message */
    if ((msg = findmsg(super,xlevmatch(SYM,&args))) == NULL)
	xlfail("no method for this message");

    /* send the message */
    return (xlxsend(obj,msg,args));
}

/* findmsg - find the message binding given an object and a class */
static struct node *findmsg(cls,sym)
  struct node *cls,*sym;
{
    struct node *lptr,*msg;

    /* start at the specified class */
    msgcls = cls;

    /* look for the message in the class or superclasses */
    while (msgcls != NULL) {

	/* lookup the message in this class */
	for (lptr = xlivar(msgcls,MESSAGES)->n_listvalue;
	     lptr != NULL;
	     lptr = lptr->n_listnext)
	    if ((msg = lptr->n_listvalue) != NULL && msg->n_msg == sym)
		return (msg);

	/* look in class's superclass */
	msgcls = xlivar(msgcls,SUPERCLASS)->n_listvalue;
    }

    /* message not found */
    return (NULL);
}

/* findvar - find a class or instance variable */
static struct node *findvar(obj,sym)
  struct node *obj,*sym;
{
    struct node *cls,*lptr;
    int base,ivarnum,cvarnum;
    int found;

    /* get the class of the object */
    cls = obj->n_obclass;

    /* get the total number of instance variables */
    base = getivcnt(cls,IVARTOTAL);

    /* find the variable */
    found = FALSE; ivarnum = 0;
    for (; cls != NULL; cls = xlivar(cls,SUPERCLASS)->n_listvalue) {

	/* get the number of instance variables for this class */
	if ((base -= getivcnt(cls,IVARCNT)) < 0)
	    xlfail("error finding instance variable");

	/* check for finding the class of the current message */
	if (!found && cls == msgclass->n_symvalue)
	    found = TRUE;

	/* lookup the instance variable */
	for (lptr = xlivar(cls,IVARS)->n_listvalue;
    	     lptr != NULL;
    	     lptr = lptr->n_listnext)
	    if (found && lptr->n_listvalue == sym)
		return (xlivar(obj,base + ivarnum));
	    else
		ivarnum++;

	/* skip the class variables if the message class hasn't been found */
	if (!found)
	    continue;

	/* lookup the class variable */
	cvarnum = 0;
	for (lptr = xlivar(cls,CVARS)->n_listvalue;
    	     lptr != NULL;
    	     lptr = lptr->n_listnext)
	    if (lptr->n_listvalue == sym)
		return (xlcvar(cls,cvarnum));
	    else
		cvarnum++;
    }

    /* variable not found */
    return (NULL);
}

/* checkvar - check for an existing class or instance variable */
static int checkvar(cls,sym)
  struct node *cls,*sym;
{
    struct node *lptr;

    /* find the variable */
    for (; cls != NULL; cls = xlivar(cls,SUPERCLASS)->n_listvalue) {

	/* lookup the instance variable */
	for (lptr = xlivar(cls,IVARS)->n_listvalue;
    	     lptr != NULL;
    	     lptr = lptr->n_listnext)
	    if (lptr->n_listvalue == sym)
		return (TRUE);

	/* lookup the class variable */
	for (lptr = xlivar(cls,CVARS)->n_listvalue;
    	     lptr != NULL;
    	     lptr = lptr->n_listnext)
	    if (lptr->n_listvalue == sym)
		return (TRUE);
    }

    /* variable not found */
    return (FALSE);
}

/* xlivar - get an instance variable */
struct node *xlivar(obj,num)
  struct node *obj; int num;
{
    struct node *ivar;

    /* get the instance variable */
    for (ivar = obj->n_obdata; num > 0; num--)
	if (ivar != NULL)
	    ivar = ivar->n_listnext;
	else
	    xlfail("bad instance variable list");

    /* return the instance variable */
    return (ivar);
}

/* xlcvar - get a class variable */
struct node *xlcvar(cls,num)
  struct node *cls; int num;
{
    struct node *cvar;

    /* get the class variable */
    for (cvar = xlivar(cls,CVALS)->n_listvalue; num > 0; num--)
	if (cvar != NULL)
	    cvar = cvar->n_listnext;
	else
	    xlfail("bad class variable list");

    /* return the class variable */
    return (cvar);
}

/* makelist - make a list of nodes */
static struct node *makelist(cnt)
  int cnt;
{
    struct node *oldstk,list,*lnew;

    /* create a new stack frame */
    oldstk = xlsave(&list,NULL);

    /* make the list */
    for (; cnt > 0; cnt--) {
        lnew = newnode(LIST);
        lnew->n_listnext = list.n_ptr;
        list.n_ptr = lnew;
    }

    /* restore the previous stack frame */
    xlstack = oldstk;

    /* return the list */
    return (list.n_ptr);
}

/* xloinit - object function initialization routine */
xloinit()
{
    /* don't confuse the garbage collector */
    class = NULL;
    object = NULL;

    /* enter the object related symbols */
    new = xlenter("new");
    isnew = xlenter("isnew");
    self = xlenter("self");
    msgclass = xlenter("msgclass");

    /* create the 'Class' object */
    class = xlclass("Class",CLASSSIZE);
    class->n_obclass = class;

    /* create the 'Object' object */
    object = xlclass("Object",0);

    /* finish initializing 'class' */
    xlivar(class,SUPERCLASS)->n_listvalue = 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",mnew);
    xladdmsg(class,"answer",answer);
    xladdmsg(class,"ivars",mivars);
    xladdmsg(class,"cvars",mcvars);
    xladdmsg(class,"isnew",misnew);

    /* finish initializing 'object' */
    xladdmsg(object,"class",getclass);
    xladdmsg(object,"print",obprint);
    xladdmsg(object,"show",obshow);
    xladdmsg(object,"isnew",defisnew);
    xladdmsg(object,"sendsuper",sendsuper);
}
<<<<<<<<<< xlprin.c >>>>>>>>>>
/* xlprint - xlisp print routine */

#include <stdio.h>
#include "xlisp.h"

/* external variables */
extern struct node *xlstack;

/* local variables */
static struct node *printsym;

/* print - builtin function print */
static struct node *print(args)
  struct node *args;
{
    xprint(args,TRUE);
}

/* princ - builtin function princ */
static struct node *princ(args)
  struct node *args;
{
    xprint(args,FALSE);
}

/* xprint - common print function */
xprint(args,flag)
  struct node *args; int flag;
{
    struct node *oldstk,arg,val;

    /* create a new stack frame */
    oldstk = xlsave(&arg,&val,NULL);

    /* initialize */
    arg.n_ptr = args;

    /* evaluate and print each argument */
    while (arg.n_ptr != NULL)
	xlprint(xlevarg(&arg.n_ptr),flag);

    /* restore previous stack frame */
    xlstack = oldstk;

    /* return null */
    return (NULL);
}

/* xlprint - print an xlisp value */
xlprint(vptr,flag)
  struct node *vptr; int flag;
{
    struct node *nptr,*next,*msg;
#ifdef FGETNAME 
    char buffer[128];
#endif

    /* print null as the empty list */
    if (vptr == NULL) {
	printf("()");
	return;
    }

    /* check value type */
    switch (vptr->n_type) {
    case SUBR:
	    printf("<Subr: #%o>",vptr);
	    break;
    case LIST:
	    putchar('(');
	    for (nptr = vptr; nptr != NULL; nptr = next) {
	        xlprint(nptr->n_listvalue,flag);
		if ((next = nptr->n_listnext) != NULL)
		    if (next->n_type == LIST)
			putchar(' ');
		    else {
			putchar('.');
			xlprint(next,flag);
			break;
		    }
	    }
	    putchar(')');
	    break;
    case SYM:
	    printf("%s",vptr->n_symname);
	    break;
    case INT:
	    printf("%d",vptr->n_int);
	    break;
    case STR:
	    if (flag)
		putstring(vptr->n_str);
	    else
		printf("%s",vptr->n_str);
	    break;
    case FPTR:
#ifdef FGETNAME
	    printf("<File: %s>",fgetname(vptr->n_fp, buffer));
#else
	    printf("<File: #%o>",vptr);
#endif
	    break;
    case OBJ:
	    if ((msg = xlmfind(vptr,printsym)) == NULL)
		xlfail("no print message");
	    xlxsend(vptr,msg,NULL);
	    break;
    case KMAP:
	    printf("<Kmap: #%o>",vptr);
	    break;
    }
}

/* putstring - output a string */
static putstring(str)
  char *str;
{
    int ch;

    /* output the initial quote */
    putchar('"');

    /* output each character in the string */
    while (ch = *str++)

	/* check for a control character */
	if (ch < 040 || ch == '\\') {
	    putchar('\\');
	    switch (ch) {
	    case '\033':
		    putchar('e');
		    break;
	    case '\n':
		    putchar('n');
		    break;
	    case '\r':
		    putchar('r');
		    break;
	    case '\t':
		    putchar('t');
		    break;
	    case '\\':
		    putchar('\\');
		    break;
	    default:
		    printf("%03o",ch);
		    break;
	    }
	}

	/* output a normal character */
	else
	    putchar(ch);

    /* output the terminating quote */
    putchar('"');
}

/* xlpinit - initialize the print routines */
xlpinit()
{
    /* find the 'print' symbol */
    printsym = xlenter("print");

    /* enter builtin functions */
    xlsubr("print",print);
    xlsubr("princ",princ);
}
<<<<<<<<<< xlread.c >>>>>>>>>>
/* xlread - xlisp expression input routine */

#include <stdio.h>
#include <ctype.h>
#include "xlisp.h"

/* global variables */
struct node *oblist;

/* external variables */
extern struct node *xlstack;
extern int (*xlgetc)();
extern int xlplevel;

/* local variables */
static int savech;

/* forward declarations (the extern hack is for decusc) */
extern struct node *parse();
extern struct node *plist();
extern struct node *pstring();
extern struct node *pnumber();
extern struct node *pquote();
extern struct node *pname();

/* xlread - read an xlisp expression */
struct node *xlread()
{
    /* initialize */
    savech = -1;
    xlplevel = 0;

    /* parse an expression */
    return (parse());
}

/* parse - parse an xlisp expression */
static struct node *parse()
{
    int ch;

    /* keep looking for a node skipping comments */
    while (TRUE)

	/* check next character for type of node */
	switch (ch = nextch()) {
	case '\'':			/* a quoted expression */
		return (pquote());
	case '(':			/* a sublist */
		return (plist());
	case ')':			/* closing paren - shouldn't happen */
		xlfail("extra right paren");
	case '.':			/* dot - shouldn't happen */
		xlfail("misplaced dot");
	case ';':			/* a comment */
		pcomment();
		break;
	case '"':			/* a string */
		return (pstring());
	default:
		if (isdigit(ch))	/* a number */
		    return (pnumber(1));
		else if (issym(ch))	/* a name */
		    return (pname());
		else
		    xlfail("invalid character");
	}
}

/* pcomment - parse a comment */
static pcomment()
{
    int ch;

    /* skip to end of line */
    while ((ch = getch()) > 0)
	if (ch == '\n')
	    break;
}

/* plist - parse a list */
static struct node *plist()
{
    struct node *oldstk,val,*lastnptr,*nptr;
    int ch;

    /* increment the nesting level */
    xlplevel += 1;

    /* create a new stack frame */
    oldstk = xlsave(&val,NULL);

    /* skip the opening paren */
    savech = -1;

    /* keep appending nodes until a closing paren is found */
    for (lastnptr = NULL; (ch = nextch()) > 0 && ch != ')'; lastnptr = nptr) {

	/* check for a dotted pair */
	if (ch == '.') {

	    /* skip the dot */
	    savech = -1;

	    /* make sure there's a node */
	    if (lastnptr == NULL)
		xlfail("invalid dotted pair");

	    /* parse the expression after the dot */
	    lastnptr->n_listnext = parse();

	    /* make sure its followed by a close paren */
	    if (nextch() != ')')
		xlfail("invalid dotted pair");

	    /* done with this list */
	    break;
	}

	/* allocate a new node and link it into the list */
	nptr = newnode(LIST);
	if (lastnptr == NULL)
	    val.n_ptr = nptr;
	else
	    lastnptr->n_listnext = nptr;

	/* initialize the new node */
	nptr->n_listvalue = parse();
    }

    /* skip the closing paren */
    savech = -1;

    /* restore the previous stack frame */
    xlstack = oldstk;

    /* decrement the nesting level */
    xlplevel -= 1;

    /* return successfully */
    return (val.n_ptr);
}

/* pstring - parse a string */
static struct node *pstring()
{
    struct node *oldstk,val;
    char sbuf[STRMAX+1];
    int ch,i,d1,d2,d3;

    /* create a new stack frame */
    oldstk = xlsave(&val,NULL);

    /* skip the opening quote */
    savech = -1;

    /* loop looking for a closing quote */
    for (i = 0; i < STRMAX && (ch = getch()) > 0 && ch != '"'; i++) {
	switch (ch) {
	case '\\':
		switch (ch = getch()) {
		case 'e':
			ch = '\033';
			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 = getch() - '0';
			    d3 = getch() - '0';
			    ch = (d1 << 6) + (d2 << 3) + d3;
			}
			break;
		}
	}
	sbuf[i] = ch;
    }
    sbuf[i] = 0;

    /* initialize the node */
    val.n_ptr = newnode(STR);
    val.n_ptr->n_str = strsave(sbuf);

    /* restore the previous stack frame */
    xlstack = oldstk;

    /* return the new string */
    return (val.n_ptr);
}

/* pnumber - parse a number */
static struct node *pnumber(sign)
  int sign;
{
    struct node *val;
    int ch,ival;

    /* loop looking for digits */
    for (ival = 0; (ch = thisch()) > 0 && isdigit(ch); savech = -1)
	ival = ival * 10 + ch - '0';

    /* make sure the number terminated correctly */
    if (issym(ch))
	xlfail("badly formed number");

    /* initialize the node */
    val = newnode(INT);
    val->n_int = sign * ival;

    /* return the new number */
    return (val);
}

/* xlenter - enter a symbol into the symbol table */
struct node *xlenter(sname)
  char *sname;
{
    struct node *sptr;

    /* check for nil */
    if (strcmp(sname,"nil") == 0)
	return (NULL);

    /* check for the oblist being undefined */
    if (oblist == NULL) {
	oblist = newnode(SYM);
	oblist->n_symname = strsave("oblist");
	oblist->n_symvalue = newnode(LIST);
	oblist->n_symvalue->n_listvalue = oblist;
    }

    /* check for symbol already in table */
    for (sptr = oblist->n_symvalue; sptr != NULL; sptr = sptr->n_listnext)
	if (sptr->n_listvalue == NULL)
	    printf("bad oblist\n");
	else if (sptr->n_listvalue->n_symname == NULL)
	    printf("bad oblist symbol\n");
	else
	if (strcmp(sptr->n_listvalue->n_symname,sname) == 0)
	    return (sptr->n_listvalue);

    /* enter a new symbol and link it into the symbol list */
    sptr = newnode(LIST);
    sptr->n_listnext = oblist->n_symvalue;
    oblist->n_symvalue = sptr;
    sptr->n_listvalue = newnode(SYM);
    sptr->n_listvalue->n_symname = strsave(sname);

    /* return the new symbol */
    return (sptr->n_listvalue);
}

/* pquote - parse a quoted expression */
static struct node *pquote()
{
    struct node *oldstk,val;

    /* create a new stack frame */
    oldstk = xlsave(&val,NULL);

    /* skip the quote character */
    savech = -1;

    /* allocate two nodes */
    val.n_ptr = newnode(LIST);
    val.n_ptr->n_listvalue = xlenter("quote");
    val.n_ptr->n_listnext = newnode(LIST);

    /* initialize the second to point to the quoted expression */
    val.n_ptr->n_listnext->n_listvalue = parse();

    /* restore the previous stack frame */
    xlstack = oldstk;

    /* return the quoted expression */
    return (val.n_ptr);
}

/* pname - parse a symbol name */
static struct node *pname()
{
    char sname[STRMAX+1];
    int ch,i;

    /* get the first character */
    ch = sname[0] = getch();

    /* check for signed number */
    if (ch == '+' || ch == '-') {
	if (isdigit(thisch()))
	    return (pnumber(ch == '+' ? 1 : -1));
    }

    /* get symbol name */
    for (i = 1; i < STRMAX && (ch = thisch()) > 0 && issym(ch); i++)
	sname[i] = getch();
    sname[i] = 0;

    /* initialize value */
    return (xlenter(sname));
}

/* nextch - look at the next non-blank character */
static int nextch()
{
    int ch;

    /* look for a non-blank character */
    while ((ch = thisch()) > 0)
	if (isspace(ch))
	    savech = -1;
	else
	    break;

    /* return the character */
    return (ch);
}

/* thisch - look at the current character */
static int thisch()
{
    /* return and save the current character */
    return (savech = getch());
}

/* getch - get the next character */
static int getch()
{
    int ch;

    /* check for a saved character */
    if ((ch = savech) >= 0)
	savech = -1;
    else
	ch = (*xlgetc)();

    /* check for the abort character */
    if (ch == '\007') {
	putchar('\n');
#ifdef CNTRLGBREAK
	xltin(FALSE);
#endif
	xlfail("input aborted");
    }

    /* return the character */
    return (ch);
}

/* issym - check whether a character if valid in a symbol name */
static int issym(ch)
  int ch;
{
    if (isspace(ch) ||
    	ch <  ' ' ||
    	ch == '(' ||
    	ch == ')' ||
    	ch == ';' || 
    	ch == '.' ||
    	ch == '"' ||
    	ch == '\'')
	return (FALSE);
    else
	return (TRUE);
}