v10i093: XLisP 2.1 sources 3b (2/2) / 5
Gary Murphy
garym at cognos.UUCP
Tue Feb 27 14:12:17 AEST 1990
Posting-number: Volume 10, Issue 93
Submitted-by: garym at cognos.UUCP (Gary Murphy)
Archive-name: xlisp21/part06
#!/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:
# xlfio.c
# xlftab.c
# xlglob.c
# xlimage.c
# xlinit.c
# xlio.c
# xlisp.c
# xlisp.h
# xlisp.lnk
# xlisp.mac
# This archive created: Sun Feb 18 23:37:48 1990
# By: Gary Murphy ()
export PATH; PATH=/bin:$PATH
echo shar: extracting "'xlfio.c'" '(9976 characters)'
if test -f 'xlfio.c'
then
echo shar: over-writing existing file "'xlfio.c'"
fi
sed 's/^X//' << \SHAR_EOF > 'xlfio.c'
X/* xlfio.c - xlisp file i/o */
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_direction,k_input,k_output;
Xextern LVAL s_stdin,s_stdout,true;
Xextern unsigned char buf[];
Xextern int xlfsize;
X
X/* external routines */
Xextern FILE *osaopen();
X
X/* forward declarations */
XFORWARD LVAL getstroutput();
XFORWARD LVAL printit();
XFORWARD LVAL flatsize();
XFORWARD LVAL openit();
X
X/* xread - read an expression */
XLVAL xread()
X{
X LVAL fptr,eof,rflag,val;
X
X /* get file pointer and eof value */
X fptr = (moreargs() ? xlgetfile() : getvalue(s_stdin));
X eof = (moreargs() ? xlgetarg() : NIL);
X rflag = (moreargs() ? xlgetarg() : NIL);
X xllastarg();
X
X /* read an expression */
X if (!xlread(fptr,&val,rflag != NIL))
X val = eof;
X
X /* return the expression */
X return (val);
X}
X
X/* xprint - built-in function 'print' */
XLVAL xprint()
X{
X return (printit(TRUE,TRUE));
X}
X
X/* xprin1 - built-in function 'prin1' */
XLVAL xprin1()
X{
X return (printit(TRUE,FALSE));
X}
X
X/* xprinc - built-in function princ */
XLVAL xprinc()
X{
X return (printit(FALSE,FALSE));
X}
X
X/* xterpri - terminate the current print line */
XLVAL xterpri()
X{
X LVAL fptr;
X
X /* get file pointer */
X fptr = (moreargs() ? xlgetfile() : getvalue(s_stdout));
X xllastarg();
X
X /* terminate the print line and return nil */
X xlterpri(fptr);
X return (NIL);
X}
X
X/* printit - common print function */
XLOCAL LVAL printit(pflag,tflag)
X int pflag,tflag;
X{
X LVAL fptr,val;
X
X /* get expression to print and file pointer */
X val = xlgetarg();
X fptr = (moreargs() ? xlgetfile() : getvalue(s_stdout));
X xllastarg();
X
X /* print the value */
X xlprint(fptr,val,pflag);
X
X /* terminate the print line if necessary */
X if (tflag)
X xlterpri(fptr);
X
X /* return the result */
X return (val);
X}
X
X/* xflatsize - compute the size of a printed representation using prin1 */
XLVAL xflatsize()
X{
X return (flatsize(TRUE));
X}
X
X/* xflatc - compute the size of a printed representation using princ */
XLVAL xflatc()
X{
X return (flatsize(FALSE));
X}
X
X/* flatsize - compute the size of a printed expression */
XLOCAL LVAL flatsize(pflag)
X int pflag;
X{
X LVAL val;
X
X /* get the expression */
X val = xlgetarg();
X xllastarg();
X
X /* print the value to compute its size */
X xlfsize = 0;
X xlprint(NIL,val,pflag);
X
X /* return the length of the expression */
X return (cvfixnum((FIXTYPE)xlfsize));
X}
X
X/* xopen - open a file */
XLVAL xopen()
X{
X char *name,*mode;
X FILE *fp;
X LVAL dir;
X
X /* get the file name and direction */
X name = (char *)getstring(xlgetfname());
X if (!xlgetkeyarg(k_direction,&dir))
X dir = k_input;
X
X /* get the mode */
X if (dir == k_input)
X mode = "r";
X else if (dir == k_output)
X mode = "w";
X else
X xlerror("bad direction",dir);
X
X /* try to open the file */
X return ((fp = osaopen(name,mode)) ? cvfile(fp) : NIL);
X}
X
X/* xclose - close a file */
XLVAL xclose()
X{
X LVAL fptr;
X
X /* get file pointer */
X fptr = xlgastream();
X xllastarg();
X
X /* make sure the file exists */
X if (getfile(fptr) == NULL)
X xlfail("file not open");
X
X /* close the file */
X osclose(getfile(fptr));
X setfile(fptr,NULL);
X
X /* return nil */
X return (NIL);
X}
X
X/* xrdchar - read a character from a file */
XLVAL xrdchar()
X{
X LVAL fptr;
X int ch;
X
X /* get file pointer */
X fptr = (moreargs() ? xlgetfile() : getvalue(s_stdin));
X xllastarg();
X
X /* get character and check for eof */
X return ((ch = xlgetc(fptr)) == EOF ? NIL : cvchar(ch));
X}
X
X/* xrdbyte - read a byte from a file */
XLVAL xrdbyte()
X{
X LVAL fptr;
X int ch;
X
X /* get file pointer */
X fptr = (moreargs() ? xlgetfile() : getvalue(s_stdin));
X xllastarg();
X
X /* get character and check for eof */
X return ((ch = xlgetc(fptr)) == EOF ? NIL : cvfixnum((FIXTYPE)ch));
X}
X
X/* xpkchar - peek at a character from a file */
XLVAL xpkchar()
X{
X LVAL flag,fptr;
X int ch;
X
X /* peek flag and get file pointer */
X flag = (moreargs() ? xlgetarg() : NIL);
X fptr = (moreargs() ? xlgetfile() : getvalue(s_stdin));
X xllastarg();
X
X /* skip leading white space and get a character */
X if (flag)
X while ((ch = xlpeek(fptr)) != EOF && isspace(ch))
X xlgetc(fptr);
X else
X ch = xlpeek(fptr);
X
X /* return the character */
X return (ch == EOF ? NIL : cvchar(ch));
X}
X
X/* xwrchar - write a character to a file */
XLVAL xwrchar()
X{
X LVAL fptr,chr;
X
X /* get the character and file pointer */
X chr = xlgachar();
X fptr = (moreargs() ? xlgetfile() : getvalue(s_stdout));
X xllastarg();
X
X /* put character to the file */
X xlputc(fptr,getchcode(chr));
X
X /* return the character */
X return (chr);
X}
X
X/* xwrbyte - write a byte to a file */
XLVAL xwrbyte()
X{
X LVAL fptr,chr;
X
X /* get the byte and file pointer */
X chr = xlgafixnum();
X fptr = (moreargs() ? xlgetfile() : getvalue(s_stdout));
X xllastarg();
X
X /* put byte to the file */
X xlputc(fptr,(int)getfixnum(chr));
X
X /* return the character */
X return (chr);
X}
X
X/* xreadline - read a line from a file */
XLVAL xreadline()
X{
X unsigned char buf[STRMAX+1],*p,*sptr;
X LVAL fptr,str,newstr;
X int len,blen,ch;
X
X /* protect some pointers */
X xlsave1(str);
X
X /* get file pointer */
X fptr = (moreargs() ? xlgetfile() : getvalue(s_stdin));
X xllastarg();
X
X /* get character and check for eof */
X len = blen = 0; p = buf;
X while ((ch = xlgetc(fptr)) != EOF && ch != '\n') {
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 /* check for end of file */
X if (len == 0 && p == buf && ch == EOF) {
X xlpop();
X return (NIL);
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 string */
X return (str);
X}
X
X
X/* xmkstrinput - make a string input stream */
XLVAL xmkstrinput()
X{
X int start,end,len,i;
X unsigned char *str;
X LVAL string,val;
X
X /* protect the return value */
X xlsave1(val);
X
X /* get the string and length */
X string = xlgastring();
X str = getstring(string);
X len = getslength(string) - 1;
X
X /* get the starting offset */
X if (moreargs()) {
X val = xlgafixnum();
X start = (int)getfixnum(val);
X }
X else start = 0;
X
X /* get the ending offset */
X if (moreargs()) {
X val = xlgafixnum();
X end = (int)getfixnum(val);
X }
X else end = len;
X xllastarg();
X
X /* check the bounds */
X if (start < 0 || start > len)
X xlerror("string index out of bounds",cvfixnum((FIXTYPE)start));
X if (end < 0 || end > len)
X xlerror("string index out of bounds",cvfixnum((FIXTYPE)end));
X
X /* make the stream */
X val = newustream();
X
X /* copy the substring into the stream */
X for (i = start; i < end; ++i)
X xlputc(val,str[i]);
X
X /* restore the stack */
X xlpop();
X
X /* return the new stream */
X return (val);
X}
X
X/* xmkstroutput - make a string output stream */
XLVAL xmkstroutput()
X{
X return (newustream());
X}
X
X/* xgetstroutput - get output stream string */
XLVAL xgetstroutput()
X{
X LVAL stream;
X stream = xlgaustream();
X xllastarg();
X return (getstroutput(stream));
X}
X
X/* xgetlstoutput - get output stream list */
XLVAL xgetlstoutput()
X{
X LVAL stream,val;
X
X /* get the stream */
X stream = xlgaustream();
X xllastarg();
X
X /* get the output character list */
X val = gethead(stream);
X
X /* empty the character list */
X sethead(stream,NIL);
X settail(stream,NIL);
X
X /* return the list */
X return (val);
X}
X
X/* xformat - formatted output function */
XLVAL xformat()
X{
X LVAL fmtstring,stream,val;
X unsigned char *fmt;
X int ch;
X
X /* protect some pointers */
X xlstkcheck(2);
X xlsave(fmtstring);
X xlsave(stream);
X
X /* get the stream and format string */
X stream = xlgetarg();
X if (stream == NIL)
X val = stream = newustream();
X else {
X if (stream == true)
X stream = getvalue(s_stdout);
X else if (!streamp(stream) && !ustreamp(stream))
X xlbadtype(stream);
X val = NIL;
X }
X fmtstring = xlgastring();
X fmt = getstring(fmtstring);
X
X /* process the format string */
X while (ch = *fmt++)
X if (ch == '~') {
X switch (*fmt++) {
X case '\0':
X xlerror("expecting a format directive",cvstring(fmt-1));
X case 'a': case 'A':
X xlprint(stream,xlgetarg(),FALSE);
X break;
X case 's': case 'S':
X xlprint(stream,xlgetarg(),TRUE);
X break;
X case '%':
X xlterpri(stream);
X break;
X case '~':
X xlputc(stream,'~');
X break;
X case '\n':
X while (*fmt && *fmt != '\n' && isspace(*fmt))
X ++fmt;
X break;
X default:
X xlerror("unknown format directive",cvstring(fmt-1));
X }
X }
X else
X xlputc(stream,ch);
X
X /* get the output string for a stream argument of NIL */
X if (val) val = getstroutput(val);
X xlpopn(2);
X
X /* return the value */
X return (val);
X}
X
X/* getstroutput - get the output stream string (internal) */
XLOCAL LVAL getstroutput(stream)
X LVAL stream;
X{
X unsigned char *str;
X LVAL next,val;
X int len,ch;
X
X /* compute the length of the stream */
X for (len = 0, next = gethead(stream); next != NIL; next = cdr(next))
X ++len;
X
X /* create a new string */
X val = newstring(len + 1);
X
X /* copy the characters into the new string */
X str = getstring(val);
X while ((ch = xlgetc(stream)) != EOF)
X *str++ = ch;
X *str = '\0';
X
X /* return the string */
X return (val);
X}
X
SHAR_EOF
if test 9976 -ne "`wc -c 'xlfio.c'`"
then
echo shar: error transmitting "'xlfio.c'" '(should have been 9976 characters)'
fi
echo shar: extracting "'xlftab.c'" '(16622 characters)'
if test -f 'xlftab.c'
then
echo shar: over-writing existing file "'xlftab.c'"
fi
sed 's/^X//' << \SHAR_EOF > 'xlftab.c'
X/* xlftab.c - xlisp function table */
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 functions */
Xextern LVAL
X xbisubr(),xbifsubr(),
X rmhash(),rmquote(),rmdquote(),rmbquote(),rmcomma(),
X clnew(),clisnew(),clanswer(),
X obisnew(),obclass(),obshow(),
X rmlpar(),rmrpar(),rmsemi(),
X xeval(),xapply(),xfuncall(),xquote(),xfunction(),xbquote(),
X xlambda(),xset(),xsetq(),xsetf(),xdefun(),xdefmacro(),
X xgensym(),xmakesymbol(),xintern(),
X xsymname(),xsymvalue(),xsymplist(),
X xget(),xputprop(),xremprop(),
X xhash(),xmkarray(),xaref(),
X xcar(),xcdr(),
X xcaar(),xcadr(),xcdar(),xcddr(),
X xcaaar(),xcaadr(),xcadar(),xcaddr(),
X xcdaar(),xcdadr(),xcddar(),xcdddr(),
X xcaaaar(),xcaaadr(),xcaadar(),xcaaddr(),
X xcadaar(),xcadadr(),xcaddar(),xcadddr(),
X xcdaaar(),xcdaadr(),xcdadar(),xcdaddr(),
X xcddaar(),xcddadr(),xcdddar(),xcddddr(),
X xcons(),xlist(),xappend(),xreverse(),xlast(),xnth(),xnthcdr(),
X xmember(),xassoc(),xsubst(),xsublis(),xlength(),xsort(),
X xremove(),xremif(),xremifnot(),
X xmapc(),xmapcar(),xmapl(),xmaplist(),
X xrplca(),xrplcd(),xnconc(),
X xdelete(),xdelif(),xdelifnot(),
X xatom(),xsymbolp(),xnumberp(),xboundp(),xnull(),xlistp(),xendp(),xconsp(),
X xeq(),xeql(),xequal(),
X xcond(),xcase(),xand(),xor(),xlet(),xletstar(),xif(),
X xprog(),xprogstar(),xprog1(),xprog2(),xprogn(),xgo(),xreturn(),
X xcatch(),xthrow(),
X xerror(),xcerror(),xbreak(),
X xcleanup(),xtoplevel(),xcontinue(),xerrset(),
X xbaktrace(),xevalhook(),
X xdo(),xdostar(),xdolist(),xdotimes(),
X xminusp(),xzerop(),xplusp(),xevenp(),xoddp(),
X xfix(),xfloat(),
X xgcd(),xadd(),xsub(),xmul(),xdiv(),xrem(),xmin(),xmax(),xabs(),
X xadd1(),xsub1(),xlogand(),xlogior(),xlogxor(),xlognot(),
X xsin(),xcos(),xtan(),xexpt(),xexp(),xsqrt(),xrand(),
X xlss(),xleq(),xequ(),xneq(),xgeq(),xgtr(),
X xstrcat(),xsubseq(),xstring(),xchar(),
X xread(),xprint(),xprin1(),xprinc(),xterpri(),
X xflatsize(),xflatc(),
X xopen(),xclose(),xrdchar(),xpkchar(),xwrchar(),xreadline(),
X xload(),xtranscript(),
X xtype(),xexit(),xpeek(),xpoke(),xaddrs(),
X xvector(),xblock(),xrtnfrom(),xtagbody(),
X xpsetq(),xflet(),xlabels(),xmacrolet(),xunwindprotect(),xpp(),
X xstrlss(),xstrleq(),xstreql(),xstrneq(),xstrgeq(),xstrgtr(),
X xstrilss(),xstrileq(),xstrieql(),xstrineq(),xstrigeq(),xstrigtr(),
X xupcase(),xdowncase(),xnupcase(),xndowncase(),
X xtrim(),xlefttrim(),xrighttrim(),
X xuppercasep(),xlowercasep(),xbothcasep(),xdigitp(),xalphanumericp(),
X xcharcode(),xcodechar(),xchupcase(),xchdowncase(),xdigitchar(),
X xchrlss(),xchrleq(),xchreql(),xchrneq(),xchrgeq(),xchrgtr(),
X xchrilss(),xchrileq(),xchrieql(),xchrineq(),xchrigeq(),xchrigtr(),
X xintegerp(),xfloatp(),xstringp(),xarrayp(),xstreamp(),xobjectp(),
X xwhen(),xunless(),xloop(),
X xsymfunction(),xfboundp(),xsend(),xsendsuper(),
X xprogv(),xrdbyte(),xwrbyte(),xformat(),
X xcharp(),xcharint(),xintchar(),
X xmkstrinput(),xmkstroutput(),xgetstroutput(),xgetlstoutput(),
X xgetlambda(),xmacroexpand(),x1macroexpand(),
X xtrace(),xuntrace(),
X xdefstruct(),xmkstruct(),xcpystruct(),xstrref(),xstrset(),xstrtypep(),
X xasin(),xacos(),xatan();
X
X/* functions specific to xldmem.c */
XLVAL xgc(),xexpand(),xalloc(),xmem();
X#ifdef SAVERESTORE
XLVAL xsave(),xrestore();
X#endif
X
X/* include system dependant definitions */
X#include "osdefs.h"
X
X/* SUBR/FSUBR indicator */
X#define S SUBR
X#define F FSUBR
X
X/* forward declarations */
XLVAL xnotimp();
X
X/* the function table */
XFUNDEF funtab[] = {
X
X /* read macro functions */
X{ NULL, S, rmhash }, /* 0 */
X{ NULL, S, rmquote }, /* 1 */
X{ NULL, S, rmdquote }, /* 2 */
X{ NULL, S, rmbquote }, /* 3 */
X{ NULL, S, rmcomma }, /* 4 */
X{ NULL, S, rmlpar }, /* 5 */
X{ NULL, S, rmrpar }, /* 6 */
X{ NULL, S, rmsemi }, /* 7 */
X{ NULL, S, xnotimp }, /* 8 */
X{ NULL, S, xnotimp }, /* 9 */
X
X /* methods */
X{ NULL, S, clnew }, /* 10 */
X{ NULL, S, clisnew }, /* 11 */
X{ NULL, S, clanswer }, /* 12 */
X{ NULL, S, obisnew }, /* 13 */
X{ NULL, S, obclass }, /* 14 */
X{ NULL, S, obshow }, /* 15 */
X{ NULL, S, xnotimp }, /* 16 */
X{ NULL, S, xnotimp }, /* 17 */
X{ NULL, S, xnotimp }, /* 18 */
X{ NULL, S, xnotimp }, /* 19 */
X
X /* evaluator functions */
X{ "EVAL", S, xeval }, /* 20 */
X{ "APPLY", S, xapply }, /* 21 */
X{ "FUNCALL", S, xfuncall }, /* 22 */
X{ "QUOTE", F, xquote }, /* 23 */
X{ "FUNCTION", F, xfunction }, /* 24 */
X{ "BACKQUOTE", F, xbquote }, /* 25 */
X{ "LAMBDA", F, xlambda }, /* 26 */
X
X /* symbol functions */
X{ "SET", S, xset }, /* 27 */
X{ "SETQ", F, xsetq }, /* 28 */
X{ "SETF", F, xsetf }, /* 29 */
X{ "DEFUN", F, xdefun }, /* 30 */
X{ "DEFMACRO", F, xdefmacro }, /* 31 */
X{ "GENSYM", S, xgensym }, /* 32 */
X{ "MAKE-SYMBOL", S, xmakesymbol }, /* 33 */
X{ "INTERN", S, xintern }, /* 34 */
X{ "SYMBOL-NAME", S, xsymname }, /* 35 */
X{ "SYMBOL-VALUE", S, xsymvalue }, /* 36 */
X{ "SYMBOL-PLIST", S, xsymplist }, /* 37 */
X{ "GET", S, xget }, /* 38 */
X{ "PUTPROP", S, xputprop }, /* 39 */
X{ "REMPROP", S, xremprop }, /* 40 */
X{ "HASH", S, xhash }, /* 41 */
X
X /* array functions */
X{ "MAKE-ARRAY", S, xmkarray }, /* 42 */
X{ "AREF", S, xaref }, /* 43 */
X
X /* list functions */
X{ "CAR", S, xcar }, /* 44 */
X{ "CDR", S, xcdr }, /* 45 */
X
X{ "CAAR", S, xcaar }, /* 46 */
X{ "CADR", S, xcadr }, /* 47 */
X{ "CDAR", S, xcdar }, /* 48 */
X{ "CDDR", S, xcddr }, /* 49 */
X
X{ "CAAAR", S, xcaaar }, /* 50 */
X{ "CAADR", S, xcaadr }, /* 51 */
X{ "CADAR", S, xcadar }, /* 52 */
X{ "CADDR", S, xcaddr }, /* 53 */
X{ "CDAAR", S, xcdaar }, /* 54 */
X{ "CDADR", S, xcdadr }, /* 55 */
X{ "CDDAR", S, xcddar }, /* 56 */
X{ "CDDDR", S, xcdddr }, /* 57 */
X
X{ "CAAAAR", S, xcaaaar }, /* 58 */
X{ "CAAADR", S, xcaaadr }, /* 59 */
X{ "CAADAR", S, xcaadar }, /* 60 */
X{ "CAADDR", S, xcaaddr }, /* 61 */
X{ "CADAAR", S, xcadaar }, /* 62 */
X{ "CADADR", S, xcadadr }, /* 63 */
X{ "CADDAR", S, xcaddar }, /* 64 */
X{ "CADDDR", S, xcadddr }, /* 65 */
X{ "CDAAAR", S, xcdaaar }, /* 66 */
X{ "CDAADR", S, xcdaadr }, /* 67 */
X{ "CDADAR", S, xcdadar }, /* 68 */
X{ "CDADDR", S, xcdaddr }, /* 69 */
X{ "CDDAAR", S, xcddaar }, /* 70 */
X{ "CDDADR", S, xcddadr }, /* 71 */
X{ "CDDDAR", S, xcdddar }, /* 72 */
X{ "CDDDDR", S, xcddddr }, /* 73 */
X
X{ "CONS", S, xcons }, /* 74 */
X{ "LIST", S, xlist }, /* 75 */
X{ "APPEND", S, xappend }, /* 76 */
X{ "REVERSE", S, xreverse }, /* 77 */
X{ "LAST", S, xlast }, /* 78 */
X{ "NTH", S, xnth }, /* 79 */
X{ "NTHCDR", S, xnthcdr }, /* 80 */
X{ "MEMBER", S, xmember }, /* 81 */
X{ "ASSOC", S, xassoc }, /* 82 */
X{ "SUBST", S, xsubst }, /* 83 */
X{ "SUBLIS", S, xsublis }, /* 84 */
X{ "REMOVE", S, xremove }, /* 85 */
X{ "LENGTH", S, xlength }, /* 86 */
X{ "MAPC", S, xmapc }, /* 87 */
X{ "MAPCAR", S, xmapcar }, /* 88 */
X{ "MAPL", S, xmapl }, /* 89 */
X{ "MAPLIST", S, xmaplist }, /* 90 */
X
X /* destructive list functions */
X{ "RPLACA", S, xrplca }, /* 91 */
X{ "RPLACD", S, xrplcd }, /* 92 */
X{ "NCONC", S, xnconc }, /* 93 */
X{ "DELETE", S, xdelete }, /* 94 */
X
X /* predicate functions */
X{ "ATOM", S, xatom }, /* 95 */
X{ "SYMBOLP", S, xsymbolp }, /* 96 */
X{ "NUMBERP", S, xnumberp }, /* 97 */
X{ "BOUNDP", S, xboundp }, /* 98 */
X{ "NULL", S, xnull }, /* 99 */
X{ "LISTP", S, xlistp }, /* 100 */
X{ "CONSP", S, xconsp }, /* 101 */
X{ "MINUSP", S, xminusp }, /* 102 */
X{ "ZEROP", S, xzerop }, /* 103 */
X{ "PLUSP", S, xplusp }, /* 104 */
X{ "EVENP", S, xevenp }, /* 105 */
X{ "ODDP", S, xoddp }, /* 106 */
X{ "EQ", S, xeq }, /* 107 */
X{ "EQL", S, xeql }, /* 108 */
X{ "EQUAL", S, xequal }, /* 109 */
X
X /* special forms */
X{ "COND", F, xcond }, /* 110 */
X{ "CASE", F, xcase }, /* 111 */
X{ "AND", F, xand }, /* 112 */
X{ "OR", F, xor }, /* 113 */
X{ "LET", F, xlet }, /* 114 */
X{ "LET*", F, xletstar }, /* 115 */
X{ "IF", F, xif }, /* 116 */
X{ "PROG", F, xprog }, /* 117 */
X{ "PROG*", F, xprogstar }, /* 118 */
X{ "PROG1", F, xprog1 }, /* 119 */
X{ "PROG2", F, xprog2 }, /* 120 */
X{ "PROGN", F, xprogn }, /* 121 */
X{ "GO", F, xgo }, /* 122 */
X{ "RETURN", F, xreturn }, /* 123 */
X{ "DO", F, xdo }, /* 124 */
X{ "DO*", F, xdostar }, /* 125 */
X{ "DOLIST", F, xdolist }, /* 126 */
X{ "DOTIMES", F, xdotimes }, /* 127 */
X{ "CATCH", F, xcatch }, /* 128 */
X{ "THROW", F, xthrow }, /* 129 */
X
X /* debugging and error handling functions */
X{ "ERROR", S, xerror }, /* 130 */
X{ "CERROR", S, xcerror }, /* 131 */
X{ "BREAK", S, xbreak }, /* 132 */
X{ "CLEAN-UP", S, xcleanup }, /* 133 */
X{ "TOP-LEVEL", S, xtoplevel }, /* 134 */
X{ "CONTINUE", S, xcontinue }, /* 135 */
X{ "ERRSET", F, xerrset }, /* 136 */
X{ "BAKTRACE", S, xbaktrace }, /* 137 */
X{ "EVALHOOK", S, xevalhook }, /* 138 */
X
X /* arithmetic functions */
X{ "TRUNCATE", S, xfix }, /* 139 */
X{ "FLOAT", S, xfloat }, /* 140 */
X{ "+", S, xadd }, /* 141 */
X{ "-", S, xsub }, /* 142 */
X{ "*", S, xmul }, /* 143 */
X{ "/", S, xdiv }, /* 144 */
X{ "1+", S, xadd1 }, /* 145 */
X{ "1-", S, xsub1 }, /* 146 */
X{ "REM", S, xrem }, /* 147 */
X{ "MIN", S, xmin }, /* 148 */
X{ "MAX", S, xmax }, /* 149 */
X{ "ABS", S, xabs }, /* 150 */
X{ "SIN", S, xsin }, /* 151 */
X{ "COS", S, xcos }, /* 152 */
X{ "TAN", S, xtan }, /* 153 */
X{ "EXPT", S, xexpt }, /* 154 */
X{ "EXP", S, xexp }, /* 155 */
X{ "SQRT", S, xsqrt }, /* 156 */
X{ "RANDOM", S, xrand }, /* 157 */
X
X /* bitwise logical functions */
X{ "LOGAND", S, xlogand }, /* 158 */
X{ "LOGIOR", S, xlogior }, /* 159 */
X{ "LOGXOR", S, xlogxor }, /* 160 */
X{ "LOGNOT", S, xlognot }, /* 161 */
X
X /* numeric comparison functions */
X{ "<", S, xlss }, /* 162 */
X{ "<=", S, xleq }, /* 163 */
X{ "=", S, xequ }, /* 164 */
X{ "/=", S, xneq }, /* 165 */
X{ ">=", S, xgeq }, /* 166 */
X{ ">", S, xgtr }, /* 167 */
X
X /* string functions */
X{ "STRCAT", S, xstrcat }, /* 168 */
X{ "SUBSEQ", S, xsubseq }, /* 169 */
X{ "STRING", S, xstring }, /* 170 */
X{ "CHAR", S, xchar }, /* 171 */
X
X /* I/O functions */
X{ "READ", S, xread }, /* 172 */
X{ "PRINT", S, xprint }, /* 173 */
X{ "PRIN1", S, xprin1 }, /* 174 */
X{ "PRINC", S, xprinc }, /* 175 */
X{ "TERPRI", S, xterpri }, /* 176 */
X{ "FLATSIZE", S, xflatsize }, /* 177 */
X{ "FLATC", S, xflatc }, /* 178 */
X
X /* file I/O functions */
X{ "OPEN", S, xopen }, /* 179 */
X{ "FORMAT", S, xformat }, /* 180 */
X{ "CLOSE", S, xclose }, /* 181 */
X{ "READ-CHAR", S, xrdchar }, /* 182 */
X{ "PEEK-CHAR", S, xpkchar }, /* 183 */
X{ "WRITE-CHAR", S, xwrchar }, /* 184 */
X{ "READ-LINE", S, xreadline }, /* 185 */
X
X /* system functions */
X{ "LOAD", S, xload }, /* 186 */
X{ "DRIBBLE", S, xtranscript }, /* 187 */
X
X/* functions specific to xldmem.c */
X{ "GC", S, xgc }, /* 188 */
X{ "EXPAND", S, xexpand }, /* 189 */
X{ "ALLOC", S, xalloc }, /* 190 */
X{ "ROOM", S, xmem }, /* 191 */
X#ifdef SAVERESTORE
X{ "SAVE", S, xsave }, /* 192 */
X{ "RESTORE", S, xrestore }, /* 193 */
X#else
X{ NULL, S, xnotimp }, /* 192 */
X{ NULL, S, xnotimp }, /* 193 */
X#endif
X/* end of functions specific to xldmem.c */
X
X{ "TYPE-OF", S, xtype }, /* 194 */
X{ "EXIT", S, xexit }, /* 195 */
X{ "PEEK", S, xpeek }, /* 196 */
X{ "POKE", S, xpoke }, /* 197 */
X{ "ADDRESS-OF", S, xaddrs }, /* 198 */
X
X /* new functions and special forms */
X{ "VECTOR", S, xvector }, /* 199 */
X{ "BLOCK", F, xblock }, /* 200 */
X{ "RETURN-FROM", F, xrtnfrom }, /* 201 */
X{ "TAGBODY", F, xtagbody }, /* 202 */
X{ "PSETQ", F, xpsetq }, /* 203 */
X{ "FLET", F, xflet }, /* 204 */
X{ "LABELS", F, xlabels }, /* 205 */
X{ "MACROLET", F, xmacrolet }, /* 206 */
X{ "UNWIND-PROTECT", F, xunwindprotect }, /* 207 */
X{ "PPRINT", S, xpp }, /* 208 */
X{ "STRING<", S, xstrlss }, /* 209 */
X{ "STRING<=", S, xstrleq }, /* 210 */
X{ "STRING=", S, xstreql }, /* 211 */
X{ "STRING/=", S, xstrneq }, /* 212 */
X{ "STRING>=", S, xstrgeq }, /* 213 */
X{ "STRING>", S, xstrgtr }, /* 214 */
X{ "STRING-LESSP", S, xstrilss }, /* 215 */
X{ "STRING-NOT-GREATERP", S, xstrileq }, /* 216 */
X{ "STRING-EQUAL", S, xstrieql }, /* 217 */
X{ "STRING-NOT-EQUAL", S, xstrineq }, /* 218 */
X{ "STRING-NOT-LESSP", S, xstrigeq }, /* 219 */
X{ "STRING-GREATERP", S, xstrigtr }, /* 220 */
X{ "INTEGERP", S, xintegerp }, /* 221 */
X{ "FLOATP", S, xfloatp }, /* 222 */
X{ "STRINGP", S, xstringp }, /* 223 */
X{ "ARRAYP", S, xarrayp }, /* 224 */
X{ "STREAMP", S, xstreamp }, /* 225 */
X{ "OBJECTP", S, xobjectp }, /* 226 */
X{ "STRING-UPCASE", S, xupcase }, /* 227 */
X{ "STRING-DOWNCASE", S, xdowncase }, /* 228 */
X{ "NSTRING-UPCASE", S, xnupcase }, /* 229 */
X{ "NSTRING-DOWNCASE", S, xndowncase }, /* 230 */
X{ "STRING-TRIM", S, xtrim }, /* 231 */
X{ "STRING-LEFT-TRIM", S, xlefttrim }, /* 232 */
X{ "STRING-RIGHT-TRIM", S, xrighttrim }, /* 233 */
X{ "WHEN", F, xwhen }, /* 234 */
X{ "UNLESS", F, xunless }, /* 235 */
X{ "LOOP", F, xloop }, /* 236 */
X{ "SYMBOL-FUNCTION", S, xsymfunction }, /* 237 */
X{ "FBOUNDP", S, xfboundp }, /* 238 */
X{ "SEND", S, xsend }, /* 239 */
X{ "SEND-SUPER", S, xsendsuper }, /* 240 */
X{ "PROGV", F, xprogv }, /* 241 */
X{ "CHARACTERP", S, xcharp }, /* 242 */
X{ "CHAR-INT", S, xcharint }, /* 243 */
X{ "INT-CHAR", S, xintchar }, /* 244 */
X{ "READ-BYTE", S, xrdbyte }, /* 245 */
X{ "WRITE-BYTE", S, xwrbyte }, /* 246 */
X{ "MAKE-STRING-INPUT-STREAM", S, xmkstrinput }, /* 247 */
X{ "MAKE-STRING-OUTPUT-STREAM", S, xmkstroutput }, /* 248 */
X{ "GET-OUTPUT-STREAM-STRING", S, xgetstroutput }, /* 249 */
X{ "GET-OUTPUT-STREAM-LIST", S, xgetlstoutput }, /* 250 */
X{ "GCD", S, xgcd }, /* 251 */
X{ "GET-LAMBDA-EXPRESSION", S, xgetlambda }, /* 252 */
X{ "MACROEXPAND", S, xmacroexpand }, /* 253 */
X{ "MACROEXPAND-1", S, x1macroexpand }, /* 254 */
X{ "CHAR<", S, xchrlss }, /* 255 */
X{ "CHAR<=", S, xchrleq }, /* 256 */
X{ "CHAR=", S, xchreql }, /* 257 */
X{ "CHAR/=", S, xchrneq }, /* 258 */
X{ "CHAR>=", S, xchrgeq }, /* 259 */
X{ "CHAR>", S, xchrgtr }, /* 260 */
X{ "CHAR-LESSP", S, xchrilss }, /* 261 */
X{ "CHAR-NOT-GREATERP", S, xchrileq }, /* 262 */
X{ "CHAR-EQUAL", S, xchrieql }, /* 263 */
X{ "CHAR-NOT-EQUAL", S, xchrineq }, /* 264 */
X{ "CHAR-NOT-LESSP", S, xchrigeq }, /* 265 */
X{ "CHAR-GREATERP", S, xchrigtr }, /* 266 */
X{ "UPPER-CASE-P", S, xuppercasep }, /* 267 */
X{ "LOWER-CASE-P", S, xlowercasep }, /* 268 */
X{ "BOTH-CASE-P", S, xbothcasep }, /* 269 */
X{ "DIGIT-CHAR-P", S, xdigitp }, /* 270 */
X{ "ALPHANUMERICP", S, xalphanumericp }, /* 271 */
X{ "CHAR-UPCASE", S, xchupcase }, /* 272 */
X{ "CHAR-DOWNCASE", S, xchdowncase }, /* 273 */
X{ "DIGIT-CHAR", S, xdigitchar }, /* 274 */
X{ "CHAR-CODE", S, xcharcode }, /* 275 */
X{ "CODE-CHAR", S, xcodechar }, /* 276 */
X{ "ENDP", S, xendp }, /* 277 */
X{ "REMOVE-IF", S, xremif }, /* 278 */
X{ "REMOVE-IF-NOT", S, xremifnot }, /* 279 */
X{ "DELETE-IF", S, xdelif }, /* 280 */
X{ "DELETE-IF-NOT", S, xdelifnot }, /* 281 */
X{ "TRACE", F, xtrace }, /* 282 */
X{ "UNTRACE", F, xuntrace }, /* 283 */
X{ "SORT", S, xsort }, /* 284 */
X{ "DEFSTRUCT", F, xdefstruct }, /* 285 */
X{ "%STRUCT-TYPE-P", S, xstrtypep }, /* 286 */
X{ "%MAKE-STRUCT", S, xmkstruct }, /* 287 */
X{ "%COPY-STRUCT", S, xcpystruct }, /* 288 */
X{ "%STRUCT-REF", S, xstrref }, /* 289 */
X{ "%STRUCT-SET", S, xstrset }, /* 290 */
X{ "ASIN", S, xasin }, /* 291 */
X{ "ACOS", S, xacos }, /* 292 */
X{ "ATAN", S, xatan }, /* 293 */
X
X /* extra table entries */
X{ NULL, S, xnotimp }, /* 294 */
X{ NULL, S, xnotimp }, /* 295 */
X{ NULL, S, xnotimp }, /* 296 */
X{ NULL, S, xnotimp }, /* 297 */
X{ NULL, S, xnotimp }, /* 298 */
X{ NULL, S, xnotimp }, /* 299 */
X
X /* include system dependant function pointers */
X#include "osptrs.h"
X
X{0,0,0} /* end of table marker */
X
X};
X
X/* xnotimp - function table entries that are currently not implemented */
XLOCAL LVAL xnotimp()
X{
X xlfail("function not implemented");
X}
X
SHAR_EOF
if test 16622 -ne "`wc -c 'xlftab.c'`"
then
echo shar: error transmitting "'xlftab.c'" '(should have been 16622 characters)'
fi
echo shar: extracting "'xlglob.c'" '(2731 characters)'
if test -f 'xlglob.c'
then
echo shar: over-writing existing file "'xlglob.c'"
fi
sed 's/^X//' << \SHAR_EOF > 'xlglob.c'
X/* xlglobals - xlisp global variables */
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/* symbols */
XLVAL true=NIL,obarray=NIL;
XLVAL s_unbound=NIL,s_dot=NIL;
XLVAL s_quote=NIL,s_function=NIL;
XLVAL s_bquote=NIL,s_comma=NIL,s_comat=NIL;
XLVAL s_evalhook=NIL,s_applyhook=NIL,s_tracelist;
XLVAL s_lambda=NIL,s_macro=NIL;
XLVAL s_stdin=NIL,s_stdout=NIL,s_stderr=NIL,s_debugio=NIL,s_traceout=NIL;
XLVAL s_rtable=NIL;
XLVAL s_tracenable=NIL,s_tlimit=NIL,s_breakenable=NIL;
XLVAL s_setf=NIL,s_car=NIL,s_cdr=NIL,s_nth=NIL,s_aref=NIL,s_get=NIL;
XLVAL s_svalue=NIL,s_sfunction=NIL,s_splist=NIL;
XLVAL s_eql=NIL,s_gcflag=NIL,s_gchook=NIL;
XLVAL s_ifmt=NIL,s_ffmt=NIL;
XLVAL s_1plus=NIL,s_2plus=NIL,s_3plus=NIL;
XLVAL s_1star=NIL,s_2star=NIL,s_3star=NIL;
XLVAL s_minus=NIL,s_printcase=NIL;
X
X/* keywords */
XLVAL k_test=NIL,k_tnot=NIL;
XLVAL k_wspace=NIL,k_const=NIL,k_nmacro=NIL,k_tmacro=NIL;
XLVAL k_sescape=NIL,k_mescape=NIL;
XLVAL k_direction=NIL,k_input=NIL,k_output=NIL;
XLVAL k_start=NIL,k_end=NIL,k_1start=NIL,k_1end=NIL;
XLVAL k_2start=NIL,k_2end=NIL,k_count=NIL,k_key=NIL;
XLVAL k_verbose=NIL,k_print=NIL;
XLVAL k_upcase=NIL,k_downcase=NIL;
X
X/* lambda list keywords */
XLVAL lk_optional=NIL,lk_rest=NIL,lk_key=NIL,lk_aux=NIL;
XLVAL lk_allow_other_keys=NIL;
X
X/* type names */
XLVAL a_subr=NIL,a_fsubr=NIL;
XLVAL a_cons=NIL,a_symbol=NIL,a_fixnum=NIL,a_flonum=NIL;
XLVAL a_string=NIL,a_object=NIL,a_stream=NIL,a_vector=NIL;
XLVAL a_closure=NIL,a_char=NIL,a_ustream=NIL;
X
X/* evaluation variables */
XLVAL **xlstack = NULL,**xlstkbase = NULL,**xlstktop = NULL;
XLVAL xlenv=NIL,xlfenv=NIL,xldenv=NIL;
X
X/* argument stack */
XLVAL *xlargstkbase = NULL; /* argument stack base */
XLVAL *xlargstktop = NULL; /* argument stack top */
XLVAL *xlfp = NULL; /* argument frame pointer */
XLVAL *xlsp = NULL; /* argument stack pointer */
XLVAL *xlargv = NULL; /* current argument vector */
Xint xlargc = 0; /* current argument count */
X
X/* exception handling variables */
XCONTEXT *xlcontext = NULL; /* current exception handler */
XCONTEXT *xltarget = NULL; /* target context (for xljump) */
XLVAL xlvalue=NIL; /* exception value (for xljump) */
Xint xlmask=0; /* exception type (for xljump) */
X
X/* debugging variables */
Xint xldebug = 0; /* debug level */
Xint xlsample = 0; /* control character sample rate */
Xint xltrcindent = 0; /* trace indent level */
X
X/* gensym variables */
Xchar gsprefix[STRMAX+1] = { 'G',0 }; /* gensym prefix string */
Xint gsnumber = 1; /* gensym number */
X
X/* i/o variables */
Xint xlfsize = 0; /* flat size of current print call */
XFILE *tfp = NULL; /* transcript file pointer */
X
X/* general purpose string buffer */
Xchar buf[STRMAX+1] = { 0 };
X
SHAR_EOF
if test 2731 -ne "`wc -c 'xlglob.c'`"
then
echo shar: error transmitting "'xlglob.c'" '(should have been 2731 characters)'
fi
echo shar: extracting "'xlimage.c'" '(8425 characters)'
if test -f 'xlimage.c'
then
echo shar: over-writing existing file "'xlimage.c'"
fi
sed 's/^X//' << \SHAR_EOF > 'xlimage.c'
X/* xlimage - xlisp memory image save/restore 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 SAVERESTORE
X
X/* external variables */
Xextern LVAL obarray,xlenv,xlfenv,xldenv,s_gchook,s_gcflag;
Xextern long nnodes,nfree,total;
Xextern int anodes,nsegs,gccalls;
Xextern struct segment *segs,*lastseg,*fixseg,*charseg;
Xextern CONTEXT *xlcontext;
Xextern LVAL fnodes;
X
X/* local variables */
Xstatic OFFTYPE off,foff,doff;
Xstatic FILE *fp;
X
X/* external procedures */
Xextern SEGMENT *newsegment();
Xextern FILE *osbopen();
Xextern char *malloc();
X
X/* forward declarations */
XOFFTYPE readptr();
XOFFTYPE cvoptr();
XLVAL cviptr();
X
X/* xlisave - save the memory image */
Xint xlisave(fname)
X char *fname;
X{
X char fullname[STRMAX+1];
X unsigned char *cp;
X SEGMENT *seg;
X int n,i,max;
X LVAL p;
X
X /* default the extension */
X if (needsextension(fname)) {
X strcpy(fullname,fname);
X strcat(fullname,".wks");
X fname = fullname;
X }
X
X /* open the output file */
X if ((fp = osbopen(fname,"w")) == NULL)
X return (FALSE);
X
X /* first call the garbage collector to clean up memory */
X gc();
X
X /* write out the pointer to the *obarray* symbol */
X writeptr(cvoptr(obarray));
X
X /* setup the initial file offsets */
X off = foff = (OFFTYPE)2;
X
X /* write out all nodes that are still in use */
X for (seg = segs; seg != NULL; seg = seg->sg_next) {
X p = &seg->sg_nodes[0];
X for (n = seg->sg_size; --n >= 0; ++p, off += 2)
X switch (ntype(p)) {
X case FREE:
X break;
X case CONS:
X case USTREAM:
X setoffset();
X osbputc(p->n_type,fp);
X writeptr(cvoptr(car(p)));
X writeptr(cvoptr(cdr(p)));
X foff += 2;
X break;
X default:
X setoffset();
X writenode(p);
X break;
X }
X }
X
X /* write the terminator */
X osbputc(FREE,fp);
X writeptr((OFFTYPE)0);
X
X /* write out data portion of vector-like nodes */
X for (seg = segs; seg != NULL; seg = seg->sg_next) {
X p = &seg->sg_nodes[0];
X for (n = seg->sg_size; --n >= 0; ++p)
X switch (ntype(p)) {
X case SYMBOL:
X case OBJECT:
X case VECTOR:
X case CLOSURE:
X case STRUCT:
X max = getsize(p);
X for (i = 0; i < max; ++i)
X writeptr(cvoptr(getelement(p,i)));
X break;
X case STRING:
X max = getslength(p);
X for (cp = getstring(p); --max >= 0; )
X osbputc(*cp++,fp);
X break;
X }
X }
X
X /* close the output file */
X osclose(fp);
X
X /* return successfully */
X return (TRUE);
X}
X
X/* xlirestore - restore a saved memory image */
Xint xlirestore(fname)
X char *fname;
X{
X extern FUNDEF funtab[];
X char fullname[STRMAX+1];
X unsigned char *cp;
X int n,i,max,type;
X SEGMENT *seg;
X LVAL p;
X
X /* default the extension */
X if (needsextension(fname)) {
X strcpy(fullname,fname);
X strcat(fullname,".wks");
X fname = fullname;
X }
X
X /* open the file */
X if ((fp = osbopen(fname,"r")) == NULL)
X return (FALSE);
X
X /* free the old memory image */
X freeimage();
X
X /* initialize */
X off = (OFFTYPE)2;
X total = nnodes = nfree = 0L;
X fnodes = NIL;
X segs = lastseg = NULL;
X nsegs = gccalls = 0;
X xlenv = xlfenv = xldenv = s_gchook = s_gcflag = NIL;
X xlstack = xlstkbase + EDEPTH;
X xlcontext = NULL;
X
X /* create the fixnum segment */
X if ((fixseg = newsegment(SFIXSIZE)) == NULL)
X xlfatal("insufficient memory - fixnum segment");
X
X /* create the character segment */
X if ((charseg = newsegment(CHARSIZE)) == NULL)
X xlfatal("insufficient memory - character segment");
X
X /* read the pointer to the *obarray* symbol */
X obarray = cviptr(readptr());
X
X /* read each node */
X while ((type = osbgetc(fp)) >= 0)
X switch (type) {
X case FREE:
X if ((off = readptr()) == (OFFTYPE)0)
X goto done;
X break;
X case CONS:
X case USTREAM:
X p = cviptr(off);
X p->n_type = type;
X p->n_flags = 0;
X rplaca(p,cviptr(readptr()));
X rplacd(p,cviptr(readptr()));
X off += 2;
X break;
X default:
X readnode(type,cviptr(off));
X off += 2;
X break;
X }
Xdone:
X
X /* read the data portion of vector-like nodes */
X for (seg = segs; seg != NULL; seg = seg->sg_next) {
X p = &seg->sg_nodes[0];
X for (n = seg->sg_size; --n >= 0; ++p)
X switch (ntype(p)) {
X case SYMBOL:
X case OBJECT:
X case VECTOR:
X case CLOSURE:
X case STRUCT:
X max = getsize(p);
X if ((p->n_vdata = (LVAL *)malloc(max * sizeof(LVAL))) == NULL)
X xlfatal("insufficient memory - vector");
X total += (long)(max * sizeof(LVAL));
X for (i = 0; i < max; ++i)
X setelement(p,i,cviptr(readptr()));
X break;
X case STRING:
X max = getslength(p);
X if ((p->n_string = (unsigned char *)malloc(max)) == NULL)
X xlfatal("insufficient memory - string");
X total += (long)max;
X for (cp = getstring(p); --max >= 0; )
X *cp++ = osbgetc(fp);
X break;
X case STREAM:
X setfile(p,NULL);
X break;
X case SUBR:
X case FSUBR:
X p->n_subr = funtab[getoffset(p)].fd_subr;
X break;
X }
X }
X
X /* close the input file */
X osclose(fp);
X
X /* collect to initialize the free space */
X gc();
X
X /* lookup all of the symbols the interpreter uses */
X xlsymbols();
X
X /* return successfully */
X return (TRUE);
X}
X
X/* freeimage - free the current memory image */
XLOCAL freeimage()
X{
X SEGMENT *seg,*next;
X FILE *fp;
X LVAL p;
X int n;
X
X /* free the data portion of vector-like nodes */
X for (seg = segs; seg != NULL; seg = next) {
X p = &seg->sg_nodes[0];
X for (n = seg->sg_size; --n >= 0; ++p)
X switch (ntype(p)) {
X case SYMBOL:
X case OBJECT:
X case VECTOR:
X case CLOSURE:
X case STRUCT:
X if (p->n_vsize)
X free(p->n_vdata);
X break;
X case STRING:
X if (getslength(p))
X free(getstring(p));
X break;
X case STREAM:
X if ((fp = getfile(p)) && (fp != stdin && fp != stdout))
X osclose(getfile(p));
X break;
X }
X next = seg->sg_next;
X free(seg);
X }
X}
X
X/* setoffset - output a positioning command if nodes have been skipped */
XLOCAL setoffset()
X{
X if (off != foff) {
X osbputc(FREE,fp);
X writeptr(off);
X foff = off;
X }
X}
X
X/* writenode - write a node to a file */
XLOCAL writenode(node)
X LVAL node;
X{
X char *p = (char *)&node->n_info;
X int n = sizeof(union ninfo);
X osbputc(node->n_type,fp);
X while (--n >= 0)
X osbputc(*p++,fp);
X foff += 2;
X}
X
X/* writeptr - write a pointer to a file */
XLOCAL writeptr(off)
X OFFTYPE off;
X{
X char *p = (char *)&off;
X int n = sizeof(OFFTYPE);
X while (--n >= 0)
X osbputc(*p++,fp);
X}
X
X/* readnode - read a node */
XLOCAL readnode(type,node)
X int type; LVAL node;
X{
X char *p = (char *)&node->n_info;
X int n = sizeof(union ninfo);
X node->n_type = type;
X node->n_flags = 0;
X while (--n >= 0)
X *p++ = osbgetc(fp);
X}
X
X/* readptr - read a pointer */
XLOCAL OFFTYPE readptr()
X{
X OFFTYPE off;
X char *p = (char *)&off;
X int n = sizeof(OFFTYPE);
X while (--n >= 0)
X *p++ = osbgetc(fp);
X return (off);
X}
X
X/* cviptr - convert a pointer on input */
XLOCAL LVAL cviptr(o)
X OFFTYPE o;
X{
X OFFTYPE off = (OFFTYPE)2;
X SEGMENT *seg;
X
X /* check for nil */
X if (o == (OFFTYPE)0)
X return ((LVAL)o);
X
X /* compute a pointer for this offset */
X for (seg = segs; seg != NULL; seg = seg->sg_next) {
X if (o >= off && o < off + (OFFTYPE)(seg->sg_size << 1))
X return (seg->sg_nodes + ((int)(o - off) >> 1));
X off += (OFFTYPE)(seg->sg_size << 1);
X }
X
X /* create new segments if necessary */
X for (;;) {
X
X /* create the next segment */
X if ((seg = newsegment(anodes)) == NULL)
X xlfatal("insufficient memory - segment");
X
X /* check to see if the offset is in this segment */
X if (o >= off && o < off + (OFFTYPE)(seg->sg_size << 1))
X return (seg->sg_nodes + ((int)(o - off) >> 1));
X off += (OFFTYPE)(seg->sg_size << 1);
X }
X}
X
X/* cvoptr - convert a pointer on output */
XLOCAL OFFTYPE cvoptr(p)
X LVAL p;
X{
X OFFTYPE off = (OFFTYPE)2;
X SEGMENT *seg;
X
X /* check for nil and small fixnums */
X if (p == NIL)
X return ((OFFTYPE)p);
X
X /* compute an offset for this pointer */
X for (seg = segs; seg != NULL; seg = seg->sg_next) {
X if (CVPTR(p) >= CVPTR(&seg->sg_nodes[0]) &&
X CVPTR(p) < CVPTR(&seg->sg_nodes[0] + seg->sg_size))
X return (off + (OFFTYPE)((p - seg->sg_nodes) << 1));
X off += (OFFTYPE)(seg->sg_size << 1);
X }
X
X /* pointer not within any segment */
X xlerror("bad pointer found during image save",p);
X}
X
X#endif
X
SHAR_EOF
if test 8425 -ne "`wc -c 'xlimage.c'`"
then
echo shar: error transmitting "'xlimage.c'" '(should have been 8425 characters)'
fi
echo shar: extracting "'xlinit.c'" '(7703 characters)'
if test -f 'xlinit.c'
then
echo shar: over-writing existing file "'xlinit.c'"
fi
sed 's/^X//' << \SHAR_EOF > 'xlinit.c'
X/* xlinit.c - xlisp initialization module */
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 true,s_dot,s_unbound;
Xextern LVAL s_quote,s_function,s_bquote,s_comma,s_comat;
Xextern LVAL s_lambda,s_macro;
Xextern LVAL s_stdin,s_stdout,s_stderr,s_debugio,s_traceout;
Xextern LVAL s_evalhook,s_applyhook,s_tracelist;
Xextern LVAL s_tracenable,s_tlimit,s_breakenable;
Xextern LVAL s_setf,s_car,s_cdr,s_nth,s_aref,s_get,s_eql;
Xextern LVAL s_svalue,s_sfunction,s_splist;
Xextern LVAL s_rtable,k_wspace,k_const,k_nmacro,k_tmacro;
Xextern LVAL k_sescape,k_mescape;
Xextern LVAL s_ifmt,s_ffmt,s_printcase;
Xextern LVAL s_1plus,s_2plus,s_3plus,s_1star,s_2star,s_3star,s_minus;
Xextern LVAL k_test,k_tnot;
Xextern LVAL k_direction,k_input,k_output;
Xextern LVAL k_start,k_end,k_1start,k_1end,k_2start,k_2end;
Xextern LVAL k_verbose,k_print,k_count,k_key,k_upcase,k_downcase;
Xextern LVAL lk_optional,lk_rest,lk_key,lk_aux,lk_allow_other_keys;
Xextern LVAL a_subr,a_fsubr,a_cons,a_symbol;
Xextern LVAL a_fixnum,a_flonum,a_string,a_stream,a_object;
Xextern LVAL a_vector,a_closure,a_char,a_ustream;
Xextern LVAL s_gcflag,s_gchook;
Xextern FUNDEF funtab[];
X
X/* xlinit - xlisp initialization routine */
Xxlinit()
X{
X /* initialize xlisp (must be in this order) */
X xlminit(); /* initialize xldmem.c */
X xldinit(); /* initialize xldbug.c */
X
X /* finish initializing */
X#ifdef SAVERESTORE
X if (!xlirestore("xlisp.wks"))
X#endif
X initwks();
X}
X
X/* initwks - build an initial workspace */
XLOCAL initwks()
X{
X FUNDEF *p;
X int i;
X
X xlsinit(); /* initialize xlsym.c */
X xlsymbols();/* enter all symbols used by the interpreter */
X xlrinit(); /* initialize xlread.c */
X xloinit(); /* initialize xlobj.c */
X
X /* setup defaults */
X setvalue(s_evalhook,NIL); /* no evalhook function */
X setvalue(s_applyhook,NIL); /* no applyhook function */
X setvalue(s_tracelist,NIL); /* no functions being traced */
X setvalue(s_tracenable,NIL); /* traceback disabled */
X setvalue(s_tlimit,NIL); /* trace limit infinite */
X setvalue(s_breakenable,NIL); /* don't enter break loop on errors */
X setvalue(s_gcflag,NIL); /* don't show gc information */
X setvalue(s_gchook,NIL); /* no gc hook active */
X setvalue(s_ifmt,cvstring(IFMT)); /* integer print format */
X setvalue(s_ffmt,cvstring("%g")); /* float print format */
X setvalue(s_printcase,k_upcase); /* upper case output of symbols */
X
X /* install the built-in functions and special forms */
X for (i = 0, p = funtab; p->fd_subr != NULL; ++i, ++p)
X if (p->fd_name)
X xlsubr(p->fd_name,p->fd_type,p->fd_subr,i);
X
X /* add some synonyms */
X setfunction(xlenter("NOT"),getfunction(xlenter("NULL")));
X setfunction(xlenter("FIRST"),getfunction(xlenter("CAR")));
X setfunction(xlenter("SECOND"),getfunction(xlenter("CADR")));
X setfunction(xlenter("THIRD"),getfunction(xlenter("CADDR")));
X setfunction(xlenter("FOURTH"),getfunction(xlenter("CADDDR")));
X setfunction(xlenter("REST"),getfunction(xlenter("CDR")));
X}
X
X/* xlsymbols - enter all of the symbols used by the interpreter */
Xxlsymbols()
X{
X LVAL sym;
X
X /* enter the unbound variable indicator (must be first) */
X s_unbound = xlenter("*UNBOUND*");
X setvalue(s_unbound,s_unbound);
X
X /* enter the 't' symbol */
X true = xlenter("T");
X setvalue(true,true);
X
X /* enter some important symbols */
X s_dot = xlenter(".");
X s_quote = xlenter("QUOTE");
X s_function = xlenter("FUNCTION");
X s_bquote = xlenter("BACKQUOTE");
X s_comma = xlenter("COMMA");
X s_comat = xlenter("COMMA-AT");
X s_lambda = xlenter("LAMBDA");
X s_macro = xlenter("MACRO");
X s_eql = xlenter("EQL");
X s_ifmt = xlenter("*INTEGER-FORMAT*");
X s_ffmt = xlenter("*FLOAT-FORMAT*");
X
X /* symbols set by the read-eval-print loop */
X s_1plus = xlenter("+");
X s_2plus = xlenter("++");
X s_3plus = xlenter("+++");
X s_1star = xlenter("*");
X s_2star = xlenter("**");
X s_3star = xlenter("***");
X s_minus = xlenter("-");
X
X /* enter setf place specifiers */
X s_setf = xlenter("*SETF*");
X s_car = xlenter("CAR");
X s_cdr = xlenter("CDR");
X s_nth = xlenter("NTH");
X s_aref = xlenter("AREF");
X s_get = xlenter("GET");
X s_svalue = xlenter("SYMBOL-VALUE");
X s_sfunction = xlenter("SYMBOL-FUNCTION");
X s_splist = xlenter("SYMBOL-PLIST");
X
X /* enter the readtable variable and keywords */
X s_rtable = xlenter("*READTABLE*");
X k_wspace = xlenter(":WHITE-SPACE");
X k_const = xlenter(":CONSTITUENT");
X k_nmacro = xlenter(":NMACRO");
X k_tmacro = xlenter(":TMACRO");
X k_sescape = xlenter(":SESCAPE");
X k_mescape = xlenter(":MESCAPE");
X
X /* enter parameter list keywords */
X k_test = xlenter(":TEST");
X k_tnot = xlenter(":TEST-NOT");
X
X /* "open" keywords */
X k_direction = xlenter(":DIRECTION");
X k_input = xlenter(":INPUT");
X k_output = xlenter(":OUTPUT");
X
X /* enter *print-case* symbol and keywords */
X s_printcase = xlenter("*PRINT-CASE*");
X k_upcase = xlenter(":UPCASE");
X k_downcase = xlenter(":DOWNCASE");
X
X /* other keywords */
X k_start = xlenter(":START");
X k_end = xlenter(":END");
X k_1start = xlenter(":START1");
X k_1end = xlenter(":END1");
X k_2start = xlenter(":START2");
X k_2end = xlenter(":END2");
X k_verbose = xlenter(":VERBOSE");
X k_print = xlenter(":PRINT");
X k_count = xlenter(":COUNT");
X k_key = xlenter(":KEY");
X
X /* enter lambda list keywords */
X lk_optional = xlenter("&OPTIONAL");
X lk_rest = xlenter("&REST");
X lk_key = xlenter("&KEY");
X lk_aux = xlenter("&AUX");
X lk_allow_other_keys = xlenter("&ALLOW-OTHER-KEYS");
X
X /* enter *standard-input*, *standard-output* and *error-output* */
X s_stdin = xlenter("*STANDARD-INPUT*");
X setvalue(s_stdin,cvfile(stdin));
X s_stdout = xlenter("*STANDARD-OUTPUT*");
X setvalue(s_stdout,cvfile(stdout));
X s_stderr = xlenter("*ERROR-OUTPUT*");
X setvalue(s_stderr,cvfile(stderr));
X
X /* enter *debug-io* and *trace-output* */
X s_debugio = xlenter("*DEBUG-IO*");
X setvalue(s_debugio,getvalue(s_stderr));
X s_traceout = xlenter("*TRACE-OUTPUT*");
X setvalue(s_traceout,getvalue(s_stderr));
X
X /* enter the eval and apply hook variables */
X s_evalhook = xlenter("*EVALHOOK*");
X s_applyhook = xlenter("*APPLYHOOK*");
X
X /* enter the symbol pointing to the list of functions being traced */
X s_tracelist = xlenter("*TRACELIST*");
X
X /* enter the error traceback and the error break enable flags */
X s_tracenable = xlenter("*TRACENABLE*");
X s_tlimit = xlenter("*TRACELIMIT*");
X s_breakenable = xlenter("*BREAKENABLE*");
X
X /* enter a symbol to control printing of garbage collection messages */
X s_gcflag = xlenter("*GC-FLAG*");
X s_gchook = xlenter("*GC-HOOK*");
X
X /* enter a copyright notice into the oblist */
X sym = xlenter("**Copyright-1988-by-David-Betz**");
X setvalue(sym,true);
X
X /* enter type names */
X a_subr = xlenter("SUBR");
X a_fsubr = xlenter("FSUBR");
X a_cons = xlenter("CONS");
X a_symbol = xlenter("SYMBOL");
X a_fixnum = xlenter("FIXNUM");
X a_flonum = xlenter("FLONUM");
X a_string = xlenter("STRING");
X a_object = xlenter("OBJECT");
X a_stream = xlenter("FILE-STREAM");
X a_vector = xlenter("ARRAY");
X a_closure = xlenter("CLOSURE");
X a_char = xlenter("CHARACTER");
X a_ustream = xlenter("UNNAMED-STREAM");
X
X /* add the object-oriented programming symbols and os specific stuff */
X obsymbols(); /* object-oriented programming symbols */
X ossymbols(); /* os specific symbols */
X}
X
SHAR_EOF
if test 7703 -ne "`wc -c 'xlinit.c'`"
then
echo shar: error transmitting "'xlinit.c'" '(should have been 7703 characters)'
fi
echo shar: extracting "'xlio.c'" '(4057 characters)'
if test -f 'xlio.c'
then
echo shar: over-writing existing file "'xlio.c'"
fi
sed 's/^X//' << \SHAR_EOF > 'xlio.c'
X/* xlio - xlisp i/o 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 s_stdin,s_stdout,s_stderr,s_debugio,s_traceout,s_unbound;
Xextern int xlfsize;
X
X/* xlgetc - get a character from a file or stream */
Xint xlgetc(fptr)
X LVAL fptr;
X{
X LVAL lptr,cptr;
X FILE *fp;
X int ch;
X
X /* check for input from nil */
X if (fptr == NIL)
X ch = EOF;
X
X /* otherwise, check for input from a stream */
X else if (ustreamp(fptr)) {
X if ((lptr = gethead(fptr)) == NIL)
X ch = EOF;
X else {
X if (!consp(lptr) || (cptr = car(lptr)) == NIL || !charp(cptr))
X xlfail("bad stream");
X sethead(fptr,lptr = cdr(lptr));
X if (lptr == NIL)
X settail(fptr,NIL);
X ch = getchcode(cptr);
X }
X }
X
X /* otherwise, check for a buffered character */
X else if (ch = getsavech(fptr))
X setsavech(fptr,'\0');
X
X /* otherwise, check for terminal input or file input */
X else {
X fp = getfile(fptr);
X if (fp == stdin || fp == stderr)
X ch = ostgetc();
X else
X ch = osagetc(fp);
X }
X
X /* return the character */
X return (ch);
X}
X
X/* xlungetc - unget a character */
Xxlungetc(fptr,ch)
X LVAL fptr; int ch;
X{
X LVAL lptr;
X
X /* check for ungetc from nil */
X if (fptr == NIL)
X ;
X
X /* otherwise, check for ungetc to a stream */
X if (ustreamp(fptr)) {
X if (ch != EOF) {
X lptr = cons(cvchar(ch),gethead(fptr));
X if (gethead(fptr) == NIL)
X settail(fptr,lptr);
X sethead(fptr,lptr);
X }
X }
X
X /* otherwise, it must be a file */
X else
X setsavech(fptr,ch);
X}
X
X/* xlpeek - peek at a character from a file or stream */
Xint xlpeek(fptr)
X LVAL fptr;
X{
X LVAL lptr,cptr;
X int ch;
X
X /* check for input from nil */
X if (fptr == NIL)
X ch = EOF;
X
X /* otherwise, check for input from a stream */
X else if (ustreamp(fptr)) {
X if ((lptr = gethead(fptr)) == NIL)
X ch = EOF;
X else {
X if (!consp(lptr) || (cptr = car(lptr)) == NIL || !charp(cptr))
X xlfail("bad stream");
X ch = getchcode(cptr);
X }
X }
X
X /* otherwise, get the next file character and save it */
X else {
X ch = xlgetc(fptr);
X setsavech(fptr,ch);
X }
X
X /* return the character */
X return (ch);
X}
X
X/* xlputc - put a character to a file or stream */
Xxlputc(fptr,ch)
X LVAL fptr; int ch;
X{
X LVAL lptr;
X FILE *fp;
X
X /* count the character */
X ++xlfsize;
X
X /* check for output to nil */
X if (fptr == NIL)
X ;
X
X /* otherwise, check for output to an unnamed stream */
X else if (ustreamp(fptr)) {
X lptr = consa(cvchar(ch));
X if (gettail(fptr))
X rplacd(gettail(fptr),lptr);
X else
X sethead(fptr,lptr);
X settail(fptr,lptr);
X }
X
X /* otherwise, check for terminal output or file output */
X else {
X fp = getfile(fptr);
X if (fp == stdout || fp == stderr)
X ostputc(ch);
X else
X osaputc(ch,fp);
X }
X}
X
X/* xlflush - flush the input buffer */
Xint xlflush()
X{
X osflush();
X}
X
X/* stdprint - print to *standard-output* */
Xstdprint(expr)
X LVAL expr;
X{
X xlprint(getvalue(s_stdout),expr,TRUE);
X xlterpri(getvalue(s_stdout));
X}
X
X/* stdputstr - print a string to *standard-output* */
Xstdputstr(str)
X char *str;
X{
X xlputstr(getvalue(s_stdout),str);
X}
X
X/* errprint - print to *error-output* */
Xerrprint(expr)
X LVAL expr;
X{
X xlprint(getvalue(s_stderr),expr,TRUE);
X xlterpri(getvalue(s_stderr));
X}
X
X/* errputstr - print a string to *error-output* */
Xerrputstr(str)
X char *str;
X{
X xlputstr(getvalue(s_stderr),str);
X}
X
X/* dbgprint - print to *debug-io* */
Xdbgprint(expr)
X LVAL expr;
X{
X xlprint(getvalue(s_debugio),expr,TRUE);
X xlterpri(getvalue(s_debugio));
X}
X
X/* dbgputstr - print a string to *debug-io* */
Xdbgputstr(str)
X char *str;
X{
X xlputstr(getvalue(s_debugio),str);
X}
X
X/* trcprin1 - print to *trace-output* */
Xtrcprin1(expr)
X LVAL expr;
X{
X xlprint(getvalue(s_traceout),expr,TRUE);
X}
X
X/* trcputstr - print a string to *trace-output* */
Xtrcputstr(str)
X char *str;
X{
X xlputstr(getvalue(s_traceout),str);
X}
X
X
SHAR_EOF
if test 4057 -ne "`wc -c 'xlio.c'`"
then
echo shar: error transmitting "'xlio.c'" '(should have been 4057 characters)'
fi
echo shar: extracting "'xlisp.c'" '(3657 characters)'
if test -f 'xlisp.c'
then
echo shar: over-writing existing file "'xlisp.c'"
fi
sed 's/^X//' << \SHAR_EOF > 'xlisp.c'
X/* xlisp.c - a small implementation of lisp with object-oriented programming */
X/* Copyright (c) 1987, by David Michael Betz
X All Rights Reserved
X Permission is granted for unrestricted non-commercial use */
X
X#include "xlisp.h"
X
X/* define the banner line string */
X#define BANNER "XLISP version 2.1, Copyright (c) 1989, by David Betz"
X
X/* global variables */
Xjmp_buf top_level;
X
X/* external variables */
Xextern LVAL s_stdin,s_evalhook,s_applyhook;
Xextern LVAL s_1plus,s_2plus,s_3plus,s_1star,s_2star,s_3star,s_minus;
Xextern int xltrcindent;
Xextern int xldebug;
Xextern LVAL true;
Xextern char buf[];
Xextern FILE *tfp;
X
X/* external routines */
Xextern FILE *osaopen();
X
X/* main - the main routine */
Xmain(argc,argv)
X int argc; char *argv[];
X{
X char *transcript;
X CONTEXT cntxt;
X int verbose,i;
X LVAL expr;
X
X /* setup default argument values */
X transcript = NULL;
X verbose = FALSE;
X
X /* parse the argument list switches */
X#ifndef LSC
X for (i = 1; i < argc; ++i)
X if (argv[i][0] == '-')
X switch(argv[i][1]) {
X case 't':
X case 'T':
X transcript = &argv[i][2];
X break;
X case 'v':
X case 'V':
X verbose = TRUE;
X break;
X }
X#endif
X
X /* initialize and print the banner line */
X osinit(BANNER);
X
X /* setup initialization error handler */
X xlbegin(&cntxt,CF_TOPLEVEL|CF_CLEANUP|CF_BRKLEVEL,(LVAL)1);
X if (setjmp(cntxt.c_jmpbuf))
X xlfatal("fatal initialization error");
X if (setjmp(top_level))
X xlfatal("RESTORE not allowed during initialization");
X
X /* initialize xlisp */
X xlinit();
X xlend(&cntxt);
X
X /* reset the error handler */
X xlbegin(&cntxt,CF_TOPLEVEL|CF_CLEANUP|CF_BRKLEVEL,true);
X
X /* open the transcript file */
X if (transcript && (tfp = osaopen(transcript,"w")) == NULL) {
X sprintf(buf,"error: can't open transcript file: %s",transcript);
X stdputstr(buf);
X }
X
X /* load "init.lsp" */
X if (setjmp(cntxt.c_jmpbuf) == 0)
X xlload("init.lsp",TRUE,FALSE);
X
X /* load any files mentioned on the command line */
X if (setjmp(cntxt.c_jmpbuf) == 0)
X for (i = 1; i < argc; i++)
X if (argv[i][0] != '-' && !xlload(argv[i],TRUE,verbose))
X xlerror("can't load file",cvstring(argv[i]));
X
X /* target for restore */
X if (setjmp(top_level))
X xlbegin(&cntxt,CF_TOPLEVEL|CF_CLEANUP|CF_BRKLEVEL,true);
X
X /* protect some pointers */
X xlsave1(expr);
X
X /* main command processing loop */
X for (;;) {
X
X /* setup the error return */
X if (setjmp(cntxt.c_jmpbuf)) {
X setvalue(s_evalhook,NIL);
X setvalue(s_applyhook,NIL);
X xltrcindent = 0;
X xldebug = 0;
X xlflush();
X }
X
X /* print a prompt */
X stdputstr("> ");
X
X /* read an expression */
X if (!xlread(getvalue(s_stdin),&expr,FALSE))
X break;
X
X /* save the input expression */
X xlrdsave(expr);
X
X /* evaluate the expression */
X expr = xleval(expr);
X
X /* save the result */
X xlevsave(expr);
X
X /* print it */
X stdprint(expr);
X }
X xlend(&cntxt);
X
X /* clean up */
X wrapup();
X}
X
X/* xlrdsave - save the last expression returned by the reader */
Xxlrdsave(expr)
X LVAL expr;
X{
X setvalue(s_3plus,getvalue(s_2plus));
X setvalue(s_2plus,getvalue(s_1plus));
X setvalue(s_1plus,getvalue(s_minus));
X setvalue(s_minus,expr);
X}
X
X/* xlevsave - save the last expression returned by the evaluator */
Xxlevsave(expr)
X LVAL expr;
X{
X setvalue(s_3star,getvalue(s_2star));
X setvalue(s_2star,getvalue(s_1star));
X setvalue(s_1star,expr);
X}
X
X/* xlfatal - print a fatal error message and exit */
Xxlfatal(msg)
X char *msg;
X{
X oserror(msg);
X wrapup();
X}
X
X/* wrapup - clean up and exit to the operating system */
Xwrapup()
X{
X if (tfp)
X osclose(tfp);
X osfinish();
X exit(0);
X}
X
SHAR_EOF
if test 3657 -ne "`wc -c 'xlisp.c'`"
then
echo shar: error transmitting "'xlisp.c'" '(should have been 3657 characters)'
fi
echo shar: extracting "'xlisp.h'" '(9630 characters)'
if test -f 'xlisp.h'
then
echo shar: over-writing existing file "'xlisp.h'"
fi
sed 's/^X//' << \SHAR_EOF > 'xlisp.h'
X/* xlisp - a small subset of lisp */
X/* Copyright (c) 1985, by David Michael Betz
X All Rights Reserved
X Permission is granted for unrestricted non-commercial use */
X
X/* system specific definitions */
X#define _TURBOC_
X
X#include <stdio.h>
X#include <ctype.h>
X#include <setjmp.h>
X
X/* NNODES number of nodes to allocate in each request (1000) */
X/* EDEPTH evaluation stack depth (2000) */
X/* ADEPTH argument stack depth (1000) */
X/* FORWARD type of a forward declaration () */
X/* LOCAL type of a local function (static) */
X/* AFMT printf format for addresses ("%x") */
X/* FIXTYPE data type for fixed point numbers (long) */
X/* ITYPE fixed point input conversion routine type (long atol()) */
X/* ICNV fixed point input conversion routine (atol) */
X/* IFMT printf format for fixed point numbers ("%ld") */
X/* FLOTYPE data type for floating point numbers (float) */
X/* OFFTYPE number the size of an address (int) */
X
X/* for the Turbo C compiler - MS-DOS, large model */
X#ifdef _TURBOC_
X#define NNODES 2000
X#define AFMT "%lx"
X#define OFFTYPE long
X#define SAVERESTORE
X#endif
X
X/* for the AZTEC C compiler - MS-DOS, large model */
X#ifdef AZTEC_LM
X#define NNODES 2000
X#define AFMT "%lx"
X#define OFFTYPE long
X#define CVPTR(x) ptrtoabs(x)
X#define NIL (void *)0
Xextern long ptrtoabs();
X#define SAVERESTORE
X#endif
X
X/* for the AZTEC C compiler - Macintosh */
X#ifdef AZTEC_MAC
X#define NNODES 2000
X#define AFMT "%lx"
X#define OFFTYPE long
X#define NIL (void *)0
X#define SAVERESTORE
X#endif
X
X/* for the AZTEC C compiler - Amiga */
X#ifdef AZTEC_AMIGA
X#define NNODES 2000
X#define AFMT "%lx"
X#define OFFTYPE long
X#define NIL (void *)0
X#define SAVERESTORE
X#endif
X
X/* for the Lightspeed C compiler - Macintosh */
X#ifdef LSC
X#define NNODES 2000
X#define AFMT "%lx"
X#define OFFTYPE long
X#define NIL (void *)0
X#define SAVERESTORE
X#endif
X
X/* for the Microsoft C compiler - MS-DOS, large model */
X#ifdef MSC
X#define NNODES 2000
X#define AFMT "%lx"
X#define OFFTYPE long
X#endif
X
X/* for the Mark Williams C compiler - Atari ST */
X#ifdef MWC
X#define AFMT "%lx"
X#define OFFTYPE long
X#endif
X
X/* for the Lattice C compiler - Atari ST */
X#ifdef LATTICE
X#define FIXTYPE int
X#define ITYPE int atoi()
X#define ICNV(n) atoi(n)
X#define IFMT "%d"
X#endif
X
X/* for the Digital Research C compiler - Atari ST */
X#ifdef DR
X#define LOCAL
X#define AFMT "%lx"
X#define OFFTYPE long
X#undef NULL
X#define NULL 0L
X#endif
X
X/* default important definitions */
X#ifndef NNODES
X#define NNODES 1000
X#endif
X#ifndef EDEPTH
X#define EDEPTH 2000
X#endif
X#ifndef ADEPTH
X#define ADEPTH 1000
X#endif
X#ifndef FORWARD
X#define FORWARD
X#endif
X#ifndef LOCAL
X#define LOCAL static
X#endif
X#ifndef AFMT
X#define AFMT "%x"
X#endif
X#ifndef FIXTYPE
X#define FIXTYPE long
X#endif
X#ifndef ITYPE
X#define ITYPE long atol()
X#endif
X#ifndef ICNV
X#define ICNV(n) atol(n)
X#endif
X#ifndef IFMT
X#define IFMT "%ld"
X#endif
X#ifndef FLOTYPE
X#define FLOTYPE double
X#endif
X#ifndef OFFTYPE
X#define OFFTYPE int
X#endif
X#ifndef CVPTR
X#define CVPTR(x) (x)
X#endif
X#ifndef UCHAR
X#define UCHAR unsigned char
X#endif
X
X/* useful definitions */
X#define TRUE 1
X#define FALSE 0
X#ifndef NIL
X#define NIL (LVAL )0
X#endif
X
X/* include the dynamic memory definitions */
X#include "xldmem.h"
X
X/* program limits */
X#define STRMAX 100 /* maximum length of a string constant */
X#define HSIZE 199 /* symbol hash table size */
X#define SAMPLE 100 /* control character sample rate */
X
X/* function table offsets for the initialization functions */
X#define FT_RMHASH 0
X#define FT_RMQUOTE 1
X#define FT_RMDQUOTE 2
X#define FT_RMBQUOTE 3
X#define FT_RMCOMMA 4
X#define FT_RMLPAR 5
X#define FT_RMRPAR 6
X#define FT_RMSEMI 7
X#define FT_CLNEW 10
X#define FT_CLISNEW 11
X#define FT_CLANSWER 12
X#define FT_OBISNEW 13
X#define FT_OBCLASS 14
X#define FT_OBSHOW 15
X
X/* macro to push a value onto the argument stack */
X#define pusharg(x) {if (xlsp >= xlargstktop) xlargstkoverflow();\
X *xlsp++ = (x);}
X
X/* macros to protect pointers */
X#define xlstkcheck(n) {if (xlstack - (n) < xlstkbase) xlstkoverflow();}
X#define xlsave(n) {*--xlstack = &n; n = NIL;}
X#define xlprotect(n) {*--xlstack = &n;}
X
X/* check the stack and protect a single pointer */
X#define xlsave1(n) {if (xlstack <= xlstkbase) xlstkoverflow();\
X *--xlstack = &n; n = NIL;}
X#define xlprot1(n) {if (xlstack <= xlstkbase) xlstkoverflow();\
X *--xlstack = &n;}
X
X/* macros to pop pointers off the stack */
X#define xlpop() {++xlstack;}
X#define xlpopn(n) {xlstack+=(n);}
X
X/* macros to manipulate the lexical environment */
X#define xlframe(e) cons(NIL,e)
X#define xlbind(s,v) xlpbind(s,v,xlenv)
X#define xlfbind(s,v) xlpbind(s,v,xlfenv);
X#define xlpbind(s,v,e) {rplaca(e,cons(cons(s,v),car(e)));}
X
X/* macros to manipulate the dynamic environment */
X#define xldbind(s,v) {xldenv = cons(cons(s,getvalue(s)),xldenv);\
X setvalue(s,v);}
X#define xlunbind(e) {for (; xldenv != (e); xldenv = cdr(xldenv))\
X setvalue(car(car(xldenv)),cdr(car(xldenv)));}
X
X/* type predicates */
X#define atom(x) ((x) == NIL || ntype(x) != CONS)
X#define null(x) ((x) == NIL)
X#define listp(x) ((x) == NIL || ntype(x) == CONS)
X#define consp(x) ((x) && ntype(x) == CONS)
X#define subrp(x) ((x) && ntype(x) == SUBR)
X#define fsubrp(x) ((x) && ntype(x) == FSUBR)
X#define stringp(x) ((x) && ntype(x) == STRING)
X#define symbolp(x) ((x) && ntype(x) == SYMBOL)
X#define streamp(x) ((x) && ntype(x) == STREAM)
X#define objectp(x) ((x) && ntype(x) == OBJECT)
X#define fixp(x) ((x) && ntype(x) == FIXNUM)
X#define floatp(x) ((x) && ntype(x) == FLONUM)
X#define vectorp(x) ((x) && ntype(x) == VECTOR)
X#define closurep(x) ((x) && ntype(x) == CLOSURE)
X#define charp(x) ((x) && ntype(x) == CHAR)
X#define ustreamp(x) ((x) && ntype(x) == USTREAM)
X#define structp(x) ((x) && ntype(x) == STRUCT)
X#define boundp(x) (getvalue(x) != s_unbound)
X#define fboundp(x) (getfunction(x) != s_unbound)
X
X/* shorthand functions */
X#define consa(x) cons(x,NIL)
X#define consd(x) cons(NIL,x)
X
X/* argument list parsing macros */
X#define xlgetarg() (testarg(nextarg()))
X#define xllastarg() {if (xlargc != 0) xltoomany();}
X#define testarg(e) (moreargs() ? (e) : xltoofew())
X#define typearg(tp) (tp(*xlargv) ? nextarg() : xlbadtype(*xlargv))
X#define nextarg() (--xlargc, *xlargv++)
X#define moreargs() (xlargc > 0)
X
X/* macros to get arguments of a particular type */
X#define xlgacons() (testarg(typearg(consp)))
X#define xlgalist() (testarg(typearg(listp)))
X#define xlgasymbol() (testarg(typearg(symbolp)))
X#define xlgastring() (testarg(typearg(stringp)))
X#define xlgaobject() (testarg(typearg(objectp)))
X#define xlgafixnum() (testarg(typearg(fixp)))
X#define xlgaflonum() (testarg(typearg(floatp)))
X#define xlgachar() (testarg(typearg(charp)))
X#define xlgavector() (testarg(typearg(vectorp)))
X#define xlgastream() (testarg(typearg(streamp)))
X#define xlgaustream() (testarg(typearg(ustreamp)))
X#define xlgaclosure() (testarg(typearg(closurep)))
X#define xlgastruct() (testarg(typearg(structp)))
X
X/* function definition structure */
Xtypedef struct {
X char *fd_name; /* function name */
X int fd_type; /* function type */
X LVAL (*fd_subr)(); /* function entry point */
X} FUNDEF;
X
X/* execution context flags */
X#define CF_GO 0x0001
X#define CF_RETURN 0x0002
X#define CF_THROW 0x0004
X#define CF_ERROR 0x0008
X#define CF_CLEANUP 0x0010
X#define CF_CONTINUE 0x0020
X#define CF_TOPLEVEL 0x0040
X#define CF_BRKLEVEL 0x0080
X#define CF_UNWIND 0x0100
X
X/* execution context */
Xtypedef struct context {
X int c_flags; /* context type flags */
X LVAL c_expr; /* expression (type dependant) */
X jmp_buf c_jmpbuf; /* longjmp context */
X struct context *c_xlcontext; /* old value of xlcontext */
X LVAL **c_xlstack; /* old value of xlstack */
X LVAL *c_xlargv; /* old value of xlargv */
X int c_xlargc; /* old value of xlargc */
X LVAL *c_xlfp; /* old value of xlfp */
X LVAL *c_xlsp; /* old value of xlsp */
X LVAL c_xlenv; /* old value of xlenv */
X LVAL c_xlfenv; /* old value of xlfenv */
X LVAL c_xldenv; /* old value of xldenv */
X} CONTEXT;
X
X/* external variables */
Xextern LVAL **xlstktop; /* top of the evaluation stack */
Xextern LVAL **xlstkbase; /* base of the evaluation stack */
Xextern LVAL **xlstack; /* evaluation stack pointer */
Xextern LVAL *xlargstkbase; /* base of the argument stack */
Xextern LVAL *xlargstktop; /* top of the argument stack */
Xextern LVAL *xlfp; /* argument frame pointer */
Xextern LVAL *xlsp; /* argument stack pointer */
Xextern LVAL *xlargv; /* current argument vector */
Xextern int xlargc; /* current argument count */
X
X/* external procedure declarations */
Xextern LVAL xleval(); /* evaluate an expression */
Xextern LVAL xlapply(); /* apply a function to arguments */
Xextern LVAL xlsubr(); /* enter a subr/fsubr */
Xextern LVAL xlenter(); /* enter a symbol */
Xextern LVAL xlmakesym(); /* make an uninterned symbol */
Xextern LVAL xlgetvalue(); /* get value of a symbol (checked) */
Xextern LVAL xlxgetvalue(); /* get value of a symbol */
Xextern LVAL xlgetfunction(); /* get functional value of a symbol */
Xextern LVAL xlxgetfunction(); /* get functional value of a symbol (checked) */
Xextern LVAL xlexpandmacros(); /* expand macros in a form */
Xextern LVAL xlgetprop(); /* get the value of a property */
Xextern LVAL xlclose(); /* create a function closure */
X
X/* argument list parsing functions */
Xextern LVAL xlgetfile(); /* get a file/stream argument */
Xextern LVAL xlgetfname(); /* get a filename argument */
X
X/* error reporting functions (don't *really* return at all) */
Xextern LVAL xltoofew(); /* report "too few arguments" error */
Xextern LVAL xlbadtype(); /* report "bad argument type" error */
X
SHAR_EOF
if test 9630 -ne "`wc -c 'xlisp.h'`"
then
echo shar: error transmitting "'xlisp.h'" '(should have been 9630 characters)'
fi
echo shar: extracting "'xlisp.lnk'" '(267 characters)'
if test -f 'xlisp.lnk'
then
echo shar: over-writing existing file "'xlisp.lnk'"
fi
sed 's/^X//' << \SHAR_EOF > 'xlisp.lnk'
Xc:\turboc\lib\c0l.obj +
Xxlisp xlbfun xlcont xldbug xldmem xleval xlfio +
Xxlftab xlglob xlimage xlinit xlio xljump xllist +
Xxlmath xlobj xlpp xlprin xlread xlstr xlstruct +
Xxlsubr xlsym xlsys msstuff
Xxlisp
Xxlisp
Xc:\turboc\lib\emu c:\turboc\lib\mathl c:\turboc\lib\cl
X
SHAR_EOF
if test 267 -ne "`wc -c 'xlisp.lnk'`"
then
echo shar: error transmitting "'xlisp.lnk'" '(should have been 267 characters)'
fi
echo shar: extracting "'xlisp.mac'" '(27375 characters)'
if test -f 'xlisp.mac'
then
echo shar: over-writing existing file "'xlisp.mac'"
fi
sed 's/^X//' << \SHAR_EOF > 'xlisp.mac'
XFrom sce!mitel!uunet!datapg!com50!pai!erc Tue Nov 14 08:51:33 EST 1989
XArticle: 753 of comp.lang.scheme
XPath: cognos!sce!mitel!uunet!datapg!com50!pai!erc
XFrom: erc at pai.UUCP (Eric Johnson)
XNewsgroups: comp.lang.scheme,comp.sys.mac
XSubject: Re: How to build xscheme for the mac
XSummary: Hope this helps...
XKeywords: xscheme, mac
XMessage-ID: <742 at pai.UUCP>
XDate: 11 Nov 89 18:55:05 GMT
XReferences: <2091 at cunixc.cc.columbia.edu>
XOrganization: Prime Automation, Inc., Burnsville, MN
XLines: 1374
XXref: cognos comp.lang.scheme:753 comp.sys.mac:33459
X
XIn article <2091 at cunixc.cc.columbia.edu>, puglia at cunixc.cc.columbia.edu (Paul Puglia) writes:
X> How does you build xscheme on a macintosh ? I have a copy of
X> the xscheme sources compiles fine on a unix machine, and works
X> great on a pc with turbo c. When I tried to compile it on a
X> friends mac II using his copy of lightspeed c. I have no luck.
X> Could someone please describe the procedure to compile this program, and
X> comment on if anything else is need to compile xscheme. I know that you
X> need some resource to compile xlisp on a mac. Do you need the same sort of
X> stuff for xscheme
X> Thanks in advance
X> Paul Puglia
X> Dept of Civil Engineering
X> Columbia University
X
X
X
XPorting Xlisp/XScheme:
X
XAwhile back, while I was taking an AI course, I was spending a lot of time
Xtrekking to campus and using their LISP system. To avoid travel time (and
Xto work on LISP at any hour I wanted), I got into porting XLisp. In looking at
Xthe code, I'd say XLisp and XScheme are two of the most portable C programs
XI have ever seen. Now, I've spent most of my time on XLisp, so your
Xmileage may vary, but...
X
XXLisp seems to place most Operating System (OS)-dependent features in
Xseparate files, named dosstuff.c, osptrs.h, osdefs.h. On UNIX, the "stuff:
Xfile is called unixstuf.c and on the Mac its called macstuff.c (all file
Xnames are <= 8 chars for MS-DOS). The mac version also has a resource
Xcompiler file (that is, a file you run through the resource compiler to
Xgenerate a resource file).
X
XI assume (hope) XScheme is similiar. Below, I placed all my Mac-related
Xfiles from XLisp (2.0, I think). The XScheme stuff should be similiar.
XI hope these help. (Note: I don't have the full sources around now, just
Xthe Mac and UNIX-specific files.) (Note2: Two extra files, macfun.c and
Xmacinit.c are below, its been so long that I'm not sure if these are extras
Xor necessary--Sorry.)
X
XI'm placing these files here in hopes they can help you with your porting. I
Xdo know that binary executable versions of XScheme are available on the
XBIX bulletin board (Byte magazine Information eXchange)--see Byte mag
Xfor details. Getting the binaries would solve all the Mac porting
Xproblems in one fell swoop.
X
XAnyway, hope this helps,
X-Eric
X
X
X======================== macfun.c =============================================
X
X/* macfun.c - macintosh user interface functions for xlisp */
X
X#include <Quickdraw.h>
X#include <WindowMgr.h>
X#include <MemoryMgr.h>
X#include "xlisp.h"
X
X/* external variables */
Xextern GrafPtr cwindow,gwindow;
X
X/* forward declarations */
XFORWARD LVAL do_0();
XFORWARD LVAL do_1();
XFORWARD LVAL do_2();
X
X/* xptsize - set the command window point size */
XLVAL xptsize()
X{
X LVAL val;
X val = xlgafixnum();
X xllastarg();
X TextSize((int)getfixnum(val));
X InvalRect(&cwindow->portRect);
X SetupScreen();
X return (NIL);
X}
X
X/* xhidepen - hide the pen */
XLVAL xhidepen()
X{
X return (do_0('H'));
X}
X
X/* xshowpen - show the pen */
XLVAL xshowpen()
X{
X return (do_0('S'));
X}
X
X/* xgetpen - get the pen position */
XLVAL xgetpen()
X{
X LVAL val;
X Point p;
X xllastarg();
X SetPort(gwindow);
X GetPen(&p);
X SetPort(cwindow);
X xlsave1(val);
X val = consa(NIL);
X rplaca(val,cvfixnum((FIXTYPE)p.h));
X rplacd(val,cvfixnum((FIXTYPE)p.v));
X xlpop();
X return (val);
X}
X
X/* xpenmode - set the pen mode */
XLVAL xpenmode()
X{
X return (do_1('M'));
X}
X
X/* xpensize - set the pen size */
XLVAL xpensize()
X{
X return (do_2('S'));
X}
X
X/* xpenpat - set the pen pattern */
XLVAL xpenpat()
X{
X LVAL plist;
X char pat[8],i;
X plist = xlgalist();
X xllastarg();
X for (i = 0; i < 8 && consp(plist); ++i, plist = cdr(plist))
X if (fixp(car(plist)))
X pat[i] = getfixnum(car(plist));
X SetPort(gwindow);
X PenPat(pat);
X SetPort(cwindow);
X return (NIL);
X}
X
X/* xpennormal - set the pen to normal */
XLVAL xpennormal()
X{
X xllastarg();
X SetPort(gwindow);
X PenNormal();
X SetPort(cwindow);
X return (NIL);
X}
X
X/* xmoveto - Move to a screen location */
XLVAL xmoveto()
X{
X return (do_2('m'));
X}
X
X/* xmove - Move in a specified direction */
XLVAL xmove()
X{
X return (do_2('M'));
X}
X
X/* xlineto - draw a Line to a screen location */
XLVAL xlineto()
X{
X return (do_2('l'));
X}
X
X/* xline - draw a Line in a specified direction */
XLVAL xline()
X{
X return (do_2('L'));
X}
X
X/* xshowgraphics - show the graphics window */
XLVAL xshowgraphics()
X{
X xllastarg();
X scrsplit(1);
X return (NIL);
X}
X
X/* xhidegraphics - hide the graphics window */
XLVAL xhidegraphics()
X{
X xllastarg();
X scrsplit(0);
X return (NIL);
X}
X
X/* xcleargraphics - clear the graphics window */
XLVAL xcleargraphics()
X{
X xllastarg();
X SetPort(gwindow);
X EraseRect(&gwindow->portRect);
X SetPort(cwindow);
X return (NIL);
X}
X
X/* do_0 - Handle commands that require no arguments */
XLOCAL LVAL do_0(fcn)
X int fcn;
X{
X xllastarg();
X SetPort(gwindow);
X switch (fcn) {
X case 'H': HidePen(); break;
X case 'S': ShowPen(); break;
X }
X SetPort(cwindow);
X return (NIL);
X}
X
X/* do_1 - Handle commands that require one integer argument */
XLOCAL LVAL do_1(fcn)
X int fcn;
X{
X int x;
X x = getnumber();
X xllastarg();
X SetPort(gwindow);
X switch (fcn) {
X case 'M': PenMode(x); break;
X }
X SetPort(cwindow);
X return (NIL);
X}
X
X/* do_2 - Handle commands that require two integer arguments */
XLOCAL LVAL do_2(fcn)
X int fcn;
X{
X int h,v;
X h = getnumber();
X v = getnumber();
X xllastarg();
X SetPort(gwindow);
X switch (fcn) {
X case 'l': LineTo(h,v); break;
X case 'L': Line(h,v); break;
X case 'm': MoveTo(h,v); break;
X case 'M': Move(h,v); break;
X case 'S': PenSize(h,v);break;
X }
X SetPort(cwindow);
X return (NIL);
X}
X
X/* getnumber - get an integer parameter */
XLOCAL int getnumber()
X{
X LVAL num;
X num = xlgafixnum();
X return ((int)getfixnum(num));
X}
X
X/* xtool - call the toolbox */
XLVAL xtool()
X{
X LVAL val;
X int trap;
X
X trap = getnumber();
X/*
X
X asm {
X move.l args(A6),D0
X beq L2
XL1: move.l D0,A0
X move.l 2(A0),A1
X move.w 4(A1),-(A7)
X move.l 6(A0),D0
X bne L1
XL2: lea L3,A0
X move.w trap(A6),(A0)
XL3: dc.w 0xA000
X clr.l val(A6)
X }
X*/
X
X return (val);
X}
X
X/* xtool16 - call the toolbox with a 16 bit result */
XLVAL xtool16()
X{
X int trap,val;
X
X trap = getnumber();
X/*
X
X asm {
X clr.w -(A7)
X move.l args(A6),D0
X beq L2
XL1: move.l D0,A0
X move.l 2(A0),A1
X move.w 4(A1),-(A7)
X move.l 6(A0),D0
X bne L1
XL2: lea L3,A0
X move.w trap(A6),(A0)
XL3: dc.w 0xA000
X move.w (A7)+,val(A6)
X }
X*/
X
X return (cvfixnum((FIXTYPE)val));
X}
X
X/* xtool32 - call the toolbox with a 32 bit result */
XLVAL xtool32()
X{
X int trap;
X long val;
X
X trap = getnumber();
X/*
X
X asm {
X clr.l -(A7)
X move.l args(A6),D0
X beq L2
XL1: move.l D0,A0
X move.l 2(A0),A1
X move.w 4(A1),-(A7)
X move.l 6(A0),D0
X bne L1
XL2: lea L3,A0
X move.w trap(A6),(A0)
XL3: dc.w 0xA000
X move.l (A7)+,val(A6)
X }
X*/
X
X return (cvfixnum((FIXTYPE)val));
X}
X
X/* xnewhandle - allocate a new handle */
XLVAL xnewhandle()
X{
X LVAL num;
X long size;
X num = xlgafixnum(); size = getfixnum(num);
X xllastarg();
X return (cvfixnum((FIXTYPE)NewHandle(size)));
X}
X
X/* xnewptr - allocate memory */
XLVAL xnewptr()
X{
X LVAL num;
X long size;
X num = xlgafixnum(); size = getfixnum(num);
X xllastarg();
X return (cvfixnum((FIXTYPE)NewPtr(size)));
X}
X
X/* xhiword - return the high order 16 bits of an integer */
XLVAL xhiword()
X{
X unsigned int val;
X val = (unsigned int)(getnumber() >> 16);
X xllastarg();
X return (cvfixnum((FIXTYPE)val));
X}
X
X/* xloword - return the low order 16 bits of an integer */
XLVAL xloword()
X{
X unsigned int val;
X val = (unsigned int)getnumber();
X xllastarg();
X return (cvfixnum((FIXTYPE)val));
X}
X
X/* xrdnohang - get the next character in the look-ahead buffer */
XLVAL xrdnohang()
X{
X int ch;
X xllastarg();
X if ((ch = scrnextc()) == EOF)
X return (NIL);
X return (cvfixnum((FIXTYPE)ch));
X}
X
X/* ossymbols - enter important symbols */
Xossymbols()
X{
X LVAL sym;
X
X /* setup globals for the window handles */
X sym = xlenter("*COMMAND-WINDOW*");
X setvalue(sym,cvfixnum((FIXTYPE)cwindow));
X sym = xlenter("*GRAPHICS-WINDOW*");
X setvalue(sym,cvfixnum((FIXTYPE)gwindow));
X}
X
X
X======================== macint.c =============================================
X
X/* macint.c - macintosh interface routines for xlisp */
X
X#include <MacTypes.h>
X#include <Quickdraw.h>
X#include <WindowMgr.h>
X#include <EventMgr.h>
X#include <DialogMgr.h>
X#include <MenuMgr.h>
X#include <PackageMgr.h>
X#include <StdFilePkg.h>
X#include <MemoryMgr.h>
X#include <DeskMgr.h>
X#include <FontMgr.h>
X#include <ControlMgr.h>
X#include <SegmentLdr.h>
X#include <FileMgr.h>
X
X/* program limits */
X#define SCRH 40 /* maximum screen height */
X#define SCRW 100 /* maximum screen width */
X#define CHARMAX 100 /* maximum number of buffered characters */
X#define TIMEON 40 /* cursor on time */
X#define TIMEOFF 20 /* cursor off time */
X
X/* useful definitions */
X#define MenuBarHeight 20
X#define TitleBarHeight 20
X#define SBarWidth 16
X#define MinWidth 80
X#define MinHeight 40
X#define ScreenMargin 2
X#define TextMargin 4
X#define GHeight 232
X
X/* menu id's */
X#define appleID 1
X#define fileID 256
X#define editID 257
X#define controlID 258
X
X/* externals */
Xextern char *s_unbound;
Xextern char *PtoCstr();
X
X/* screen dimensions */
Xint screenWidth;
Xint screenHeight;
X
X/* command window (normal screen) */
Xint nHorizontal,nVertical,nWidth,nHeight;
X
X/* command window (split screen) */
Xint sHorizontal,sVertical,sWidth,sHeight;
X
X/* graphics window */
Xint gHorizontal,gVertical,gWidth,gHeight;
X
X/* menu handles */
XMenuHandle appleMenu;
XMenuHandle fileMenu;
XMenuHandle editMenu;
XMenuHandle controlMenu;
X
X/* misc variables */
XOSType filetypes[] = { 'TEXT' };
X
X/* font information */
Xint tmargin,lmargin;
Xint xinc,yinc;
X
X/* command window */
XWindowRecord cwrecord;
XWindowPtr cwindow;
X
X/* graphics window */
XWindowRecord gwrecord;
XWindowPtr gwindow;
X
X/* window mode */
Xint splitmode;
X
X/* cursor variables */
Xlong cursortime;
Xint cursorstate;
Xint x,y;
X
X/* screen buffer */
Xchar screen[SCRH*SCRW],*topline,*curline;
Xint scrh,scrw;
X
X/* type ahead buffer */
Xchar charbuf[CHARMAX],*inptr,*outptr;
Xint charcnt;
X
Xmacinit()
X{
X /* initialize the toolbox */
X InitGraf(&thePort);
X InitFonts();
X InitWindows();
X InitMenus();
X TEInit();
X InitDialogs(0L);
X InitCursor();
X
X /* setup the menu bar */
X SetupMenus();
X
X /* get the size of the screen */
X screenWidth = screenBits.bounds.right - screenBits.bounds.left;
X screenHeight = screenBits.bounds.bottom - screenBits.bounds.top;
X
X /* Create the graphics and control windows */
X gwindow = GetNewWindow(129,&gwrecord,-1L);
X cwindow = GetNewWindow(128,&cwrecord,-1L);
X
X /* establish the command window as the current port */
X SetPort(cwindow);
X
X /* compute the size of the normal command window */
X nHorizontal = ScreenMargin;
X nVertical = MenuBarHeight + TitleBarHeight + ScreenMargin - 2;
X nWidth = screenWidth - (ScreenMargin * 2) - 1;
X nHeight = screenHeight - MenuBarHeight - TitleBarHeight - (ScreenMargin * 2);
X
X /* compute the size of the split command window */
X sHorizontal = nHorizontal;
X sVertical = nVertical + GHeight + 1;
X sWidth = nWidth;
X sHeight = nHeight - GHeight - 1;
X
X /* compute the size of the graphics window */
X gHorizontal = nHorizontal;
X gVertical = MenuBarHeight + ScreenMargin;
X gWidth = screenWidth - (ScreenMargin * 2);
X gHeight = GHeight;
X
X /* move and size the graphics window */
X MoveWindow(gwindow,gHorizontal,gVertical,0);
X SizeWindow(gwindow,gWidth,gHeight,0);
X
X /* setup the font, size and writing mode for the command window */
X TextFont(monaco); TextSize(9); TextMode(srcCopy);
X
X /* setup command mode */
X scrsplit(FALSE);
X
X /* disable the Cursor */
X cursorstate = -1;
X
X /* setup the input ring buffer */
X inptr = outptr = charbuf;
X charcnt = 0;
X
X /* lock the font in memory */
X SetFontLock(-1);
X}
X
XSetupMenus()
X{
X appleMenu = GetMenu(appleID); /* setup the apple menu */
X AddResMenu(appleMenu,'DRVR');
X InsertMenu(appleMenu,0);
X fileMenu = GetMenu(fileID); /* setup the file menu */
X InsertMenu(fileMenu,0);
X editMenu = GetMenu(editID); /* setup the edit menu */
X InsertMenu(editMenu,0);
X controlMenu = GetMenu(controlID); /* setup the control menu */
X InsertMenu(controlMenu,0);
X DrawMenuBar();
X}
X
Xint scrgetc()
X{
X CursorOn();
X while (charcnt == 0)
X DoEvent();
X CursorOff();
X return (scrnextc());
X}
X
Xint scrnextc()
X{
X int ch;
X if (charcnt > 0) {
X ch = *outptr++; charcnt--;
X if (outptr >= &charbuf[CHARMAX])
X outptr = charbuf;
X }
X else {
X charcnt = 0;
X ch = -1;
X }
X return (ch);
X}
X
Xscrputc(ch)
X int ch;
X{
X switch (ch) {
X case '\r':
X x = 0;
X break;
X case '\n':
X nextline(&curline);
X if (++y >= scrh) {
X y = scrh - 1;
X scrollup();
X }
X break;
X case '\t':
X do { scrputc(' '); } while (x & 7);
X break;
X case '\010':
X if (x) x--;
X break;
X default:
X if (ch >= 0x20 && ch < 0x7F) {
X scrposition(x,y);
X DrawChar(ch);
X curline[x] = ch;
X if (++x >= scrw) {
X nextline(&curline);
X if (++y >= scrh) {
X y = scrh - 1;
X scrollup();
X }
X x = 0;
X }
X }
X break;
X }
X}
X
Xscrdelete()
X{
X scrputc('\010');
X scrputc(' ');
X scrputc('\010');
X}
X
Xscrclear()
X{
X curline = screen;
X for (y = 0; y < SCRH; y++)
X for (x = 0; x < SCRW; x++)
X *curline++ = ' ';
X topline = curline = screen;
X x = y = 0;
X}
X
Xscrflush()
X{
X inptr = outptr = charbuf;
X charcnt = -1;
X osflush();
X}
X
Xscrposition(x,y)
X int x,y;
X{
X MoveTo((x * xinc) + lmargin,(y * yinc) + tmargin);
X}
X
XDoEvent()
X{
X EventRecord myEvent;
X
X SystemTask();
X CursorUpdate();
X
X while (GetNextEvent(everyEvent,&myEvent))
X switch (myEvent.what) {
X case mouseDown:
X DoMouseDown(&myEvent);
X break;
X case keyDown:
X case autoKey:
X DoKeyPress(&myEvent);
X break;
X case activateEvt:
X DoActivate(&myEvent);
X break;
X case updateEvt:
X DoUpdate(&myEvent);
X break;
X }
X}
X
XDoMouseDown(myEvent)
X EventRecord *myEvent;
X{
X WindowPtr whichWindow;
X
X switch (FindWindow(myEvent->where,&whichWindow)) {
X case inMenuBar:
X DoMenuClick(myEvent);
X break;
X case inSysWindow:
X SystemClick(myEvent,whichWindow);
X break;
X case inDrag:
X DoDrag(myEvent,whichWindow);
X break;
X case inGoAway:
X DoGoAway(myEvent,whichWindow);
X break;
X case inGrow:
X DoGrow(myEvent,whichWindow);
X break;
X case inContent:
X DoContent(myEvent,whichWindow);
X break;
X }
X}
X
XDoMenuClick(myEvent)
X EventRecord *myEvent;
X{
X long choice;
X if (choice = MenuSelect(myEvent->where))
X DoCommand(choice);
X}
X
XDoDrag(myEvent,whichWindow)
X EventRecord *myEvent;
X WindowPtr whichWindow;
X{
X Rect dragRect;
X SetRect(&dragRect,0,MenuBarHeight,screenWidth,screenHeight);
X InsetRect(&dragRect,ScreenMargin,ScreenMargin);
X DragWindow(whichWindow,myEvent->where,&dragRect);
X}
X
XDoGoAway(myEvent,whichWindow)
X EventRecord *myEvent;
X WindowPtr whichWindow;
X{
X if (TrackGoAway(whichWindow,myEvent->where))
X wrapup();
X}
X
XDoGrow(myEvent,whichWindow)
X EventRecord *myEvent;
X WindowPtr whichWindow;
X{
X Rect sizeRect;
X long newSize;
X if (whichWindow != FrontWindow() && whichWindow != gwindow)
X SelectWindow(whichWindow);
X else {
X SetRect(&sizeRect,MinWidth,MinHeight,screenWidth,screenHeight-MenuBarHeight);
X newSize = GrowWindow(whichWindow,myEvent->where,&sizeRect);
X if (newSize) {
X EraseRect(&whichWindow->portRect);
X SizeWindow(whichWindow,LoWord(newSize),HiWord(newSize),-1);
X InvalRect(&whichWindow->portRect);
X SetupScreen();
X scrflush();
X }
X }
X}
X
XDoContent(myEvent,whichWindow)
X EventRecord *myEvent;
X WindowPtr whichWindow;
X{
X if (whichWindow != FrontWindow() && whichWindow != gwindow)
X SelectWindow(whichWindow);
X}
X
XDoKeyPress(myEvent)
X EventRecord *myEvent;
X{
X long choice;
X
X if (FrontWindow() == cwindow) {
X if (myEvent->modifiers & 0x100) {
X if (choice = MenuKey((char)myEvent->message))
X DoCommand(choice);
X }
X else {
X if (charcnt < CHARMAX) {
X *inptr++ = myEvent->message & 0xFF; charcnt++;
X if (inptr >= &charbuf[CHARMAX])
X inptr = charbuf;
X }
X }
X }
X}
X
XDoActivate(myEvent)
X EventRecord *myEvent;
X{
X WindowPtr whichWindow;
X whichWindow = (WindowPtr)myEvent->message;
X SetPort(whichWindow);
X if (whichWindow == cwindow)
X DrawGrowIcon(whichWindow);
X}
X
XDoUpdate(myEvent)
X EventRecord *myEvent;
X{
X WindowPtr whichWindow;
X GrafPtr savePort;
X GetPort(&savePort);
X whichWindow = (WindowPtr)myEvent->message;
X SetPort(whichWindow);
X BeginUpdate(whichWindow);
X EraseRect(&whichWindow->portRect);
X if (whichWindow == cwindow) {
X DrawGrowIcon(whichWindow);
X RedrawScreen();
X }
X EndUpdate(whichWindow);
X SetPort(savePort);
X}
X
XDoCommand(choice)
X long choice;
X{
X int theMenu,theItem;
X
X /* decode the menu choice */
X theMenu = HiWord(choice);
X theItem = LoWord(choice);
X
X CursorOff();
X HiliteMenu(theMenu);
X switch (theMenu) {
X case appleID:
X DoAppleMenu(theItem);
X break;
X case fileID:
X DoFileMenu(theItem);
X break;
X case editID:
X DoEditMenu(theItem);
X break;
X case controlID:
X DoControlMenu(theItem);
X break;
X }
X HiliteMenu(0);
X CursorOn();
X}
X
Xpascal aboutfilter(theDialog,theEvent,itemHit)
X DialogPtr theDialog; EventRecord *theEvent; int *itemHit;
X{
X return (theEvent->what == mouseDown ? -1 : 0);
X}
X
XDoAppleMenu(theItem)
X int theItem;
X{
X DialogRecord mydialog;
X char name[256];
X GrafPtr gp;
X int n;
X
X switch (theItem) {
X case 1:
X GetNewDialog(129,&mydialog,-1L);
X ModalDialog(aboutfilter,&n);
X CloseDialog(&mydialog);
X break;
X default:
X GetItem(appleMenu,theItem,name);
X GetPort(&gp);
X OpenDeskAcc(name);
X SetPort(gp);
X break;
X }
X}
X
Xpascal int filefilter(pblock)
X ParmBlkPtr pblock;
X{
X unsigned char *p; int len;
X p = pblock->fileParam.ioNamePtr; len = *p++ &0xFF;
X return (len >= 4 && strncmp(p+len-4,".lsp",4) == 0 ? 0 : -1);
X}
X
XDoFileMenu(theItem)
X int theItem;
X{
X SFReply loadfile;
X Point p;
X
X switch (theItem) {
X case 1: /* load */
X case 2: /* load noisily */
X p.h = 100; p.v = 100;
X SFGetFile(p,"\P",filefilter,-1,filetypes,0L,&loadfile);
X if (loadfile.good) {
X HiliteMenu(0);
X SetVol(0L,loadfile.vRefNum);
X if (xlload(PtoCstr(loadfile.fName),1,(theItem == 1 ? 0 : 1)))
X scrflush();
X else
X xlabort("load error");
X }
X break;
X case 4: /* quit */
X wrapup();
X }
X}
X
XDoEditMenu(theItem)
X int theItem;
X{
X switch (theItem) {
X case 1: /* undo */
X case 3: /* cut */
X case 4: /* copy */
X case 5: /* paste */
X case 6: /* clear */
X SystemEdit(theItem-1);
X break;
X }
X}
X
XDoControlMenu(theItem)
X int theItem;
X{
X scrflush();
X HiliteMenu(0);
X switch (theItem) {
X case 1: /* break */
X xlbreak("user break",s_unbound);
X break;
X case 2: /* continue */
X xlcontinue();
X break;
X case 3: /* clean-up error */
X xlcleanup();
X break;
X case 4: /* Cancel input */
X xlabort("input canceled");
X break;
X case 5: /* Top Level */
X xltoplevel();
X break;
X case 7: /* split screen */
X scrsplit(splitmode ? FALSE : TRUE);
X break;
X }
X}
X
Xscrsplit(split)
X int split;
X{
X ShowHide(cwindow,0);
X if (split) {
X CheckItem(controlMenu,7,-1);
X ShowHide(gwindow,-1);
X MoveWindow(cwindow,sHorizontal,sVertical,-1);
X SizeWindow(cwindow,sWidth,sHeight,-1);
X InvalRect(&cwindow->portRect);
X SetupScreen();
X }
X else {
X CheckItem(controlMenu,7,0);
X ShowHide(gwindow,0);
X MoveWindow(cwindow,nHorizontal,nVertical,-1);
X SizeWindow(cwindow,nWidth,nHeight,-1);
X InvalRect(&cwindow->portRect);
X SetupScreen();
X }
X ShowHide(cwindow,-1);
X splitmode = split;
X}
X
XSetupScreen()
X{
X FontInfo info;
X Rect *pRect;
X
X /* get font information */
X GetFontInfo(&info);
X
X /* compute the top and bottom margins */
X tmargin = TextMargin + info.ascent;
X lmargin = TextMargin;
X
X /* compute the x and y increments */
X xinc = info.widMax;
X yinc = info.ascent + info.descent + info.leading;
X
X /* compute the character dimensions of the screen */
X pRect = &cwindow->portRect;
X scrh = (pRect->bottom - (2 * TextMargin) - (SBarWidth - 1)) / yinc;
X if (scrh > SCRH) scrh = SCRH;
X scrw = (pRect->right - (2 * TextMargin) - (SBarWidth - 1)) / xinc;
X if (scrw > SCRW) scrw = SCRW;
X
X /* clear the screen */
X scrclear();
X}
X
XCursorUpdate()
X{
X if (cursorstate != -1)
X if (cursortime < TickCount()) {
X scrposition(x,y);
X if (cursorstate) {
X DrawChar(' ');
X cursortime = TickCount() + TIMEOFF;
X cursorstate = 0;
X }
X else {
X DrawChar('_');
X cursortime = TickCount() + TIMEON;
X cursorstate = 1;
X }
X }
X}
X
XCursorOn()
X{
X cursortime = TickCount();
X cursorstate = 0;
X}
X
XCursorOff()
X{
X if (cursorstate == 1) {
X scrposition(x,y);
X DrawChar(' ');
X }
X cursorstate = -1;
X}
X
XRedrawScreen()
X{
X char *Line; int y;
X Line = topline;
X for (y = 0; y < scrh; y++) {
X scrposition(0,y);
X DrawText(Line,0,scrw);
X nextline(&Line);
X }
X}
X
Xnextline(pline)
X char **pline;
X{
X if ((*pline += SCRW) >= &screen[SCRH*SCRW])
X *pline = screen;
X}
X
Xscrollup()
X{
X RgnHandle updateRgn;
X Rect rect;
X int x;
X updateRgn = NewRgn();
X rect = cwindow->portRect;
X rect.bottom -= SBarWidth - 1;
X rect.right -= SBarWidth - 1;
X ScrollRect(&rect,0,-yinc,updateRgn);
X DisposeRgn(updateRgn);
X for (x = 0; x < SCRW; x++)
X topline[x] = ' ';
X nextline(&topline);
X}
X
X======================== macstuff.c ==========================================
X
X/* macstuff.c - macintosh interface routines for xlisp */
X
X#include <stdio.h>
X
X/* program limits */
X#define LINEMAX 200 /* maximum line length */
X
X/* externals */
Xextern FILE *tfp;
Xextern int x;
X
X/* local variables */
Xstatic char linebuf[LINEMAX+1],*lineptr;
Xstatic int linepos[LINEMAX],linelen;
Xstatic long rseed = 1L;
X
Xosinit(name)
X char *name;
X{
X /* initialize the mac interface routines */
X macinit();
X
X /* initialize the line editor */
X linelen = 0;
X}
X
Xosfinish()
X{
X}
X
Xoserror(msg)
X{
X char line[100],*p;
X sprintf(line,"error: %s\n",msg);
X for (p = line; *p != '\0'; ++p)
X ostputc(*p);
X}
X
Xint osrand(n)
X int n;
X{
X long k1;
X
X /* make sure we don't get stuck at zero */
X if (rseed == 0L) rseed = 1L;
X
X /* algorithm taken from Dr. Dobbs Journal, November 1985, Page 91 */
X k1 = rseed / 127773L;
X if ((rseed = 16807L * (rseed - k1 * 127773L) - k1 * 2836L) < 0L)
X rseed += 2147483647L;
X
X /* return a random number between 0 and n-1 */
X return ((int)(rseed % (long)n));
X}
X
XFILE *osaopen(name,mode)
X char *name,*mode;
X{
X return (fopen(name,mode));
X}
X
XFILE *osbopen(name,mode)
X char *name,*mode;
X{
X char nmode[4];
X strcpy(nmode,mode); strcat(nmode,"b");
X return (fopen(name,nmode));
X}
X
Xint osclose(fp)
X FILE *fp;
X{
X return (fclose(fp));
X}
X
Xint osagetc(fp)
X FILE *fp;
X{
X return (getc(fp));
X}
X
Xint osbgetc(fp)
X FILE *fp;
X{
X return (getc(fp));
X}
X
Xint osaputc(ch,fp)
X int ch; FILE *fp;
X{
X return (putc(ch,fp));
X}
X
Xint osbputc(ch,fp)
X int ch; FILE *fp;
X{
X return (putc(ch,fp));
X}
X
Xint ostgetc()
X{
X int ch,i;
X
X if (linelen--) return (*lineptr++);
X linelen = 0;
X while ((ch = scrgetc()) != '\r')
X switch (ch) {
X case EOF:
X return (ostgetc());
X case '\010':
X if (linelen > 0) {
X linelen--;
X while (x > linepos[linelen])
X scrdelete();
X }
X break;
X default:
X if (linelen < LINEMAX) {
X linebuf[linelen] = ch;
X linepos[linelen] = x;
X linelen++;
X }
X scrputc(ch);
X break;
X }
X linebuf[linelen++] = '\n';
X scrputc('\r'); scrputc('\n');
X if (tfp)
X for (i = 0; i < linelen; ++i)
X osaputc(linebuf[i],tfp);
X lineptr = linebuf; linelen--;
X return (*lineptr++);
X}
X
Xint ostputc(ch)
X int ch;
X{
X if (ch == '\n')
X scrputc('\r');
X scrputc(ch);
X if (tfp)
X osaputc(ch,tfp);
X return (1);
X}
X
Xosflush()
X{
X lineptr = linebuf;
X linelen = 0;
X}
X
Xoscheck()
X{
X DoEvent();
X}
X
X
X=========================== osdefs.h =====================================
X
Xextern LVAL xptsize(),
X xhidepen(),xshowpen(),xgetpen(),xpensize(),xpenmode(),
X xpenpat(),xpennormal(),xmoveto(),xmove(),xlineto(),xline(),
X xshowgraphics(),xhidegraphics(),xcleargraphics(),
X xtool(),xtool16(),xtool32(),xnewhandle(),xnewptr(),
X xhiword(),xloword(),xrdnohang();
X
X=========================== osptrs.h =====================================
X
X{ "HIDEPEN", S, xhidepen }, /* 300 */
X{ "SHOWPEN", S, xshowpen }, /* 301 */
X{ "GETPEN", S, xgetpen }, /* 302 */
X{ "PENSIZE", S, xpensize }, /* 303 */
X{ "PENMODE", S, xpenmode }, /* 304 */
X{ "PENPAT", S, xpenpat }, /* 305 */
X{ "PENNORMAL", S, xpennormal }, /* 306 */
X{ "MOVETO", S, xmoveto }, /* 307 */
X{ "MOVE", S, xmove }, /* 308 */
X{ "LINETO", S, xlineto }, /* 309 */
X{ "LINE", S, xline }, /* 310 */
X{ "SHOW-GRAPHICS", S, xshowgraphics }, /* 311 */
X{ "HIDE-GRAPHICS", S, xhidegraphics }, /* 312 */
X{ "CLEAR-GRAPHICS", S, xcleargraphics }, /* 313 */
X{ "TOOLBOX", S, xtool }, /* 314 */
X{ "TOOLBOX-16", S, xtool16 }, /* 315 */
X{ "TOOLBOX-32", S, xtool32 }, /* 316 */
X{ "NEWHANDLE", S, xnewhandle }, /* 317 */
X{ "NEWPTR", S, xnewptr }, /* 318 */
X{ "HIWORD", S, xhiword }, /* 319 */
X{ "LOWORD", S, xloword }, /* 320 */
X{ "READ-CHAR-NO-HANG", S, xrdnohang }, /* 321 */
X{ "COMMAND-POINT-SIZE", S, xptsize }, /* 322 */
X
X
X======================== Xlisp.Rsrc ==========================================
X
XXLisp.Rsrc
X
XTYPE WIND
X ,128
XXLISP version 2.0
X41 4 339 508
XInVisible GoAway
X0
X0
X
XTYPE WIND
X ,129
XGraphics Window
X22 4 254 508
XInVisible NoGoAway
X2
X0
X
XTYPE DLOG
X ,129
XAbout XLISP
X50 100 290 395
XVisible NoGoAway
X3
X0
X129
X
XTYPE DITL
X ,129
X9
X
XstaticText
X20 20 40 275
XXLISP v2.0, February 6, 1988
X
XstaticText
X40 20 60 275
XCopyright (c) 1988, by David Betz
X
XstaticText
X60 20 80 275
XAll Rights Reserved
X
XstaticText
X90 20 110 275
XAuthor contact information:
X
XstaticText
X110 40 130 275
XDavid Betz
X
XstaticText
X130 40 150 275
X127 Taylor Road
X
XstaticText
X150 40 170 275
XPeterborough, NH 03458
X
XstaticText
X170 40 190 275
X(603) 924-6936
X
XstaticText
X200 20 220 275
XPortions Copyright Think Technologies
X
XTYPE MENU
X ,1
X\14
XAbout XLISP
X(-
X
XTYPE MENU
X ,256
XFile
XLoad.../L
XLoad Noisily.../N
X(-
XQuit/Q
X
XTYPE MENU
X ,257
XEdit
XUndo/Z
X(-
XCut/X
XCopy/C
XPaste/V
XClear
X
XTYPE MENU
X ,258
XControl
XBreak/B
XContinue/P
XClean Up Error/G
XCancel Input/U
XTop Level/T
X(-
XSplit Screen/S
X
X
X======================== Alles ist gemacht ==================================
X
X
X--
XEric F. Johnson, Boulware Technologies, Inc.
X415 W. Travelers Trail, Burnsville, MN 55337 USA. Phone: +1 612-894-0313.
Xerc at pai.mn.org - or - bungia!pai!erc
X(We have a very dumb mailer, so please send a bang-!-style return address.)
X
X
SHAR_EOF
if test 27375 -ne "`wc -c 'xlisp.mac'`"
then
echo shar: error transmitting "'xlisp.mac'" '(should have been 27375 characters)'
fi
# End of shell archive
exit 0
--
Gary Murphy uunet!mitel!sce!cognos!garym
(garym%cognos.uucp at 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
More information about the Comp.sources.misc
mailing list