Thread View: net.micro.atari
1 messages
1 total messages
Started by Jwahar R. Bammi
Sat, 18 Jan 1986 20:05
xlisp (PART 6 of 6)
Author: Jwahar R. Bammi
Date: Sat, 18 Jan 1986 20:05
Date: Sat, 18 Jan 1986 20:05
2102 lines
51407 bytes
51407 bytes
#!/bin/sh
# This is a shell archive, meaning:
# 1. Remove everything above the #!/bin/sh line.
# 2. Save the resulting text in a file.
# 3. Execute the file with /bin/sh (not csh) to create the files:
# xlobj.c
# xlprin.c
# xlread.c
# xlstr.c
# xlsubr.c
# xlsym.c
# xlsys.c
# This archive created: Sat Jan 18 14:32:30 1986
# By: Jwahar R. Bammi ()
export PATH; PATH=/bin:$PATH
echo shar: extracting "'xlobj.c'" '(14267 characters)'
if test -f 'xlobj.c'
then
echo shar: over-writing existing file "'xlobj.c'"
fi
sed 's/^X//' << \SHAR_EOF > 'xlobj.c'
X/* xlobj - xlisp object functions */
X/* Copyright (c) 1985, by David Michael Betz
X All Rights Reserved
X Permission is granted for unrestricted non-commercial use */
X
X#include "xlisp.h"
X
X#ifdef MEGAMAX
Xoverlay "overflow"
X#endif
X
X/* external variables */
Xextern NODE *xlstack,*xlenv;
Xextern NODE *s_stdout;
Xextern NODE *self,*msgclass,*msgcls,*class,*object;
Xextern NODE *new,*isnew;
X
X/* instance variable numbers for the class 'Class' */
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/* number of instance variables for the class 'Class' */
X#define CLASSSIZE 7
X
X/* forward declarations */
XFORWARD NODE *entermsg();
XFORWARD NODE *findmsg();
XFORWARD NODE *sendmsg();
XFORWARD NODE *findvar();
XFORWARD NODE *getivar();
XFORWARD NODE *getcvar();
XFORWARD NODE *makelist();
X
X/* xlgetivar - get the value of an instance variable */
XNODE *xlgetivar(obj,num)
X NODE *obj; int num;
X{
X return (car(getivar(obj,num)));
X}
X
X/* xlsetivar - set the value of an instance variable */
Xxlsetivar(obj,num,val)
X NODE *obj; int num; NODE *val;
X{
X rplaca(getivar(obj,num),val);
X}
X
X/* xlclass - define a class */
XNODE *xlclass(name,vcnt)
X char *name; int vcnt;
X{
X NODE *sym,*cls;
X
X /* create the class */
X sym = xlsenter(name);
X setvalue(sym,cls = newnode(OBJ));
X cls->n_obclass = class;
X cls->n_obdata = makelist(CLASSSIZE);
X
X /* set the instance variable counts */
X xlsetivar(cls,IVARCNT,cvfixnum((FIXNUM)vcnt));
X xlsetivar(cls,IVARTOTAL,cvfixnum((FIXNUM)vcnt));
X
X /* set the superclass to 'Object' */
X xlsetivar(cls,SUPERCLASS,object);
X
X /* return the new class */
X return (cls);
X}
X
X/* xladdivar - enter an instance variable */
Xxladdivar(cls,var)
X NODE *cls; char *var;
X{
X NODE *ivar,*lptr;
X
X /* find the 'ivars' instance variable */
X ivar = getivar(cls,IVARS);
X
X /* add the instance variable */
X lptr = newnode(LIST);
X rplacd(lptr,car(ivar));
X rplaca(ivar,lptr);
X rplaca(lptr,xlsenter(var));
X}
X
X/* xladdmsg - add a message to a class */
Xxladdmsg(cls,msg,code)
X NODE *cls; char *msg; NODE *(*code)();
X{
X NODE *mptr;
X
X /* enter the message selector */
X mptr = entermsg(cls,xlsenter(msg));
X
X /* store the method for this message */
X rplacd(mptr,newnode(SUBR));
X cdr(mptr)->n_subr = code;
X}
X
X/* xlsend - send a message to an object (message in arg list) */
XNODE *xlsend(obj,args)
X NODE *obj,*args;
X{
X NODE *oldstk,arglist,*msg,*val;
X
X /* find the message binding for this message */
X if ((msg = findmsg(obj->n_obclass,xlevmatch(SYM,&args))) == NIL)
X xlfail("no method for this message");
X
X /* evaluate the arguments and send the message */
X oldstk = xlsave(&arglist,NULL);
X arglist.n_ptr = xlevlist(args);
X val = sendmsg(obj,msg,arglist.n_ptr);
X xlstack = oldstk;
X
X /* return the result */
X return (val);
X}
X
X/* xlobgetvalue - get the value of an instance variable */
Xint xlobgetvalue(sym,pval)
X NODE *sym,**pval;
X{
X NODE *bnd;
X if ((bnd = findvar(sym)) == NIL)
X return (FALSE);
X *pval = car(bnd);
X return (TRUE);
X}
X
X/* xlobsetvalue - set the value of an instance variable */
Xint xlobsetvalue(sym,val)
X NODE *sym,*val;
X{
X NODE *bnd;
X if ((bnd = findvar(sym)) == NIL)
X return (FALSE);
X rplaca(bnd,val);
X return (TRUE);
X}
X
X/* obisnew - default 'isnew' method */
XLOCAL NODE *obisnew(args)
X NODE *args;
X{
X xllastarg(args);
X return (xlygetvalue(self));
X}
X
X/* obclass - get the class of an object */
XLOCAL NODE *obclass(args)
X NODE *args;
X{
X /* make sure there aren't any arguments */
X xllastarg(args);
X
X /* return the object's class */
X return (xlygetvalue(self)->n_obclass);
X}
X
X/* obshow - show the instance variables of an object */
XLOCAL NODE *obshow(args)
X NODE *args;
X{
X NODE *oldstk,fptr,*obj,*cls,*names;
X int ivtotal,n;
X
X /* create a new stack frame */
X oldstk = xlsave(&fptr,NULL);
X
X /* get the file pointer */
X fptr.n_ptr = (args ? xlgetfile(&args) : getvalue(s_stdout));
X xllastarg(args);
X
X /* get the object and its class */
X obj = xlygetvalue(self);
X cls = obj->n_obclass;
X
X /* print the object and class */
X xlputstr(fptr.n_ptr,"Object is ");
X xlprint(fptr.n_ptr,obj,TRUE);
X xlputstr(fptr.n_ptr,", Class is ");
X xlprint(fptr.n_ptr,cls,TRUE);
X xlterpri(fptr.n_ptr);
X
X /* print the object's instance variables */
X for (cls = obj->n_obclass; cls; cls = xlgetivar(cls,SUPERCLASS)) {
X names = xlgetivar(cls,IVARS);
X ivtotal = getivcnt(cls,IVARTOTAL);
X for (n = ivtotal - getivcnt(cls,IVARCNT); n < ivtotal; ++n) {
X xlputstr(fptr.n_ptr," ");
X xlprint(fptr.n_ptr,car(names),TRUE);
X xlputstr(fptr.n_ptr," = ");
X xlprint(fptr.n_ptr,xlgetivar(obj,n),TRUE);
X xlterpri(fptr.n_ptr);
X names = cdr(names);
X }
X }
X
X /* restore the previous stack frame */
X xlstack = oldstk;
X
X /* return the object */
X return (obj);
X}
X
X/* obsendsuper - send a message to an object's superclass */
XLOCAL NODE *obsendsuper(args)
X NODE *args;
X{
X NODE *obj,*super,*msg;
X
X /* get the object */
X obj = xlygetvalue(self);
X
X /* get the object's superclass */
X super = xlgetivar(obj->n_obclass,SUPERCLASS);
X
X /* find the message binding for this message */
X if ((msg = findmsg(super,xlmatch(SYM,&args))) == NIL)
X xlfail("no method for this message");
X
X /* send the message */
X return (sendmsg(obj,msg,args));
X}
X
X/* clnew - create a new object instance */
XLOCAL NODE *clnew()
X{
X NODE *oldstk,obj,*cls;
X
X /* create a new stack frame */
X oldstk = xlsave(&obj,NULL);
X
X /* get the class */
X cls = xlygetvalue(self);
X
X /* generate a new object */
X obj.n_ptr = newnode(OBJ);
X obj.n_ptr->n_obclass = cls;
X obj.n_ptr->n_obdata = makelist(getivcnt(cls,IVARTOTAL));
X
X /* restore the previous stack frame */
X xlstack = oldstk;
X
X /* return the new object */
X return (obj.n_ptr);
X}
X
X/* clisnew - initialize a new class */
XLOCAL NODE *clisnew(args)
X NODE *args;
X{
X NODE *ivars,*cvars,*super,*cls;
X int n;
X
X /* get the ivars, cvars and superclass */
X ivars = xlmatch(LIST,&args);
X cvars = (args ? xlmatch(LIST,&args) : NIL);
X super = (args ? xlmatch(OBJ,&args) : object);
X xllastarg(args);
X
X /* get the new class object */
X cls = xlygetvalue(self);
X
X /* store the instance and class variable lists and the superclass */
X xlsetivar(cls,IVARS,ivars);
X xlsetivar(cls,CVARS,cvars);
X xlsetivar(cls,CVALS,makelist(listlength(cvars)));
X xlsetivar(cls,SUPERCLASS,super);
X
X /* compute the instance variable count */
X n = listlength(ivars);
X xlsetivar(cls,IVARCNT,cvfixnum((FIXNUM)n));
X n += getivcnt(super,IVARTOTAL);
X xlsetivar(cls,IVARTOTAL,cvfixnum((FIXNUM)n));
X
X /* return the new class object */
X return (cls);
X}
X
X/* clanswer - define a method for answering a message */
XLOCAL NODE *clanswer(args)
X NODE *args;
X{
X NODE *oldstk,arg,msg,fargs,code;
X NODE *obj,*mptr,*fptr;
X
X /* create a new stack frame */
X oldstk = xlsave(&arg,&msg,&fargs,&code,NULL);
X
X /* initialize */
X arg.n_ptr = args;
X
X /* message symbol, formal argument list and code */
X msg.n_ptr = xlmatch(SYM,&arg.n_ptr);
X fargs.n_ptr = xlmatch(LIST,&arg.n_ptr);
X code.n_ptr = xlmatch(LIST,&arg.n_ptr);
X xllastarg(arg.n_ptr);
X
X /* get the object node */
X obj = xlygetvalue(self);
X
X /* make a new message list entry */
X mptr = entermsg(obj,msg.n_ptr);
X
X /* setup the message node */
X rplacd(mptr,fptr = newnode(LIST));
X rplaca(fptr,fargs.n_ptr);
X rplacd(fptr,code.n_ptr);
X
X /* restore the previous stack frame */
X xlstack = oldstk;
X
X /* return the object */
X return (obj);
X}
X
X/* entermsg - add a message to a class */
XLOCAL NODE *entermsg(cls,msg)
X NODE *cls,*msg;
X{
X NODE *ivar,*lptr,*mptr;
X
X /* find the 'messages' instance variable */
X ivar = getivar(cls,MESSAGES);
X
X /* lookup the message */
X for (lptr = car(ivar); lptr != NIL; lptr = cdr(lptr))
X if (car(mptr = car(lptr)) == msg)
X return (mptr);
X
X /* allocate a new message entry if one wasn't found */
X lptr = newnode(LIST);
X rplacd(lptr,car(ivar));
X rplaca(ivar,lptr);
X rplaca(lptr,mptr = newnode(LIST));
X rplaca(mptr,msg);
X
X /* return the symbol node */
X return (mptr);
X}
X
X/* findmsg - find the message binding given an object and a class */
XLOCAL NODE *findmsg(cls,sym)
X NODE *cls,*sym;
X{
X NODE *lptr,*msg;
X
X /* look for the message in the class or superclasses */
X for (msgcls = cls; msgcls != NIL; ) {
X
X /* lookup the message in this class */
X for (lptr = xlgetivar(msgcls,MESSAGES); lptr != NIL; lptr = cdr(lptr))
X if ((msg = car(lptr)) != NIL && car(msg) == sym)
X return (msg);
X
X /* look in class's superclass */
X msgcls = xlgetivar(msgcls,SUPERCLASS);
X }
X
X /* message not found */
X return (NIL);
X}
X
X/* sendmsg - send a message to an object */
XLOCAL NODE *sendmsg(obj,msg,args)
X NODE *obj,*msg,*args;
X{
X NODE *oldstk,oldenv,newenv,method,cptr,val,*isnewmsg;
X
X /* create a new stack frame */
X oldstk = xlsave(&oldenv,&newenv,&method,&cptr,&val,NULL);
X
X /* get the method for this message */
X method.n_ptr = cdr(msg);
X
X /* make sure its a function or a subr */
X if (!subrp(method.n_ptr) && !consp(method.n_ptr))
X xlfail("bad method");
X
X /* create a new environment frame */
X newenv.n_ptr = xlframe(NIL);
X oldenv.n_ptr = xlenv;
X
X /* bind the symbols 'self' and 'msgclass' */
X xlbind(self,obj,newenv.n_ptr);
X xlbind(msgclass,msgcls,newenv.n_ptr);
X
X /* evaluate the function call */
X if (subrp(method.n_ptr)) {
X xlenv = newenv.n_ptr;
X val.n_ptr = (*method.n_ptr->n_subr)(args);
X }
X else {
X
X /* bind the formal arguments */
X xlabind(car(method.n_ptr),args,newenv.n_ptr);
X xlenv = newenv.n_ptr;
X
X /* execute the code */
X cptr.n_ptr = cdr(method.n_ptr);
X while (cptr.n_ptr != NIL)
X val.n_ptr = xlevarg(&cptr.n_ptr);
X }
X
X /* restore the environment */
X xlenv = oldenv.n_ptr;
X
X /* after creating an object, send it the "isnew" message */
X if (car(msg) == new && val.n_ptr != NIL) {
X if ((isnewmsg = findmsg(val.n_ptr->n_obclass,isnew)) == NIL)
X xlfail("no method for the isnew message");
X sendmsg(val.n_ptr,isnewmsg,args);
X }
X
X /* restore the previous stack frame */
X xlstack = oldstk;
X
X /* return the result value */
X return (val.n_ptr);
X}
X
X/* getivcnt - get the number of instance variables for a class */
XLOCAL int getivcnt(cls,ivar)
X NODE *cls; int ivar;
X{
X NODE *cnt;
X if ((cnt = xlgetivar(cls,ivar)) == NIL || !fixp(cnt))
X xlfail("bad value for instance variable count");
X return ((int)cnt->n_int);
X}
X
X/* findvar - find a class or instance variable */
XLOCAL NODE *findvar(sym)
X NODE *sym;
X{
X NODE *obj,*cls,*names;
X int ivtotal,n;
X
X /* get the current object and the message class */
X obj = xlygetvalue(self);
X cls = xlygetvalue(msgclass);
X if (!(objectp(obj) && objectp(cls)))
X return (NIL);
X
X /* find the instance or class variable */
X for (; objectp(cls); cls = xlgetivar(cls,SUPERCLASS)) {
X
X /* check the instance variables */
X names = xlgetivar(cls,IVARS);
X ivtotal = getivcnt(cls,IVARTOTAL);
X for (n = ivtotal - getivcnt(cls,IVARCNT); n < ivtotal; ++n) {
X if (car(names) == sym)
X return (getivar(obj,n));
X names = cdr(names);
X }
X
X /* check the class variables */
X names = xlgetivar(cls,CVARS);
X for (n = 0; consp(names); ++n) {
X if (car(names) == sym)
X return (getcvar(cls,n));
X names = cdr(names);
X }
X }
X
X /* variable not found */
X return (NIL);
X}
X
X/* getivar - get an instance variable */
XLOCAL NODE *getivar(obj,num)
X NODE *obj; int num;
X{
X NODE *ivar;
X
X /* get the instance variable */
X for (ivar = obj->n_obdata; num > 0; num--)
X if (ivar != NIL)
X ivar = cdr(ivar);
X else
X xlfail("bad instance variable list");
X
X /* return the instance variable */
X return (ivar);
X}
X
X/* getcvar - get a class variable */
XLOCAL NODE *getcvar(cls,num)
X NODE *cls; int num;
X{
X NODE *cvar;
X
X /* get the class variable */
X for (cvar = xlgetivar(cls,CVALS); num > 0; num--)
X if (cvar != NIL)
X cvar = cdr(cvar);
X else
X xlfail("bad class variable list");
X
X /* return the class variable */
X return (cvar);
X}
X
X/* listlength - find the length of a list */
XLOCAL int listlength(list)
X NODE *list;
X{
X int len;
X for (len = 0; consp(list); len++)
X list = cdr(list);
X return (len);
X}
X
X/* makelist - make a list of nodes */
XLOCAL NODE *makelist(cnt)
X int cnt;
X{
X NODE *oldstk,list,*lnew;
X
X /* make the list */
X oldstk = xlsave(&list,NULL);
X for (; cnt > 0; cnt--) {
X lnew = newnode(LIST);
X rplacd(lnew,list.n_ptr);
X list.n_ptr = lnew;
X }
X xlstack = oldstk;
X
X /* return the list */
X return (list.n_ptr);
X}
X
X/* xloinit - object function initialization routine */
Xxloinit()
X{
X /* don't confuse the garbage collector */
X class = object = NIL;
X
X /* enter the object related symbols */
X self = xlsenter("SELF");
X msgclass = xlsenter("MSGCLASS");
X new = xlsenter(":NEW");
X isnew = xlsenter(":ISNEW");
X
X /* create the 'Class' object */
X class = xlclass("CLASS",CLASSSIZE);
X class->n_obclass = class;
X
X /* create the 'Object' object */
X object = xlclass("OBJECT",0);
X
X /* finish initializing 'class' */
X xlsetivar(class,SUPERCLASS,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",clnew);
X xladdmsg(class,":ISNEW",clisnew);
X xladdmsg(class,":ANSWER",clanswer);
X
X /* finish initializing 'object' */
X xladdmsg(object,":ISNEW",obisnew);
X xladdmsg(object,":CLASS",obclass);
X xladdmsg(object,":SHOW",obshow);
X xladdmsg(object,":SENDSUPER",obsendsuper);
X}
SHAR_EOF
if test 14267 -ne "`wc -c 'xlobj.c'`"
then
echo shar: error transmitting "'xlobj.c'" '(should have been 14267 characters)'
fi
echo shar: extracting "'xlprin.c'" '(3182 characters)'
if test -f 'xlprin.c'
then
echo shar: over-writing existing file "'xlprin.c'"
fi
sed 's/^X//' << \SHAR_EOF > 'xlprin.c'
X/* xlprint - xlisp print routine */
X/* Copyright (c) 1985, by David Michael Betz
X All Rights Reserved
X Permission is granted for unrestricted non-commercial use */
X
X#include "xlisp.h"
X
X#ifdef MEGAMAX
Xoverlay "io"
X#endif
X
X/* external variables */
Xextern NODE *xlstack;
Xextern char buf[];
X
X/* xlprint - print an xlisp value */
Xxlprint(fptr,vptr,flag)
X NODE *fptr,*vptr; int flag;
X{
X NODE *nptr,*next;
X
X /* print nil */
X if (vptr == NIL) {
X xlputstr(fptr,"NIL");
X return;
X }
X
X /* check value type */
X switch (ntype(vptr)) {
X case SUBR:
X putatm(fptr,"Subr",vptr);
X break;
X case FSUBR:
X putatm(fptr,"FSubr",vptr);
X break;
X case LIST:
X xlputc(fptr,'(');
X for (nptr = vptr; nptr != NIL; nptr = next) {
X xlprint(fptr,car(nptr),flag);
X if (next = cdr(nptr))
X if (consp(next))
X xlputc(fptr,' ');
X else {
X xlputstr(fptr," . ");
X xlprint(fptr,next,flag);
X break;
X }
X }
X xlputc(fptr,')');
X break;
X case SYM:
X xlputstr(fptr,xlsymname(vptr));
X break;
X case INT:
X putdec(fptr,vptr->n_int);
X break;
X case FLOAT:
X putfloat(fptr,vptr->n_float);
X break;
X case STR:
X if (flag)
X putstring(fptr,vptr->n_str);
X else
X xlputstr(fptr,vptr->n_str);
X break;
X case FPTR:
X putatm(fptr,"File",vptr);
X break;
X case OBJ:
X putatm(fptr,"Object",vptr);
X break;
X case FREE:
X putatm(fptr,"Free",vptr);
X break;
X default:
X putatm(fptr,"Foo",vptr);
X break;
X }
X}
X
X/* xlterpri - terminate the current print line */
Xxlterpri(fptr)
X NODE *fptr;
X{
X xlputc(fptr,'\n');
X}
X
X/* xlputstr - output a string */
Xxlputstr(fptr,str)
X NODE *fptr; char *str;
X{
X while (*str)
X xlputc(fptr,*str++);
X}
X
X/* putstring - output a string */
XLOCAL putstring(fptr,str)
X NODE *fptr; char *str;
X{
X int ch;
X
X /* output the initial quote */
X xlputc(fptr,'"');
X
X /* output each character in the string */
X while (ch = *str++)
X
X /* check for a control character */
X if (ch < 040 || ch == '\\') {
X xlputc(fptr,'\\');
X switch (ch) {
X case '\033':
X xlputc(fptr,'e');
X break;
X case '\n':
X xlputc(fptr,'n');
X break;
X case '\r':
X xlputc(fptr,'r');
X break;
X case '\t':
X xlputc(fptr,'t');
X break;
X case '\\':
X xlputc(fptr,'\\');
X break;
X default:
X putoct(fptr,ch);
X break;
X }
X }
X
X /* output a normal character */
X else
X xlputc(fptr,ch);
X
X /* output the terminating quote */
X xlputc(fptr,'"');
X}
X
X/* putatm - output an atom */
XLOCAL putatm(fptr,tag,val)
X NODE *fptr; char *tag; NODE *val;
X{
X sprintf(buf,"#<%s: #",tag); xlputstr(fptr,buf);
X sprintf(buf,AFMT,val); xlputstr(fptr,buf);
X xlputc(fptr,'>');
X}
X
X/* putdec - output a decimal number */
XLOCAL putdec(fptr,n)
X NODE *fptr; FIXNUM n;
X{
X sprintf(buf,IFMT,n);
X xlputstr(fptr,buf);
X}
X
X/* putfloat - output a floating point number */
XLOCAL putfloat(fptr,n)
X NODE *fptr; FLONUM n;
X{
X sprintf(buf,FFMT,n);
X xlputstr(fptr,buf);
X}
X
X/* putoct - output an octal byte value */
XLOCAL putoct(fptr,n)
X NODE *fptr; int n;
X{
X sprintf(buf,"%03o",n);
X xlputstr(fptr,buf);
X}
SHAR_EOF
if test 3182 -ne "`wc -c 'xlprin.c'`"
then
echo shar: error transmitting "'xlprin.c'" '(should have been 3182 characters)'
fi
echo shar: extracting "'xlread.c'" '(9377 characters)'
if test -f 'xlread.c'
then
echo shar: over-writing existing file "'xlread.c'"
fi
sed 's/^X//' << \SHAR_EOF > 'xlread.c'
X/* xlread - xlisp expression input routine */
X/* Copyright (c) 1985, by David Michael Betz
X All Rights Reserved
X Permission is granted for unrestricted non-commercial use */
X
X#include "xlisp.h"
X
X#ifdef MEGAMAX
Xoverlay "io"
X#endif
X
X/* external variables */
Xextern NODE *s_stdout,*true;
Xextern NODE *s_quote,*s_function,*s_bquote,*s_comma,*s_comat;
Xextern NODE *xlstack;
Xextern int xlplevel;
Xextern char buf[];
X
X/* external routines */
Xextern FILE *fopen();
Xextern ITYPE;
Xextern FTYPE;
X
X/* forward declarations */
XFORWARD NODE *plist();
XFORWARD NODE *phexnumber();
XFORWARD NODE *pstring();
XFORWARD NODE *pquote();
XFORWARD NODE *pname();
X
X/* xlload - load a file of xlisp expressions */
Xint xlload(fname,vflag,pflag)
X char *fname; int vflag,pflag;
X{
X NODE *oldstk,fptr,expr;
X CONTEXT cntxt;
X int sts;
X
X /* create a new stack frame */
X oldstk = xlsave(&fptr,&expr,NULL);
X
X /* allocate a file node */
X fptr.n_ptr = newnode(FPTR);
X fptr.n_ptr->n_fp = NULL;
X fptr.n_ptr->n_savech = 0;
X
X /* print the information line */
X if (vflag)
X { sprintf(buf,"; loading \"%s\"\n",fname); stdputstr(buf); }
X
X /* open the file */
X if ((fptr.n_ptr->n_fp = fopen(fname,"r")) == NULL) {
X xlstack = oldstk;
X return (FALSE);
X }
X
X /* read, evaluate and possibly print each expression in the file */
X xlbegin(&cntxt,CF_ERROR,true);
X if (setjmp(cntxt.c_jmpbuf))
X sts = FALSE;
X else {
X while (xlread(fptr.n_ptr,&expr.n_ptr)) {
X expr.n_ptr = xleval(expr.n_ptr);
X if (pflag)
X stdprint(expr.n_ptr);
X }
X sts = TRUE;
X }
X xlend(&cntxt);
X
X /* close the file */
X fclose(fptr.n_ptr->n_fp);
X fptr.n_ptr->n_fp = NULL;
X
X /* restore the previous stack frame */
X xlstack = oldstk;
X
X /* return status */
X return (sts);
X}
X
X/* xlread - read an xlisp expression */
Xint xlread(fptr,pval)
X NODE *fptr,**pval;
X{
X /* initialize */
X xlplevel = 0;
X
X /* parse an expression */
X return (parse(fptr,pval));
X}
X
X/* parse - parse an xlisp expression */
XLOCAL int parse(fptr,pval)
X NODE *fptr,**pval;
X{
X int ch;
X
X /* keep looking for a node skipping comments */
X while (TRUE)
X
X /* check next character for type of node */
X switch (ch = nextch(fptr)) {
X case EOF:
X xlgetc(fptr);
X return (FALSE);
X case '\'': /* a quoted expression */
X xlgetc(fptr);
X *pval = pquote(fptr,s_quote);
X return (TRUE);
X case '#': /* a quoted function */
X xlgetc(fptr);
X switch (ch = xlgetc(fptr)) {
X case '<':
X xlfail("unreadable atom");
X case '\'':
X *pval = pquote(fptr,s_function);
X break;
X case 'x':
X case 'X':
X *pval = phexnumber(fptr);
X break;
X case '\\':
X *pval = cvfixnum((FIXNUM)xlgetc(fptr));
X break;
X default:
X xlfail("unknown character after #");
X }
X return (TRUE);
X case '`': /* a back quoted expression */
X xlgetc(fptr);
X *pval = pquote(fptr,s_bquote);
X return (TRUE);
X case ',': /* a comma or comma-at expression */
X xlgetc(fptr);
X if (xlpeek(fptr) == '@') {
X xlgetc(fptr);
X *pval = pquote(fptr,s_comat);
X }
X else
X *pval = pquote(fptr,s_comma);
X return (TRUE);
X case '(': /* a sublist */
X *pval = plist(fptr);
X return (TRUE);
X case ')': /* closing paren - shouldn't happen */
X xlfail("extra right paren");
X case '.': /* dot - shouldn't happen */
X xlfail("misplaced dot");
X case ';': /* a comment */
X pcomment(fptr);
X break;
X case '"': /* a string */
X *pval = pstring(fptr);
X return (TRUE);
X default:
X if (issym(ch)) /* a name */
X *pval = pname(fptr);
X else
X xlfail("invalid character");
X return (TRUE);
X }
X}
X
X/* phexnumber - parse a hexidecimal number */
XLOCAL NODE *phexnumber(fptr)
X NODE *fptr;
X{
X long num;
X int ch;
X
X num = 0L;
X while ((ch = xlpeek(fptr)) != EOF) {
X if (islower(ch)) ch = toupper(ch);
X if (!isdigit(ch) && !(ch >= 'A' && ch <= 'F'))
X break;
X xlgetc(fptr);
X num = num * 16L + (long)(ch <= '9' ? ch - '0' : ch - 'A' + 10);
X }
X return (cvfixnum((FIXNUM)num));
X}
X
X/* pcomment - parse a comment */
XLOCAL pcomment(fptr)
X NODE *fptr;
X{
X int ch;
X
X /* skip to end of line */
X while ((ch = checkeof(fptr)) != EOF && ch != '\n')
X ;
X}
X
X/* plist - parse a list */
XLOCAL NODE *plist(fptr)
X NODE *fptr;
X{
X NODE *oldstk,val,*lastnptr,*nptr,*p;
X int ch;
X
X /* increment the nesting level */
X xlplevel += 1;
X
X /* create a new stack frame */
X oldstk = xlsave(&val,NULL);
X
X /* skip the opening paren */
X xlgetc(fptr);
X
X /* keep appending nodes until a closing paren is found */
X lastnptr = NIL;
X for (lastnptr = NIL; (ch = nextch(fptr)) != ')'; lastnptr = nptr) {
X
X /* check for end of file */
X if (ch == EOF)
X badeof(fptr);
X
X /* check for a dotted pair */
X if (ch == '.') {
X
X /* skip the dot */
X xlgetc(fptr);
X
X /* make sure there's a node */
X if (lastnptr == NIL)
X xlfail("invalid dotted pair");
X
X /* parse the expression after the dot */
X if (!parse(fptr,&p))
X badeof(fptr);
X rplacd(lastnptr,p);
X
X /* make sure its followed by a close paren */
X if (nextch(fptr) != ')')
X xlfail("invalid dotted pair");
X
X /* done with this list */
X break;
X }
X
X /* allocate a new node and link it into the list */
X nptr = newnode(LIST);
X if (lastnptr == NIL)
X val.n_ptr = nptr;
X else
X rplacd(lastnptr,nptr);
X
X /* initialize the new node */
X if (!parse(fptr,&p))
X badeof(fptr);
X rplaca(nptr,p);
X }
X
X /* skip the closing paren */
X xlgetc(fptr);
X
X /* restore the previous stack frame */
X xlstack = oldstk;
X
X /* decrement the nesting level */
X xlplevel -= 1;
X
X /* return successfully */
X return (val.n_ptr);
X}
X
X/* pstring - parse a string */
XLOCAL NODE *pstring(fptr)
X NODE *fptr;
X{
X NODE *oldstk,val;
X char sbuf[STRMAX+1];
X int ch,i,d1,d2,d3;
X
X /* create a new stack frame */
X oldstk = xlsave(&val,NULL);
X
X /* skip the opening quote */
X xlgetc(fptr);
X
X /* loop looking for a closing quote */
X for (i = 0; i < STRMAX && (ch = checkeof(fptr)) != '"'; i++) {
X switch (ch) {
X case EOF:
X badeof(fptr);
X case '\\':
X switch (ch = checkeof(fptr)) {
X case 'e':
X ch = '\033';
X break;
X case 'n':
X ch = '\n';
X break;
X case 'r':
X ch = '\r';
X break;
X case 't':
X ch = '\t';
X break;
X default:
X if (ch >= '0' && ch <= '7') {
X d1 = ch - '0';
X d2 = checkeof(fptr) - '0';
X d3 = checkeof(fptr) - '0';
X ch = (d1 << 6) + (d2 << 3) + d3;
X }
X break;
X }
X }
X sbuf[i] = ch;
X }
X sbuf[i] = 0;
X
X /* initialize the node */
X val.n_ptr = newnode(STR);
X val.n_ptr->n_str = strsave(sbuf);
X val.n_ptr->n_strtype = DYNAMIC;
X
X /* restore the previous stack frame */
X xlstack = oldstk;
X
X /* return the new string */
X return (val.n_ptr);
X}
X
X/* pquote - parse a quoted expression */
XLOCAL NODE *pquote(fptr,sym)
X NODE *fptr,*sym;
X{
X NODE *oldstk,val,*p;
X
X /* create a new stack frame */
X oldstk = xlsave(&val,NULL);
X
X /* allocate two nodes */
X val.n_ptr = newnode(LIST);
X rplaca(val.n_ptr,sym);
X rplacd(val.n_ptr,newnode(LIST));
X
X /* initialize the second to point to the quoted expression */
X if (!parse(fptr,&p))
X badeof(fptr);
X rplaca(cdr(val.n_ptr),p);
X
X /* restore the previous stack frame */
X xlstack = oldstk;
X
X /* return the quoted expression */
X return (val.n_ptr);
X}
X
X/* pname - parse a symbol name */
XLOCAL NODE *pname(fptr)
X NODE *fptr;
X{
X char sname[STRMAX+1];
X NODE *val;
X int ch,i;
X
X /* get symbol name */
X for (i = 0; i < STRMAX && (ch = xlpeek(fptr)) != EOF && issym(ch); ) {
X sname[i++] = (islower(ch) ? toupper(ch) : ch);
X xlgetc(fptr);
X }
X sname[i] = 0;
X
X /* check for a number or enter the symbol into the oblist */
X return (isnumber(sname,&val) ? val : xlenter(sname,DYNAMIC));
X}
X
X/* nextch - look at the next non-blank character */
XLOCAL int nextch(fptr)
X NODE *fptr;
X{
X int ch;
X
X /* return and save the next non-blank character */
X while ((ch = xlpeek(fptr)) != EOF && isspace(ch))
X xlgetc(fptr);
X return (ch);
X}
X
X/* checkeof - get a character and check for end of file */
XLOCAL int checkeof(fptr)
X NODE *fptr;
X{
X int ch;
X
X if ((ch = xlgetc(fptr)) == EOF)
X badeof(fptr);
X return (ch);
X}
X
X/* badeof - unexpected eof */
XLOCAL badeof(fptr)
X NODE *fptr;
X{
X xlgetc(fptr);
X xlfail("unexpected EOF");
X}
X
X/* isnumber - check if this string is a number */
Xint isnumber(str,pval)
X char *str; NODE **pval;
X{
X int dl,dr;
X char *p;
X
X /* initialize */
X p = str; dl = dr = 0;
X
X /* check for a sign */
X if (*p == '+' || *p == '-')
X p++;
X
X /* check for a string of digits */
X while (isdigit(*p))
X p++, dl++;
X
X /* check for a decimal point */
X if (*p == '.') {
X p++;
X while (isdigit(*p))
X p++, dr++;
X }
X
X /* make sure there was at least one digit and this is the end */
X if ((dl == 0 && dr == 0) || *p)
X return (FALSE);
X
X /* convert the string to an integer and return successfully */
X if (*str == '+') ++str;
X if (str[strlen(str)-1] == '.') str[strlen(str)-1] = 0;
X *pval = (dr ? cvflonum(FCNV(str)) : cvfixnum(ICNV(str)));
X return (TRUE);
X}
X
X/* issym - check whether a character if valid in a symbol name */
XLOCAL int issym(ch)
X int ch;
X{
X if (ch <= ' ' || ch >= 0177 ||
X ch == '(' ||
X ch == ')' ||
X ch == ';' ||
X ch == ',' ||
X ch == '`' ||
X ch == '"' ||
X ch == '\'')
X return (FALSE);
X else
X return (TRUE);
X}
SHAR_EOF
if test 9377 -ne "`wc -c 'xlread.c'`"
then
echo shar: error transmitting "'xlread.c'" '(should have been 9377 characters)'
fi
echo shar: extracting "'xlstr.c'" '(3152 characters)'
if test -f 'xlstr.c'
then
echo shar: over-writing existing file "'xlstr.c'"
fi
sed 's/^X//' << \SHAR_EOF > 'xlstr.c'
X/* xlstr - xlisp string builtin functions */
X/* Copyright (c) 1985, by David Michael Betz
X All Rights Reserved
X Permission is granted for unrestricted non-commercial use */
X
X#include "xlisp.h"
X
X/* external variables */
Xextern NODE *xlstack;
X
X/* external procedures */
Xextern char *strcat();
X
X/* xstrcat - concatenate a bunch of strings */
XNODE *xstrcat(args)
X NODE *args;
X{
X NODE *oldstk,val,*p;
X char *str;
X int len;
X
X /* create a new stack frame */
X oldstk = xlsave(&val,NULL);
X
X /* find the length of the new string */
X for (p = args, len = 0; p; )
X len += strlen(xlmatch(STR,&p)->n_str);
X
X /* create the result string */
X val.n_ptr = newnode(STR);
X val.n_ptr->n_str = str = stralloc(len);
X *str = 0;
X
X /* combine the strings */
X while (args)
X strcat(str,xlmatch(STR,&args)->n_str);
X
X /* restore the previous stack frame */
X xlstack = oldstk;
X
X /* return the new string */
X return (val.n_ptr);
X}
X
X/* xsubstr - return a substring */
XNODE *xsubstr(args)
X NODE *args;
X{
X NODE *oldstk,arg,src,val;
X int start,forlen,srclen;
X char *srcptr,*dstptr;
X
X /* create a new stack frame */
X oldstk = xlsave(&arg,&src,&val,NULL);
X
X /* initialize */
X arg.n_ptr = args;
X
X /* get string and its length */
X src.n_ptr = xlmatch(STR,&arg.n_ptr);
X srcptr = src.n_ptr->n_str;
X srclen = strlen(srcptr);
X
X /* get starting pos -- must be present */
X start = xlmatch(INT,&arg.n_ptr)->n_int;
X
X /* get length -- if not present use remainder of string */
X forlen = (arg.n_ptr ? xlmatch(INT,&arg.n_ptr)->n_int : srclen);
X
X /* make sure there aren't any more arguments */
X xllastarg(arg.n_ptr);
X
X /* don't take more than exists */
X if (start + forlen > srclen)
X forlen = srclen - start + 1;
X
X /* if start beyond string -- return null string */
X if (start > srclen) {
X start = 1;
X forlen = 0; }
X
X /* create return node */
X val.n_ptr = newnode(STR);
X val.n_ptr->n_str = dstptr = stralloc(forlen);
X
X /* move string */
X for (srcptr += start-1; forlen--; *dstptr++ = *srcptr++)
X ;
X *dstptr = 0;
X
X /* restore the previous stack frame */
X xlstack = oldstk;
X
X /* return the substring */
X return (val.n_ptr);
X}
X
X/* xstring - return a string consisting of a single character */
XNODE *xstring(args)
X NODE *args;
X{
X NODE *oldstk,val;
X char *p;
X int ch;
X
X /* get the character (integer) */
X ch = xlmatch(INT,&args)->n_int;
X xllastarg(args);
X
X /* make a one character string */
X oldstk = xlsave(&val,NULL);
X val.n_ptr = newnode(STR);
X val.n_ptr->n_str = p = stralloc(1);
X *p++ = ch; *p = '\0';
X xlstack = oldstk;
X
X /* return the new string */
X return (val.n_ptr);
X}
X
X/* xchar - extract a character from a string */
XNODE *xchar(args)
X NODE *args;
X{
X char *str;
X int n;
X
X /* get the string and the index */
X str = xlmatch(STR,&args)->n_str;
X n = xlmatch(INT,&args)->n_int;
X xllastarg(args);
X
X /* range check the index */
X if (n < 0 || n >= strlen(str))
X xlerror("index out of range",cvfixnum((FIXNUM)n));
X
X /* return the character */
X return (cvfixnum((FIXNUM)str[n]));
X}
SHAR_EOF
if test 3152 -ne "`wc -c 'xlstr.c'`"
then
echo shar: error transmitting "'xlstr.c'" '(should have been 3152 characters)'
fi
echo shar: extracting "'xlsubr.c'" '(4445 characters)'
if test -f 'xlsubr.c'
then
echo shar: over-writing existing file "'xlsubr.c'"
fi
sed 's/^X//' << \SHAR_EOF > 'xlsubr.c'
X/* xlsubr - xlisp builtin function support routines */
X/* Copyright (c) 1985, by David Michael Betz
X All Rights Reserved
X Permission is granted for unrestricted non-commercial use */
X
X#include "xlisp.h"
X
X/* external variables */
Xextern NODE *k_test,*k_tnot,*s_eql;
Xextern NODE *xlstack;
X
X/* xlsubr - define a builtin function */
Xxlsubr(sname,type,subr)
X char *sname; int type; NODE *(*subr)();
X{
X NODE *sym;
X
X /* enter the symbol */
X sym = xlsenter(sname);
X
X /* initialize the value */
X sym->n_symvalue = newnode(type);
X sym->n_symvalue->n_subr = subr;
X}
X
X/* xlarg - get the next argument */
XNODE *xlarg(pargs)
X NODE **pargs;
X{
X NODE *arg;
X
X /* make sure the argument exists */
X if (!consp(*pargs))
X xlfail("too few arguments");
X
X /* get the argument value */
X arg = car(*pargs);
X
X /* move the argument pointer ahead */
X *pargs = cdr(*pargs);
X
X /* return the argument */
X return (arg);
X}
X
X/* xlmatch - get an argument and match its type */
XNODE *xlmatch(type,pargs)
X int type; NODE **pargs;
X{
X NODE *arg;
X
X /* get the argument */
X arg = xlarg(pargs);
X
X /* check its type */
X if (type == LIST) {
X if (arg && ntype(arg) != LIST)
X xlerror("bad argument type",arg);
X }
X else {
X if (arg == NIL || ntype(arg) != type)
X xlerror("bad argument type",arg);
X }
X
X /* return the argument */
X return (arg);
X}
X
X/* xlevarg - get the next argument and evaluate it */
XNODE *xlevarg(pargs)
X NODE **pargs;
X{
X NODE *oldstk,val;
X
X /* create a new stack frame */
X oldstk = xlsave(&val,NULL);
X
X /* get the argument */
X val.n_ptr = xlarg(pargs);
X
X /* evaluate the argument */
X val.n_ptr = xleval(val.n_ptr);
X
X /* restore the previous stack frame */
X xlstack = oldstk;
X
X /* return the argument */
X return (val.n_ptr);
X}
X
X/* xlevmatch - get an evaluated argument and match its type */
XNODE *xlevmatch(type,pargs)
X int type; NODE **pargs;
X{
X NODE *arg;
X
X /* get the argument */
X arg = xlevarg(pargs);
X
X /* check its type */
X if (type == LIST) {
X if (arg && ntype(arg) != LIST)
X xlerror("bad argument type",arg);
X }
X else {
X if (arg == NIL || ntype(arg) != type)
X xlerror("bad argument type",arg);
X }
X
X /* return the argument */
X return (arg);
X}
X
X/* xltest - get the :test or :test-not keyword argument */
Xxltest(pfcn,ptresult,pargs)
X NODE **pfcn; int *ptresult; NODE **pargs;
X{
X NODE *arg;
X
X /* default the argument to eql */
X if (!consp(*pargs)) {
X *pfcn = getvalue(s_eql);
X *ptresult = TRUE;
X return;
X }
X
X /* get the keyword */
X arg = car(*pargs);
X
X /* check the keyword */
X if (arg == k_test)
X *ptresult = TRUE;
X else if (arg == k_tnot)
X *ptresult = FALSE;
X else
X xlfail("expecting :test or :test-not");
X
X /* move the argument pointer ahead */
X *pargs = cdr(*pargs);
X
X /* make sure the argument exists */
X if (!consp(*pargs))
X xlfail("no value for keyword argument");
X
X /* get the argument value */
X *pfcn = car(*pargs);
X
X /* if its a symbol, get its value */
X if (symbolp(*pfcn))
X *pfcn = xleval(*pfcn);
X
X /* move the argument pointer ahead */
X *pargs = cdr(*pargs);
X}
X
X/* xlgetfile - get a file or stream */
XNODE *xlgetfile(pargs)
X NODE **pargs;
X{
X NODE *arg;
X
X /* get a file or stream (cons) or nil */
X if (arg = xlarg(pargs)) {
X if (filep(arg)) {
X if (arg->n_fp == NULL)
X xlfail("file not open");
X }
X else if (!consp(arg))
X xlerror("bad argument type",arg);
X }
X return (arg);
X}
X
X/* xllastarg - make sure the remainder of the argument list is empty */
Xxllastarg(args)
X NODE *args;
X{
X if (args)
X xlfail("too many arguments");
X}
X
X/* eq - internal eq function */
Xint eq(arg1,arg2)
X NODE *arg1,*arg2;
X{
X return (arg1 == arg2);
X}
X
X/* eql - internal eql function */
Xint eql(arg1,arg2)
X NODE *arg1,*arg2;
X{
X if (eq(arg1,arg2))
X return (TRUE);
X else if (fixp(arg1) && fixp(arg2))
X return (arg1->n_int == arg2->n_int);
X else if (floatp(arg1) && floatp(arg2))
X return (arg1->n_float == arg2->n_float);
X else if (stringp(arg1) && stringp(arg2))
X return (strcmp(arg1->n_str,arg2->n_str) == 0);
X else
X return (FALSE);
X}
X
X/* equal - internal equal function */
Xint equal(arg1,arg2)
X NODE *arg1,*arg2;
X{
X /* compare the arguments */
X if (eql(arg1,arg2))
X return (TRUE);
X else if (consp(arg1) && consp(arg2))
X return (equal(car(arg1),car(arg2)) && equal(cdr(arg1),cdr(arg2)));
X else
X return (FALSE);
X}
SHAR_EOF
if test 4445 -ne "`wc -c 'xlsubr.c'`"
then
echo shar: error transmitting "'xlsubr.c'" '(should have been 4445 characters)'
fi
echo shar: extracting "'xlsym.c'" '(5794 characters)'
if test -f 'xlsym.c'
then
echo shar: over-writing existing file "'xlsym.c'"
fi
sed 's/^X//' << \SHAR_EOF > 'xlsym.c'
X/* xlsym - symbol handling routines */
X/* Copyright (c) 1985, by David Michael Betz
X All Rights Reserved
X Permission is granted for unrestricted non-commercial use */
X
X#include "xlisp.h"
X
X/* external variables */
Xextern NODE *oblist,*keylist;
Xextern NODE *s_unbound;
Xextern NODE *xlstack;
Xextern NODE *xlenv;
X
X/* forward declarations */
XFORWARD NODE *symenter();
XFORWARD NODE *findprop();
X
X/* xlenter - enter a symbol into the oblist or keylist */
XNODE *xlenter(name,type)
X char *name;
X{
X return (symenter(name,type,(*name == ':' ? keylist : oblist)));
X}
X
X/* symenter - enter a symbol into a package */
XLOCAL NODE *symenter(name,type,listsym)
X char *name; int type; NODE *listsym;
X{
X NODE *oldstk,*lsym,*nsym,newsym;
X int cmp;
X
X /* check for nil */
X if (strcmp(name,"NIL") == 0)
X return (NIL);
X
X /* check for symbol already in table */
X lsym = NIL;
X nsym = getvalue(listsym);
X while (nsym) {
X if ((cmp = strcmp(name,xlsymname(car(nsym)))) <= 0)
X break;
X lsym = nsym;
X nsym = cdr(nsym);
X }
X
X /* check to see if we found it */
X if (nsym && cmp == 0)
X return (car(nsym));
X
X /* make a new symbol node and link it into the list */
X oldstk = xlsave(&newsym,NULL);
X newsym.n_ptr = newnode(LIST);
X rplaca(newsym.n_ptr,xlmakesym(name,type));
X rplacd(newsym.n_ptr,nsym);
X if (lsym)
X rplacd(lsym,newsym.n_ptr);
X else
X setvalue(listsym,newsym.n_ptr);
X xlstack = oldstk;
X
X /* return the new symbol */
X return (car(newsym.n_ptr));
X}
X
X/* xlsenter - enter a symbol with a static print name */
XNODE *xlsenter(name)
X char *name;
X{
X return (xlenter(name,STATIC));
X}
X
X/* xlmakesym - make a new symbol node */
XNODE *xlmakesym(name,type)
X char *name;
X{
X NODE *oldstk,sym,*str;
X
X /* create a new stack frame */
X oldstk = xlsave(&sym,NULL);
X
X /* make a new symbol node */
X sym.n_ptr = newnode(SYM);
X setvalue(sym.n_ptr,*name == ':' ? sym.n_ptr : s_unbound);
X sym.n_ptr->n_symplist = newnode(LIST);
X rplaca(sym.n_ptr->n_symplist,str = newnode(STR));
X str->n_str = (type == DYNAMIC ? strsave(name) : name);
X str->n_strtype = type;
X
X /* restore the previous stack frame */
X xlstack = oldstk;
X
X /* return the new symbol node */
X return (sym.n_ptr);
X}
X
X/* xlsymname - return the print name of a symbol */
Xchar *xlsymname(sym)
X NODE *sym;
X{
X return (car(sym->n_symplist)->n_str);
X}
X
X/* xlframe - create a new environment frame */
XNODE *xlframe(env)
X NODE *env;
X{
X NODE *ptr;
X ptr = newnode(LIST);
X rplacd(ptr,env);
X return (ptr);
X}
X
X/* xlbind - bind a value to a symbol */
Xxlbind(sym,val,env)
X NODE *sym,*val,*env;
X{
X NODE *ptr;
X
X /* create a new environment list entry */
X ptr = newnode(LIST);
X rplacd(ptr,car(env));
X rplaca(env,ptr);
X
X /* create a new variable binding */
X rplaca(ptr,newnode(LIST));
X rplaca(car(ptr),sym);
X rplacd(car(ptr),val);
X}
X
X/* xlgetvalue - get the value of a symbol (checked) */
XNODE *xlgetvalue(sym)
X NODE *sym;
X{
X NODE *val;
X while ((val = xlxgetvalue(sym)) == s_unbound)
X xlunbound(sym);
X return (val);
X}
X
X/* xlxgetvalue - get the value of a symbol */
XNODE *xlxgetvalue(sym)
X NODE *sym;
X{
X NODE *val;
X
X /* check for this being an instance variable */
X if (xlobgetvalue(sym,&val))
X return (val);
X
X /* get the value from the environment list or the global value */
X return (xlygetvalue(sym));
X}
X
X/* xlygetvalue - get the value of a symbol (no instance variables) */
XNODE *xlygetvalue(sym)
X NODE *sym;
X{
X NODE *fp,*ep;
X
X /* check the environment list */
X for (fp = xlenv; fp; fp = cdr(fp))
X for (ep = car(fp); ep; ep = cdr(ep))
X if (sym == car(car(ep)))
X return (cdr(car(ep)));
X
X /* return the global value */
X return (getvalue(sym));
X}
X
X/* xlsetvalue - set the value of a symbol */
Xxlsetvalue(sym,val)
X NODE *sym,*val;
X{
X NODE *fp,*ep;
X
X /* check for this being an instance variable */
X if (xlobsetvalue(sym,val))
X return;
X
X /* look for the symbol in the environment list */
X for (fp = xlenv; fp; fp = cdr(fp))
X for (ep = car(fp); ep; ep = cdr(ep))
X if (sym == car(car(ep))) {
X rplacd(car(ep),val);
X return;
X }
X
X /* store the global value */
X setvalue(sym,val);
X}
X
X/* xlgetprop - get the value of a property */
XNODE *xlgetprop(sym,prp)
X NODE *sym,*prp;
X{
X NODE *p;
X return ((p = findprop(sym,prp)) ? car(p) : NIL);
X}
X
X/* xlputprop - put a property value onto the property list */
Xxlputprop(sym,val,prp)
X NODE *sym,*val,*prp;
X{
X NODE *oldstk,p,*pair;
X if ((pair = findprop(sym,prp)) == NIL) {
X oldstk = xlsave(&p,NULL);
X p.n_ptr = newnode(LIST);
X rplaca(p.n_ptr,prp);
X rplacd(p.n_ptr,pair = newnode(LIST));
X rplaca(pair,val);
X rplacd(pair,cdr(sym->n_symplist));
X rplacd(sym->n_symplist,p.n_ptr);
X xlstack = oldstk;
X }
X rplaca(pair,val);
X}
X
X/* xlremprop - remove a property from a property list */
Xxlremprop(sym,prp)
X NODE *sym,*prp;
X{
X NODE *last,*p;
X last = NIL;
X for (p = cdr(sym->n_symplist); consp(p) && consp(cdr(p)); p = cdr(last)) {
X if (car(p) == prp)
X if (last)
X rplacd(last,cdr(cdr(p)));
X else
X rplacd(sym->n_symplist,cdr(cdr(p)));
X last = cdr(p);
X }
X}
X
X/* findprop - find a property pair */
XLOCAL NODE *findprop(sym,prp)
X NODE *sym,*prp;
X{
X NODE *p;
X for (p = cdr(sym->n_symplist); consp(p) && consp(cdr(p)); p = cdr(cdr(p)))
X if (car(p) == prp)
X return (cdr(p));
X return (NIL);
X}
X
X/* xlsinit - symbol initialization routine */
Xxlsinit()
X{
X /* initialize the oblist */
X oblist = xlmakesym("*OBLIST*",STATIC);
X setvalue(oblist,newnode(LIST));
X rplaca(getvalue(oblist),oblist);
X
X /* initialize the keyword list */
X keylist = xlsenter("*KEYLIST*");
X
X /* enter the unbound symbol indicator */
X s_unbound = xlsenter("*UNBOUND*");
X setvalue(s_unbound,s_unbound);
X}
SHAR_EOF
if test 5794 -ne "`wc -c 'xlsym.c'`"
then
echo shar: error transmitting "'xlsym.c'" '(should have been 5794 characters)'
fi
echo shar: extracting "'xlsys.c'" '(3738 characters)'
if test -f 'xlsys.c'
then
echo shar: over-writing existing file "'xlsys.c'"
fi
sed 's/^X//' << \SHAR_EOF > 'xlsys.c'
X/* xlsys.c - xlisp builtin system functions */
X/* Copyright (c) 1985, by David Michael Betz
X All Rights Reserved
X Permission is granted for unrestricted non-commercial use */
X
X#include "xlisp.h"
X
X/* external variables */
Xextern NODE *xlstack,*xlenv;
Xextern int anodes;
X
X/* external symbols */
Xextern NODE *a_subr,*a_fsubr;
Xextern NODE *a_list,*a_sym,*a_int,*a_float,*a_str,*a_obj,*a_fptr;
Xextern NODE *true;
X
X/* xload - direct input from a file */
XNODE *xload(args)
X NODE *args;
X{
X NODE *oldstk,fname,*val;
X int vflag,pflag;
X
X /* create a new stack frame */
X oldstk = xlsave(&fname,NULL);
X
X /* get the file name, verbose flag and print flag */
X fname.n_ptr = xlmatch(STR,&args);
X vflag = (args ? xlarg(&args) != NIL : TRUE);
X pflag = (args ? xlarg(&args) != NIL : FALSE);
X xllastarg(args);
X
X /* load the file */
X val = (xlload(fname.n_ptr->n_str,vflag,pflag) ? true : NIL);
X
X /* restore the previous stack frame */
X xlstack = oldstk;
X
X /* return the status */
X return (val);
X}
X
X/* xgc - xlisp function to force garbage collection */
XNODE *xgc(args)
X NODE *args;
X{
X /* make sure there aren't any arguments */
X xllastarg(args);
X
X /* garbage collect */
X gc();
X
X /* return nil */
X return (NIL);
X}
X
X/* xexpand - xlisp function to force memory expansion */
XNODE *xexpand(args)
X NODE *args;
X{
X int n,i;
X
X /* get the new number to allocate */
X n = (args ? xlmatch(INT,&args)->n_int : 1);
X xllastarg(args);
X
X /* allocate more segments */
X for (i = 0; i < n; i++)
X if (!addseg())
X break;
X
X /* return the number of segments added */
X return (cvfixnum((FIXNUM)i));
X}
X
X/* xalloc - xlisp function to set the number of nodes to allocate */
XNODE *xalloc(args)
X NODE *args;
X{
X int n,oldn;
X
X /* get the new number to allocate */
X n = xlmatch(INT,&args)->n_int;
X
X /* make sure there aren't any more arguments */
X xllastarg(args);
X
X /* set the new number of nodes to allocate */
X oldn = anodes;
X anodes = n;
X
X /* return the old number */
X return (cvfixnum((FIXNUM)oldn));
X}
X
X/* xmem - xlisp function to print memory statistics */
XNODE *xmem(args)
X NODE *args;
X{
X /* make sure there aren't any arguments */
X xllastarg(args);
X
X /* print the statistics */
X stats();
X
X /* return nil */
X return (NIL);
X}
X
X/* xtype - return type of a thing */
XNODE *xtype(args)
X NODE *args;
X{
X NODE *arg;
X
X if (!(arg = xlarg(&args)))
X return (NIL);
X
X switch (ntype(arg)) {
X case SUBR: return (a_subr);
X case FSUBR: return (a_fsubr);
X case LIST: return (a_list);
X case SYM: return (a_sym);
X case INT: return (a_int);
X case FLOAT: return (a_float);
X case STR: return (a_str);
X case OBJ: return (a_obj);
X case FPTR: return (a_fptr);
X default: xlfail("bad node type");
X }
X}
X
X/* xbaktrace - print the trace back stack */
XNODE *xbaktrace(args)
X NODE *args;
X{
X int n;
X
X n = (args ? xlmatch(INT,&args)->n_int : -1);
X xllastarg(args);
X xlbaktrace(n);
X return (NIL);
X}
X
X/* xexit - get out of xlisp */
XNODE *xexit(args)
X NODE *args;
X{
X xllastarg(args);
X exit();
X}
X
X/* xpeek - peek at a location in 68000 memory */
XNODE *xpeek(args)
X NODE *args;
X{
X int *adr;
X adr = (int *)xlmatch(INT,&args)->n_int;
X xllastarg(args);
X return (cvfixnum((FIXNUM)*adr));
X}
X
X/* xpoke - poke a location in 68000 memory */
XNODE *xpoke(args)
X NODE *args;
X{
X NODE *val;
X int *adr;
X adr = (int *)xlmatch(INT,&args)->n_int;
X val = xlmatch(INT,&args);
X xllastarg(args);
X *adr = val->n_int;
X return (val);
X}
X
X/* xaddressof - return the address of an XLISP node */
XNODE *xaddressof(args)
X NODE *args;
X{
X NODE *node;
X node = xlarg(&args);
X xllastarg(args);
X return (cvfixnum((FIXNUM)node));
X}
SHAR_EOF
if test 3738 -ne "`wc -c 'xlsys.c'`"
then
echo shar: error transmitting "'xlsys.c'" '(should have been 3738 characters)'
fi
# End of shell archive
exit 0
--
Jwahar R. Bammi
Usenet: .....!decvax!cwruecmp!bammi
CSnet: bammi@case
Arpa: bammi%case@csnet-relay
CompuServe: 71515,155
Thread Navigation
This is a paginated view of messages in the thread with full content displayed inline.
Messages are displayed in chronological order, with the original post highlighted in green.
Use pagination controls to navigate through all messages in large threads.
Back to All Threads