XLISP, part 4 of 4
Jay C. Weber
jcw at cvl.UUCP
Sat Jul 21 01:17:51 AEST 1984
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
More information about the Comp.sources.unix
mailing list