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