john@x.UUCP (John Woods) (08/27/84)
This represents part 5 of 5 of my modified XLISP. Tear at the dotted line,
and run "sh" over it to extract.
Thanks to Dave Betz for providing the original XLISP.
________________________________________________________________
echo extract with /bin/sh, not /bin/csh
echo x xlread.c
sed -n -e 's/^X//p' > xlread.c << '!Funky!Stuff!'
X
X /* xlread - xlisp expression input routine */
X#define static
X#ifdef CI_86
X#include "a:stdio.h"
X#include "xlisp.h"
X#endif
X
X#ifdef AZTEC
X#include "a:stdio.h"
X#include "xlisp.h"
X#endif
X
X#ifdef unix
X#include <stdio.h>
X#include <ctype.h>
X#include "xlisp.h"
X#endif
X
X /* global variables */
X
Xstruct node *oblist;
X
X /* external variables */
X
Xextern struct node *xlstack;
Xextern int (*xlgetc)();
Xextern int xlplevel;
X
X /* local variables */
X
Xstatic int savech;
X#ifdef HACK
X /* forward declarations (the extern hack is for decusc) */
X
Xextern struct node *parse();
Xextern struct node *plist();
Xextern struct node *pstring();
Xextern struct node *pnumber();
Xextern struct node *pquote();
Xextern struct node *pname();
X#endif
X#ifdef REALS
Xextern struct node *pfloat();
X#endif
X
X /**************************************
X * xlread - read an xlisp expression *
X **************************************/
X
Xstruct node *xlread()
X{
X savech = -1; /* initialize */
X xlplevel = 0;
X
X return (parse()); /* Parse an expression */
X}
X
X
X /**************************************
X * parse - parse an xlisp expression *
X **************************************/
X
Xstatic struct node *parse()
X{
X int ch;
X
X while (TRUE) /* Look for a node, skipp comments */
X {
X switch (ch = nextch()) /* Switch on next character */
X {
X case '\'': /* a quoted expression */
X return (pquote());
X
X case '(': /* a sublist */
X return (plist());
X
X case ')': /* closing paren - shouldn't happen */
X/* xlfail("extra right paren"); */
X getch();
X break;
X
X case '.':
X#ifdef REALS
X return (pfloat(0)); /* Real fractional only */
X#else
X xlfail("misplaced dot");/* dot - shouldn't happen */
X#endif
X
X case ';': /* a comment */
X pcomment();
X break;
X
X case '|': /* a superquoted symbol */
X case '"': /* a string */
X return (pstring(ch));
X
X default:
X if (!issym(ch))
X xlfail("invalid character");
X /* else ... */
X case '\\':
X return (pword());
X }
X }
X}
X
X
X /*******************************
X * pcomment - parse a comment *
X *******************************/
X
Xstatic pcomment()
X{
X while (getch() != '\n') /* Skip to end of line */
X ;
X}
X
X
X /*************************
X * plist - parse a list *
X *************************/
X
Xstatic struct node *plist()
X{
X struct node *oldstk,val,*lastnptr,*nptr;
X int ch;
X
X xlplevel += 1; /* Increment nesting level */
X oldstk = xlsave(&val,NULL); /* Create .... */
X savech = -1; /* Skip opend paren */
X
X /* keep appending nodes until a closing paren is found */
X for (lastnptr = NULL; (ch = nextch()) > 0 && ch != ')'; lastnptr = nptr)
X {
X if (ch == '.') /* Check for a dotted pair */
X {
X savech = -1; /* Skip the dot */
X
X if (lastnptr == NULL) /* Make sure there is a node */
X xlfail("invalid dotted pair");
X
X lastnptr->n_listnext = parse(); /* Parse expression */
X
X if (nextch() != ')') /* Check for closing paren */
X xlfail("invalid dotted pair");
X
X break; /* Done with this list */
X }
X
X nptr = newnode(LIST); /* Allocate and link new node */
X if (lastnptr == NULL)
X val.n_ptr = nptr;
X else
X lastnptr->n_listnext = nptr;
X
X nptr->n_listvalue = parse(); /* Initialize it */
X }
X
X savech = -1; /* Skip the closing paren */
X
X xlstack = oldstk; /* Restore previous stack frame */
X xlplevel -= 1; /* Decrement nesting level */
X
X return (val.n_ptr); /* Successful return */
X}
X
X /*****************************
X * pstring - parse a string *
X *****************************/
X
Xstatic struct node *pstring(term)
X int term; /* terminator */
X{
X struct node *oldstk,val;
X char sbuf[STRMAX+1];
X int ch,i,d1,d2,d3;
X
X oldstk = xlsave(&val,NULL); /* Create a new stack frame */
X savech = -1; /* Skip opening quote */
X
X /* loop looking for a closing qte */
X for (i = 0; i < STRMAX && (ch = getch()) != term; i++)
X {
X switch (ch)
X {
X case '\\':
X switch (ch = getch())
X {
X case 'e':
X ch = '\033';
X break;
X
X case 'n':
X ch = '\n';
X break;
X
X case 'r':
X ch = '\r';
X break;
X
X case 't':
X ch = '\t';
X break;
X
X case '0':
X case '1':
X case '2':
X case '3':
X case '4':
X case '5':
X case '6':
X case '7':
X d1 = ch - '0';
X while (((ch = getch()) >= '0') && (ch < '8'))
X d1 = d1 <<3 + (ch - '0');
X ch = d1;
X break;
X
X default:
X break;
X }
X }
X sbuf[i] = ch;
X }
X sbuf[i] = 0;
X
X if (term == '|')
X return xlenter(sbuf);
X
X val.n_ptr = newnode(STR); /* Initialize the node */
X val.n_ptr->n_str = strsave(sbuf);
X
X xlstack = oldstk; /* Restore old stack frame */
X return (val.n_ptr); /* .. and return */
X}
X
X
X#ifdef REALS
X /********************************************************
X * pfloat - parse the fractional part of a real number *
X ********************************************************/
X
Xstatic struct node *pfloat(i)
X int i;
X{
X struct node *val;
X int ch;
X long float rval = (float) ((i<0) ? -i : i), fp= 1;
X
X for ( ; isdigit(ch = thisch()); savech = -1)
X rval = rval + (ch - '0')/(fp *= 10);
X
X if (issym(ch)) /* ensure correct termination */
X xlfail("badly formed number");
X
X val = newnode(REAL); /* Initialze the new node */
X val->n_real = (i < 0) ? -rval : rval;
X
X return (val);
X}
X#endif
X
X /*****************************
X * pnumber - parse a number *
X *****************************/
X
Xstruct node *pnumber(buf)
X char *buf;
X{
X struct node *val;
X int ch,ival = 0, sign = 1;
X
X if (*buf == '+') buf++;
X else if (*buf == '-') sign = -1, buf++;
X
X for ( ; isdigit(*buf); ++buf) /* loop while digits */
X ival = ival * 10 + *buf - '0';
X
X#ifdef REALS
X if (thisch() == '.')
X {
X savech = -1;
X return pfloat(sign*ival);
X }
X#endif
X
X val = newnode(INT); /* Initialze the new node */
X val->n_int = sign * ival;
X
X return (val);
X}
X
X /* isallnumeric - is all of this char buffer numeric? */
Xint isallnumeric(s) char *s;
X{
X if (*s == '+' || *s == '-') {
X s++;
X if (!*s) return 0;
X }
X while (*s) if (!isdigit(*s)) return 0; else s++;
X return 1;
X}
X
X /***************************************************
X * xlenter - enter a symbol into the symbol table *
X ***************************************************/
X
Xstruct node *xlenter(sname)
X char *sname;
X{
X struct node *sptr;
X
X if (strcmp(sname,"nil") == 0) /* Check for nil */
X return (NULL);
X
X if (oblist == NULL) /* Create oblist if required */
X {
X oblist = newnode(SYM);
X oblist->n_symname = strsave("oblist");
X oblist->n_symvalue = newnode(LIST);
X oblist->n_symvalue->n_listvalue = oblist;
X }
X
X sptr = oblist->n_symvalue; /* check for symbol already in table */
X while (sptr != NULL)
X {
X if (sptr->n_listvalue == NULL)
X {
X printf("bad oblist\n");
X sptr = oblist->n_symvalue;
X while (sptr != NULL)
X {
X if (sptr->n_listvalue == NULL)
X xlfail("end oblist");
X printf("\n%s",sptr->n_listvalue->n_symname);
X sptr = sptr->n_listnext;
X }
X }
X else if (sptr->n_listvalue->n_symname == NULL)
X printf("bad oblist symbol\n");
X else
X if (strcmp(sptr->n_listvalue->n_symname,sname) == 0)
X return (sptr->n_listvalue);
X sptr = sptr->n_listnext;
X }
X
X sptr = newnode(LIST); /* Create and link new symbol */
X sptr->n_listnext = oblist->n_symvalue;
X oblist->n_symvalue = sptr;
X sptr->n_listvalue = newnode(SYM);
X sptr->n_listvalue->n_symname = strsave(sname);
X
X return (sptr->n_listvalue);
X}
X
X
X /***************************************
X * pquote - parse a quoted expression *
X ***************************************/
X
Xstatic struct node *pquote()
X{
X struct node *oldstk,val;
X
X oldstk = xlsave(&val,NULL); /* Create new stack frame */
X savech = -1; /* Skip the quote character */
X
X val.n_ptr = newnode(LIST); /* Allocate two new nodes */
X val.n_ptr->n_listvalue = xlenter("quote");
X val.n_ptr->n_listnext = newnode(LIST);
X val.n_ptr->n_listnext->n_listvalue = parse();
X
X xlstack = oldstk; /* Restore old stack frame */
X return (val.n_ptr); /* .. return quoted expression */
X}
X
X
X /********************************************
X * pword - parse a symbol name or a number *
X *********************************************/
X
Xstruct node *pword()
X{
X char sname[STRMAX+1];
X int ch,i, quoted = 0;
X
X /* get symbol name */
X for (i = 0; i < STRMAX && (issym(ch = thisch()) || ch == '\\'); i++)
X { if (ch == '\\')
X { quoted = 1;
X savech = -1;
X }
X sname[i] = getch();
X }
X sname[i] = 0;
X
X if (!quoted && isallnumeric(sname))
X return (pnumber(sname)); /* create number */
X
X return (xlenter(sname)); /* Create symbol */
X}
X
X
X /**************************************************
X * nextch - look at the next non-blank character *
X **************************************************/
X
Xstatic int nextch()
X{
X while (isspace(thisch())) /* Find non blank character */
X savech = -1;
X
X return savech; /* .. and return it */
X}
X
X
X /*******************************************
X * thisch - look at the current character *
X *******************************************/
X
Xstatic int thisch()
X{
X return (savech = getch()); /* return and save next character */
X}
X
X
X /***********************************
X * getch - get the next character *
X ***********************************/
X
Xstatic int getch()
X{
X int ch;
X
X if ((ch = savech) >= 0) /* Check for saved character */
X savech = -1;
X else
X ch = (*xlgetc)();
X
X if (ch == EOF) /* Check for abort character */
X if (xlplevel > 0)
X {
X putchar('\n');
X xltin(FALSE);
X xlfail("input aborted");
X }
X else
X exit();
X
X return (ch); /* Return char */
X}
X
X
X /****************************************************************
X * issym - check whether a character if valid in a symbol name *
X ****************************************************************/
X
Xstatic int issym(ch)
X int ch;
X{
X if (isspace(ch))
X return FALSE;
X
X return (index("();.\"'|\\",ch) == 0);
X
X}
!Funky!Stuff!
echo x xlstr.c
sed -n -e 's/^X//p' > xlstr.c << '!Funky!Stuff!'
X /* xlstr - xlisp string builtin functions */
X
X#ifdef CI_86
X#include "a:stdio.h"
X#include "xlisp.h"
X#endif
X
X#ifdef AZTEC
X#include "a:stdio.h"
X#include "xlisp.h"
X#endif
X
X#ifdef unix
X#include <stdio.h>
X#include "xlisp.h"
X#endif
X
X
X /* external variables */
X
Xextern struct node *xlstack;
X
X
X /* external procedures */
X
Xextern char *strcat();
X
X
X /*********************************
X * xstrlen - length of a string *
X *********************************/
X
Xstatic struct node *xstrlen(args)
X struct node *args;
X{
X struct node *oldstk,arg,*val;
X int total;
X
X oldstk = xlsave(&arg,NULL);
X arg.n_ptr = args;
X total = 0;
X
X while (arg.n_ptr != NULL)
X total += strlen(xlmatch(STR,&arg.n_ptr)->n_str);
X
X xlstack = oldstk;
X
X val = newnode(INT);
X val->n_int = total;
X
X return (val);
X}
X
X
X /*********************************************
X * xstrcat - concatenate a bunch of strings *
X *********************************************/
X
X
Xstatic struct node *xstrcat(args)
X struct node *args;
X{
X/* this routine does it the dumb way -- one at a time */
X struct node *oldstk,arg,val,rval;
X int newlen;
X char *result,*argstr,*newstr;
X
X oldstk = xlsave(&arg,&val,&rval,NULL);
X arg.n_ptr = args;
X rval.n_ptr = newnode(STR);
X rval.n_ptr->n_str = result = stralloc(0);
X *result = 0;
X
X while (arg.n_ptr != NULL) {
X val.n_ptr = xlmatch(STR,&arg.n_ptr);
X argstr = val.n_ptr->n_str;
X newlen = strlen(result) + strlen(argstr);
X newstr = stralloc(newlen);
X strcpy(newstr,result);
X strfree(result);
X rval.n_ptr->n_str = result = strcat(newstr,argstr);
X }
X
X xlstack = oldstk;
X return (rval.n_ptr);
X}
X
X
X /********************************
X * substr - return a substring *
X ********************************/
X
Xstatic struct node *substr(args)
X struct node *args;
X{
X struct node *oldstk,arg,src,val;
X int start,forlen,srclen;
X char *srcptr,*dstptr;
X
X oldstk = xlsave(&arg,&src,&val,NULL);
X arg.n_ptr = args;
X
X src.n_ptr = xlmatch(STR,&arg.n_ptr);
X srcptr = src.n_ptr->n_str;
X srclen = strlen(srcptr);
X
X start = xlmatch(INT,&arg.n_ptr)->n_int;
X
X if (arg.n_ptr != NULL)
X forlen = xlmatch(INT,&arg.n_ptr)->n_int;
X else
X forlen = srclen; /* use len and fix below */
X
X xllastarg(arg.n_ptr);
X
X if (start + forlen > srclen)
X forlen = srclen - start + 1;
X
X if (start > srclen)
X {
X start = 1;
X forlen = 0;
X }
X
X val.n_ptr = newnode(STR);
X val.n_ptr->n_str = dstptr = stralloc(forlen);
X
X for (srcptr += start-1; forlen--; *dstptr++ = *srcptr++)
X ;
X
X *dstptr = 0;
X
X xlstack = oldstk;
X return (val.n_ptr);
X}
X
X
X /*******************************
X * ascii - return ascii value *
X *******************************/
X
Xstatic struct node *ascii(args)
X struct node *args;
X{
X struct node *oldstk,val;
X
X oldstk = xlsave(&val,NULL);
X
X val.n_ptr = newnode(INT);
X val.n_ptr->n_int = *(xlmatch(STR,&args)->n_str);
X
X xllastarg(args);
X
X xlstack = oldstk;
X return (val.n_ptr);
X}
X
X
X /***********************************************************
X * chr - convert an INT into a one character ascii string *
X ***********************************************************/
X
Xstatic struct node *chr(args)
X struct node *args;
X{
X struct node *oldstk,val;
X char *sptr;
X
X oldstk = xlsave(&val,NULL);
X
X val.n_ptr = newnode(STR);
X val.n_ptr->n_str = sptr = stralloc(1);
X *sptr++ = xlmatch(INT,&args)->n_int;
X *sptr = 0;
X
X xllastarg(args);
X
X xlstack = oldstk;
X return (val.n_ptr);
X}
X
X
X /**************************************************
X * xatoi - convert an ascii string to an integer *
X **************************************************/
X
Xstatic struct node *xatoi(args)
X struct node *args;
X{
X struct node *val;
X int n;
X
X n = atoi(xlmatch(STR,&args)->n_str);
X
X xllastarg(args);
X
X val = newnode(INT);
X val->n_int = n;
X return (val);
X}
X
X
X /**************************************************
X * xitoa - convert an integer to an ascii string *
X **************************************************/
X
Xstatic struct node *xitoa(args)
X struct node *args;
X{
X struct node *val;
X char buf[20];
X
X sprintf(buf,"%d",xlmatch(INT,&args)->n_int);
X
X xllastarg(args);
X
X val = newnode(STR);
X val->n_str = strsave(buf);
X return (val);
X}
X
X
X /**************************************************
X * xlsinit - xlisp string initialization routine *
X **************************************************/
X
Xxlsinit()
X{
X xlsubr("strlen",xstrlen);
X xlsubr("strcat",xstrcat);
X xlsubr("substr",substr);
X xlsubr("ascii",ascii);
X xlsubr("chr", chr);
X xlsubr("atoi",xatoi);
X xlsubr("itoa",xitoa);
X}
!Funky!Stuff!
echo x xlsubr.c
sed -n -e 's/^X//p' > xlsubr.c << '!Funky!Stuff!'
X /* xlfsubr - xlisp builtin functions */
X#ifdef CI_86
X#include "a:stdio.h"
X#include "xlisp.h"
X#endif
X
X#ifdef AZTEC
X#include "a:stdio.h"
X#include "xlisp.h"
X#endif
X
X#ifdef unix
X#include <stdio.h>
X#include "xlisp.h"
X#endif
X
X /* external variables */
X
Xextern int (*xlgetc)();
Xextern struct node *xlstack;
X
X /* global variables */
X
Xstruct node *Lambda, *Fexpr, *Macro;
Xstruct node *Subrprop, *Fsubrprop, *Exprop, *Fexprop, *Macprop;
X
X /* local variables */
Xstatic char *sgetptr;
Xstatic struct node *t;
X
X /***************************************
X * xlsubr - define a builtin function *
X ***************************************/
X
Xxlsubr(sname,subr)
X char *sname; struct node *(*subr)();
X{
X struct node *sym, *newsubr;
X
X sym = xlenter(sname); /* Enter the symbol */
X
X (newsubr = newnode(SUBR))->n_subr = subr;
X xlputprop(sym,newsubr,Subrprop);
X}
X
X
X /*********************************************
X * xlfsubr - define a builtin funny function *
X **********************************************/
X
Xxlfsubr(sname,fsubr)
X char *sname; struct node *(*fsubr)();
X{
X struct node *sym, *newsubr;
X
X sym = xlenter(sname); /* Enter the symbol */
X
X (newsubr = newnode(FSUBR))->n_subr = fsubr;
X xlputprop(sym,newsubr,Fsubrprop);
X}
X
X
X /**********************************************
X * xlsvar - define a builtin string variable *
X **********************************************/
X
Xxlsvar(sname,str)
X char *sname,*str;
X{
X struct node *sym;
X
X sym = xlenter(sname); /* Enter the symbol */
X
X sym->n_symvalue = newnode(STR); /* Initialize the value */
X sym->n_symvalue->n_str = strsave(str);
X}
X
X
X /**********************************
X * xlarg - get the next argument *
X **********************************/
X
Xstruct node *xlarg(pargs)
X struct node **pargs;
X{
X struct node *arg;
X
X if (*pargs == NULL) /* Does argument exist ? */
X xlfail("too few arguments");
X
X arg = (*pargs)->n_listvalue; /* If so get its value */
X *pargs = (*pargs)->n_listnext; /* and mov arg pointer ahead */
X
X return (arg);
X}
X
X
X /*************************************************
X * xlmatch - get an argument and match its type *
X *************************************************/
X
Xstruct node *xlmatch(type,pargs)
X int type; struct node **pargs;
X{
X struct node *arg;
X
X arg = xlarg(pargs); /* Get the argument */
X if (type == LIST) /* Check its type */
X {
X if (arg != NULL && arg->n_type != LIST)
X xlfail("bad argument type");
X }
X else
X {
X if (arg == NULL || arg->n_type != type)
X xlfail("bad argument type");
X }
X
X return (arg);
X}
X
X
X /****************************************************
X * xlevarg - get the next argument and evaluate it *
X ****************************************************/
X
Xstruct node *xlevarg(pargs)
X struct node **pargs;
X{
X struct node *oldstk,val;
X
X oldstk = xlsave(&val,NULL); /* Creat new stack frame */
X
X val.n_ptr = xlarg(pargs); /* Get and evaluate the argument */
X val.n_ptr = xleval(val.n_ptr);
X
X xlstack = oldstk; /* Restore old stack frame */
X return (val.n_ptr);
X}
X
X
X /*************************************************************
X * xlevmatch - get an evaluated argument and match its type *
X *************************************************************/
X
Xstruct node *xlevmatch(type,pargs)
X int type; struct node **pargs;
X{
X struct node *arg;
X
X arg = xlevarg(pargs); /* Get argument and check type */
X if (type == LIST)
X {
X if (arg != NULL && arg->n_type != LIST)
X xlfail("bad argument type");
X }
X else
X {
X if (arg == NULL || arg->n_type != type)
X xlfail("bad argument type");
X }
X
X return (arg);
X}
X
X
X /**********************************************************************
X * xllastarg - make sure the remainder of the argument list is empty *
X **********************************************************************/
X
Xxllastarg(args)
X struct node *args;
X{
X if (args != NULL)
X xlfail("too many arguments");
X}
X
X
X /****************************************
X * assign - assign a value to a symbol *
X ****************************************/
X
Xstatic assign(sym,val)
X struct node *sym,*val;
X{
X struct node *lptr;
X
X if ((lptr = xlobsym(sym)) != NULL) /* Check for a current object */
X lptr->n_listvalue = val;
X else
X sym->n_symvalue = val;
X}
X
X
X /*******************************
X * set - builtin function set *
X *******************************/
X
Xstatic struct node *set(args)
X struct node *args;
X{
X struct node *oldstk,arg,sym,val;
X
X oldstk = xlsave(&arg,&sym,&val,NULL); /* Create new stack frame */
X arg.n_ptr = args;
X
X sym.n_ptr = xlmatch(SYM,&arg.n_ptr); /* Get symbol */
X val.n_ptr = xlarg(&arg.n_ptr);
X xllastarg(arg.n_ptr);
X assign(sym.n_ptr,val.n_ptr);
X
X xlstack = oldstk; /* Restore old stack frame */
X return (val.n_ptr);
X}
X
X
X /*********************************
X * setq - builtin function setq *
X *********************************/
X
Xstatic struct node *setq(args)
X struct node *args;
X{
X struct node *oldstk,arg,sym,val;
X
X oldstk = xlsave(&arg,&sym,&val,NULL); /* Create new stack frame */
X arg.n_ptr = args;
X
X sym.n_ptr = xlmatch(SYM,&arg.n_ptr); /* get symbol */
X val.n_ptr = xlevarg(&arg.n_ptr);
X xllastarg(arg.n_ptr);
X assign(sym.n_ptr,val.n_ptr);
X
X xlstack = oldstk; /* Restore old stack frame */
X return (val.n_ptr);
X}
X
X
X /************************************
X * load - direct input from a file *
X ************************************/
X
Xstatic struct node *load(args)
X struct node *args;
X{
X struct node *fname;
X
X fname = xlmatch(STR,&args); /* Get file name */
X xllastarg(args);
X
X xlfin(fname->n_str);
X
X return (fname);
X}
X
X
X /***********************************
X * defun - builtin function defun *
X ***********************************/
X
Xstatic struct node *defun(args)
X struct node *args;
X{
X struct node *oldstk,arg,sym,fargs,fun, *p;
X int macro = 0, fexpr = 0;
X
X /* create a new stack frame */
X oldstk = xlsave(&arg,&sym,&fargs,&fun,NULL);
X
X /* initialize */
X arg.n_ptr = args;
X
X /* get the function symbol */
X sym.n_ptr = xlmatch(SYM,&arg.n_ptr);
X
X /* get the formal argument list */
X fargs.n_ptr = xlarg(&arg.n_ptr);
X
X /* is this a magic form? */
X if ((xeq(fargs.n_ptr,Macro) && (macro=1))
X || (xeq(fargs.n_ptr,Fexpr) && (fexpr=1)))
X { fargs.n_ptr = xlmatch(LIST,&arg.n_ptr);
X } else
X if (fargs.n_ptr->n_type != LIST
X && fargs.n_ptr->n_type != SYM) xlfail("bad argument type");
X
X /* create a new function definition */
X fun.n_ptr = newnode(LIST);
X fun.n_ptr->n_listvalue = Lambda;
X p = fun.n_ptr->n_listnext = newnode(LIST);
X p->n_listvalue = fargs.n_ptr;
X p->n_listnext = arg.n_ptr;
X
X /* make the symbol point to a new function definition */
X xlputprop(sym.n_ptr,fun.n_ptr,(macro?Macprop: (fexpr?Fexprop:Exprop)));
X
X /* restore the previous stack frame */
X xlstack = oldstk;
X
X /* return the function symbol */
X return (sym.n_ptr);
X}
X
X /******************************************
X * sgetc - get a character from a string *
X ******************************************/
X
Xstatic int sgetc()
X{
X if (*sgetptr == 0)
X return (-1);
X else
X return (*sgetptr++);
X}
X
X /******************************
X * read - read an expression *
X ******************************/
X
Xstatic struct node *read(args)
X struct node *args;
X{
X struct node *val;
X int (*oldgetc)();
X
X /* save the old input stream */
X oldgetc = xlgetc;
X
X /* get the string or file pointer */
X if (args != NULL) {
X sgetptr = xlmatch(STR,&args)->n_str;
X xlgetc = sgetc;
X }
X
X /* make sure there aren't any more arguments */
X xllastarg(args);
X
X val = xlread();
X xlgetc = oldgetc;
X
X return (val);
X}
X
X
X /************************************
X * fwhile - builtin function while *
X ************************************/
X
Xstatic struct node *fwhile(args)
X struct node *args;
X{
X struct node *oldstk,farg,arg,*val;
X
X /* create a new stack frame */
X oldstk = xlsave(&farg,&arg,NULL);
X
X /* initialize */
X farg.n_ptr = arg.n_ptr = args;
X
X /* loop until test fails */
X val = NULL;
X for (; TRUE; arg.n_ptr = farg.n_ptr) {
X
X /* evaluate the test expression */
X if (!testvalue(xlevarg(&arg.n_ptr)))
X break;
X
X /* evaluate each remaining argument */
X while (arg.n_ptr != NULL)
X val = xlevarg(&arg.n_ptr);
X }
X
X /* restore the previous stack frame */
X xlstack = oldstk;
X
X /* return the last test expression value */
X return (val);
X}
X
X
X /**************************************
X * frepeat - builtin function repeat *
X **************************************/
X
Xstatic struct node *frepeat(args)
X struct node *args;
X{
X struct node *oldstk,farg,arg,*val;
X int cnt;
X
X /* create a new stack frame */
X oldstk = xlsave(&farg,&arg,NULL);
X
X /* initialize */
X arg.n_ptr = args;
X
X cnt = xlevmatch(INT,&arg.n_ptr)->n_int;
X
X /* save the first expression to repeat */
X farg.n_ptr = arg.n_ptr;
X
X /* loop until test fails */
X val = NULL;
X for (; cnt > 0; cnt--) {
X
X /* evaluate each remaining argument */
X while (arg.n_ptr != NULL)
X val = xlevarg(&arg.n_ptr);
X
X /* restore pointer to first expression */
X arg.n_ptr = farg.n_ptr;
X }
X
X /* restore the previous stack frame */
X xlstack = oldstk;
X
X /* return the last test expression value */
X return (val);
X}
X
X
X /***************************************
X * foreach - builtin function foreach *
X ***************************************/
X
Xstatic struct node *foreach(args)
X struct node *args;
X{
X struct node *oldstk,arg,sym,list,code,oldbnd,*val;
X
X /* create a new stack frame */
X oldstk = xlsave(&arg,&sym,&list,&code,&oldbnd,NULL);
X
X /* initialize */
X arg.n_ptr = args;
X
X /* get the symbol to bind to each list element */
X sym.n_ptr = xlmatch(SYM,&arg.n_ptr);
X
X /* save the old binding of the symbol */
X oldbnd.n_ptr = sym.n_ptr->n_symvalue;
X
X /* get the list to iterate over */
X list.n_ptr = xlevmatch(LIST,&arg.n_ptr);
X
X /* save the pointer to the code */
X code.n_ptr = arg.n_ptr;
X
X /* loop until test fails */
X val = NULL;
X while (list.n_ptr != NULL) {
X
X /* check the node type */
X if (list.n_ptr->n_type != LIST)
X xlfail("bad node type in list");
X
X /* bind the symbol to the list element */
X sym.n_ptr->n_symvalue = list.n_ptr->n_listvalue;
X
X /* evaluate each remaining argument */
X while (arg.n_ptr != NULL)
X val = xlevarg(&arg.n_ptr);
X
X /* point to the next list element */
X list.n_ptr = list.n_ptr->n_listnext;
X
X /* restore the pointer to the code */
X arg.n_ptr = code.n_ptr;
X }
X
X /* restore the previous stack frame */
X xlstack = oldstk;
X
X /* restore the old binding of the symbol */
X sym.n_ptr->n_symvalue = oldbnd.n_ptr;
X
X /* return the last test expression value */
X return (val);
X}
X
X
X /******************************
X * fif - builtin function if *
X ******************************/
X
Xstatic struct node *fif(args)
X struct node *args;
X{
X struct node *oldstk,arg,testexpr,thenexpr,elseexpr,*val;
X int dothen;
X
X /* create a new stack frame */
X oldstk = xlsave(&arg,&testexpr,&thenexpr,&elseexpr,NULL);
X
X /* initialize */
X arg.n_ptr = args;
X
X /* evaluate the test expression */
X testexpr.n_ptr = xlevarg(&arg.n_ptr);
X
X /* get the then clause */
X thenexpr.n_ptr = xlmatch(LIST,&arg.n_ptr);
X
X /* get the else clause */
X if (arg.n_ptr != NULL)
X elseexpr.n_ptr = xlmatch(LIST,&arg.n_ptr);
X else
X elseexpr.n_ptr = NULL;
X
X /* make sure there aren't any more arguments */
X xllastarg(arg.n_ptr);
X
X /* figure out which expression to evaluate */
X dothen = testvalue(testexpr.n_ptr);
X
X /* default the result value to the value of the test expression */
X val = testexpr.n_ptr;
X
X /* evaluate the appropriate clause */
X if (dothen)
X while (thenexpr.n_ptr != NULL)
X val = xlevarg(&thenexpr.n_ptr);
X else
X while (elseexpr.n_ptr != NULL)
X val = xlevarg(&elseexpr.n_ptr);
X
X /* restore the previous stack frame */
X xlstack = oldstk;
X
X /* return the last value */
X return (val);
X}
X
X
X /****************************************************
X * quote - builtin function to quote an expression *
X ****************************************************/
X
Xstatic struct node *quote(args)
X struct node *args;
X{
X /* make sure there is exactly one argument */
X if (args == NULL || args->n_listnext != NULL)
X xlfail("incorrect number of arguments");
X
X /* return the quoted expression */
X return (args->n_listvalue);
X}
X
X
X /*****************************
X * fexit - get out of xlisp *
X *****************************/
X
Xfexit()
X{
X exit();
X}
X
X
X /***********************************************
X * testvalue - test a value for true or false *
X ***********************************************/
X
Xstatic int testvalue(val)
X struct node *val;
X{
X /* check for a nil value */
X if (val == NULL)
X return (FALSE);
X
X /* check the value type */
X switch (val->n_type) {
X case INT:
X return (val->n_int != 0);
X
X case STR:
X return (strlen(val->n_str) != 0);
X
X default:
X return (TRUE);
X }
X}
X
Xstatic struct node *comment() { return t; }
X
X /******************************************
X * xlinit - xlisp initialization routine *
X ******************************************/
X
Xxlinit()
X{
X /* enter a copyright notice into the oblist */
X xlenter("Copyright-1983-by-David-Betz");
X t = xlenter("t");
X Lambda = xlenter("lambda");
X Fexpr = xlenter("fexpr");
X Macro = xlenter("macro");
X Subrprop = xlenter("SUBR");
X Fsubrprop = xlenter("FSUBR");
X Exprop = xlenter("EXPR");
X Fexprop = xlenter("FEXPR");
X Macprop = xlenter("MACRO");
X
X /* enter the builtin functions */
X xlsubr("set",set);
X xlfsubr("setq",setq);
X xlsubr("load",load);
X xlsubr("read",read);
X xlfsubr("comment",comment);
X xlfsubr("quote",quote);
X xlfsubr("while",fwhile);
X xlfsubr("repeat",frepeat);
X xlfsubr("foreach",foreach);
X xlfsubr("defun",defun);
X xlfsubr("if",fif);
X xlfsubr("exit",fexit);
X}
!Funky!Stuff!
exit 0
--
John Woods, Charles River Data Systems, Framingham MA, (617) 626-1114
...!decvax!frog!john, ...!mit-eddie!jfw, JFW@MIT-XX.ARPA
I have absolutely nothing clever to say in this signature.