xlisp3.txt - new xlisp release
utzoo!decvax!betz
utzoo!decvax!betz
Thu Mar 31 20:39:24 AEST 1983
<<<<<<<<<< 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 *list,*lnew;
/* make the list */
for (list = NULL; cnt > 0; cnt--) {
lnew = newnode(LIST);
lnew->n_listnext = list;
list = lnew;
}
/* return the list */
return (list);
}
/* 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);
}
More information about the Comp.sources.unix
mailing list