betz (04/08/83)
This file is xlisp3.txt <<<<<<<<<< xlobj.c >>>>>>>>>> /* xlobj - xlisp object functions */ #include <stdio.h> #include "xlisp.h" /* global variables */ struct node *self; /* external variables */ extern struct node *xlstack; extern struct node *xlenv; /* local variables */ static struct node *class; static struct node *object; static struct node *new; static struct node *isnew; static struct node *msgcls; static struct node *msgclass; static int varcnt; /* instance variable numbers for the class 'Class' */ #define MESSAGES 0 /* list of messages */ #define IVARS 1 /* list of instance variable names */ #define CVARS 2 /* list of class variable names */ #define CVALS 3 /* list of class variable values */ #define SUPERCLASS 4 /* pointer to the superclass */ #define IVARCNT 5 /* number of class instance variables */ #define IVARTOTAL 6 /* total number of instance variables */ /* number of instance variables for the class 'Class' */ #define CLASSSIZE 7 /* forward declarations (the extern hack is because of decusc) */ extern struct node *findmsg(); extern struct node *findvar(); extern struct node *defvars(); extern struct node *makelist(); /* xlclass - define a class */ struct node *xlclass(name,vcnt) char *name; int vcnt; { struct node *cls; /* create the class */ cls = xlenter(name)->n_symvalue = newnode(OBJ); cls->n_obclass = class; cls->n_obdata = makelist(CLASSSIZE); /* set the instance variable counts */ if (vcnt > 0) { (xlivar(cls,IVARCNT)->n_listvalue = newnode(INT))->n_int = vcnt; (xlivar(cls,IVARTOTAL)->n_listvalue = newnode(INT))->n_int = vcnt; } /* set the superclass to 'Object' */ xlivar(cls,SUPERCLASS)->n_listvalue = object; /* return the new class */ return (cls); } /* xlmfind - find the message binding for a message to an object */ struct node *xlmfind(obj,msym) struct node *obj,*msym; { return (findmsg(obj->n_obclass,msym)); } /* xlxsend - send a message to an object */ struct node *xlxsend(obj,msg,args) struct node *obj,*msg,*args; { struct node *oldstk,method,cptr,val,*isnewmsg,*oldenv; /* save the old environment */ oldenv = xlenv; /* create a new stack frame */ oldstk = xlsave(&method,&cptr,&val,NULL); /* get the method for this message */ method.n_ptr = msg->n_msgcode; /* make sure its a function or a subr */ if (method.n_ptr->n_type != SUBR && method.n_ptr->n_type != LIST) xlfail("bad method"); /* bind the symbols 'self' and 'msgclass' */ xlbind(self,obj); xlbind(msgclass,msgcls); /* evaluate the function call */ if (method.n_ptr->n_type == SUBR) { xlfixbindings(oldenv); val.n_ptr = (*method.n_ptr->n_subr)(args); } else { /* bind the formal arguments */ xlabind(method.n_ptr->n_listvalue,args); xlfixbindings(oldenv); /* execute the code */ cptr.n_ptr = method.n_ptr->n_listnext; while (cptr.n_ptr != NULL) val.n_ptr = xlevarg(&cptr.n_ptr); } /* restore the environment */ xlunbind(oldenv); /* after creating an object, send it the "isnew" message */ if (msg->n_msg == new && val.n_ptr != NULL) { if ((isnewmsg = xlmfind(val.n_ptr,isnew)) == NULL) xlfail("no method for the isnew message"); val.n_ptr = xlxsend(val.n_ptr,isnewmsg,args); } /* restore the previous stack frame */ xlstack = oldstk; /* return the result value */ return (val.n_ptr); } /* xlsend - send a message to an object (message in arg list) */ struct node *xlsend(obj,args) struct node *obj,*args; { struct node *msg; /* find the message binding for this message */ if ((msg = xlmfind(obj,xlevmatch(SYM,&args))) == NULL) xlfail("no method for this message"); /* send the message */ return (xlxsend(obj,msg,args)); } /* xlobsym - find a class or instance variable for the current object */ struct node *xlobsym(sym) struct node *sym; { struct node *obj; if ((obj = self->n_symvalue) != NULL && obj->n_type == OBJ) return (findvar(obj,sym)); else return (NULL); } /* mnew - create a new object instance */ static struct node *mnew() { struct node *oldstk,obj,*cls; /* create a new stack frame */ oldstk = xlsave(&obj,NULL); /* get the class */ cls = self->n_symvalue; /* generate a new object */ obj.n_ptr = newnode(OBJ); obj.n_ptr->n_obclass = cls; obj.n_ptr->n_obdata = makelist(getivcnt(cls,IVARTOTAL)); /* restore the previous stack frame */ xlstack = oldstk; /* return the new object */ return (obj.n_ptr); } /* misnew - initialize a new class */ static struct node *misnew(args) struct node *args; { struct node *oldstk,super,*obj; /* create a new stack frame */ oldstk = xlsave(&super,NULL); /* get the superclass if there is one */ if (args != NULL) super.n_ptr = xlevmatch(OBJ,&args); else super.n_ptr = object; /* make sure there aren't any more arguments */ xllastarg(args); /* get the object */ obj = self->n_symvalue; /* store the superclass */ xlivar(obj,SUPERCLASS)->n_listvalue = super.n_ptr; (xlivar(obj,IVARTOTAL)->n_listvalue = newnode(INT))->n_int = getivcnt(super.n_ptr,IVARTOTAL); /* restore the previous stack frame */ xlstack = oldstk; /* return the new object */ return (obj); } /* xladdivar - enter an instance variable */ xladdivar(cls,var) struct node *cls; char *var; { struct node *ivar,*lptr; /* find the 'ivars' instance variable */ ivar = xlivar(cls,IVARS); /* add the instance variable */ lptr = newnode(LIST); lptr->n_listnext = ivar->n_listvalue; ivar->n_listvalue = lptr; lptr->n_listvalue = xlenter(var); } /* entermsg - add a message to a class */ static struct node *entermsg(cls,msg) struct node *cls,*msg; { struct node *ivar,*lptr,*mptr; /* find the 'messages' instance variable */ ivar = xlivar(cls,MESSAGES); /* lookup the message */ for (lptr = ivar->n_listvalue; lptr != NULL; lptr = lptr->n_listnext) if ((mptr = lptr->n_listvalue)->n_msg == msg) return (mptr); /* allocate a new message entry if one wasn't found */ lptr = newnode(LIST); lptr->n_listnext = ivar->n_listvalue; ivar->n_listvalue = lptr; lptr->n_listvalue = mptr = newnode(LIST); mptr->n_msg = msg; /* return the symbol node */ return (mptr); } /* answer - define a method for answering a message */ static struct node *answer(args) struct node *args; { struct node *oldstk,arg,msg,fargs,code; struct node *obj,*mptr,*fptr; /* create a new stack frame */ oldstk = xlsave(&arg,&msg,&fargs,&code,NULL); /* initialize */ arg.n_ptr = args; /* message symbol */ msg.n_ptr = xlevmatch(SYM,&arg.n_ptr); /* get the formal argument list */ fargs.n_ptr = xlevmatch(LIST,&arg.n_ptr); /* get the code */ code.n_ptr = xlevmatch(LIST,&arg.n_ptr); /* make sure there aren't any more arguments */ xllastarg(arg.n_ptr); /* get the object node */ obj = self->n_symvalue; /* make a new message list entry */ mptr = entermsg(obj,msg.n_ptr); /* setup the message node */ mptr->n_msgcode = fptr = newnode(LIST); fptr->n_listvalue = fargs.n_ptr; fptr->n_listnext = code.n_ptr; /* restore the previous stack frame */ xlstack = oldstk; /* return the object */ return (obj); } /* mivars - define the list of instance variables */ static struct node *mivars(args) struct node *args; { struct node *cls,*super; int scnt; /* define the list of instance variables */ cls = defvars(args,IVARS); /* get the superclass instance variable count */ if ((super = xlivar(cls,SUPERCLASS)->n_listvalue) != NULL) scnt = getivcnt(super,IVARTOTAL); else scnt = 0; /* save the number of instance variables */ (xlivar(cls,IVARCNT)->n_listvalue = newnode(INT))->n_int = varcnt; (xlivar(cls,IVARTOTAL)->n_listvalue = newnode(INT))->n_int = scnt+varcnt; /* return the class */ return (cls); } /* getivcnt - get the number of instance variables for a class */ static int getivcnt(cls,ivar) struct node *cls; int ivar; { struct node *cnt; if ((cnt = xlivar(cls,ivar)->n_listvalue) != NULL) if (cnt->n_type == INT) return (cnt->n_int); else xlfail("bad value for instance variable count"); else return (0); } /* mcvars - define the list of class variables */ static struct node *mcvars(args) struct node *args; { struct node *cls; /* define the list of class variables */ cls = defvars(args,CVARS); /* make a new list of values */ xlivar(cls,CVALS)->n_listvalue = makelist(varcnt); /* return the class */ return (cls); } /* defvars - define a class or instance variable list */ static struct node *defvars(args,varnum) struct node *args; int varnum; { struct node *oldstk,vars,*vptr,*cls,*sym; /* create a new stack frame */ oldstk = xlsave(&vars,NULL); /* get ivar list */ vars.n_ptr = xlevmatch(LIST,&args); /* make sure there aren't any more arguments */ xllastarg(args); /* get the class node */ cls = self->n_symvalue; /* check each variable in the list */ varcnt = 0; for (vptr = vars.n_ptr; vptr != NULL && vptr->n_type == LIST; vptr = vptr->n_listnext) { /* make sure this is a valid symbol in the list */ if ((sym = vptr->n_listvalue) == NULL || sym->n_type != SYM) xlfail("bad variable list"); /* make sure its not already defined */ if (checkvar(cls,sym)) xlfail("multiply defined variable"); /* count the variable */ varcnt++; } /* make sure the list ended properly */ if (vptr != NULL) xlfail("bad variable list"); /* define the new variable list */ xlivar(cls,varnum)->n_listvalue = vars.n_ptr; /* restore the previous stack frame */ xlstack = oldstk; /* return the class */ return (cls); } /* xladdmsg - add a message to a class */ xladdmsg(cls,msg,code) struct node *cls; char *msg; struct node *(*code)(); { struct node *mptr; /* enter the message selector */ mptr = entermsg(cls,xlenter(msg)); /* store the method for this message */ mptr->n_msgcode = newnode(SUBR); mptr->n_msgcode->n_subr = code; } /* getclass - get the class of an object */ static struct node *getclass(args) struct node *args; { /* make sure there aren't any arguments */ xllastarg(args); /* return the object's class */ return (self->n_symvalue->n_obclass); } /* obprint - print an object */ static struct node *obprint(args) struct node *args; { /* make sure there aren't any arguments */ xllastarg(args); /* print the object */ printf("<Object: #%o>",self->n_symvalue); /* return the object */ return (self->n_symvalue); } /* obshow - show the instance variables of an object */ static struct node *obshow(args) struct node *args; { /* make sure there aren't any arguments */ xllastarg(args); /* print the object's instance variables */ xlprint(self->n_symvalue->n_obdata,TRUE); /* return the object */ return (self->n_symvalue); } /* defisnew - default 'isnew' method */ static struct node *defisnew(args) struct node *args; { /* make sure there aren't any arguments */ xllastarg(args); /* return the object */ return (self->n_symvalue); } /* sendsuper - send a message to an object's superclass */ static struct node *sendsuper(args) struct node *args; { struct node *obj,*super,*msg; /* get the object */ obj = self->n_symvalue; /* get the object's superclass */ super = xlivar(obj->n_obclass,SUPERCLASS)->n_listvalue; /* find the message binding for this message */ if ((msg = findmsg(super,xlevmatch(SYM,&args))) == NULL) xlfail("no method for this message"); /* send the message */ return (xlxsend(obj,msg,args)); } /* findmsg - find the message binding given an object and a class */ static struct node *findmsg(cls,sym) struct node *cls,*sym; { struct node *lptr,*msg; /* start at the specified class */ msgcls = cls; /* look for the message in the class or superclasses */ while (msgcls != NULL) { /* lookup the message in this class */ for (lptr = xlivar(msgcls,MESSAGES)->n_listvalue; lptr != NULL; lptr = lptr->n_listnext) if ((msg = lptr->n_listvalue) != NULL && msg->n_msg == sym) return (msg); /* look in class's superclass */ msgcls = xlivar(msgcls,SUPERCLASS)->n_listvalue; } /* message not found */ return (NULL); } /* findvar - find a class or instance variable */ static struct node *findvar(obj,sym) struct node *obj,*sym; { struct node *cls,*lptr; int base,ivarnum,cvarnum; int found; /* get the class of the object */ cls = obj->n_obclass; /* get the total number of instance variables */ base = getivcnt(cls,IVARTOTAL); /* find the variable */ found = FALSE; ivarnum = 0; for (; cls != NULL; cls = xlivar(cls,SUPERCLASS)->n_listvalue) { /* get the number of instance variables for this class */ if ((base -= getivcnt(cls,IVARCNT)) < 0) xlfail("error finding instance variable"); /* check for finding the class of the current message */ if (!found && cls == msgclass->n_symvalue) found = TRUE; /* lookup the instance variable */ for (lptr = xlivar(cls,IVARS)->n_listvalue; lptr != NULL; lptr = lptr->n_listnext) if (found && lptr->n_listvalue == sym) return (xlivar(obj,base + ivarnum)); else ivarnum++; /* skip the class variables if the message class hasn't been found */ if (!found) continue; /* lookup the class variable */ cvarnum = 0; for (lptr = xlivar(cls,CVARS)->n_listvalue; lptr != NULL; lptr = lptr->n_listnext) if (lptr->n_listvalue == sym) return (xlcvar(cls,cvarnum)); else cvarnum++; } /* variable not found */ return (NULL); } /* checkvar - check for an existing class or instance variable */ static int checkvar(cls,sym) struct node *cls,*sym; { struct node *lptr; /* find the variable */ for (; cls != NULL; cls = xlivar(cls,SUPERCLASS)->n_listvalue) { /* lookup the instance variable */ for (lptr = xlivar(cls,IVARS)->n_listvalue; lptr != NULL; lptr = lptr->n_listnext) if (lptr->n_listvalue == sym) return (TRUE); /* lookup the class variable */ for (lptr = xlivar(cls,CVARS)->n_listvalue; lptr != NULL; lptr = lptr->n_listnext) if (lptr->n_listvalue == sym) return (TRUE); } /* variable not found */ return (FALSE); } /* xlivar - get an instance variable */ struct node *xlivar(obj,num) struct node *obj; int num; { struct node *ivar; /* get the instance variable */ for (ivar = obj->n_obdata; num > 0; num--) if (ivar != NULL) ivar = ivar->n_listnext; else xlfail("bad instance variable list"); /* return the instance variable */ return (ivar); } /* xlcvar - get a class variable */ struct node *xlcvar(cls,num) struct node *cls; int num; { struct node *cvar; /* get the class variable */ for (cvar = xlivar(cls,CVALS)->n_listvalue; num > 0; num--) if (cvar != NULL) cvar = cvar->n_listnext; else xlfail("bad class variable list"); /* return the class variable */ return (cvar); } /* makelist - make a list of nodes */ static struct node *makelist(cnt) int cnt; { struct node *oldstk,list,*lnew; /* create a new stack frame */ oldstk = xlsave(&list,NULL); /* make the list */ for (; cnt > 0; cnt--) { lnew = newnode(LIST); lnew->n_listnext = list.n_ptr; list.n_ptr = lnew; } /* restore the previous stack frame */ xlstack = oldstk; /* return the list */ return (list.n_ptr); } /* xloinit - object function initialization routine */ xloinit() { /* don't confuse the garbage collector */ class = NULL; object = NULL; /* enter the object related symbols */ new = xlenter("new"); isnew = xlenter("isnew"); self = xlenter("self"); msgclass = xlenter("msgclass"); /* create the 'Class' object */ class = xlclass("Class",CLASSSIZE); class->n_obclass = class; /* create the 'Object' object */ object = xlclass("Object",0); /* finish initializing 'class' */ xlivar(class,SUPERCLASS)->n_listvalue = object; xladdivar(class,"ivartotal"); /* ivar number 6 */ xladdivar(class,"ivarcnt"); /* ivar number 5 */ xladdivar(class,"superclass"); /* ivar number 4 */ xladdivar(class,"cvals"); /* ivar number 3 */ xladdivar(class,"cvars"); /* ivar number 2 */ xladdivar(class,"ivars"); /* ivar number 1 */ xladdivar(class,"messages"); /* ivar number 0 */ xladdmsg(class,"new",mnew); xladdmsg(class,"answer",answer); xladdmsg(class,"ivars",mivars); xladdmsg(class,"cvars",mcvars); xladdmsg(class,"isnew",misnew); /* finish initializing 'object' */ xladdmsg(object,"class",getclass); xladdmsg(object,"print",obprint); xladdmsg(object,"show",obshow); xladdmsg(object,"isnew",defisnew); xladdmsg(object,"sendsuper",sendsuper); } <<<<<<<<<< xlprin.c >>>>>>>>>> /* xlprint - xlisp print routine */ #include <stdio.h> #include "xlisp.h" /* external variables */ extern struct node *xlstack; /* local variables */ static struct node *printsym; /* print - builtin function print */ static struct node *print(args) struct node *args; { xprint(args,TRUE); } /* princ - builtin function princ */ static struct node *princ(args) struct node *args; { xprint(args,FALSE); } /* xprint - common print function */ xprint(args,flag) struct node *args; int flag; { struct node *oldstk,arg,val; /* create a new stack frame */ oldstk = xlsave(&arg,&val,NULL); /* initialize */ arg.n_ptr = args; /* evaluate and print each argument */ while (arg.n_ptr != NULL) xlprint(xlevarg(&arg.n_ptr),flag); /* restore previous stack frame */ xlstack = oldstk; /* return null */ return (NULL); } /* xlprint - print an xlisp value */ xlprint(vptr,flag) struct node *vptr; int flag; { struct node *nptr,*next,*msg; #ifdef FGETNAME char buffer[128]; #endif /* print null as the empty list */ if (vptr == NULL) { printf("()"); return; } /* check value type */ switch (vptr->n_type) { case SUBR: printf("<Subr: #%o>",vptr); break; case LIST: putchar('('); for (nptr = vptr; nptr != NULL; nptr = next) { xlprint(nptr->n_listvalue,flag); if ((next = nptr->n_listnext) != NULL) if (next->n_type == LIST) putchar(' '); else { putchar('.'); xlprint(next,flag); break; } } putchar(')'); break; case SYM: printf("%s",vptr->n_symname); break; case INT: printf("%d",vptr->n_int); break; case STR: if (flag) putstring(vptr->n_str); else printf("%s",vptr->n_str); break; case FPTR: #ifdef FGETNAME printf("<File: %s>",fgetname(vptr->n_fp, buffer)); #else printf("<File: #%o>",vptr); #endif break; case OBJ: if ((msg = xlmfind(vptr,printsym)) == NULL) xlfail("no print message"); xlxsend(vptr,msg,NULL); break; case KMAP: printf("<Kmap: #%o>",vptr); break; } } /* putstring - output a string */ static putstring(str) char *str; { int ch; /* output the initial quote */ putchar('"'); /* output each character in the string */ while (ch = *str++) /* check for a control character */ if (ch < 040 || ch == '\\') { putchar('\\'); switch (ch) { case '\033': putchar('e'); break; case '\n': putchar('n'); break; case '\r': putchar('r'); break; case '\t': putchar('t'); break; case '\\': putchar('\\'); break; default: printf("%03o",ch); break; } } /* output a normal character */ else putchar(ch); /* output the terminating quote */ putchar('"'); } /* xlpinit - initialize the print routines */ xlpinit() { /* find the 'print' symbol */ printsym = xlenter("print"); /* enter builtin functions */ xlsubr("print",print); xlsubr("princ",princ); } <<<<<<<<<< xlread.c >>>>>>>>>> /* xlread - xlisp expression input routine */ #include <stdio.h> #include <ctype.h> #include "xlisp.h" /* global variables */ struct node *oblist; /* external variables */ extern struct node *xlstack; extern int (*xlgetc)(); extern int xlplevel; /* local variables */ static int savech; /* forward declarations (the extern hack is for decusc) */ extern struct node *parse(); extern struct node *plist(); extern struct node *pstring(); extern struct node *pnumber(); extern struct node *pquote(); extern struct node *pname(); /* xlread - read an xlisp expression */ struct node *xlread() { /* initialize */ savech = -1; xlplevel = 0; /* parse an expression */ return (parse()); } /* parse - parse an xlisp expression */ static struct node *parse() { int ch; /* keep looking for a node skipping comments */ while (TRUE) /* check next character for type of node */ switch (ch = nextch()) { case '\'': /* a quoted expression */ return (pquote()); case '(': /* a sublist */ return (plist()); case ')': /* closing paren - shouldn't happen */ xlfail("extra right paren"); case '.': /* dot - shouldn't happen */ xlfail("misplaced dot"); case ';': /* a comment */ pcomment(); break; case '"': /* a string */ return (pstring()); default: if (isdigit(ch)) /* a number */ return (pnumber(1)); else if (issym(ch)) /* a name */ return (pname()); else xlfail("invalid character"); } } /* pcomment - parse a comment */ static pcomment() { int ch; /* skip to end of line */ while ((ch = getch()) > 0) if (ch == '\n') break; } /* plist - parse a list */ static struct node *plist() { struct node *oldstk,val,*lastnptr,*nptr; int ch; /* increment the nesting level */ xlplevel += 1; /* create a new stack frame */ oldstk = xlsave(&val,NULL); /* skip the opening paren */ savech = -1; /* keep appending nodes until a closing paren is found */ for (lastnptr = NULL; (ch = nextch()) > 0 && ch != ')'; lastnptr = nptr) { /* check for a dotted pair */ if (ch == '.') { /* skip the dot */ savech = -1; /* make sure there's a node */ if (lastnptr == NULL) xlfail("invalid dotted pair"); /* parse the expression after the dot */ lastnptr->n_listnext = parse(); /* make sure its followed by a close paren */ if (nextch() != ')') xlfail("invalid dotted pair"); /* done with this list */ break; } /* allocate a new node and link it into the list */ nptr = newnode(LIST); if (lastnptr == NULL) val.n_ptr = nptr; else lastnptr->n_listnext = nptr; /* initialize the new node */ nptr->n_listvalue = parse(); } /* skip the closing paren */ savech = -1; /* restore the previous stack frame */ xlstack = oldstk; /* decrement the nesting level */ xlplevel -= 1; /* return successfully */ return (val.n_ptr); } /* pstring - parse a string */ static struct node *pstring() { struct node *oldstk,val; char sbuf[STRMAX+1]; int ch,i,d1,d2,d3; /* create a new stack frame */ oldstk = xlsave(&val,NULL); /* skip the opening quote */ savech = -1; /* loop looking for a closing quote */ for (i = 0; i < STRMAX && (ch = getch()) > 0 && ch != '"'; i++) { switch (ch) { case '\\': switch (ch = getch()) { case 'e': ch = '\033'; break; case 'n': ch = '\n'; break; case 'r': ch = '\r'; break; case 't': ch = '\t'; break; default: if (ch >= '0' && ch <= '7') { d1 = ch - '0'; d2 = getch() - '0'; d3 = getch() - '0'; ch = (d1 << 6) + (d2 << 3) + d3; } break; } } sbuf[i] = ch; } sbuf[i] = 0; /* initialize the node */ val.n_ptr = newnode(STR); val.n_ptr->n_str = strsave(sbuf); /* restore the previous stack frame */ xlstack = oldstk; /* return the new string */ return (val.n_ptr); } /* pnumber - parse a number */ static struct node *pnumber(sign) int sign; { struct node *val; int ch,ival; /* loop looking for digits */ for (ival = 0; (ch = thisch()) > 0 && isdigit(ch); savech = -1) ival = ival * 10 + ch - '0'; /* make sure the number terminated correctly */ if (issym(ch)) xlfail("badly formed number"); /* initialize the node */ val = newnode(INT); val->n_int = sign * ival; /* return the new number */ return (val); } /* xlenter - enter a symbol into the symbol table */ struct node *xlenter(sname) char *sname; { struct node *sptr; /* check for nil */ if (strcmp(sname,"nil") == 0) return (NULL); /* check for the oblist being undefined */ if (oblist == NULL) { oblist = newnode(SYM); oblist->n_symname = strsave("oblist"); oblist->n_symvalue = newnode(LIST); oblist->n_symvalue->n_listvalue = oblist; } /* check for symbol already in table */ for (sptr = oblist->n_symvalue; sptr != NULL; sptr = sptr->n_listnext) if (sptr->n_listvalue == NULL) printf("bad oblist\n"); else if (sptr->n_listvalue->n_symname == NULL) printf("bad oblist symbol\n"); else if (strcmp(sptr->n_listvalue->n_symname,sname) == 0) return (sptr->n_listvalue); /* enter a new symbol and link it into the symbol list */ sptr = newnode(LIST); sptr->n_listnext = oblist->n_symvalue; oblist->n_symvalue = sptr; sptr->n_listvalue = newnode(SYM); sptr->n_listvalue->n_symname = strsave(sname); /* return the new symbol */ return (sptr->n_listvalue); } /* pquote - parse a quoted expression */ static struct node *pquote() { struct node *oldstk,val; /* create a new stack frame */ oldstk = xlsave(&val,NULL); /* skip the quote character */ savech = -1; /* allocate two nodes */ val.n_ptr = newnode(LIST); val.n_ptr->n_listvalue = xlenter("quote"); val.n_ptr->n_listnext = newnode(LIST); /* initialize the second to point to the quoted expression */ val.n_ptr->n_listnext->n_listvalue = parse(); /* restore the previous stack frame */ xlstack = oldstk; /* return the quoted expression */ return (val.n_ptr); } /* pname - parse a symbol name */ static struct node *pname() { char sname[STRMAX+1]; int ch,i; /* get the first character */ ch = sname[0] = getch(); /* check for signed number */ if (ch == '+' || ch == '-') { if (isdigit(thisch())) return (pnumber(ch == '+' ? 1 : -1)); } /* get symbol name */ for (i = 1; i < STRMAX && (ch = thisch()) > 0 && issym(ch); i++) sname[i] = getch(); sname[i] = 0; /* initialize value */ return (xlenter(sname)); } /* nextch - look at the next non-blank character */ static int nextch() { int ch; /* look for a non-blank character */ while ((ch = thisch()) > 0) if (isspace(ch)) savech = -1; else break; /* return the character */ return (ch); } /* thisch - look at the current character */ static int thisch() { /* return and save the current character */ return (savech = getch()); } /* getch - get the next character */ static int getch() { int ch; /* check for a saved character */ if ((ch = savech) >= 0) savech = -1; else ch = (*xlgetc)(); /* check for the abort character */ if (ch == '\007') { putchar('\n'); #ifdef CNTRLGBREAK xltin(FALSE); #endif xlfail("input aborted"); } /* return the character */ return (ch); } /* issym - check whether a character if valid in a symbol name */ static int issym(ch) int ch; { if (isspace(ch) || ch < ' ' || ch == '(' || ch == ')' || ch == ';' || ch == '.' || ch == '"' || ch == '\'') return (FALSE); else return (TRUE); }