garym@cognos.UUCP (Gary Murphy) (02/27/90)
Posting-number: Volume 10, Issue 95
Submitted-by: garym@cognos.UUCP (Gary Murphy)
Archive-name: xlisp21/part08
#!/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:
# xlread.c
# xlstr.c
# xlstruct.c
# xlsubr.c
# xlsym.c
# xlsys.c
# This archive created: Sun Feb 18 23:40:39 1990
# By: Gary Murphy ()
export PATH; PATH=/bin:$PATH
echo shar: extracting "'xlread.c'" '(17573 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/* symbol parser modes */
X#define DONE 0
X#define NORMAL 1
X#define ESCAPE 2
X
X/* external variables */
Xextern LVAL s_stdout,true,s_dot;
Xextern LVAL s_quote,s_function,s_bquote,s_comma,s_comat;
Xextern LVAL s_rtable,k_wspace,k_const,k_nmacro,k_tmacro;
Xextern LVAL k_sescape,k_mescape;
Xextern char buf[];
X
X/* external routines */
Xextern FILE *osaopen();
Xextern double atof();
Xextern ITYPE;
X
X#define WSPACE "\t \f\r\n"
X#define CONST1 "!$%&*+-./0123456789:<=>?@[]^_{}~"
X#define CONST2 "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz"
X
X/* forward declarations */
XFORWARD LVAL callmacro();
XFORWARD LVAL psymbol(),punintern();
XFORWARD LVAL pnumber(),pquote(),plist(),pvector(),pstruct();
XFORWARD LVAL readlist(),tentry();
X
X/* xlload - load a file of xlisp expressions */
Xint xlload(fname,vflag,pflag)
X char *fname; int vflag,pflag;
X{
X char fullname[STRMAX+1];
X LVAL fptr,expr;
X CONTEXT cntxt;
X FILE *fp;
X int sts;
X
X /* protect some pointers */
X xlstkcheck(2);
X xlsave(fptr);
X xlsave(expr);
X
X /* default the extension */
X if (needsextension(fname)) {
X strcpy(fullname,fname);
X strcat(fullname,".lsp");
X fname = fullname;
X }
X
X /* allocate a file node */
X fptr = cvfile(NULL);
X
X /* open the file */
X if ((fp = osaopen(fname,"r")) == NULL) {
X xlpopn(2);
X return (FALSE);
X }
X setfile(fptr,fp);
X
X /* print the information line */
X if (vflag)
X { sprintf(buf,"; loading \"%s\"\n",fname); stdputstr(buf); }
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,&expr,FALSE)) {
X expr = xleval(expr);
X if (pflag)
X stdprint(expr);
X }
X sts = TRUE;
X }
X xlend(&cntxt);
X
X /* close the file */
X osclose(getfile(fptr));
X setfile(fptr,NULL);
X
X /* restore the stack */
X xlpopn(2);
X
X /* return status */
X return (sts);
X}
X
X/* xlread - read an xlisp expression */
Xint xlread(fptr,pval,rflag)
X LVAL fptr,*pval; int rflag;
X{
X int sts;
X
X /* read an expression */
X while ((sts = readone(fptr,pval)) == FALSE)
X ;
X
X /* return status */
X return (sts == EOF ? FALSE : TRUE);
X}
X
X/* readone - attempt to read a single expression */
Xint readone(fptr,pval)
X LVAL fptr,*pval;
X{
X LVAL val,type;
X int ch;
X
X /* get a character and check for EOF */
X if ((ch = xlgetc(fptr)) == EOF)
X return (EOF);
X
X /* handle white space */
X if ((type = tentry(ch)) == k_wspace)
X return (FALSE);
X
X /* handle symbol constituents */
X else if (type == k_const) {
X xlungetc(fptr,ch);
X *pval = psymbol(fptr);
X return (TRUE);
X }
X
X /* handle single and multiple escapes */
X else if (type == k_sescape || type == k_mescape) {
X xlungetc(fptr,ch);
X *pval = psymbol(fptr);
X return (TRUE);
X }
X
X /* handle read macros */
X else if (consp(type)) {
X if ((val = callmacro(fptr,ch)) && consp(val)) {
X *pval = car(val);
X return (TRUE);
X }
X else
X return (FALSE);
X }
X
X /* handle illegal characters */
X else
X xlerror("illegal character",cvfixnum((FIXTYPE)ch));
X}
X
X/* rmhash - read macro for '#' */
XLVAL rmhash()
X{
X LVAL fptr,mch,val;
X int escflag,ch;
X
X /* protect some pointers */
X xlsave1(val);
X
X /* get the file and macro character */
X fptr = xlgetfile();
X mch = xlgachar();
X xllastarg();
X
X /* make the return value */
X val = consa(NIL);
X
X /* check the next character */
X switch (ch = xlgetc(fptr)) {
X case '\'':
X rplaca(val,pquote(fptr,s_function));
X break;
X case '(':
X xlungetc(fptr,ch);
X rplaca(val,pvector(fptr));
X break;
X case 'b':
X case 'B':
X rplaca(val,pnumber(fptr,2));
X break;
X case 'o':
X case 'O':
X rplaca(val,pnumber(fptr,8));
X break;
X case 'x':
X case 'X':
X rplaca(val,pnumber(fptr,16));
X break;
X case 's':
X case 'S':
X rplaca(val,pstruct(fptr));
X break;
X case '\\':
X xlungetc(fptr,ch);
X pname(fptr,&escflag);
X ch = buf[0];
X if (strlen(buf) > 1) {
X upcase(buf);
X if (strcmp(buf,"NEWLINE") == 0)
X ch = '\n';
X else if (strcmp(buf,"SPACE") == 0)
X ch = ' ';
X else
X xlerror("unknown character name",cvstring(buf));
X }
X rplaca(val,cvchar(ch));
X break;
X case ':':
X rplaca(val,punintern(fptr));
X break;
X case '|':
X pcomment(fptr);
X val = NIL;
X break;
X default:
X xlerror("illegal character after #",cvfixnum((FIXTYPE)ch));
X }
X
X /* restore the stack */
X xlpop();
X
X /* return the value */
X return (val);
X}
X
X/* rmquote - read macro for '\'' */
XLVAL rmquote()
X{
X LVAL fptr,mch;
X
X /* get the file and macro character */
X fptr = xlgetfile();
X mch = xlgachar();
X xllastarg();
X
X /* parse the quoted expression */
X return (consa(pquote(fptr,s_quote)));
X}
X
X/* rmdquote - read macro for '"' */
XLVAL rmdquote()
X{
X unsigned char buf[STRMAX+1],*p,*sptr;
X LVAL fptr,str,newstr,mch;
X int len,blen,ch,d2,d3;
X
X /* protect some pointers */
X xlsave1(str);
X
X /* get the file and macro character */
X fptr = xlgetfile();
X mch = xlgachar();
X xllastarg();
X
X /* loop looking for a closing quote */
X len = blen = 0; p = buf;
X while ((ch = checkeof(fptr)) != '"') {
X
X /* handle escaped characters */
X switch (ch) {
X case '\\':
X switch (ch = checkeof(fptr)) {
X case 't':
X ch = '\011';
X break;
X case 'n':
X ch = '\012';
X break;
X case 'f':
X ch = '\014';
X break;
X case 'r':
X ch = '\015';
X break;
X default:
X if (ch >= '0' && ch <= '7') {
X d2 = checkeof(fptr);
X d3 = checkeof(fptr);
X if (d2 < '0' || d2 > '7'
X || d3 < '0' || d3 > '7')
X xlfail("invalid octal digit");
X ch -= '0'; d2 -= '0'; d3 -= '0';
X ch = (ch << 6) | (d2 << 3) | d3;
X }
X break;
X }
X }
X
X /* check for buffer overflow */
X if (blen >= STRMAX) {
X newstr = newstring(len + STRMAX + 1);
X sptr = getstring(newstr); *sptr = '\0';
X if (str) strcat(sptr,getstring(str));
X *p = '\0'; strcat(sptr,buf);
X p = buf; blen = 0;
X len += STRMAX;
X str = newstr;
X }
X
X /* store the character */
X *p++ = ch; ++blen;
X }
X
X /* append the last substring */
X if (str == NIL || blen) {
X newstr = newstring(len + blen + 1);
X sptr = getstring(newstr); *sptr = '\0';
X if (str) strcat(sptr,getstring(str));
X *p = '\0'; strcat(sptr,buf);
X str = newstr;
X }
X
X /* restore the stack */
X xlpop();
X
X /* return the new string */
X return (consa(str));
X}
X
X/* rmbquote - read macro for '`' */
XLVAL rmbquote()
X{
X LVAL fptr,mch;
X
X /* get the file and macro character */
X fptr = xlgetfile();
X mch = xlgachar();
X xllastarg();
X
X /* parse the quoted expression */
X return (consa(pquote(fptr,s_bquote)));
X}
X
X/* rmcomma - read macro for ',' */
XLVAL rmcomma()
X{
X LVAL fptr,mch,sym;
X int ch;
X
X /* get the file and macro character */
X fptr = xlgetfile();
X mch = xlgachar();
X xllastarg();
X
X /* check the next character */
X if ((ch = xlgetc(fptr)) == '@')
X sym = s_comat;
X else {
X xlungetc(fptr,ch);
X sym = s_comma;
X }
X
X /* make the return value */
X return (consa(pquote(fptr,sym)));
X}
X
X/* rmlpar - read macro for '(' */
XLVAL rmlpar()
X{
X LVAL fptr,mch;
X
X /* get the file and macro character */
X fptr = xlgetfile();
X mch = xlgachar();
X xllastarg();
X
X /* make the return value */
X return (consa(plist(fptr)));
X}
X
X/* rmrpar - read macro for ')' */
XLVAL rmrpar()
X{
X xlfail("misplaced right paren");
X}
X
X/* rmsemi - read macro for ';' */
XLVAL rmsemi()
X{
X LVAL fptr,mch;
X int ch;
X
X /* get the file and macro character */
X fptr = xlgetfile();
X mch = xlgachar();
X xllastarg();
X
X /* skip to end of line */
X while ((ch = xlgetc(fptr)) != EOF && ch != '\n')
X ;
X
X /* return nil (nothing read) */
X return (NIL);
X}
X
X/* pcomment - parse a comment delimited by #| and |# */
XLOCAL pcomment(fptr)
X LVAL fptr;
X{
X int lastch,ch,n;
X
X /* look for the matching delimiter (and handle nesting) */
X for (n = 1, lastch = -1; n > 0 && (ch = xlgetc(fptr)) != EOF; ) {
X if (lastch == '|' && ch == '#')
X { --n; ch = -1; }
X else if (lastch == '#' && ch == '|')
X { ++n; ch = -1; }
X lastch = ch;
X }
X}
X
X/* pnumber - parse a number */
XLOCAL LVAL pnumber(fptr,radix)
X LVAL fptr; int radix;
X{
X int digit,ch;
X long num;
X
X for (num = 0L; (ch = xlgetc(fptr)) != EOF; ) {
X if (islower(ch)) ch = toupper(ch);
X if (!('0' <= ch && ch <= '9') && !('A' <= ch && ch <= 'F'))
X break;
X if ((digit = (ch <= '9' ? ch - '0' : ch - 'A' + 10)) >= radix)
X break;
X num = num * (long)radix + (long)digit;
X }
X xlungetc(fptr,ch);
X return (cvfixnum((FIXTYPE)num));
X}
X
X/* plist - parse a list */
XLOCAL LVAL plist(fptr)
X LVAL fptr;
X{
X LVAL val,expr,lastnptr,nptr;
X
X /* protect some pointers */
X xlstkcheck(2);
X xlsave(val);
X xlsave(expr);
X
X /* keep appending nodes until a closing paren is found */
X for (lastnptr = NIL; nextch(fptr) != ')'; )
X
X /* get the next expression */
X switch (readone(fptr,&expr)) {
X case EOF:
X badeof(fptr);
X case TRUE:
X
X /* check for a dotted tail */
X if (expr == s_dot) {
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 (!xlread(fptr,&expr,TRUE))
X badeof(fptr);
X rplacd(lastnptr,expr);
X
X /* make sure its followed by a close paren */
X if (nextch(fptr) != ')')
X xlfail("invalid dotted pair");
X }
X
X /* otherwise, handle a normal list element */
X else {
X nptr = consa(expr);
X if (lastnptr == NIL)
X val = nptr;
X else
X rplacd(lastnptr,nptr);
X lastnptr = nptr;
X }
X break;
X }
X
X /* skip the closing paren */
X xlgetc(fptr);
X
X /* restore the stack */
X xlpopn(2);
X
X /* return successfully */
X return (val);
X}
X
X/* pvector - parse a vector */
XLOCAL LVAL pvector(fptr)
X LVAL fptr;
X{
X LVAL list,val;
X int len,i;
X
X /* protect some pointers */
X xlsave1(list);
X
X /* read the list */
X list = readlist(fptr,&len);
X
X /* make a vector of the appropriate length */
X val = newvector(len);
X
X /* copy the list into the vector */
X for (i = 0; i < len; ++i, list = cdr(list))
X setelement(val,i,car(list));
X
X /* restore the stack */
X xlpop();
X
X /* return successfully */
X return (val);
X}
X
X/* pstruct - parse a structure */
XLOCAL LVAL pstruct(fptr)
X LVAL fptr;
X{
X extern LVAL xlrdstruct();
X LVAL list,val;
X int len;
X
X /* protect some pointers */
X xlsave1(list);
X
X /* read the list */
X list = readlist(fptr,&len);
X
X /* make the structure */
X val = xlrdstruct(list);
X
X /* restore the stack */
X xlpop();
X
X /* return successfully */
X return (val);
X}
X
X/* pquote - parse a quoted expression */
XLOCAL LVAL pquote(fptr,sym)
X LVAL fptr,sym;
X{
X LVAL val,p;
X
X /* protect some pointers */
X xlsave1(val);
X
X /* allocate two nodes */
X val = consa(sym);
X rplacd(val,consa(NIL));
X
X /* initialize the second to point to the quoted expression */
X if (!xlread(fptr,&p,TRUE))
X badeof(fptr);
X rplaca(cdr(val),p);
X
X /* restore the stack */
X xlpop();
X
X /* return the quoted expression */
X return (val);
X}
X
X/* psymbol - parse a symbol name */
XLOCAL LVAL psymbol(fptr)
X LVAL fptr;
X{
X int escflag;
X LVAL val;
X pname(fptr,&escflag);
X return (escflag || !isnumber(buf,&val) ? xlenter(buf) : val);
X}
X
X/* punintern - parse an uninterned symbol */
XLOCAL LVAL punintern(fptr)
X LVAL fptr;
X{
X int escflag;
X pname(fptr,&escflag);
X return (xlmakesym(buf));
X}
X
X/* pname - parse a symbol/package name */
XLOCAL int pname(fptr,pescflag)
X LVAL fptr; int *pescflag;
X{
X int mode,ch,i;
X LVAL type;
X
X /* initialize */
X *pescflag = FALSE;
X mode = NORMAL;
X i = 0;
X
X /* accumulate the symbol name */
X while (mode != DONE) {
X
X /* handle normal mode */
X while (mode == NORMAL)
X if ((ch = xlgetc(fptr)) == EOF)
X mode = DONE;
X else if ((type = tentry(ch)) == k_sescape) {
X i = storech(buf,i,checkeof(fptr));
X *pescflag = TRUE;
X }
X else if (type == k_mescape) {
X *pescflag = TRUE;
X mode = ESCAPE;
X }
X else if (type == k_const
X || (consp(type) && car(type) == k_nmacro))
X i = storech(buf,i,islower(ch) ? toupper(ch) : ch);
X else
X mode = DONE;
X
X /* handle multiple escape mode */
X while (mode == ESCAPE)
X if ((ch = xlgetc(fptr)) == EOF)
X badeof(fptr);
X else if ((type = tentry(ch)) == k_sescape)
X i = storech(buf,i,checkeof(fptr));
X else if (type == k_mescape)
X mode = NORMAL;
X else
X i = storech(buf,i,ch);
X }
X buf[i] = 0;
X
X /* check for a zero length name */
X if (i == 0)
X xlerror("zero length name");
X
X /* unget the last character and return it */
X xlungetc(fptr,ch);
X return (ch);
X}
X
X/* readlist - read a list terminated by a ')' */
XLOCAL LVAL readlist(fptr,plen)
X LVAL fptr; int *plen;
X{
X LVAL list,expr,lastnptr,nptr;
X int ch;
X
X /* protect some pointers */
X xlstkcheck(2);
X xlsave(list);
X xlsave(expr);
X
X /* get the open paren */
X if ((ch = nextch(fptr)) != '(')
X xlfail("expecting an open paren");
X xlgetc(fptr);
X
X /* keep appending nodes until a closing paren is found */
X for (lastnptr = NIL, *plen = 0; (ch = nextch(fptr)) != ')'; ) {
X
X /* check for end of file */
X if (ch == EOF)
X badeof(fptr);
X
X /* get the next expression */
X switch (readone(fptr,&expr)) {
X case EOF:
X badeof(fptr);
X case TRUE:
X nptr = consa(expr);
X if (lastnptr == NIL)
X list = nptr;
X else
X rplacd(lastnptr,nptr);
X lastnptr = nptr;
X ++(*plen);
X break;
X }
X }
X
X /* skip the closing paren */
X xlgetc(fptr);
X
X /* restore the stack */
X xlpopn(2);
X
X /* return the list */
X return (list);
X}
X
X/* storech - store a character in the print name buffer */
XLOCAL int storech(buf,i,ch)
X char *buf; int i,ch;
X{
X if (i < STRMAX)
X buf[i++] = ch;
X return (i);
X}
X
X/* tentry - get a readtable entry */
XLVAL tentry(ch)
X int ch;
X{
X LVAL rtable;
X rtable = getvalue(s_rtable);
X if (!vectorp(rtable) || ch < 0 || ch >= getsize(rtable))
X return (NIL);
X return (getelement(rtable,ch));
X}
X
X/* nextch - look at the next non-blank character */
XLOCAL int nextch(fptr)
X LVAL fptr;
X{
X int ch;
X
X /* return and save the next non-blank character */
X while ((ch = xlgetc(fptr)) != EOF && isspace(ch))
X ;
X xlungetc(fptr,ch);
X return (ch);
X}
X
X/* checkeof - get a character and check for end of file */
XLOCAL int checkeof(fptr)
X LVAL 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 LVAL 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; LVAL *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 /* check for an exponent */
X if ((dl || dr) && *p == 'E') {
X p++;
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++, 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 (pval) {
X if (*str == '+') ++str;
X if (str[strlen(str)-1] == '.') str[strlen(str)-1] = 0;
X *pval = (dr ? cvflonum(atof(str)) : cvfixnum(ICNV(str)));
X }
X return (TRUE);
X}
X
X/* defmacro - define a read macro */
Xdefmacro(ch,type,offset)
X int ch; LVAL type; int offset;
X{
X extern FUNDEF funtab[];
X LVAL subr;
X subr = cvsubr(funtab[offset].fd_subr,funtab[offset].fd_type,offset);
X setelement(getvalue(s_rtable),ch,cons(type,subr));
X}
X
X/* callmacro - call a read macro */
XLVAL callmacro(fptr,ch)
X LVAL fptr; int ch;
X{
X LVAL *newfp;
X
X /* create the new call frame */
X newfp = xlsp;
X pusharg(cvfixnum((FIXTYPE)(newfp - xlfp)));
X pusharg(cdr(getelement(getvalue(s_rtable),ch)));
X pusharg(cvfixnum((FIXTYPE)2));
X pusharg(fptr);
X pusharg(cvchar(ch));
X xlfp = newfp;
X return (xlapply(2));
X}
X
X/* upcase - translate a string to upper case */
XLOCAL upcase(str)
X unsigned char *str;
X{
X for (; *str != '\0'; ++str)
X if (islower(*str))
X *str = toupper(*str);
X}
X
X/* xlrinit - initialize the reader */
Xxlrinit()
X{
X LVAL rtable;
X char *p;
X int ch;
X
X /* create the read table */
X rtable = newvector(256);
X setvalue(s_rtable,rtable);
X
X /* initialize the readtable */
X for (p = WSPACE; ch = *p++; )
X setelement(rtable,ch,k_wspace);
X for (p = CONST1; ch = *p++; )
X setelement(rtable,ch,k_const);
X for (p = CONST2; ch = *p++; )
X setelement(rtable,ch,k_const);
X
X /* setup the escape characters */
X setelement(rtable,'\\',k_sescape);
X setelement(rtable,'|', k_mescape);
X
X /* install the read macros */
X defmacro('#', k_nmacro,FT_RMHASH);
X defmacro('\'',k_tmacro,FT_RMQUOTE);
X defmacro('"', k_tmacro,FT_RMDQUOTE);
X defmacro('`', k_tmacro,FT_RMBQUOTE);
X defmacro(',', k_tmacro,FT_RMCOMMA);
X defmacro('(', k_tmacro,FT_RMLPAR);
X defmacro(')', k_tmacro,FT_RMRPAR);
X defmacro(';', k_tmacro,FT_RMSEMI);
X}
X
SHAR_EOF
if test 17573 -ne "`wc -c 'xlread.c'`"
then
echo shar: error transmitting "'xlread.c'" '(should have been 17573 characters)'
fi
echo shar: extracting "'xlstr.c'" '(13099 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 and character built-in 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/* local definitions */
X#define fix(n) cvfixnum((FIXTYPE)(n))
X#define TLEFT 1
X#define TRIGHT 2
X
X/* external variables */
Xextern LVAL k_start,k_end,k_1start,k_1end,k_2start,k_2end;
Xextern LVAL true;
Xextern char buf[];
X
X/* external procedures */
Xextern char *strcat();
X
X/* forward declarations */
XFORWARD LVAL strcompare();
XFORWARD LVAL chrcompare();
XFORWARD LVAL changecase();
XFORWARD LVAL trim();
X
X/* string comparision functions */
XLVAL xstrlss() { return (strcompare('<',FALSE)); } /* string< */
XLVAL xstrleq() { return (strcompare('L',FALSE)); } /* string<= */
XLVAL xstreql() { return (strcompare('=',FALSE)); } /* string= */
XLVAL xstrneq() { return (strcompare('#',FALSE)); } /* string/= */
XLVAL xstrgeq() { return (strcompare('G',FALSE)); } /* string>= */
XLVAL xstrgtr() { return (strcompare('>',FALSE)); } /* string> */
X
X/* string comparison functions (not case sensitive) */
XLVAL xstrilss() { return (strcompare('<',TRUE)); } /* string-lessp */
XLVAL xstrileq() { return (strcompare('L',TRUE)); } /* string-not-greaterp */
XLVAL xstrieql() { return (strcompare('=',TRUE)); } /* string-equal */
XLVAL xstrineq() { return (strcompare('#',TRUE)); } /* string-not-equal */
XLVAL xstrigeq() { return (strcompare('G',TRUE)); } /* string-not-lessp */
XLVAL xstrigtr() { return (strcompare('>',TRUE)); } /* string-greaterp */
X
X/* strcompare - compare strings */
XLOCAL LVAL strcompare(fcn,icase)
X int fcn,icase;
X{
X int start1,end1,start2,end2,ch1,ch2;
X unsigned char *p1,*p2;
X LVAL str1,str2;
X
X /* get the strings */
X str1 = xlgastring();
X str2 = xlgastring();
X
X /* get the substring specifiers */
X getbounds(str1,k_1start,k_1end,&start1,&end1);
X getbounds(str2,k_2start,k_2end,&start2,&end2);
X
X /* setup the string pointers */
X p1 = &getstring(str1)[start1];
X p2 = &getstring(str2)[start2];
X
X /* compare the strings */
X for (; start1 < end1 && start2 < end2; ++start1,++start2) {
X ch1 = *p1++;
X ch2 = *p2++;
X if (icase) {
X if (isupper(ch1)) ch1 = tolower(ch1);
X if (isupper(ch2)) ch2 = tolower(ch2);
X }
X if (ch1 != ch2)
X switch (fcn) {
X case '<': return (ch1 < ch2 ? fix(start1) : NIL);
X case 'L': return (ch1 <= ch2 ? fix(start1) : NIL);
X case '=': return (NIL);
X case '#': return (fix(start1));
X case 'G': return (ch1 >= ch2 ? fix(start1) : NIL);
X case '>': return (ch1 > ch2 ? fix(start1) : NIL);
X }
X }
X
X /* check the termination condition */
X switch (fcn) {
X case '<': return (start1 >= end1 && start2 < end2 ? fix(start1) : NIL);
X case 'L': return (start1 >= end1 ? fix(start1) : NIL);
X case '=': return (start1 >= end1 && start2 >= end2 ? true : NIL);
X case '#': return (start1 >= end1 && start2 >= end2 ? NIL : fix(start1));
X case 'G': return (start2 >= end2 ? fix(start1) : NIL);
X case '>': return (start2 >= end2 && start1 < end1 ? fix(start1) : NIL);
X }
X}
X
X/* case conversion functions */
XLVAL xupcase() { return (changecase('U',FALSE)); }
XLVAL xdowncase() { return (changecase('D',FALSE)); }
X
X/* destructive case conversion functions */
XLVAL xnupcase() { return (changecase('U',TRUE)); }
XLVAL xndowncase() { return (changecase('D',TRUE)); }
X
X/* changecase - change case */
XLOCAL LVAL changecase(fcn,destructive)
X int fcn,destructive;
X{
X unsigned char *srcp,*dstp;
X int start,end,len,ch,i;
X LVAL src,dst;
X
X /* get the string */
X src = xlgastring();
X
X /* get the substring specifiers */
X getbounds(src,k_start,k_end,&start,&end);
X len = getslength(src) - 1;
X
X /* make a destination string */
X dst = (destructive ? src : newstring(len+1));
X
X /* setup the string pointers */
X srcp = getstring(src);
X dstp = getstring(dst);
X
X /* copy the source to the destination */
X for (i = 0; i < len; ++i) {
X ch = *srcp++;
X if (i >= start && i < end)
X switch (fcn) {
X case 'U': if (islower(ch)) ch = toupper(ch); break;
X case 'D': if (isupper(ch)) ch = tolower(ch); break;
X }
X *dstp++ = ch;
X }
X *dstp = '\0';
X
X /* return the new string */
X return (dst);
X}
X
X/* trim functions */
XLVAL xtrim() { return (trim(TLEFT|TRIGHT)); }
XLVAL xlefttrim() { return (trim(TLEFT)); }
XLVAL xrighttrim() { return (trim(TRIGHT)); }
X
X/* trim - trim character from a string */
XLOCAL LVAL trim(fcn)
X int fcn;
X{
X unsigned char *leftp,*rightp,*dstp;
X LVAL bag,src,dst;
X
X /* get the bag and the string */
X bag = xlgastring();
X src = xlgastring();
X xllastarg();
X
X /* setup the string pointers */
X leftp = getstring(src);
X rightp = leftp + getslength(src) - 2;
X
X /* trim leading characters */
X if (fcn & TLEFT)
X while (leftp <= rightp && inbag(*leftp,bag))
X ++leftp;
X
X /* trim character from the right */
X if (fcn & TRIGHT)
X while (rightp >= leftp && inbag(*rightp,bag))
X --rightp;
X
X /* make a destination string and setup the pointer */
X dst = newstring((int)(rightp-leftp+2));
X dstp = getstring(dst);
X
X /* copy the source to the destination */
X while (leftp <= rightp)
X *dstp++ = *leftp++;
X *dstp = '\0';
X
X /* return the new string */
X return (dst);
X}
X
X/* getbounds - get the start and end bounds of a string */
XLOCAL getbounds(str,skey,ekey,pstart,pend)
X LVAL str,skey,ekey; int *pstart,*pend;
X{
X LVAL arg;
X int len;
X
X /* get the length of the string */
X len = getslength(str) - 1;
X
X /* get the starting index */
X if (xlgkfixnum(skey,&arg)) {
X *pstart = (int)getfixnum(arg);
X if (*pstart < 0 || *pstart > len)
X xlerror("string index out of bounds",arg);
X }
X else
X *pstart = 0;
X
X /* get the ending index */
X if (xlgkfixnum(ekey,&arg)) {
X *pend = (int)getfixnum(arg);
X if (*pend < 0 || *pend > len)
X xlerror("string index out of bounds",arg);
X }
X else
X *pend = len;
X
X /* make sure the start is less than or equal to the end */
X if (*pstart > *pend)
X xlerror("starting index error",cvfixnum((FIXTYPE)*pstart));
X}
X
X/* inbag - test if a character is in a bag */
XLOCAL int inbag(ch,bag)
X int ch; LVAL bag;
X{
X unsigned char *p;
X for (p = getstring(bag); *p != '\0'; ++p)
X if (*p == ch)
X return (TRUE);
X return (FALSE);
X}
X
X/* xstrcat - concatenate a bunch of strings */
XLVAL xstrcat()
X{
X LVAL *saveargv,tmp,val;
X unsigned char *str;
X int saveargc,len;
X
X /* save the argument list */
X saveargv = xlargv;
X saveargc = xlargc;
X
X /* find the length of the new string */
X for (len = 0; moreargs(); ) {
X tmp = xlgastring();
X len += (int)getslength(tmp) - 1;
X }
X
X /* create the result string */
X val = newstring(len+1);
X str = getstring(val);
X
X /* restore the argument list */
X xlargv = saveargv;
X xlargc = saveargc;
X
X /* combine the strings */
X for (*str = '\0'; moreargs(); ) {
X tmp = nextarg();
X strcat(str,getstring(tmp));
X }
X
X /* return the new string */
X return (val);
X}
X
X/* xsubseq - return a subsequence */
XLVAL xsubseq()
X{
X unsigned char *srcp,*dstp;
X int start,end,len;
X LVAL src,dst;
X
X /* get string and starting and ending positions */
X src = xlgastring();
X
X /* get the starting position */
X dst = xlgafixnum(); start = (int)getfixnum(dst);
X if (start < 0 || start > getslength(src) - 1)
X xlerror("string index out of bounds",dst);
X
X /* get the ending position */
X if (moreargs()) {
X dst = xlgafixnum(); end = (int)getfixnum(dst);
X if (end < 0 || end > getslength(src) - 1)
X xlerror("string index out of bounds",dst);
X }
X else
X end = getslength(src) - 1;
X xllastarg();
X
X /* setup the source pointer */
X srcp = getstring(src) + start;
X len = end - start;
X
X /* make a destination string and setup the pointer */
X dst = newstring(len+1);
X dstp = getstring(dst);
X
X /* copy the source to the destination */
X while (--len >= 0)
X *dstp++ = *srcp++;
X *dstp = '\0';
X
X /* return the substring */
X return (dst);
X}
X
X/* xstring - return a string consisting of a single character */
XLVAL xstring()
X{
X LVAL arg;
X
X /* get the argument */
X arg = xlgetarg();
X xllastarg();
X
X /* make sure its not NIL */
X if (null(arg))
X xlbadtype(arg);
X
X /* check the argument type */
X switch (ntype(arg)) {
X case STRING:
X return (arg);
X case SYMBOL:
X return (getpname(arg));
X case CHAR:
X buf[0] = (int)getchcode(arg);
X buf[1] = '\0';
X return (cvstring(buf));
X default:
X xlbadtype(arg);
X }
X}
X
X/* xchar - extract a character from a string */
XLVAL xchar()
X{
X LVAL str,num;
X int n;
X
X /* get the string and the index */
X str = xlgastring();
X num = xlgafixnum();
X xllastarg();
X
X /* range check the index */
X if ((n = (int)getfixnum(num)) < 0 || n >= getslength(str) - 1)
X xlerror("index out of range",num);
X
X /* return the character */
X return (cvchar(getstring(str)[n]));
X}
X
X/* xcharint - convert an integer to a character */
XLVAL xcharint()
X{
X LVAL arg;
X arg = xlgachar();
X xllastarg();
X return (cvfixnum((FIXTYPE)getchcode(arg)));
X}
X
X/* xintchar - convert a character to an integer */
XLVAL xintchar()
X{
X LVAL arg;
X arg = xlgafixnum();
X xllastarg();
X return (cvchar((int)getfixnum(arg)));
X}
X
X/* xuppercasep - built-in function 'upper-case-p' */
XLVAL xuppercasep()
X{
X int ch;
X ch = getchcode(xlgachar());
X xllastarg();
X return (isupper(ch) ? true : NIL);
X}
X
X/* xlowercasep - built-in function 'lower-case-p' */
XLVAL xlowercasep()
X{
X int ch;
X ch = getchcode(xlgachar());
X xllastarg();
X return (islower(ch) ? true : NIL);
X}
X
X/* xbothcasep - built-in function 'both-case-p' */
XLVAL xbothcasep()
X{
X int ch;
X ch = getchcode(xlgachar());
X xllastarg();
X return (isupper(ch) || islower(ch) ? true : NIL);
X}
X
X/* xdigitp - built-in function 'digit-char-p' */
XLVAL xdigitp()
X{
X int ch;
X ch = getchcode(xlgachar());
X xllastarg();
X return (isdigit(ch) ? cvfixnum((FIXTYPE)(ch - '0')) : NIL);
X}
X
X/* xcharcode - built-in function 'char-code' */
XLVAL xcharcode()
X{
X int ch;
X ch = getchcode(xlgachar());
X xllastarg();
X return (cvfixnum((FIXTYPE)ch));
X}
X
X/* xcodechar - built-in function 'code-char' */
XLVAL xcodechar()
X{
X LVAL arg;
X int ch;
X arg = xlgafixnum(); ch = getfixnum(arg);
X xllastarg();
X return (ch >= 0 && ch <= 127 ? cvchar(ch) : NIL);
X}
X
X/* xchupcase - built-in function 'char-upcase' */
XLVAL xchupcase()
X{
X LVAL arg;
X int ch;
X arg = xlgachar(); ch = getchcode(arg);
X xllastarg();
X return (islower(ch) ? cvchar(toupper(ch)) : arg);
X}
X
X/* xchdowncase - built-in function 'char-downcase' */
XLVAL xchdowncase()
X{
X LVAL arg;
X int ch;
X arg = xlgachar(); ch = getchcode(arg);
X xllastarg();
X return (isupper(ch) ? cvchar(tolower(ch)) : arg);
X}
X
X/* xdigitchar - built-in function 'digit-char' */
XLVAL xdigitchar()
X{
X LVAL arg;
X int n;
X arg = xlgafixnum(); n = getfixnum(arg);
X xllastarg();
X return (n >= 0 && n <= 9 ? cvchar(n + '0') : NIL);
X}
X
X/* xalphanumericp - built-in function 'alphanumericp' */
XLVAL xalphanumericp()
X{
X int ch;
X ch = getchcode(xlgachar());
X xllastarg();
X return (isupper(ch) || islower(ch) || isdigit(ch) ? true : NIL);
X}
X
X/* character comparision functions */
XLVAL xchrlss() { return (chrcompare('<',FALSE)); } /* char< */
XLVAL xchrleq() { return (chrcompare('L',FALSE)); } /* char<= */
XLVAL xchreql() { return (chrcompare('=',FALSE)); } /* char= */
XLVAL xchrneq() { return (chrcompare('#',FALSE)); } /* char/= */
XLVAL xchrgeq() { return (chrcompare('G',FALSE)); } /* char>= */
XLVAL xchrgtr() { return (chrcompare('>',FALSE)); } /* char> */
X
X/* character comparision functions (case insensitive) */
XLVAL xchrilss() { return (chrcompare('<',TRUE)); } /* char-lessp */
XLVAL xchrileq() { return (chrcompare('L',TRUE)); } /* char-not-greaterp */
XLVAL xchrieql() { return (chrcompare('=',TRUE)); } /* char-equalp */
XLVAL xchrineq() { return (chrcompare('#',TRUE)); } /* char-not-equalp */
XLVAL xchrigeq() { return (chrcompare('G',TRUE)); } /* char-not-lessp */
XLVAL xchrigtr() { return (chrcompare('>',TRUE)); } /* char-greaterp */
X
X/* chrcompare - compare characters */
XLOCAL LVAL chrcompare(fcn,icase)
X int fcn,icase;
X{
X int ch1,ch2,icmp;
X LVAL arg;
X
X /* get the characters */
X arg = xlgachar(); ch1 = getchcode(arg);
X
X /* convert to lowercase if case insensitive */
X if (icase && isupper(ch1))
X ch1 = tolower(ch1);
X
X /* handle each remaining argument */
X for (icmp = TRUE; icmp && moreargs(); ch1 = ch2) {
X
X /* get the next argument */
X arg = xlgachar(); ch2 = getchcode(arg);
X
X /* convert to lowercase if case insensitive */
X if (icase && isupper(ch2))
X ch2 = tolower(ch2);
X
X /* compare the characters */
X switch (fcn) {
X case '<': icmp = (ch1 < ch2); break;
X case 'L': icmp = (ch1 <= ch2); break;
X case '=': icmp = (ch1 == ch2); break;
X case '#': icmp = (ch1 != ch2); break;
X case 'G': icmp = (ch1 >= ch2); break;
X case '>': icmp = (ch1 > ch2); break;
X }
X }
X
X /* return the result */
X return (icmp ? true : NIL);
X}
X
SHAR_EOF
if test 13099 -ne "`wc -c 'xlstr.c'`"
then
echo shar: error transmitting "'xlstr.c'" '(should have been 13099 characters)'
fi
echo shar: extracting "'xlstruct.c'" '(10906 characters)'
if test -f 'xlstruct.c'
then
echo shar: over-writing existing file "'xlstruct.c'"
fi
sed 's/^X//' << \SHAR_EOF > 'xlstruct.c'
X/* xlstruct.c - the defstruct facility */
X/* Copyright (c) 1988, 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 LVAL xlenv,xlfenv;
Xextern LVAL s_lambda,s_quote,lk_key,true;
Xextern char buf[];
X
X/* local variables */
Xstatic prefix[STRMAX+1];
X
X/* xmkstruct - the '%make-struct' function */
XLVAL xmkstruct()
X{
X LVAL type,val;
X int i;
X
X /* get the structure type */
X type = xlgasymbol();
X
X /* make the structure */
X val = newstruct(type,xlargc);
X
X /* store each argument */
X for (i = 1; moreargs(); ++i)
X setelement(val,i,nextarg());
X xllastarg();
X
X /* return the structure */
X return (val);
X}
X
X/* xcpystruct - the '%copy-struct' function */
XLVAL xcpystruct()
X{
X LVAL str,val;
X int size,i;
X str = xlgastruct();
X xllastarg();
X size = getsize(str);
X val = newstruct(getelement(str,0),size-1);
X for (i = 1; i < size; ++i)
X setelement(val,i,getelement(str,i));
X return (val);
X}
X
X/* xstrref - the '%struct-ref' function */
XLVAL xstrref()
X{
X LVAL str,val;
X int i;
X str = xlgastruct();
X val = xlgafixnum(); i = (int)getfixnum(val);
X xllastarg();
X return (getelement(str,i));
X}
X
X/* xstrset - the '%struct-set' function */
XLVAL xstrset()
X{
X LVAL str,val;
X int i;
X str = xlgastruct();
X val = xlgafixnum(); i = (int)getfixnum(val);
X val = xlgetarg();
X xllastarg();
X setelement(str,i,val);
X return (val);
X}
X
X/* xstrtypep - the '%struct-type-p' function */
XLVAL xstrtypep()
X{
X LVAL type,val;
X type = xlgasymbol();
X val = xlgetarg();
X xllastarg();
X return (structp(val) && getelement(val,0) == type ? true : NIL);
X}
X
X/* xdefstruct - the 'defstruct' special form */
XLVAL xdefstruct()
X{
X LVAL structname,slotname,defexpr,sym,tmp,args,body;
X LVAL options,oargs,slots;
X char *pname;
X int slotn;
X
X /* protect some pointers */
X xlstkcheck(6);
X xlsave(structname);
X xlsave(slotname);
X xlsave(defexpr);
X xlsave(args);
X xlsave(body);
X xlsave(tmp);
X
X /* initialize */
X args = body = NIL;
X slotn = 0;
X
X /* get the structure name */
X tmp = xlgetarg();
X if (symbolp(tmp)) {
X structname = tmp;
X strcpy(prefix,getstring(getpname(structname)));
X strcat(prefix,"-");
X }
X
X /* get the structure name and options */
X else if (consp(tmp) && symbolp(car(tmp))) {
X structname = car(tmp);
X strcpy(prefix,getstring(getpname(structname)));
X strcat(prefix,"-");
X
X /* handle the list of options */
X for (options = cdr(tmp); consp(options); options = cdr(options)) {
X
X /* get the next argument */
X tmp = car(options);
X
X /* handle options that don't take arguments */
X if (symbolp(tmp)) {
X pname = getstring(getpname(tmp));
X xlerror("unknown option",tmp);
X }
X
X /* handle options that take arguments */
X else if (consp(tmp) && symbolp(car(tmp))) {
X pname = getstring(getpname(car(tmp)));
X oargs = cdr(tmp);
X
X /* check for the :CONC-NAME keyword */
X if (strcmp(pname,":CONC-NAME") == 0) {
X
X /* get the name of the structure to include */
X if (!consp(oargs) || !symbolp(car(oargs)))
X xlerror("expecting a symbol",oargs);
X
X /* save the prefix */
X strcpy(prefix,getstring(getpname(car(oargs))));
X }
X
X /* check for the :INCLUDE keyword */
X else if (strcmp(pname,":INCLUDE") == 0) {
X
X /* get the name of the structure to include */
X if (!consp(oargs) || !symbolp(car(oargs)))
X xlerror("expecting a structure name",oargs);
X tmp = car(oargs);
X oargs = cdr(oargs);
X
X /* add each slot from the included structure */
X slots = xlgetprop(tmp,xlenter("*STRUCT-SLOTS*"));
X for (; consp(slots); slots = cdr(slots)) {
X if (consp(car(slots)) && consp(cdr(car(slots)))) {
X
X /* get the next slot description */
X tmp = car(slots);
X
X /* create the slot access functions */
X addslot(car(tmp),car(cdr(tmp)),++slotn,&args,&body);
X }
X }
X
X /* handle slot initialization overrides */
X for (; consp(oargs); oargs = cdr(oargs)) {
X tmp = car(oargs);
X if (symbolp(tmp)) {
X slotname = tmp;
X defexpr = NIL;
X }
X else if (consp(tmp) && symbolp(car(tmp))) {
X slotname = car(tmp);
X defexpr = (consp(cdr(tmp)) ? car(cdr(tmp)) : NIL);
X }
X else
X xlerror("bad slot description",tmp);
X updateslot(args,slotname,defexpr);
X }
X }
X else
X xlerror("unknown option",tmp);
X }
X else
X xlerror("bad option syntax",tmp);
X }
X }
X
X /* get each of the structure members */
X while (moreargs()) {
X
X /* get the slot name and default value expression */
X tmp = xlgetarg();
X if (symbolp(tmp)) {
X slotname = tmp;
X defexpr = NIL;
X }
X else if (consp(tmp) && symbolp(car(tmp))) {
X slotname = car(tmp);
X defexpr = (consp(cdr(tmp)) ? car(cdr(tmp)) : NIL);
X }
X else
X xlerror("bad slot description",tmp);
X
X /* create a closure for non-trival default expressions */
X if (defexpr != NIL) {
X tmp = newclosure(NIL,s_lambda,xlenv,xlfenv);
X setbody(tmp,cons(defexpr,NIL));
X tmp = cons(tmp,NIL);
X defexpr = tmp;
X }
X
X /* create the slot access functions */
X addslot(slotname,defexpr,++slotn,&args,&body);
X }
X
X /* store the slotnames and default expressions */
X xlputprop(structname,args,xlenter("*STRUCT-SLOTS*"));
X
X /* enter the MAKE-xxx symbol */
X sprintf(buf,"MAKE-%s",getstring(getpname(structname)));
X sym = xlenter(buf);
X
X /* make the MAKE-xxx function */
X args = cons(lk_key,args);
X tmp = cons(structname,NIL);
X tmp = cons(s_quote,tmp);
X body = cons(tmp,body);
X body = cons(xlenter("%MAKE-STRUCT"),body);
X body = cons(body,NIL);
X setfunction(sym,
X xlclose(sym,s_lambda,args,body,xlenv,xlfenv));
X
X /* enter the xxx-P symbol */
X sprintf(buf,"%s-P",getstring(getpname(structname)));
X sym = xlenter(buf);
X
X /* make the xxx-P function */
X args = cons(xlenter("X"),NIL);
X body = cons(xlenter("X"),NIL);
X tmp = cons(structname,NIL);
X tmp = cons(s_quote,tmp);
X body = cons(tmp,body);
X body = cons(xlenter("%STRUCT-TYPE-P"),body);
X body = cons(body,NIL);
X setfunction(sym,
X xlclose(sym,s_lambda,args,body,NIL,NIL));
X
X /* enter the COPY-xxx symbol */
X sprintf(buf,"COPY-%s",getstring(getpname(structname)));
X sym = xlenter(buf);
X
X /* make the COPY-xxx function */
X args = cons(xlenter("X"),NIL);
X body = cons(xlenter("X"),NIL);
X body = cons(xlenter("%COPY-STRUCT"),body);
X body = cons(body,NIL);
X setfunction(sym,
X xlclose(sym,s_lambda,args,body,NIL,NIL));
X
X /* restore the stack */
X xlpopn(6);
X
X /* return the structure name */
X return (structname);
X}
X
X/* xlrdstruct - convert a list to a structure (used by the reader) */
XLVAL xlrdstruct(list)
X LVAL list;
X{
X LVAL structname,sym,slotname,expr,last,val;
X
X /* protect the new structure */
X xlsave1(expr);
X
X /* get the structure name */
X if (!consp(list) || !symbolp(car(list)))
X xlerror("bad structure initialization list",list);
X structname = car(list);
X list = cdr(list);
X
X /* enter the MAKE-xxx symbol */
X sprintf(buf,"MAKE-%s",getstring(getpname(structname)));
X
X /* initialize the MAKE-xxx function call expression */
X expr = cons(xlenter(buf),NIL);
X last = expr;
X
X /* turn the rest of the initialization list into keyword arguments */
X while (consp(list) && consp(cdr(list))) {
X
X /* get the slot keyword name */
X slotname = car(list);
X if (!symbolp(slotname))
X xlerror("expecting a slot name",slotname);
X sprintf(buf,":%s",getstring(getpname(slotname)));
X
X /* add the slot keyword */
X rplacd(last,cons(xlenter(buf),NIL));
X last = cdr(last);
X list = cdr(list);
X
X /* add the value expression */
X rplacd(last,cons(car(list),NIL));
X last = cdr(last);
X list = cdr(list);
X }
X
X /* make sure all of the initializers were used */
X if (consp(list))
X xlerror("bad structure initialization list",list);
X
X /* invoke the creation function */
X val = xleval(expr);
X
X /* restore the stack */
X xlpop();
X
X /* return the new structure */
X return (val);
X}
X
X/* xlprstruct - print a structure (used by printer) */
Xxlprstruct(fptr,vptr,flag)
X LVAL fptr,vptr; int flag;
X{
X LVAL next;
X int i,n;
X xlputc(fptr,'#'); xlputc(fptr,'S'); xlputc(fptr,'(');
X xlprint(fptr,getelement(vptr,0),flag);
X next = xlgetprop(getelement(vptr,0),xlenter("*STRUCT-SLOTS*"));
X for (i = 1, n = getsize(vptr) - 1; i <= n && consp(next); ++i) {
X if (consp(car(next))) { /* should always succeed */
X xlputc(fptr,' ');
X xlprint(fptr,car(car(next)),flag);
X xlputc(fptr,' ');
X xlprint(fptr,getelement(vptr,i),flag);
X }
X next = cdr(next);
X }
X xlputc(fptr,')');
X}
X
X/* addslot - make the slot access functions */
XLOCAL addslot(slotname,defexpr,slotn,pargs,pbody)
X LVAL slotname,defexpr; int slotn; LVAL *pargs,*pbody;
X{
X LVAL sym,args,body,tmp;
X
X /* protect some pointers */
X xlstkcheck(4);
X xlsave(sym);
X xlsave(args);
X xlsave(body);
X xlsave(tmp);
X
X /* construct the update function name */
X sprintf(buf,"%s%s",prefix,getstring(getpname(slotname)));
X sym = xlenter(buf);
X
X /* make the access function */
X args = cons(xlenter("S"),NIL);
X body = cons(cvfixnum((FIXTYPE)slotn),NIL);
X body = cons(xlenter("S"),body);
X body = cons(xlenter("%STRUCT-REF"),body);
X body = cons(body,NIL);
X setfunction(sym,
X xlclose(sym,s_lambda,args,body,NIL,NIL));
X
X /* make the update function */
X args = cons(xlenter("V"),NIL);
X args = cons(xlenter("S"),args);
X body = cons(xlenter("V"),NIL);
X body = cons(cvfixnum((FIXTYPE)slotn),body);
X body = cons(xlenter("S"),body);
X body = cons(xlenter("%STRUCT-SET"),body);
X body = cons(body,NIL);
X xlputprop(sym,
X xlclose(NIL,s_lambda,args,body,NIL,NIL),
X xlenter("*SETF*"));
X
X /* add the slotname to the make-xxx keyword list */
X tmp = cons(defexpr,NIL);
X tmp = cons(slotname,tmp);
X tmp = cons(tmp,NIL);
X if ((args = *pargs) == NIL)
X *pargs = tmp;
X else {
X while (cdr(args) != NIL)
X args = cdr(args);
X rplacd(args,tmp);
X }
X
X /* add the slotname to the %make-xxx argument list */
X tmp = cons(slotname,NIL);
X if ((body = *pbody) == NIL)
X *pbody = tmp;
X else {
X while (cdr(body) != NIL)
X body = cdr(body);
X rplacd(body,tmp);
X }
X
X /* restore the stack */
X xlpopn(4);
X}
X
X/* updateslot - update a slot definition */
XLOCAL updateslot(args,slotname,defexpr)
X LVAL args,slotname,defexpr;
X{
X LVAL tmp;
X for (; consp(args); args = cdr(args))
X if (slotname == car(car(args))) {
X if (defexpr != NIL) {
X xlsave1(tmp);
X tmp = newclosure(NIL,s_lambda,xlenv,xlfenv);
X setbody(tmp,cons(defexpr,NIL));
X tmp = cons(tmp,NIL);
X defexpr = tmp;
X xlpop();
X }
X rplaca(cdr(car(args)),defexpr);
X break;
X }
X if (args == NIL)
X xlerror("unknown slot name",slotname);
X}
X
SHAR_EOF
if test 10906 -ne "`wc -c 'xlstruct.c'`"
then
echo shar: error transmitting "'xlstruct.c'" '(should have been 10906 characters)'
fi
echo shar: extracting "'xlsubr.c'" '(3858 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 LVAL k_test,k_tnot,s_eql;
X
X/* xlsubr - define a builtin function */
XLVAL xlsubr(sname,type,fcn,offset)
X char *sname; int type; LVAL (*fcn)(); int offset;
X{
X LVAL sym;
X sym = xlenter(sname);
X setfunction(sym,cvsubr(fcn,type,offset));
X return (sym);
X}
X
X/* xlgetkeyarg - get a keyword argument */
Xint xlgetkeyarg(key,pval)
X LVAL key,*pval;
X{
X LVAL *argv=xlargv;
X int argc=xlargc;
X for (argv = xlargv, argc = xlargc; (argc -= 2) >= 0; argv += 2) {
X if (*argv == key) {
X *pval = *++argv;
X return (TRUE);
X }
X }
X return (FALSE);
X}
X
X/* xlgkfixnum - get a fixnum keyword argument */
Xint xlgkfixnum(key,pval)
X LVAL key,*pval;
X{
X if (xlgetkeyarg(key,pval)) {
X if (!fixp(*pval))
X xlbadtype(*pval);
X return (TRUE);
X }
X return (FALSE);
X}
X
X/* xltest - get the :test or :test-not keyword argument */
Xxltest(pfcn,ptresult)
X LVAL *pfcn; int *ptresult;
X{
X if (xlgetkeyarg(k_test,pfcn)) /* :test */
X *ptresult = TRUE;
X else if (xlgetkeyarg(k_tnot,pfcn)) /* :test-not */
X *ptresult = FALSE;
X else {
X *pfcn = getfunction(s_eql);
X *ptresult = TRUE;
X }
X}
X
X/* xlgetfile - get a file or stream */
XLVAL xlgetfile()
X{
X LVAL arg;
X
X /* get a file or stream (cons) or nil */
X if (arg = xlgetarg()) {
X if (streamp(arg)) {
X if (getfile(arg) == NULL)
X xlfail("file not open");
X }
X else if (!ustreamp(arg))
X xlerror("bad argument type",arg);
X }
X return (arg);
X}
X
X/* xlgetfname - get a filename */
XLVAL xlgetfname()
X{
X LVAL name;
X
X /* get the next argument */
X name = xlgetarg();
X
X /* get the filename string */
X if (symbolp(name))
X name = getpname(name);
X else if (!stringp(name))
X xlerror("bad argument type",name);
X
X /* return the name */
X return (name);
X}
X
X/* needsextension - check if a filename needs an extension */
Xint needsextension(name)
X char *name;
X{
X char *p;
X
X /* check for an extension */
X for (p = &name[strlen(name)]; --p >= &name[0]; )
X if (*p == '.')
X return (FALSE);
X else if (!islower(*p) && !isupper(*p) && !isdigit(*p))
X return (TRUE);
X
X /* no extension found */
X return (TRUE);
X}
X
X/* xlbadtype - report a "bad argument type" error */
XLVAL xlbadtype(arg)
X LVAL arg;
X{
X xlerror("bad argument type",arg);
X}
X
X/* xltoofew - report a "too few arguments" error */
XLVAL xltoofew()
X{
X xlfail("too few arguments");
X}
X
X/* xltoomany - report a "too many arguments" error */
Xxltoomany()
X{
X xlfail("too many arguments");
X}
X
X/* eq - internal eq function */
Xint eq(arg1,arg2)
X LVAL arg1,arg2;
X{
X return (arg1 == arg2);
X}
X
X/* eql - internal eql function */
Xint eql(arg1,arg2)
X LVAL arg1,arg2;
X{
X /* compare the arguments */
X if (arg1 == arg2)
X return (TRUE);
X else if (arg1) {
X switch (ntype(arg1)) {
X case FIXNUM:
X return (fixp(arg2) ? getfixnum(arg1)==getfixnum(arg2) : FALSE);
X case FLONUM:
X return (floatp(arg2) ? getflonum(arg1)==getflonum(arg2) : FALSE);
X default:
X return (FALSE);
X }
X }
X else
X return (FALSE);
X}
X
X/* equal - internal equal function */
Xint equal(arg1,arg2)
X LVAL arg1,arg2;
X{
X /* compare the arguments */
X if (arg1 == arg2)
X return (TRUE);
X else if (arg1) {
X switch (ntype(arg1)) {
X case FIXNUM:
X return (fixp(arg2) ? getfixnum(arg1)==getfixnum(arg2) : FALSE);
X case FLONUM:
X return (floatp(arg2) ? getflonum(arg1)==getflonum(arg2) : FALSE);
X case STRING:
X return (stringp(arg2) ? strcmp(getstring(arg1),
X getstring(arg2)) == 0 : FALSE);
X case CONS:
X return (consp(arg2) ? equal(car(arg1),car(arg2))
X && equal(cdr(arg1),cdr(arg2)) : FALSE);
X default:
X return (FALSE);
X }
X }
X else
X return (FALSE);
X}
SHAR_EOF
if test 3858 -ne "`wc -c 'xlsubr.c'`"
then
echo shar: error transmitting "'xlsubr.c'" '(should have been 3858 characters)'
fi
echo shar: extracting "'xlsym.c'" '(5057 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 LVAL obarray,s_unbound;
Xextern LVAL xlenv,xlfenv,xldenv;
X
X/* forward declarations */
XFORWARD LVAL findprop();
X
X/* xlenter - enter a symbol into the obarray */
XLVAL xlenter(name)
X char *name;
X{
X LVAL sym,array;
X int i;
X
X /* check for nil */
X if (strcmp(name,"NIL") == 0)
X return (NIL);
X
X /* check for symbol already in table */
X array = getvalue(obarray);
X i = hash(name,HSIZE);
X for (sym = getelement(array,i); sym; sym = cdr(sym))
X if (strcmp(name,getstring(getpname(car(sym)))) == 0)
X return (car(sym));
X
X /* make a new symbol node and link it into the list */
X xlsave1(sym);
X sym = consd(getelement(array,i));
X rplaca(sym,xlmakesym(name));
X setelement(array,i,sym);
X xlpop();
X
X /* return the new symbol */
X return (car(sym));
X}
X
X/* xlmakesym - make a new symbol node */
XLVAL xlmakesym(name)
X char *name;
X{
X LVAL sym;
X sym = cvsymbol(name);
X if (*name == ':')
X setvalue(sym,sym);
X return (sym);
X}
X
X/* xlgetvalue - get the value of a symbol (with check) */
XLVAL xlgetvalue(sym)
X LVAL sym;
X{
X LVAL val;
X
X /* look for the value of the symbol */
X while ((val = xlxgetvalue(sym)) == s_unbound)
X xlunbound(sym);
X
X /* return the value */
X return (val);
X}
X
X/* xlxgetvalue - get the value of a symbol */
XLVAL xlxgetvalue(sym)
X LVAL sym;
X{
X register LVAL fp,ep;
X LVAL val;
X
X /* check the environment list */
X for (fp = xlenv; fp; fp = cdr(fp))
X
X /* check for an instance variable */
X if ((ep = car(fp)) && objectp(car(ep))) {
X if (xlobgetvalue(ep,sym,&val))
X return (val);
X }
X
X /* check an environment stack frame */
X else {
X for (; ep; ep = cdr(ep))
X if (sym == car(car(ep)))
X return (cdr(car(ep)));
X }
X
X /* return the global value */
X return (getvalue(sym));
X}
X
X/* xlsetvalue - set the value of a symbol */
Xxlsetvalue(sym,val)
X LVAL sym,val;
X{
X register LVAL fp,ep;
X
X /* look for the symbol in the environment list */
X for (fp = xlenv; fp; fp = cdr(fp))
X
X /* check for an instance variable */
X if ((ep = car(fp)) && objectp(car(ep))) {
X if (xlobsetvalue(ep,sym,val))
X return;
X }
X
X /* check an environment stack frame */
X else {
X for (; ep; ep = cdr(ep))
X if (sym == car(car(ep))) {
X rplacd(car(ep),val);
X return;
X }
X }
X
X /* store the global value */
X setvalue(sym,val);
X}
X
X/* xlgetfunction - get the functional value of a symbol (with check) */
XLVAL xlgetfunction(sym)
X LVAL sym;
X{
X LVAL val;
X
X /* look for the functional value of the symbol */
X while ((val = xlxgetfunction(sym)) == s_unbound)
X xlfunbound(sym);
X
X /* return the value */
X return (val);
X}
X
X/* xlxgetfunction - get the functional value of a symbol */
XLVAL xlxgetfunction(sym)
X LVAL sym;
X{
X register LVAL fp,ep;
X
X /* check the environment list */
X for (fp = xlfenv; 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 (getfunction(sym));
X}
X
X/* xlsetfunction - set the functional value of a symbol */
Xxlsetfunction(sym,val)
X LVAL sym,val;
X{
X register LVAL fp,ep;
X
X /* look for the symbol in the environment list */
X for (fp = xlfenv; 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 setfunction(sym,val);
X}
X
X/* xlgetprop - get the value of a property */
XLVAL xlgetprop(sym,prp)
X LVAL sym,prp;
X{
X LVAL 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 LVAL sym,val,prp;
X{
X LVAL pair;
X if (pair = findprop(sym,prp))
X rplaca(pair,val);
X else
X setplist(sym,cons(prp,cons(val,getplist(sym))));
X}
X
X/* xlremprop - remove a property from a property list */
Xxlremprop(sym,prp)
X LVAL sym,prp;
X{
X LVAL last,p;
X last = NIL;
X for (p = getplist(sym); 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 setplist(sym,cdr(cdr(p)));
X last = cdr(p);
X }
X}
X
X/* findprop - find a property pair */
XLOCAL LVAL findprop(sym,prp)
X LVAL sym,prp;
X{
X LVAL p;
X for (p = getplist(sym); consp(p) && consp(cdr(p)); p = cdr(cdr(p)))
X if (car(p) == prp)
X return (cdr(p));
X return (NIL);
X}
X
X/* hash - hash a symbol name string */
Xint hash(str,len)
X char *str;
X{
X int i;
X for (i = 0; *str; )
X i = (i << 2) ^ *str++;
X i %= len;
X return (i < 0 ? -i : i);
X}
X
X/* xlsinit - symbol initialization routine */
Xxlsinit()
X{
X LVAL array,p;
X
X /* initialize the obarray */
X obarray = xlmakesym("*OBARRAY*");
X array = newvector(HSIZE);
X setvalue(obarray,array);
X
X /* add the symbol *OBARRAY* to the obarray */
X p = consa(obarray);
X setelement(array,hash("*OBARRAY*",HSIZE),p);
X}
SHAR_EOF
if test 5057 -ne "`wc -c 'xlsym.c'`"
then
echo shar: error transmitting "'xlsym.c'" '(should have been 5057 characters)'
fi
echo shar: extracting "'xlsys.c'" '(3335 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 jmp_buf top_level;
Xextern FILE *tfp;
X
X/* external symbols */
Xextern LVAL a_subr,a_fsubr,a_cons,a_symbol;
Xextern LVAL a_fixnum,a_flonum,a_string,a_object,a_stream;
Xextern LVAL a_vector,a_closure,a_char,a_ustream;
Xextern LVAL k_verbose,k_print;
Xextern LVAL true;
X
X/* external routines */
Xextern FILE *osaopen();
X
X/* xload - read and evaluate expressions from a file */
XLVAL xload()
X{
X unsigned char *name;
X int vflag,pflag;
X LVAL arg;
X
X /* get the file name */
X name = getstring(xlgetfname());
X
X /* get the :verbose flag */
X if (xlgetkeyarg(k_verbose,&arg))
X vflag = (arg != NIL);
X else
X vflag = TRUE;
X
X /* get the :print flag */
X if (xlgetkeyarg(k_print,&arg))
X pflag = (arg != NIL);
X else
X pflag = FALSE;
X
X /* load the file */
X return (xlload(name,vflag,pflag) ? true : NIL);
X}
X
X/* xtranscript - open or close a transcript file */
XLVAL xtranscript()
X{
X unsigned char *name;
X
X /* get the transcript file name */
X name = (moreargs() ? getstring(xlgetfname()) : NULL);
X xllastarg();
X
X /* close the current transcript */
X if (tfp) osclose(tfp);
X
X /* open the new transcript */
X tfp = (name ? osaopen(name,"w") : NULL);
X
X /* return T if a transcript is open, NIL otherwise */
X return (tfp ? true : NIL);
X}
X
X/* xtype - return type of a thing */
XLVAL xtype()
X{
X LVAL arg;
X
X if (!(arg = xlgetarg()))
X return (NIL);
X
X switch (ntype(arg)) {
X case SUBR: return (a_subr);
X case FSUBR: return (a_fsubr);
X case CONS: return (a_cons);
X case SYMBOL: return (a_symbol);
X case FIXNUM: return (a_fixnum);
X case FLONUM: return (a_flonum);
X case STRING: return (a_string);
X case OBJECT: return (a_object);
X case STREAM: return (a_stream);
X case VECTOR: return (a_vector);
X case CLOSURE: return (a_closure);
X case CHAR: return (a_char);
X case USTREAM: return (a_ustream);
X case STRUCT: return (getelement(arg,0));
X default: xlfail("bad node type");
X }
X}
X
X/* xbaktrace - print the trace back stack */
XLVAL xbaktrace()
X{
X LVAL num;
X int n;
X
X if (moreargs()) {
X num = xlgafixnum();
X n = getfixnum(num);
X }
X else
X n = -1;
X xllastarg();
X xlbaktrace(n);
X return (NIL);
X}
X
X/* xexit - get out of xlisp */
XLVAL xexit()
X{
X xllastarg();
X wrapup();
X}
X
X/* xpeek - peek at a location in memory */
XLVAL xpeek()
X{
X LVAL num;
X int *adr;
X
X /* get the address */
X num = xlgafixnum(); adr = (int *)getfixnum(num);
X xllastarg();
X
X /* return the value at that address */
X return (cvfixnum((FIXTYPE)*adr));
X}
X
X/* xpoke - poke a value into memory */
XLVAL xpoke()
X{
X LVAL val;
X int *adr;
X
X /* get the address and the new value */
X val = xlgafixnum(); adr = (int *)getfixnum(val);
X val = xlgafixnum();
X xllastarg();
X
X /* store the new value */
X *adr = (int)getfixnum(val);
X
X /* return the new value */
X return (val);
X}
X
X/* xaddrs - get the address of an XLISP node */
XLVAL xaddrs()
X{
X LVAL val;
X
X /* get the node */
X val = xlgetarg();
X xllastarg();
X
X /* return the address of the node */
X return (cvfixnum((FIXTYPE)val));
X}
X
SHAR_EOF
if test 3335 -ne "`wc -c 'xlsys.c'`"
then
echo shar: error transmitting "'xlsys.c'" '(should have been 3335 characters)'
fi
# End of shell archive
exit 0
--
Gary Murphy uunet!mitel!sce!cognos!garym
(garym%cognos.uucp@uunet.uu.net)
(613) 738-1338 x5537 Cognos Inc. P.O. Box 9707 Ottawa K1G 3N3
"There are many things which do not concern the process" - Joan of Arc