[net.sources] XLISP, part 4 of 4

jcw@cvl.UUCP (Jay C. Weber) (07/20/84)

This is the last third of the C source for David Betz' XLISP
interpreter.

Tear at the dotted line, run sh(1) over it.

Jay Weber
----------------------------------------------------
: Run this shell script with "sh" not "csh"
PATH=:/bin:/usr/bin:/usr/ucb
export PATH
/bin/echo 'Extracting xlobj.c'
sed 's/^X//' <<'//go.sysin dd *' >xlobj.c
X		      /* xlobj - xlisp object functions */
X
X#ifdef CI_86
X#include "a:stdio.h"
X#include "xlisp.h"
X#endif
X
X
X#ifdef AZTEC
X#include "a:stdio.h"
X#include "xlisp.h"
X#endif
X
X
X#ifdef unix
X#include <stdio.h>
X#include <xlisp.h>
X#endif
X
X
X			     /* global variables */
X
Xstruct node *self;
X
X
X			    /* external variables */
X
Xextern struct node *xlstack;
Xextern struct node *xlenv;
X
X
X			      /* local variables */
X
Xstatic struct node *class;
Xstatic struct node *object;
Xstatic struct node *new;
Xstatic struct node *isnew;
Xstatic struct node *msgcls;
Xstatic struct node *msgclass;
Xstatic int varcnt;
X
X
X	      /* instance variable numbers for the class 'Class' */
X
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
X	    /* number of instance variables for the class 'Class' */
X
X#define CLASSSIZE       7
X
X
X
X	/* forward declarations (the extern hack is because of decusc) */
X
Xextern struct node *findmsg();
Xextern struct node *findvar();
Xextern struct node *defvars();
Xextern struct node *makelist();
X
X
X			 /*****************************
X			 *  xlclass - define a class  *
X			 *****************************/
X
Xstruct node *xlclass(name,vcnt)
X  char *name; int vcnt;
X{
X    struct node *sym,*cls;
X
X    sym = xlenter(name);                    /* Create the class */
X    cls = sym->n_symvalue = newnode(OBJ);
X    cls->n_obclass = class;
X    cls->n_obdata = makelist(CLASSSIZE);
X
X    if (vcnt > 0)                           /* Set instance var count */
X    {
X	(xlivar(cls,IVARCNT)->n_listvalue = newnode(INT))->n_int = vcnt;
X	(xlivar(cls,IVARTOTAL)->n_listvalue = newnode(INT))->n_int = vcnt;
X    }
X
X    xlivar(cls,SUPERCLASS)->n_listvalue = object;     /* superclass = object */
X
X    return (cls);
X}
X
X
X       /******************************************************************
X       *  xlmfind - find the message binding for a message to an object  *
X       ******************************************************************/
X
Xstruct node *xlmfind(obj,msym)
X  struct node *obj,*msym;
X{
X    return (findmsg(obj->n_obclass,msym));
X}
X
X
X		   /******************************************
X		   *  xlxsend - send a message to an object  *
X		   ******************************************/
X
Xstruct node *xlxsend(obj,msg,args)
X  struct node *obj,*msg,*args;
X{
X    struct node *oldstk,method,cptr,val,*isnewmsg,*oldenv;
X
X    oldenv = xlenv;                         /* Save old environment */
X    oldstk = xlsave(&method,&cptr,&val,NULL);
X
X    method.n_ptr = msg->n_msgcode;          /* Get method for this msg */
X    if (method.n_ptr->n_type != SUBR && method.n_ptr->n_type != LIST)
X	xlfail("bad method");
X
X    xlbind(self,obj);                       /* Bind 'self' and 'msgclass' */
X    xlbind(msgclass,msgcls);
X
X    if (method.n_ptr->n_type == SUBR)       /* Evaluate function */
X    {
X	xlfixbindings(oldenv);
X	val.n_ptr = (*method.n_ptr->n_subr)(args);
X    }
X    else
X    {                                       /* Bind formal arguments */
X	xlabind(method.n_ptr->n_listvalue,args);
X	xlfixbindings(oldenv);
X
X	cptr.n_ptr = method.n_ptr->n_listnext;
X	while (cptr.n_ptr != NULL)
X	    val.n_ptr = xlevarg(&cptr.n_ptr);
X    }
X
X    xlunbind(oldenv);                       /* Restore environment */
X
X    /* after creating an object, send it the "isnew" message */
X    if (msg->n_msg == new && val.n_ptr != NULL)
X    {
X	if ((isnewmsg = xlmfind(val.n_ptr,isnew)) == NULL)
X	    xlfail("no method for the isnew message");
X	val.n_ptr = xlxsend(val.n_ptr,isnewmsg,args);
X    }
X
X    xlstack = oldstk;                       /* Restore old stack frame */
X    return (val.n_ptr);
X}
X
X
X	/***************************************************************
X	*  xlsend - send a message to an object (message in arg list)  *
X	***************************************************************/
X
Xstruct node *xlsend(obj,args)
X  struct node *obj,*args;
X{
X    struct node *msg;
X
X    if ((msg = xlmfind(obj,xlevmatch(SYM,&args))) == NULL)
X	xlfail("no method for this message");
X
X    return (xlxsend(obj,msg,args));
X}
X
X
X    /***********************************************************************
X    *  xlobsym - find a class or instance variable for the current object  *
X    ***********************************************************************/
X
Xstruct node *xlobsym(sym)
X  struct node *sym;
X{
X    struct node *obj;
X
X    if ((obj = self->n_symvalue) != NULL && obj->n_type == OBJ)
X	return (findvar(obj,sym));
X    else
X	return (NULL);
X}
X
X
X		    /****************************************
X		    *  mnew - create a new object instance  *
X		    ****************************************/
X
Xstatic struct node *mnew()
X{
X    struct node *oldstk,obj,*cls;
X
X    oldstk = xlsave(&obj,NULL);             /* New stack frame */
X
X    cls = self->n_symvalue;                 /* Get class name */
X
X    obj.n_ptr = newnode(OBJ);               /* Generate new object */
X    obj.n_ptr->n_obclass = cls;
X    obj.n_ptr->n_obdata = makelist(getivcnt(cls,IVARTOTAL));
X
X    xlstack = oldstk;                       /* Restore old stack frame */
X    return (obj.n_ptr);
X}
X
X
X		      /************************************
X		      *  misnew - initialize a new class  *
X		      ************************************/
X
Xstatic struct node *misnew(args)
X  struct node *args;
X{
X    struct node *oldstk,super,*obj;
X
X    oldstk = xlsave(&super,NULL);           /* Create new stack frame */
X
X    if (args != NULL)                       /* Get superclass is present */
X	super.n_ptr = xlevmatch(OBJ,&args);
X    else
X	super.n_ptr = object;
X
X    xllastarg(args);                        /* Check no more args */
X
X    obj = self->n_symvalue;                 /* Get the object */
X    xlivar(obj,SUPERCLASS)->n_listvalue = super.n_ptr;
X    (xlivar(obj,IVARTOTAL)->n_listvalue = newnode(INT))->n_int =
X	 getivcnt(super.n_ptr,IVARTOTAL);
X
X    xlstack = oldstk;                       /* Restore stack frame */
X    return (obj);
X}
X
X
X		  /*******************************************
X		  *  xladdivar - enter an instance variable  *
X		  *******************************************/
X
Xxladdivar(cls,var)
X  struct node *cls; char *var;
X{
X    struct node *ivar,*lptr;
X
X    ivar = xlivar(cls,IVARS);               /* Find 'ivars' instance var */
X
X    lptr = newnode(LIST);                   /* add instance var */
X    lptr->n_listnext = ivar->n_listvalue;
X    ivar->n_listvalue = lptr;
X    lptr->n_listvalue = xlenter(var);
X}
X
X
X		    /****************************************
X		    *  entermsg - add a message to a class  *
X		    ****************************************/
X
Xstatic struct node *entermsg(cls,msg)
X  struct node *cls,*msg;
X{
X    struct node *ivar,*lptr,*mptr;
X
X    ivar = xlivar(cls,MESSAGES);                 /* Find 'messages' iv */
X
X    for (lptr = ivar->n_listvalue; lptr != NULL; lptr = lptr->n_listnext)
X	if ((mptr = lptr->n_listvalue)->n_msg == msg)
X	    return (mptr);
X
X    /* allocate a new message entry if one wasn't found */
X    lptr = newnode(LIST);
X    lptr->n_listnext = ivar->n_listvalue;
X    ivar->n_listvalue = lptr;
X    lptr->n_listvalue = mptr = newnode(LIST);
X    mptr->n_msg = msg;
X
X    return (mptr);                               /* Return the symbol node */
X}
X
X
X	     /*****************************************************
X	     *  answer - define a method for answering a message  *
X	     *****************************************************/
X
Xstatic struct node *answer(args)
X  struct node *args;
X{
X    struct node *oldstk,arg,msg,fargs,code;
X    struct node *obj,*mptr,*fptr;
X
X    oldstk = xlsave(&arg,&msg,&fargs,&code,NULL);     /* New stack frame */
X    arg.n_ptr = args;
X
X    msg.n_ptr = xlevmatch(SYM,&arg.n_ptr);       /* Message symbol */
X
X    fargs.n_ptr = xlevmatch(LIST,&arg.n_ptr);    /* Formal arg list */
X    code.n_ptr = xlevmatch(LIST,&arg.n_ptr);     /* the code */
X    xllastarg(arg.n_ptr);                        /* End of args */
X
X    obj = self->n_symvalue;                      /* Object node */
X    mptr = entermsg(obj,msg.n_ptr);              /* New message list entry */
X
X    mptr->n_msgcode = fptr = newnode(LIST);      /* Set up message node */
X    fptr->n_listvalue = fargs.n_ptr;
X    fptr->n_listnext = code.n_ptr;
X
X    xlstack = oldstk;                            /* Restore old stack frame */
X    return (obj);
X}
X
X
X	      /***************************************************
X	      *  mivars - define the list of instance variables  *
X	      ***************************************************/
X
Xstatic struct node *mivars(args)
X  struct node *args;
X{
X    struct node *cls,*super;
X    int scnt;
X
X    cls = defvars(args,IVARS);              /* Define list of ivs */
X
X    if ((super = xlivar(cls,SUPERCLASS)->n_listvalue) != NULL)
X	scnt = getivcnt(super,IVARTOTAL);
X    else
X	scnt = 0;
X
X    (xlivar(cls,IVARCNT)->n_listvalue = newnode(INT))->n_int = varcnt;
X    (xlivar(cls,IVARTOTAL)->n_listvalue = newnode(INT))->n_int = scnt+varcnt;
X
X    return (cls);
X}
X
X
X
X	/****************************************************************
X	*  getivcnt - get the number of instance variables for a class  *
X	****************************************************************/
X
Xstatic int getivcnt(cls,ivar)
X  struct node *cls; int ivar;
X{
X    struct node *cnt;
X
X    if ((cnt = xlivar(cls,ivar)->n_listvalue) != NULL)
X	if (cnt->n_type == INT)
X	    return (cnt->n_int);
X	else
X	    xlfail("bad value for instance variable count");
X    else
X	return (0);
X}
X
X
X
X		/************************************************
X		*  mcvars - define the list of class variables  *
X		************************************************/
X
Xstatic struct node *mcvars(args)
X  struct node *args;
X{
X    struct node *cls;
X
X    cls = defvars(args,CVARS);              /* define list of class vars */
X    xlivar(cls,CVALS)->n_listvalue = makelist(varcnt);     /* make new list */
X
X    return (cls);
X}
X
X
X
X	    /*******************************************************
X	    *  defvars - define a class or instance variable list  *
X	    *******************************************************/
X
Xstatic struct node *defvars(args,varnum)
X  struct node *args; int varnum;
X{
X    struct node *oldstk,vars,*vptr,*cls,*sym;
X
X    oldstk = xlsave(&vars,NULL);            /* Create new stack frame */
X    vars.n_ptr = xlevmatch(LIST,&args);     /* Get ivar list */
X    xllastarg(args);                        /* Last argument ! */
X
X    cls = self->n_symvalue;                 /* Class node */
X
X    varcnt = 0;                             /* Check each var in list */
X    for (vptr = vars.n_ptr;
X	 vptr != NULL && vptr->n_type == LIST;
X	 vptr = vptr->n_listnext)
X    {
X	/* make sure this is a valid symbol in the list */
X	if ((sym = vptr->n_listvalue) == NULL || sym->n_type != SYM)
X	    xlfail("bad variable list");
X
X	if (checkvar(cls,sym))              /* Check not already defined */
X	    xlfail("multiply defined variable");
X	varcnt++;                           /* Count the variable */
X    }
X
X    if (vptr != NULL)                       /* Check for correct end */
X	xlfail("bad variable list");
X
X    xlivar(cls,varnum)->n_listvalue = vars.n_ptr;     /* Define new list */
X
X    xlstack = oldstk;                       /* Restore old stack frame */
X    return (cls);
X}
X
X
X
X		    /****************************************
X		    *  xladdmsg - add a message to a class  *
X		    ****************************************/
X
Xxladdmsg(cls,msg,code)
X  struct node *cls; char *msg; struct node *(*code)();
X{
X    struct node *mptr;
X
X    mptr = entermsg(cls,xlenter(msg));      /* enter message selector */
X    mptr->n_msgcode = newnode(SUBR);        /* Store the method */
X    mptr->n_msgcode->n_subr = code;
X}
X
X
X
X		   /******************************************
X		   *  getclass - get the class of an object  *
X		   ******************************************/
X
Xstatic struct node *getclass(args)
X  struct node *args;
X{
X    xllastarg(args);                   /* Check no arguments */
X    return (self->n_symvalue->n_obclass);
X}
X
X
X
X			 /******************************
X			 *  obprint - print an object  *
X			 ******************************/
X
Xstatic struct node *obprint(args)
X  struct node *args;
X{
X    xllastarg(args);                   /* Check no arguments */
X
X    printf("<Object: #%o>",self->n_symvalue);
X    return (self->n_symvalue);
X}
X
X
X
X	     /******************************************************
X	     *  obshow - show the instance variables of an object  *
X	     ******************************************************/
X
Xstatic struct node *obshow(args)
X  struct node *args;
X{
X    xllastarg(args);                   /* Check no arguments */
X
X    xlprint(self->n_symvalue->n_obdata,TRUE);
X    return (self->n_symvalue);
X}
X
X
X
X		     /**************************************
X		     *  defisnew - default 'isnew' method  *
X		     **************************************/
X
Xstatic struct node *defisnew(args)
X  struct node *args;
X{
X    xllastarg(args);                   /* Check for null arg list */
X    return (self->n_symvalue);
X}
X
X
X
X	   /*********************************************************
X	   *  sendsuper - send a message to an object's superclass  *
X	   *********************************************************/
X
Xstatic struct node *sendsuper(args)
X  struct node *args;
X{
X    struct node *obj,*super,*msg;
X
X    obj = self->n_symvalue;            /* Get the object and its super class */
X    super = xlivar(obj->n_obclass,SUPERCLASS)->n_listvalue;
X
X				       /* Find message binding */
X    if ((msg = findmsg(super,xlevmatch(SYM,&args))) == NULL)
X	xlfail("no method for this message");
X
X    return (xlxsend(obj,msg,args));    /* and send it */
X}
X
X
X      /*******************************************************************
X      *  findmsg - find the message binding given an object and a class  *
X      *******************************************************************/
X
Xstatic struct node *findmsg(cls,sym)
X  struct node *cls,*sym;
X{
X    struct node *lptr,*msg;
X
X    msgcls = cls;                           /* Start at specified class */
X    while (msgcls != NULL)                  /* Look for the message */
X    {
X	for (lptr = xlivar(msgcls,MESSAGES)->n_listvalue;
X	     lptr != NULL;
X	     lptr = lptr->n_listnext)
X	    if ((msg = lptr->n_listvalue) != NULL && msg->n_msg == sym)
X		return (msg);
X
X	msgcls = xlivar(msgcls,SUPERCLASS)->n_listvalue;
X    }
X
X    return (NULL);                          /* Message not found */
X}
X
X
X		/************************************************
X		*  findvar - find a class or instance variable  *
X		************************************************/
X
Xstatic struct node *findvar(obj,sym)
X  struct node *obj,*sym;
X{
X    struct node *cls,*lptr;
X    int base,varnum;
X    int found;
X
X    cls = obj->n_obclass;                        /* Get class of object */
X    base = getivcnt(cls,IVARTOTAL);              /* Get number of ivs */
X
X    found = FALSE;                               /* Find the var */
X    for (; cls != NULL; cls = xlivar(cls,SUPERCLASS)->n_listvalue)
X    {
X	if ((base -= getivcnt(cls,IVARCNT)) < 0)
X	    xlfail("error finding instance variable");
X
X	if (!found && cls == msgclass->n_symvalue)
X	    found = TRUE;
X
X	varnum = 0;                              /* Lookup the iv */
X	for (lptr = xlivar(cls,IVARS)->n_listvalue;
X	     lptr != NULL;
X	     lptr = lptr->n_listnext)
X	    if (found && lptr->n_listvalue == sym)
X		return (xlivar(obj,base + varnum));
X	    else
X		varnum++;
X
X	if (!found)                              /* Skip class vars if found */
X	    continue;
X
X	varnum = 0;                              /* Lookup class vars */
X	for (lptr = xlivar(cls,CVARS)->n_listvalue;
X	     lptr != NULL;
X	     lptr = lptr->n_listnext)
X	    if (lptr->n_listvalue == sym)
X		return (xlcvar(cls,varnum));
X	    else
X		varnum++;
X    }
X
X    return (NULL);                               /* Var not found */
X}
X
X
X	/****************************************************************
X	*  checkvar - check for an existing class or instance variable  *
X	****************************************************************/
X
Xstatic int checkvar(cls,sym)
X  struct node *cls,*sym;
X{
X    struct node *lptr;
X
X    for (; cls != NULL; cls = xlivar(cls,SUPERCLASS)->n_listvalue)
X    {
X	for (lptr = xlivar(cls,IVARS)->n_listvalue;   /* Lookup instance var */
X	     lptr != NULL;
X	     lptr = lptr->n_listnext)
X	    if (lptr->n_listvalue == sym)
X		return (TRUE);
X
X	for (lptr = xlivar(cls,CVARS)->n_listvalue;   /* Lookup class var */
X	     lptr != NULL;
X	     lptr = lptr->n_listnext)
X	    if (lptr->n_listvalue == sym)
X		return (TRUE);
X    }
X
X    return (FALSE);                                   /* Var not found */
X}
X
X
X		     /**************************************
X		     *  xlivar - get an instance variable  *
X		     **************************************/
X
Xstruct node *xlivar(obj,num)
X  struct node *obj; int num;
X{
X    struct node *ivar;
X
X    for (ivar = obj->n_obdata; num > 0; num--)   /* Get instance var */
X	if (ivar != NULL)
X	    ivar = ivar->n_listnext;
X	else
X	    xlfail("bad instance variable list");
X
X    return (ivar);
X}
X
X
X		       /**********************************
X		       *  xlcvar - get a class variable  *
X		       **********************************/
X
Xstruct node *xlcvar(cls,num)
X  struct node *cls; int num;
X{
X    struct node *cvar;
X
X    for (cvar = xlivar(cls,CVALS)->n_listvalue; num > 0; num--)
X	if (cvar != NULL)
X	    cvar = cvar->n_listnext;
X	else
X	    xlfail("bad class variable list");
X
X    return (cvar);
X}
X
X
X
X		      /************************************
X		      *  makelist - make a list of nodes  *
X		      ************************************/
X
Xstatic struct node *makelist(cnt)
X    int cnt;
X{
X    struct node *oldstk,list,*lnew;
X
X    oldstk = xlsave(&list,NULL);            /* Create a new stack frame */
X
X    for (; cnt > 0; cnt--)                  /* Make the list */
X    {
X	lnew = newnode(LIST);
X	lnew->n_listnext = list.n_ptr;
X	list.n_ptr = lnew;
X    }
X
X    xlstack = oldstk;                       /* Restore the old stack frame */
X    return (list.n_ptr);
X}
X
X
X	     /*****************************************************
X	     *  xloinit - object function initialization routine  *
X	     *****************************************************/
X
Xxloinit()
X{
X    class = NULL;                           /* Dont confuse gc */
X    object = NULL;
X
X    new = xlenter("new");                   /* Enter object realtaed symbols */
X    isnew = xlenter("isnew");
X    self = xlenter("self");
X    msgclass = xlenter("msgclass");
X
X    class = xlclass("Class",CLASSSIZE);     /* Create 'Class' object */
X    class->n_obclass = class;
X
X    object = xlclass("Object",0);           /* Create 'Object class */
X
X    xlivar(class,SUPERCLASS)->n_listvalue = 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",mnew);
X    xladdmsg(class,"answer",answer);
X    xladdmsg(class,"ivars",mivars);
X    xladdmsg(class,"cvars",mcvars);
X    xladdmsg(class,"isnew",misnew);
X
X    xladdmsg(object,"class",getclass);
X    xladdmsg(object,"print",obprint);
X    xladdmsg(object,"show",obshow);
X    xladdmsg(object,"isnew",defisnew);
X    xladdmsg(object,"sendsuper",sendsuper);
X}
//go.sysin dd *
/bin/chmod 664 xlobj.c
/bin/echo -n '	'; /bin/ls -ld xlobj.c
/bin/echo 'Extracting xlprin.c'
sed 's/^X//' <<'//go.sysin dd *' >xlprin.c
X
X		       /* xlprint - xlisp print routine */
X
X#ifdef CI_86
X#include "a:stdio.h"
X#include "xlisp.h"
X#endif
X
X#ifdef AZTEC
X#include "a:stdio.h"
X#include "xlisp.h"
X#endif
X
X#ifdef unix
X#include <stdio.h>
X#include <xlisp.h>
X#endif
X
X
X			    /* external variables */
X
Xextern struct node *xlstack;
X
X
X			      /* local variables */
X
Xstatic struct node *printsym;
X
X
X		      /***********************************
X		      *  print - builtin function print  *
X		      ***********************************/
X
Xstatic struct node *print(args)
X  struct node *args;
X{
X    xprint(args,TRUE);
X}
X
X
X		      /***********************************
X		      *  princ - builtin function princ  *
X		      ***********************************/
X
Xstatic struct node *princ(args)
X  struct node *args;
X{
X    xprint(args,FALSE);
X}
X
X
X		      /***********************************
X		      *  xprint - common print function  *
X		      ***********************************/
X
Xxprint(args,flag)
X  struct node *args; int flag;
X{
X    struct node *oldstk,arg,val;
X
X    oldstk = xlsave(&arg,&val,NULL);        /* New stack frame */
X    arg.n_ptr = args;
X
X    while (arg.n_ptr != NULL)               /* Evaluate an print each arg */
X	xlprint(xlevarg(&arg.n_ptr),flag);
X
X    xlstack = oldstk;                       /* Restore old stack frame */
X    return (NULL);
X}
X
X
X		      /***********************************
X		      *  xlprint - print an xlisp value  *
X		      ***********************************/
X
Xxlprint(vptr,flag)
X  struct node *vptr; int flag;
X{
X    struct node *nptr,*next,*msg;
X
X#ifdef FGETNAME
X    char buffer[128];
X#endif
X
X    if (vptr == NULL)                  /* Print NULL as the empty list */
X    {
X	printf("()");
X	return;
X    }
X
X    switch (vptr->n_type)              /* Check value type */
X    {
X    case SUBR:
X	    printf("<Subr: #%o>",vptr);
X	    break;
X
X    case LIST:
X	    putchar('(');
X	    for (nptr = vptr; nptr != NULL; nptr = next)
X	    {
X		xlprint(nptr->n_listvalue,flag);
X		if ((next = nptr->n_listnext) != NULL)
X		    if (next->n_type == LIST)
X			putchar(' ');
X		    else
X		    {
X			putchar('.');
X			xlprint(next,flag);
X			break;
X		    }
X	    }
X	    putchar(')');
X	    break;
X
X    case SYM:
X	    printf("%s",vptr->n_symname);
X	    break;
X
X    case INT:
X	    printf("%d",vptr->n_int);
X	    break;
X
X#ifdef REALS
X    case REAL:
X	    printf("%g",vptr->n_real);
X	    break;
X#endif
X
X    case STR:
X	    if (flag)
X		putstring(vptr->n_str);
X	    else
X		printf("%s",vptr->n_str);
X	    break;
X
X    case FPTR:
X
X#ifdef FGETNAME
X	    printf("<File: %s>",fgetname(vptr->n_fp, buffer));
X#else
X	    printf("<File: #%o>",vptr);
X#endif
X	    break;
X
X    case OBJ:
X	    if ((msg = xlmfind(vptr,printsym)) == NULL)
X		xlfail("no print message");
X	    xlxsend(vptr,msg,NULL);
X	    break;
X
X    case KMAP:
X	    printf("<Kmap: #%o>",vptr);
X	    break;
X
X    default:
X	    printf("Invalid node type %d", vptr->n_type);
X	    break;
X    }
X}
X
X
X			/********************************
X			*  putstring - output a string  *
X			********************************/
X
Xstatic putstring(str)
X  char *str;
X{
X    int ch;
X
X    putchar('"');
X    while (ch = *str++)
X	if (ch < 040 || ch == '\\')              /* Check for control char */
X	{
X	    putchar('\\');
X	    switch (ch)
X	    {
X	    case '\033':
X		    putchar('e');
X		    break;
X
X	    case '\n':
X		    putchar('n');
X		    break;
X
X	    case '\r':
X		    putchar('r');
X		    break;
X
X	    case '\t':
X		    putchar('t');
X		    break;
X
X	    case '\\':
X		    putchar('\\');
X		    break;
X
X	    default:
X		    printf("%03o",ch);
X		    break;
X	    }
X	}
X	else                           /* Output a normal char */
X	    putchar(ch);
X
X    putchar('"');
X}
X
X
X		  /********************************************
X		  *  xlpinit - initialize the print routines  *
X		  ********************************************/
X
Xxlpinit()
X{
X    printsym = xlenter("print");            /* Find the print symbol */
X
X    xlsubr("print",print);                  /* Enter the built in functions */
X    xlsubr("princ",princ);
X}
//go.sysin dd *
/bin/chmod 664 xlprin.c
/bin/echo -n '	'; /bin/ls -ld xlprin.c
/bin/echo 'Extracting xlread.c'
sed 's/^X//' <<'//go.sysin dd *' >xlread.c
X
X		  /* xlread - xlisp expression input routine */
X
X#ifdef CI_86
X#include "a:stdio.h"
X#include "xlisp.h"
X#endif
X
X#ifdef AZTEC
X#include "a:stdio.h"
X#include "xlisp.h"
X#endif
X
X#ifdef unix
X#include <stdio.h>
X#include <ctype.h>
X#include <xlisp.h>
X#endif
X
X			   /* global variables */
X
Xstruct node *oblist;
X
X			  /* external variables */
X
Xextern struct node *xlstack;
Xextern int (*xlgetc)();
Xextern int xlplevel;
X
X			    /* local variables */
X
Xstatic int savech;
X
X	 /* forward declarations (the extern hack is for decusc) */
X
Xextern struct node *parse();
Xextern struct node *plist();
Xextern struct node *pstring();
Xextern struct node *pnumber();
Xextern struct node *pquote();
Xextern struct node *pname();
X
X#ifdef REALS
Xextern struct node *pfloat();
X#endif
X
X		     /**************************************
X		     *  xlread - read an xlisp expression  *
X		     **************************************/
X
Xstruct node *xlread()
X{
X    savech = -1;                       /* initialize */
X    xlplevel = 0;
X
X    return (parse());                  /* Parse an expression */
X}
X
X
X		     /**************************************
X		     *  parse - parse an xlisp expression  *
X		     **************************************/
X
Xstatic struct node *parse()
X{
X    int ch;
X
X    while (TRUE)                        /* Look for a node, skipp comments */
X    {
X	switch (ch = nextch())          /* Switch on next character */
X	{
X	case '\'':                      /* a quoted expression */
X		return (pquote());
X
X	case '(':                       /* a sublist */
X		return (plist());
X
X	case ')':                       /* closing paren - shouldn't happen */
X		xlfail("extra right paren");
X
X	case '.':
X#ifdef REALS
X		return (pfloat(0));     /* Real fractional only */
X#else
X		xlfail("misplaced dot");/* dot - shouldn't happen */
X#endif
X
X	case ';':                       /* a comment */
X		pcomment();
X		break;
X
X	case '"':                       /* a string */
X		return (pstring());
X
X	default:
X		if (isdigit(ch))        /* a number */
X		    return (pnumber(1));
X		else if (issym(ch))     /* a name */
X		    return (pname());
X		else
X		    xlfail("invalid character");
X	}
X    }
X}
X
X
X			/*******************************
X			*  pcomment - parse a comment  *
X			*******************************/
X
Xstatic pcomment()
X{
X    while (getch() != '\n')                 /* Skip to end of line */
X	;
X}
X
X
X			   /*************************
X			   *  plist - parse a list  *
X			   *************************/
X
Xstatic struct node *plist()
X{
X    struct node *oldstk,val,*lastnptr,*nptr;
X    int ch;
X
X    xlplevel += 1;                     /* Increment nesting level */
X    oldstk = xlsave(&val,NULL);        /* Create .... */
X    savech = -1;                       /* Skip opend paren */
X
X		       /* keep appending nodes until a closing paren is found */
X    for (lastnptr = NULL; (ch = nextch()) > 0 && ch != ')'; lastnptr = nptr)
X    {
X	if (ch == '.')                 /* Check for a dotted pair */
X	{
X	    savech = -1;               /* Skip the dot */
X
X	    if (lastnptr == NULL)      /* Make sure there is a node */
X		xlfail("invalid dotted pair");
X
X	    lastnptr->n_listnext = parse();      /* Parse expression */
X
X	    if (nextch() != ')')       /* Check for closing paren */
X		xlfail("invalid dotted pair");
X
X	    break;                     /* Done with this list */
X	}
X
X	nptr = newnode(LIST);          /* Allocate and link new node */
X	if (lastnptr == NULL)
X	    val.n_ptr = nptr;
X	else
X	    lastnptr->n_listnext = nptr;
X
X	nptr->n_listvalue = parse();   /* Initialize it */
X    }
X
X    savech = -1;                       /* Skip the closing paren */
X
X    xlstack = oldstk;                  /* Restore previous stack frame */
X    xlplevel -= 1;                     /* Decrement nesting level */
X
X    return (val.n_ptr);                /* Successful return */
X}
X
X			 /*****************************
X			 *  pstring - parse a string  *
X			 *****************************/
X
Xstatic struct node *pstring()
X{
X    struct node *oldstk,val;
X    char sbuf[STRMAX+1];
X    int ch,i,d1,d2,d3;
X
X    oldstk = xlsave(&val,NULL);             /* Create a new stack frame */
X    savech = -1;                            /* Skip opening quote */
X
X					    /* loop looking for a closing qte */
X    for (i = 0; i < STRMAX && (ch = getch()) != '"'; i++)
X    {
X	switch (ch)
X	{
X	case '\\':
X		switch (ch = getch())
X		{
X		case 'e':
X			ch = '\033';
X			break;
X
X		case 'n':
X			ch = '\n';
X			break;
X
X		case 'r':
X			ch = '\r';
X			break;
X
X		case 't':
X			ch = '\t';
X			break;
X
X		case '0':
X		case '1':
X		case '2':
X		case '3':
X		case '4':
X		case '5':
X		case '6':
X		case '7':
X			d1 = ch - '0';
X			while (((ch = getch()) >= '0') && (ch < '8'))
X			    d1 = d1 <<3 + (ch - '0');
X			ch = d1;
X			break;
X
X		default:
X			break;
X		}
X	}
X	sbuf[i] = ch;
X    }
X    sbuf[i] = 0;
X
X    val.n_ptr = newnode(STR);               /* Initialize the node */
X    val.n_ptr->n_str = strsave(sbuf);
X
X    xlstack = oldstk;                       /* Restore old stack frame */
X    return (val.n_ptr);                     /* .. and return */
X}
X
X
X#ifdef REALS
X	    /********************************************************
X	    *  pfloat - parse the fractional part of a real number  *
X	    ********************************************************/
X
Xstatic struct node *pfloat(i)
X    int i;
X{
X    struct node *val;
X    int ch;
X    long float rval = (float) ((i<0) ? -i : i), fp= 1;
X
X    for ( ; isdigit(ch = thisch()); savech = -1)
X	rval = rval + (ch - '0')/(fp *= 10);
X
X    if (issym(ch))                     /* ensure correct termination */
X	xlfail("badly formed number");
X
X    val = newnode(REAL);               /* Initialze the new node */
X    val->n_real = (i < 0) ? -rval : rval;
X
X    return (val);
X}
X#endif
X
X			 /*****************************
X			 *  pnumber - parse a number  *
X			 *****************************/
X
Xstatic struct node *pnumber(sign)
X    int sign;
X{
X    struct node *val;
X    int ch,ival = 0;
X
X    for ( ; isdigit(ch = thisch()); savech = -1)      /* loop while digits */
X	ival = ival * 10 + ch - '0';
X
X#ifdef REALS
X    if (ch == '.')
X    {
X	 savech = -1;
X	 return pfloat(sign*ival);
X    }
X#endif
X
X    if (issym(ch))                     /* ensure correct termination */
X	xlfail("badly formed number");
X
X    val = newnode(INT);                /* Initialze the new node */
X    val->n_int = sign * ival;
X
X    return (val);
X}
X
X	      /***************************************************
X	      *  xlenter - enter a symbol into the symbol table  *
X	      ***************************************************/
X
Xstruct node *xlenter(sname)
X    char *sname;
X{
X    struct node *sptr;
X
X    if (strcmp(sname,"nil") == 0)      /* Check for nil */
X	return (NULL);
X
X    if (oblist == NULL)                /* Create oblist if required */
X    {
X	oblist = newnode(SYM);
X	oblist->n_symname = strsave("oblist");
X	oblist->n_symvalue = newnode(LIST);
X	oblist->n_symvalue->n_listvalue = oblist;
X    }
X
X    sptr = oblist->n_symvalue;         /* check for symbol already in table */
X    while (sptr != NULL)
X    {
X	if (sptr->n_listvalue == NULL)
X	{
X	    printf("bad oblist\n");
X	    sptr = oblist->n_symvalue;
X	    while (sptr != NULL)
X	    {
X		 if (sptr->n_listvalue == NULL)
X		     xlfail("end oblist");
X		 printf("\n%s",sptr->n_listvalue->n_symname);
X		 sptr = sptr->n_listnext;
X	     }
X	}
X	else if (sptr->n_listvalue->n_symname == NULL)
X	    printf("bad oblist symbol\n");
X	else
X	if (strcmp(sptr->n_listvalue->n_symname,sname) == 0)
X	    return (sptr->n_listvalue);
X	sptr = sptr->n_listnext;
X    }
X
X    sptr = newnode(LIST);              /* Create and link new symbol */
X    sptr->n_listnext = oblist->n_symvalue;
X    oblist->n_symvalue = sptr;
X    sptr->n_listvalue = newnode(SYM);
X    sptr->n_listvalue->n_symname = strsave(sname);
X
X    return (sptr->n_listvalue);
X}
X
X
X		    /***************************************
X		    *  pquote - parse a quoted expression  *
X		    ***************************************/
X
Xstatic struct node *pquote()
X{
X    struct node *oldstk,val;
X
X    oldstk = xlsave(&val,NULL);             /* Create new stack frame */
X    savech = -1;                            /* Skip the quote character */
X
X    val.n_ptr = newnode(LIST);              /* Allocate two new nodes */
X    val.n_ptr->n_listvalue = xlenter("quote");
X    val.n_ptr->n_listnext = newnode(LIST);
X    val.n_ptr->n_listnext->n_listvalue = parse();
X
X    xlstack = oldstk;                       /* Restore old stack frame */
X    return (val.n_ptr);                     /* .. return quoted expression */
X}
X
X
X			/********************************
X			*  pname - parse a symbol name  *
X			********************************/
X
Xstatic struct node *pname()
X{
X    char sname[STRMAX+1];
X    int ch,i;
X
X    ch = sname[0] = getch();                /* Get first character */
X    if (ch == '+' || ch == '-')             /* Check for signed number */
X    {
X	if (isdigit(thisch()))
X	    return (pnumber(ch == '+' ? 1 : -1));
X    }
X
X    for (i = 1; i < STRMAX && issym(thisch()); i++)   /* get symbol name */
X	sname[i] = getch();
X    sname[i] = 0;
X
X    return (xlenter(sname));                /* Initialize value */
X}
X
X
X	       /**************************************************
X	       *  nextch - look at the next non-blank character  *
X	       **************************************************/
X
Xstatic int nextch()
X{
X    while (isspace(thisch()))               /* Find non blank character */
X	savech = -1;
X
X    return savech;                          /* .. and return it */
X}
X
X
X		  /*******************************************
X		  *  thisch - look at the current character  *
X		  *******************************************/
X
Xstatic int thisch()
X{
X    return (savech = getch());         /* return and save next character */
X}
X
X
X		      /***********************************
X		      *  getch - get the next character  *
X		      ***********************************/
X
Xstatic int getch()
X{
X    int ch;
X
X    if ((ch = savech) >= 0)            /* Check for saved character */
X	savech = -1;
X    else
X	ch = (*xlgetc)();
X
X    if (ch == EOF)                     /* Check for abort character */
X	if (xlplevel > 0)
X	{
X	    putchar('\n');
X	    xltin(FALSE);
X	    xlfail("input aborted");
X	}
X	else
X	    exit();
X
X    return (ch);                       /* Return char */
X}
X
X
X	/****************************************************************
X	*  issym - check whether a character if valid in a symbol name  *
X	****************************************************************/
X
Xstatic int issym(ch)
X  int ch;
X{
X    if (isspace(ch))
X	return FALSE;
X
X    switch (ch)
X    {
X    case ' ':
X    case '(':
X    case ')':
X    case ';':
X    case '.':
X    case '"':
X    case '\\':
X	return (FALSE);
X
X    default:
X	return (TRUE);
X    }
X}
//go.sysin dd *
/bin/chmod 664 xlread.c
/bin/echo -n '	'; /bin/ls -ld xlread.c
/bin/echo 'Extracting xlstr.c'
sed 's/^X//' <<'//go.sysin dd *' >xlstr.c
X		  /* xlstr - xlisp string builtin functions */
X
X#ifdef CI_86
X#include "a:stdio.h"
X#include "xlisp.h"
X#endif
X
X#ifdef AZTEC
X#include "a:stdio.h"
X#include "xlisp.h"
X#endif
X
X#ifdef unix
X#include <stdio.h>
X#include <xlisp.h>
X#endif
X
X
X			    /* external variables */
X
Xextern struct node *xlstack;
X
X
X			    /* external procedures */
X
Xextern char *strcat();
X
X
X		       /*********************************
X		       *  xstrlen - length of a string  *
X		       *********************************/
X
Xstatic struct node *xstrlen(args)
X  struct node *args;
X{
X    struct node *oldstk,arg,*val;
X    int total;
X
X    oldstk = xlsave(&arg,NULL);
X    arg.n_ptr = args;
X    total = 0;
X
X    while (arg.n_ptr != NULL)
X	total += strlen(xlevmatch(STR,&arg.n_ptr)->n_str);
X
X    xlstack = oldstk;
X
X    val = newnode(INT);
X    val->n_int = total;
X
X    return (val);
X}
X
X
X		 /*********************************************
X		 *  xstrcat - concatenate a bunch of strings  *
X		 *********************************************/
X
X
Xstatic struct node *xstrcat(args)
X  struct node *args;
X{
X/*              this routine does it the dumb way -- one at a time */
X    struct node *oldstk,arg,val,rval;
X    int newlen;
X    char *result,*argstr,*newstr;
X
X    oldstk = xlsave(&arg,&val,&rval,NULL);
X    arg.n_ptr = args;
X    rval.n_ptr = newnode(STR);
X    rval.n_ptr->n_str = result = stralloc(0);
X    *result = 0;
X
X    while (arg.n_ptr != NULL) {
X	val.n_ptr = xlevmatch(STR,&arg.n_ptr);
X	argstr = val.n_ptr->n_str;
X	newlen = strlen(result) + strlen(argstr);
X	newstr = stralloc(newlen);
X	strcpy(newstr,result);
X	strfree(result);
X	rval.n_ptr->n_str = result = strcat(newstr,argstr);
X    }
X
X    xlstack = oldstk;
X    return (rval.n_ptr);
X}
X
X
X			/********************************
X			*  substr - return a substring  *
X			********************************/
X
Xstatic struct node *substr(args)
X  struct node *args;
X{
X    struct node *oldstk,arg,src,val;
X    int start,forlen,srclen;
X    char *srcptr,*dstptr;
X
X    oldstk = xlsave(&arg,&src,&val,NULL);
X    arg.n_ptr = args;
X
X    src.n_ptr = xlevmatch(STR,&arg.n_ptr);
X    srcptr = src.n_ptr->n_str;
X    srclen = strlen(srcptr);
X
X    start = xlevmatch(INT,&arg.n_ptr)->n_int;
X
X    if (arg.n_ptr != NULL)
X	forlen = xlevmatch(INT,&arg.n_ptr)->n_int;
X    else
X	forlen = srclen;                /* use len and fix below */
X
X    xllastarg(arg.n_ptr);
X
X    if (start + forlen > srclen)
X	forlen = srclen - start + 1;
X
X    if (start > srclen)
X    {
X	start = 1;
X	forlen = 0;
X    }
X
X    val.n_ptr = newnode(STR);
X    val.n_ptr->n_str = dstptr = stralloc(forlen);
X
X    for (srcptr += start-1; forlen--; *dstptr++ = *srcptr++)
X	;
X
X    *dstptr = 0;
X
X    xlstack = oldstk;
X    return (val.n_ptr);
X}
X
X
X			/*******************************
X			*  ascii - return ascii value  *
X			*******************************/
X
Xstatic struct node *ascii(args)
X  struct node *args;
X{
X    struct node *oldstk,val;
X
X    oldstk = xlsave(&val,NULL);
X
X    val.n_ptr = newnode(INT);
X    val.n_ptr->n_int = *(xlevmatch(STR,&args)->n_str);
X
X    xllastarg(args);
X
X    xlstack = oldstk;
X    return (val.n_ptr);
X}
X
X
X	  /***********************************************************
X	  *  chr - convert an INT into a one character ascii string  *
X	  ***********************************************************/
X
Xstatic struct node *chr(args)
X  struct node *args;
X{
X    struct node *oldstk,val;
X    char *sptr;
X
X    oldstk = xlsave(&val,NULL);
X
X    val.n_ptr = newnode(STR);
X    val.n_ptr->n_str = sptr = stralloc(1);
X    *sptr++ = xlevmatch(INT,&args)->n_int;
X    *sptr = 0;
X
X    xllastarg(args);
X
X    xlstack = oldstk;
X    return (val.n_ptr);
X}
X
X
X	       /**************************************************
X	       *  xatoi - convert an ascii string to an integer  *
X	       **************************************************/
X
Xstatic struct node *xatoi(args)
X  struct node *args;
X{
X    struct node *val;
X    int n;
X
X    n = atoi(xlevmatch(STR,&args)->n_str);
X
X    xllastarg(args);
X
X    val = newnode(INT);
X    val->n_int = n;
X    return (val);
X}
X
X
X	       /**************************************************
X	       *  xitoa - convert an integer to an ascii string  *
X	       **************************************************/
X
Xstatic struct node *xitoa(args)
X  struct node *args;
X{
X    struct node *val;
X    char buf[20];
X
X    sprintf(buf,"%d",xlevmatch(INT,&args)->n_int);
X
X    xllastarg(args);
X
X    val = newnode(STR);
X    val->n_str = strsave(buf);
X    return (val);
X}
X
X
X	       /**************************************************
X	       *  xlsinit - xlisp string initialization routine  *
X	       **************************************************/
X
Xxlsinit()
X{
X    xlsubr("strlen",xstrlen);
X    xlsubr("strcat",xstrcat);
X    xlsubr("substr",substr);
X    xlsubr("ascii",ascii);
X    xlsubr("chr", chr);
X    xlsubr("atoi",xatoi);
X    xlsubr("itoa",xitoa);
X}
//go.sysin dd *
/bin/chmod 664 xlstr.c
/bin/echo -n '	'; /bin/ls -ld xlstr.c