Path: utzoo!utgpu!jarvis.csri.toronto.edu!cs.utexas.edu!uunet!allbery
From: garym@cognos.UUCP (Gary Murphy)
Newsgroups: comp.sources.misc
Subject: v10i093: XLisP 2.1 sources 3b (2/2) / 5
Message-ID: <79995@uunet.UU.NET>
Date: 27 Feb 90 03:12:17 GMT
Sender: allbery@uunet.UU.NET
Organization: Cognos Inc., Ottawa, Canada
Lines: 3865
Approved: allbery@uunet.UU.NET (Brandon S. Allbery - comp.sources.misc)

Posting-number: Volume 10, Issue 93
Submitted-by: garym@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@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@pai.UUCP>
XDate: 11 Nov 89 18:55:05 GMT
XReferences: <2091@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@cunixc.cc.columbia.edu>, puglia@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@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@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