sources-request@mirror.UUCP (08/18/86)
Submitted by: seismo!utah-cs!b-davis (Brad Davis)
Mod.sources: Volume 6, Issue 110
Archive-name: xlisp1.6/Part04
#! /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:
# Make.lattice
# Makefile
# asstuff.c
# msstuff.c
# pcfun.doc
# pcstuff.c
# psstuff.c
# readme.1st
# unixstuff.c
# xlisp.h
# This archive created: Mon Jul 14 10:24:59 1986
export PATH; PATH=/bin:$PATH
if test -f 'Make.lattice'
then
echo shar: will not over-write existing file "'Make.lattice'"
else
cat << \SHAR_EOF > 'Make.lattice'
# Because of braindamage in the Lattice runtime environment, where
# printf and friends are incapable of dealing with long strings, we
# must break up the list of files into managable pieces and join them
# in archives before linking. Jeez...
SRC1 = xlobj.c xllist.c xlcont.c xlbfun.c
SRC2 = xldmem.c xleval.c xlfio.c xlftab.c xlglob.c xlio.c xlisp.c xljump.c
SRC2a = xlmath.c xlprin.c xlread.c xlinit.c
SRC3 = xlstr.c xlsubr.c xlsym.c xlsys.c xldbug.c asstuff.c
SRCS = $(SRC1) $(SRC2) $(SRC2a) $(SRC3) xlisp.h
OBJS1 = xlbfun.o xlcont.o xldbug.o xldmem.o xleval.o xlfio.o
OBJS2 = xlftab.o xlglob.o xlinit.o xlio.o xlisp.o xljump.o xllist.o xlmath.o
OBJS3 = xlobj.o xlprin.o xlread.o xlstr.o xlsubr.o xlsym.o xlsys.o asstuff.o
OBJS = lib1.o lib2.o lib3.o
MISC1 = Makefile fact.lsp init.lsp object.lsp prolog.lsp trace.lsp
MISC2 = xlstub.c.NOTUSED
MISC = $(MISC1) $(MISC2)
CFLAGS = -O
CC = cc
#LIBS = -lm
xlisp : $(OBJS)
$(CC) -o xlisp $(CFLAGS) $(OBJS) $(LIBS)
lib1.o : $(OBJS1)
join $(OBJS1) as lib1.o
lib2.o : $(OBJS2)
join $(OBJS2) as lib2.o
lib3.o : $(OBJS3)
join $(OBJS3) as lib3.o
clean :
delete $(OBJS)
delete $(OBJS1)
delete $(OBJS2)
delete $(OBJS3)
xlbfun.o : xlbfun.c xlisp.h
$(CC) -c $(CFLAGS) xlbfun.c
xlcont.o : xlcont.c xlisp.h
$(CC) -c $(CFLAGS) xlcont.c
xldbug.o : xldbug.c xlisp.h
$(CC) -c $(CFLAGS) xldbug.c
xldmem.o : xldmem.c xlisp.h
$(CC) -c $(CFLAGS) xldmem.c
xleval.o : xleval.c xlisp.h
$(CC) -c $(CFLAGS) xleval.c
xlfio.o : xlfio.c xlisp.h
$(CC) -c $(CFLAGS) xlfio.c
xlftab.o : xlftab.c xlisp.h
$(CC) -c $(CFLAGS) xlftab.c
xlglob.o : xlglob.c xlisp.h
$(CC) -c $(CFLAGS) xlglob.c
xlinit.o : xlinit.c xlisp.h
$(CC) -c $(CFLAGS) xlinit.c
xlio.o : xlio.c xlisp.h
$(CC) -c $(CFLAGS) xlio.c
xlisp.o : xlisp.c xlisp.h
$(CC) -c $(CFLAGS) xlisp.c
xljump.o : xljump.c xlisp.h
$(CC) -c $(CFLAGS) xljump.c
xllist.o : xllist.c xlisp.h
$(CC) -c $(CFLAGS) xllist.c
xlmath.o : xlmath.c xlisp.h
$(CC) -c $(CFLAGS) xlmath.c
xlobj.o : xlobj.c xlisp.h
$(CC) -c $(CFLAGS) xlobj.c
xlprin.o : xlprin.c xlisp.h
$(CC) -c $(CFLAGS) xlprin.c
xlread.o : xlread.c xlisp.h
$(CC) -c $(CFLAGS) xlread.c
xlstr.o : xlstr.c xlisp.h
$(CC) -c $(CFLAGS) xlstr.c
xlstub.o : xlstub.c xlisp.h
$(CC) -c $(CFLAGS) xlstub.c
xlsubr.o : xlsubr.c xlisp.h
$(CC) -c $(CFLAGS) xlsubr.c
xlsym.o : xlsym.c xlisp.h
$(CC) -c $(CFLAGS) xlsym.c
xlsys.o : xlsys.c xlisp.h
$(CC) -c $(CFLAGS) xlsys.c
asstuff.o : asstuff.c
$(CC) -c $(CFLAGS) asstuff.c
SHAR_EOF
fi # end of overwriting check
if test -f 'Makefile'
then
echo shar: will not over-write existing file "'Makefile'"
else
cat << \SHAR_EOF > 'Makefile'
OS=unix
SRC1 = xlobj.c xllist.c xlcont.c xlbfun.c
SRC2 = xldmem.c xleval.c xlfio.c xlftab.c xlglob.c xlio.c xlisp.c xljump.c
SRC2a = xlmath.c xlprin.c xlread.c xlinit.c
SRC3 = xlstr.c xlsubr.c xlsym.c xlsys.c xldbug.c $(OS)stuff.c
SRCS = $(SRC1) $(SRC2) $(SRC2a) $(SRC3) xlisp.h
OBJS1 = xlbfun.o xlcont.o xldbug.o xldmem.o xleval.o xlfio.o
OBJS2 = xlftab.o xlglob.o xlinit.o xlio.o xlisp.o xljump.o xllist.o xlmath.o
OBJS3 = xlobj.o xlprin.o xlread.o xlstr.o xlsubr.o xlsym.o xlsys.o $(OS)stuff.o
OBJS = $(OBJS1) $(OBJS2) $(OBJS3)
MISC1 = Makefile fact.lsp init.lsp object.lsp prolog.lsp trace.lsp
MISC2 = xlstub.c.NOTUSED
MISC = $(MISC1) $(MISC2)
CFLAGS = -O
CC = cc
LIBS = -lm
xlisp : $(OBJS)
cc -o xlisp.unix $(CFLAGS) $(OBJS) $(LIBS)
rcs : $(SRCS)
rcs -l $?
touch rcs
lint :
lint -ach $(SRCS)
new : clean
rm -f xlisp
make xlisp
clean :
rm -f *.o
shar : $(SRCS) $(MISC)
shar -c -v xlisp.doc > xlisp1.shar
shar -c -v $(SRC1) > xlisp2.shar
shar -c -v $(SRC2) > xlisp3.shar
shar -c -v $(SRC3) $(MISC) > xlisp4.shar
xlbfun.o : xlbfun.c xlisp.h
$(CC) -c $(CFLAGS) xlbfun.c
xlcont.o : xlcont.c xlisp.h
$(CC) -c $(CFLAGS) xlcont.c
xldbug.o : xldbug.c xlisp.h
$(CC) -c $(CFLAGS) xldbug.c
xldmem.o : xldmem.c xlisp.h
$(CC) -c $(CFLAGS) xldmem.c
xleval.o : xleval.c xlisp.h
$(CC) -c $(CFLAGS) xleval.c
xlfio.o : xlfio.c xlisp.h
$(CC) -c $(CFLAGS) xlfio.c
xlftab.o : xlftab.c xlisp.h
$(CC) -c $(CFLAGS) xlftab.c
xlglob.o : xlglob.c xlisp.h
$(CC) -c $(CFLAGS) xlglob.c
xlinit.o : xlinit.c xlisp.h
$(CC) -c $(CFLAGS) xlinit.c
xlio.o : xlio.c xlisp.h
$(CC) -c $(CFLAGS) xlio.c
xlisp.o : xlisp.c xlisp.h
$(CC) -c $(CFLAGS) xlisp.c
xljump.o : xljump.c xlisp.h
$(CC) -c $(CFLAGS) xljump.c
xllist.o : xllist.c xlisp.h
$(CC) -c $(CFLAGS) xllist.c
xlmath.o : xlmath.c xlisp.h
$(CC) -c $(CFLAGS) xlmath.c
xlobj.o : xlobj.c xlisp.h
$(CC) -c $(CFLAGS) xlobj.c
xlprin.o : xlprin.c xlisp.h
$(CC) -c $(CFLAGS) xlprin.c
xlread.o : xlread.c xlisp.h
$(CC) -c $(CFLAGS) xlread.c
xlstr.o : xlstr.c xlisp.h
$(CC) -c $(CFLAGS) xlstr.c
xlstub.o : xlstub.c xlisp.h
$(CC) -c $(CFLAGS) xlstub.c
xlsubr.o : xlsubr.c xlisp.h
$(CC) -c $(CFLAGS) xlsubr.c
xlsym.o : xlsym.c xlisp.h
$(CC) -c $(CFLAGS) xlsym.c
xlsys.o : xlsys.c xlisp.h
$(CC) -c $(CFLAGS) xlsys.c
$(OS)stuff.o : $(OS)stuff.c
$(CC) -c $(CFLAGS) $(OS)stuff.c
SHAR_EOF
fi # end of overwriting check
if test -f 'asstuff.c'
then
echo shar: will not over-write existing file "'asstuff.c'"
else
cat << \SHAR_EOF > 'asstuff.c'
/* asstuff.c - Amiga specific routines */
#include "xlisp.h"
#ifndef MANX
#define agetc getc /* Not sure if this will work in all cases (fnf) */
#define aputc putc /* Not sure if this will work in all cases (fnf) */
#endif
#define LBSIZE 200
/* external routines */
extern double ran();
/* external variables */
extern NODE *s_unbound,*true;
extern int prompt;
extern int errno;
/* line buffer variables */
static char lbuf[LBSIZE];
static int lpos[LBSIZE];
static int lindex;
static int lcount;
static int lposition;
#define NEW 1006
static long xlispwindow;
/* osinit - initialize */
osinit(banner)
char *banner;
{
extern int Enable_Abort;
Enable_Abort = 0; /* Turn off ^C interrupt in case it's on */
xlispwindow = Open("RAW:1/1/639/199/Xlisp by David Betz", NEW);
while (*banner != '\000') {
xputc (*banner++);
}
xputc ('\n');
lposition = 0;
lindex = 0;
lcount = 0;
}
osfinish ()
{
Close (xlispwindow);
}
/* osrand - return a random number between 0 and n-1 */
int osrand(n)
int n;
{
n = (int)(ran() * (double)n);
return (n < 0 ? -n : n);
}
/* osgetc - get a character from the terminal */
int osgetc(fp)
FILE *fp;
{
int ch;
/* check for input from a file other than stdin */
if (fp != stdin)
return ((int)agetc(fp));
/* check for a buffered character */
if (lcount--)
return ((int)lbuf[lindex++]);
/* get an input line */
for (lcount = 0; ; )
switch (ch = xgetc()) {
case '\n':
case '\r':
lbuf[lcount++] = '\n';
xputc('\r'); xputc('\n'); lposition = 0;
lindex = 0; lcount--;
return ((int)lbuf[lindex++]);
case '\010':
case '\177':
if (lcount) {
lcount--;
while (lposition > lpos[lcount]) {
xputc('\010'); xputc(' '); xputc('\010');
lposition--;
}
}
break;
case '\032':
osflush();
return (EOF);
default:
if (ch == '\t' || (ch >= 0x20 && ch < 0x7F)) {
lbuf[lcount] = ch;
lpos[lcount] = lposition;
if (ch == '\t')
do {
xputc(' ');
} while (++lposition & 7);
else {
xputc(ch); lposition++;
}
lcount++;
}
else {
osflush();
switch (ch) {
case '\003': xltoplevel(); /* control-c */
case '\007': xlcleanup(); /* control-g */
case '\020': xlcontinue(); /* control-p */
case '\032': return (EOF); /* control-z */
default: return (ch);
}
}
}
}
/* osputc - put a character to the terminal */
osputc(ch,fp)
int ch; FILE *fp;
{
/* check for output to something other than stdout */
if (fp != stdout)
return (aputc(ch,fp));
/* check for control characters */
oscheck();
/* output the character */
if (ch == '\n') {
xputc('\r'); xputc('\n');
lposition = 0;
}
else {
xputc(ch);
lposition++;
}
}
/* oscheck - check for control characters during execution */
oscheck()
{
int ch;
if (ch = xcheck())
switch (ch) {
case '\002': osflush(); xlbreak("BREAK",s_unbound); break;
case '\003': osflush(); xltoplevel(); break;
}
}
/* osflush - flush the input line buffer */
osflush()
{
lindex = lcount = 0;
osputc('\n',stdout);
prompt = 1;
}
/* xgetc - get a character from the terminal without echo */
static int xgetc()
{
char ch;
Read (xlispwindow, &ch, 1);
return (ch & 0xFF);
}
/* xputc - put a character to the terminal */
static xputc(ch)
int ch;
{
char chout;
chout = ch;
Write (xlispwindow, &chout, 1L);
}
/* xcheck - check for a character */
static int xcheck()
{
if (WaitForChar (xlispwindow, 0L) == 0L)
return (0);
return (xgetc() & 0xFF);
}
/* xdos - execute a dos command */
NODE *xdos(args)
NODE *args;
{
char *cmd;
cmd = xlmatch(STR,&args)->n_str;
xllastarg(args);
return (system(cmd) == -1 ? cvfixnum((FIXNUM)errno) : true);
}
int system (cmd)
char *cmd;
{
return (Execute(cmd, 0L, xlispwindow));
}
double ran () /* Just punt for now, not in Manx C; FIXME!!*/
{
static long seed = 654321;
long lval;
double dval;
seed *= ((8 * (123456) - 3));
lval = seed & 0xFFFF;
dval = ((double) lval) / ((double) (0x10000));
return (dval);
}
/* xgetkey - get a key from the keyboard */
NODE *xgetkey(args)
NODE *args;
{
xllastarg(args);
return (cvfixnum((FIXNUM)xgetc()));
}
#ifdef DEADCODE /* Dont' use this for now? (fnf) */
/* xcursor - set the cursor position */
NODE *xcursor(args)
NODE *args;
{
int row,col;
row = xlmatch(INT,&args)->n_int;
col = xlmatch(INT,&args)->n_int;
xllastarg(args);
scr_curs(row,col);
return (NIL);
}
/* xclear - clear the screen */
NODE *xclear(args)
NODE *args;
{
xllastarg(args);
scr_clear();
return (NIL);
}
/* xeol - clear to end of line */
NODE *xeol(args)
NODE *args;
{
xllastarg(args);
scr_eol();
return (NIL);
}
/* xeos - clear to end of screen */
NODE *xeos(args)
NODE *args;
{
xllastarg(args);
scr_eos();
return (NIL);
}
/* xlinsert - insert line */
NODE *xlinsert(args)
NODE *args;
{
xllastarg(args);
scr_linsert();
return (NIL);
}
/* xldelete - delete line */
NODE *xldelete(args)
NODE *args;
{
xllastarg(args);
scr_ldelete();
return (NIL);
}
/* xcinsert - insert character */
NODE *xcinsert(args)
NODE *args;
{
xllastarg(args);
scr_cinsert();
return (NIL);
}
/* xcdelete - delete character */
NODE *xcdelete(args)
NODE *args;
{
xllastarg(args);
scr_cdelete();
return (NIL);
}
/* xinverse - set/clear inverse video */
NODE *xinverse(args)
NODE *args;
{
NODE *val;
val = xlarg(&args);
xllastarg(args);
scr_invers(val ? 1 : 0);
return (NIL);
}
/* xline - draw a line */
NODE *xline(args)
NODE *args;
{
int x1,y1,x2,y2;
x1 = xlmatch(INT,&args)->n_int;
y1 = xlmatch(INT,&args)->n_int;
x2 = xlmatch(INT,&args)->n_int;
y2 = xlmatch(INT,&args)->n_int;
xllastarg(args);
line(x1,y1,x2,y2);
return (NIL);
}
/* xpoint - draw a point */
NODE *xpoint(args)
NODE *args;
{
int x,y;
x = xlmatch(INT,&args)->n_int;
y = xlmatch(INT,&args)->n_int;
xllastarg(args);
point(x,y);
return (NIL);
}
/* xcircle - draw a circle */
NODE *xcircle(args)
NODE *args;
{
int x,y,r;
x = xlmatch(INT,&args)->n_int;
y = xlmatch(INT,&args)->n_int;
r = xlmatch(INT,&args)->n_int;
xllastarg(args);
circle(x,y,r);
return (NIL);
}
/* xaspect - set the aspect ratio */
NODE *xaspect(args)
NODE *args;
{
int x,y;
x = xlmatch(INT,&args)->n_int;
y = xlmatch(INT,&args)->n_int;
xllastarg(args);
set_asp(x,y);
return (NIL);
}
/* xcolors - setup the display colors */
NODE *xcolors(args)
NODE *args;
{
int c,p,b;
c = xlmatch(INT,&args)->n_int;
p = xlmatch(INT,&args)->n_int;
b = xlmatch(INT,&args)->n_int;
xllastarg(args);
color(c);
palette(p);
ground(b);
return (NIL);
}
/* xmode - set the display mode */
NODE *xmode(args)
NODE *args;
{
int m;
m = xlmatch(INT,&args)->n_int;
xllastarg(args);
mode(m);
return (NIL);
}
#endif DEADCODE
/* osfinit - initialize pc specific functions */
osfinit()
{
xlsubr("DOS", SUBR, xdos);
xlsubr("GET-KEY", SUBR, xgetkey);
#ifdef DEADCODE
xlsubr("SET-CURSOR", SUBR, xcursor);
xlsubr("CLEAR", SUBR, xclear);
xlsubr("CLEAR-EOL", SUBR, xeol);
xlsubr("CLEAR-EOS", SUBR, xeos);
xlsubr("INSERT-LINE", SUBR, xlinsert);
xlsubr("DELETE-LINE", SUBR, xldelete);
xlsubr("INSERT-CHAR", SUBR, xcinsert);
xlsubr("DELETE-CHAR", SUBR, xcdelete);
xlsubr("SET-INVERSE", SUBR, xinverse);
xlsubr("LINE", SUBR, xline);
xlsubr("POINT", SUBR, xpoint);
xlsubr("CIRCLE", SUBR, xcircle);
xlsubr("ASPECT-RATIO", SUBR, xaspect);
xlsubr("COLORS", SUBR, xcolors);
xlsubr("MODE", SUBR, xmode);
#endif DEADCODE
}
SHAR_EOF
fi # end of overwriting check
if test -f 'msstuff.c'
then
echo shar: will not over-write existing file "'msstuff.c'"
else
cat << \SHAR_EOF > 'msstuff.c'
/* msstuff.c - ms-dos specific routines */
#include "xlisp.h"
#define LBSIZE 200
/* external routines */
extern double ran();
/* external variables */
extern NODE *s_unbound,*true;
extern int prompt;
extern int errno;
/* line buffer variables */
static char lbuf[LBSIZE];
static int lpos[LBSIZE];
static int lindex;
static int lcount;
static int lposition;
/* osinit - initialize */
osinit(banner)
char *banner;
{
printf("%s\n",banner);
lposition = 0;
lindex = 0;
lcount = 0;
}
/* osrand - return a random number between 0 and n-1 */
int osrand(n)
int n;
{
n = (int)(ran() * (double)n);
return (n < 0 ? -n : n);
}
/* osgetc - get a character from the terminal */
int osgetc(fp)
FILE *fp;
{
int ch;
/* check for input from a file other than stdin */
if (fp != stdin)
return (agetc(fp));
/* check for a buffered character */
if (lcount--)
return (lbuf[lindex++]);
/* get an input line */
for (lcount = 0; ; )
switch (ch = xgetc()) {
case '\r':
lbuf[lcount++] = '\n';
xputc('\r'); xputc('\n'); lposition = 0;
lindex = 0; lcount--;
return (lbuf[lindex++]);
case '\010':
case '\177':
if (lcount) {
lcount--;
while (lposition > lpos[lcount]) {
xputc('\010'); xputc(' '); xputc('\010');
lposition--;
}
}
break;
case '\032':
osflush();
return (EOF);
default:
if (ch == '\t' || (ch >= 0x20 && ch < 0x7F)) {
lbuf[lcount] = ch;
lpos[lcount] = lposition;
if (ch == '\t')
do {
xputc(' ');
} while (++lposition & 7);
else {
xputc(ch); lposition++;
}
lcount++;
}
else {
osflush();
switch (ch) {
case '\003': xltoplevel(); /* control-c */
case '\007': xlcleanup(); /* control-g */
case '\020': xlcontinue(); /* control-p */
case '\032': return (EOF); /* control-z */
default: return (ch);
}
}
}
}
/* osputc - put a character to the terminal */
osputc(ch,fp)
int ch; FILE *fp;
{
/* check for output to something other than stdout */
if (fp != stdout)
return (aputc(ch,fp));
/* check for control characters */
oscheck();
/* output the character */
if (ch == '\n') {
xputc('\r'); xputc('\n');
lposition = 0;
}
else {
xputc(ch);
lposition++;
}
}
/* oscheck - check for control characters during execution */
oscheck()
{
int ch;
if (ch = xcheck())
switch (ch) {
case '\002': osflush(); xlbreak("BREAK",s_unbound); break;
case '\003': osflush(); xltoplevel(); break;
}
}
/* osflush - flush the input line buffer */
osflush()
{
lindex = lcount = 0;
osputc('\n',stdout);
prompt = 1;
}
/* xgetc - get a character from the terminal without echo */
static int xgetc()
{
return (bdos(7));
}
/* xputc - put a character to the terminal */
static xputc(ch)
int ch;
{
bdos(6,ch);
}
/* xcheck - check for a character */
static int xcheck()
{
return (bdos(6,0xFF));
}
/* xdos - execute a dos command */
NODE *xdos(args)
NODE *args;
{
char *cmd;
cmd = xlmatch(STR,&args)->n_str;
xllastarg(args);
return (system(cmd) == -1 ? cvfixnum((FIXNUM)errno) : true);
}
/* xgetkey - get a key from the keyboard */
NODE *xgetkey(args)
NODE *args;
{
xllastarg(args);
return (cvfixnum((FIXNUM)xgetc()));
}
/* osfinit - initialize pc specific functions */
osfinit()
{
xlsubr("DOS", SUBR, xdos);
xlsubr("GET-KEY", SUBR, xgetkey);
}
SHAR_EOF
fi # end of overwriting check
if test -f 'pcfun.doc'
then
echo shar: will not over-write existing file "'pcfun.doc'"
else
cat << \SHAR_EOF > 'pcfun.doc'
PCFUN.MEM
12/9/85
This is a list of IBM-PC specific functions in XLISP version 1.5d.
All of the functions take integers as arguments except where noted.
All of the functions return NIL.
(dos <cmd>) Execute a DOS command
<cmd> the command string
(get-key) Get a key from the keyboard
(set-cursor <row> <col>) Set the cursor position
(clear) Clear the screen
(clear-eol) Clear to the end of the current line
(clear-eos) Clear to the end of the screen
(insert-line) Insert a line
(delete-line) Delete a line
(insert-char) Insert a character
(delete-char) Delete a character
(set-inverse <mode>) Set inverse mode
<mode> is T for inverse, NIL for normal
(line <x1> <y1> <x2> <y2>) Draw a line
(point <x> <y>) Draw a point
(circle <x> <y> <radius>) Draw a circle
(aspect-ratio <x> <y>) Set the aspect ratio for circles
(colors <color> <palette> <background>) Set the display colors
(mode <mode>) Set the display mode
SHAR_EOF
fi # end of overwriting check
if test -f 'pcstuff.c'
then
echo shar: will not over-write existing file "'pcstuff.c'"
else
cat << \SHAR_EOF > 'pcstuff.c'
/* pcstuff.c - ibm-pc specific routines */
#include "xlisp.h"
#define LBSIZE 200
/* external routines */
extern double ran();
/* external variables */
extern NODE *s_unbound,*true;
extern int prompt;
extern int errno;
/* line buffer variables */
static char lbuf[LBSIZE];
static int lpos[LBSIZE];
static int lindex;
static int lcount;
static int lposition;
/* osinit - initialize */
osinit(banner)
char *banner;
{
printf("%s\n",banner);
lposition = 0;
lindex = 0;
lcount = 0;
}
/* osrand - return a random number between 0 and n-1 */
int osrand(n)
int n;
{
n = (int)(ran() * (double)n);
return (n < 0 ? -n : n);
}
/* osgetc - get a character from the terminal */
int osgetc(fp)
FILE *fp;
{
int ch;
/* check for input from a file other than stdin */
if (fp != stdin)
return (agetc(fp));
/* check for a buffered character */
if (lcount--)
return (lbuf[lindex++]);
/* get an input line */
for (lcount = 0; ; )
switch (ch = xgetc()) {
case '\r':
lbuf[lcount++] = '\n';
xputc('\r'); xputc('\n'); lposition = 0;
lindex = 0; lcount--;
return (lbuf[lindex++]);
case '\010':
case '\177':
if (lcount) {
lcount--;
while (lposition > lpos[lcount]) {
xputc('\010'); xputc(' '); xputc('\010');
lposition--;
}
}
break;
case '\032':
osflush();
return (EOF);
default:
if (ch == '\t' || (ch >= 0x20 && ch < 0x7F)) {
lbuf[lcount] = ch;
lpos[lcount] = lposition;
if (ch == '\t')
do {
xputc(' ');
} while (++lposition & 7);
else {
xputc(ch); lposition++;
}
lcount++;
}
else {
osflush();
switch (ch) {
case '\003': xltoplevel(); /* control-c */
case '\007': xlcleanup(); /* control-g */
case '\020': xlcontinue(); /* control-p */
case '\032': return (EOF); /* control-z */
default: return (ch);
}
}
}
}
/* osputc - put a character to the terminal */
osputc(ch,fp)
int ch; FILE *fp;
{
/* check for output to something other than stdout */
if (fp != stdout)
return (aputc(ch,fp));
/* check for control characters */
oscheck();
/* output the character */
if (ch == '\n') {
xputc('\r'); xputc('\n');
lposition = 0;
}
else {
xputc(ch);
lposition++;
}
}
/* oscheck - check for control characters during execution */
oscheck()
{
int ch;
if (ch = xcheck())
switch (ch) {
case '\002': osflush(); xlbreak("BREAK",s_unbound); break;
case '\003': osflush(); xltoplevel(); break;
}
}
/* osflush - flush the input line buffer */
osflush()
{
lindex = lcount = 0;
osputc('\n',stdout);
prompt = 1;
}
/* xgetc - get a character from the terminal without echo */
static int xgetc()
{
return (scr_getc() & 0xFF);
}
/* xputc - put a character to the terminal */
static xputc(ch)
int ch;
{
scr_putc(ch);
}
/* xcheck - check for a character */
static int xcheck()
{
if (scr_poll() == -1)
return (0);
return (scr_getc() & 0xFF);
}
/* xdos - execute a dos command */
NODE *xdos(args)
NODE *args;
{
char *cmd;
cmd = xlmatch(STR,&args)->n_str;
xllastarg(args);
return (system(cmd) == -1 ? cvfixnum((FIXNUM)errno) : true);
}
/* xgetkey - get a key from the keyboard */
NODE *xgetkey(args)
NODE *args;
{
xllastarg(args);
return (cvfixnum((FIXNUM)scr_getc()));
}
/* xcursor - set the cursor position */
NODE *xcursor(args)
NODE *args;
{
int row,col;
row = xlmatch(INT,&args)->n_int;
col = xlmatch(INT,&args)->n_int;
xllastarg(args);
scr_curs(row,col);
return (NIL);
}
/* xclear - clear the screen */
NODE *xclear(args)
NODE *args;
{
xllastarg(args);
scr_clear();
return (NIL);
}
/* xeol - clear to end of line */
NODE *xeol(args)
NODE *args;
{
xllastarg(args);
scr_eol();
return (NIL);
}
/* xeos - clear to end of screen */
NODE *xeos(args)
NODE *args;
{
xllastarg(args);
scr_eos();
return (NIL);
}
/* xlinsert - insert line */
NODE *xlinsert(args)
NODE *args;
{
xllastarg(args);
scr_linsert();
return (NIL);
}
/* xldelete - delete line */
NODE *xldelete(args)
NODE *args;
{
xllastarg(args);
scr_ldelete();
return (NIL);
}
/* xcinsert - insert character */
NODE *xcinsert(args)
NODE *args;
{
xllastarg(args);
scr_cinsert();
return (NIL);
}
/* xcdelete - delete character */
NODE *xcdelete(args)
NODE *args;
{
xllastarg(args);
scr_cdelete();
return (NIL);
}
/* xinverse - set/clear inverse video */
NODE *xinverse(args)
NODE *args;
{
NODE *val;
val = xlarg(&args);
xllastarg(args);
scr_invers(val ? 1 : 0);
return (NIL);
}
/* xline - draw a line */
NODE *xline(args)
NODE *args;
{
int x1,y1,x2,y2;
x1 = xlmatch(INT,&args)->n_int;
y1 = xlmatch(INT,&args)->n_int;
x2 = xlmatch(INT,&args)->n_int;
y2 = xlmatch(INT,&args)->n_int;
xllastarg(args);
line(x1,y1,x2,y2);
return (NIL);
}
/* xpoint - draw a point */
NODE *xpoint(args)
NODE *args;
{
int x,y;
x = xlmatch(INT,&args)->n_int;
y = xlmatch(INT,&args)->n_int;
xllastarg(args);
point(x,y);
return (NIL);
}
/* xcircle - draw a circle */
NODE *xcircle(args)
NODE *args;
{
int x,y,r;
x = xlmatch(INT,&args)->n_int;
y = xlmatch(INT,&args)->n_int;
r = xlmatch(INT,&args)->n_int;
xllastarg(args);
circle(x,y,r);
return (NIL);
}
/* xaspect - set the aspect ratio */
NODE *xaspect(args)
NODE *args;
{
int x,y;
x = xlmatch(INT,&args)->n_int;
y = xlmatch(INT,&args)->n_int;
xllastarg(args);
set_asp(x,y);
return (NIL);
}
/* xcolors - setup the display colors */
NODE *xcolors(args)
NODE *args;
{
int c,p,b;
c = xlmatch(INT,&args)->n_int;
p = xlmatch(INT,&args)->n_int;
b = xlmatch(INT,&args)->n_int;
xllastarg(args);
color(c);
palette(p);
ground(b);
return (NIL);
}
/* xmode - set the display mode */
NODE *xmode(args)
NODE *args;
{
int m;
m = xlmatch(INT,&args)->n_int;
xllastarg(args);
mode(m);
return (NIL);
}
/* osfinit - initialize pc specific functions */
osfinit()
{
xlsubr("DOS", SUBR, xdos);
xlsubr("GET-KEY", SUBR, xgetkey);
xlsubr("SET-CURSOR", SUBR, xcursor);
xlsubr("CLEAR", SUBR, xclear);
xlsubr("CLEAR-EOL", SUBR, xeol);
xlsubr("CLEAR-EOS", SUBR, xeos);
xlsubr("INSERT-LINE", SUBR, xlinsert);
xlsubr("DELETE-LINE", SUBR, xldelete);
xlsubr("INSERT-CHAR", SUBR, xcinsert);
xlsubr("DELETE-CHAR", SUBR, xcdelete);
xlsubr("SET-INVERSE", SUBR, xinverse);
xlsubr("LINE", SUBR, xline);
xlsubr("POINT", SUBR, xpoint);
xlsubr("CIRCLE", SUBR, xcircle);
xlsubr("ASPECT-RATIO", SUBR, xaspect);
xlsubr("COLORS", SUBR, xcolors);
xlsubr("MODE", SUBR, xmode);
}
SHAR_EOF
fi # end of overwriting check
if test -f 'psstuff.c'
then
echo shar: will not over-write existing file "'psstuff.c'"
else
cat << \SHAR_EOF > 'psstuff.c'
/* pcstuff.c - ibm-pc specific routines */
#include "xlisp.h"
#define LBSIZE 200
/* external routines */
extern double ran();
/* external variables */
extern NODE *s_unbound,*true;
extern int prompt;
extern int errno;
/* line buffer variables */
static char lbuf[LBSIZE];
static int lpos[LBSIZE];
static int lindex;
static int lcount;
static int lposition;
/* osinit - initialize */
osinit(banner)
char *banner;
{
printf("%s\n",banner);
lposition = 0;
lindex = 0;
lcount = 0;
}
/* osrand - return a random number between 0 and n-1 */
int osrand(n)
int n;
{
n = (int)(ran() * (double)n);
return (n < 0 ? -n : n);
}
/* osgetc - get a character from the terminal */
int osgetc(fp)
FILE *fp;
{
int ch;
/* check for input from a file other than stdin */
if (fp != stdin)
return (agetc(fp));
/* check for a buffered character */
if (lcount--)
return (lbuf[lindex++]);
/* get an input line */
for (lcount = 0; ; )
switch (ch = xgetc()) {
case '\r':
lbuf[lcount++] = '\n';
xputc('\r'); xputc('\n'); lposition = 0;
lindex = 0; lcount--;
return (lbuf[lindex++]);
case '\010':
case '\177':
if (lcount) {
lcount--;
while (lposition > lpos[lcount]) {
xputc('\010'); xputc(' '); xputc('\010');
lposition--;
}
}
break;
case '\032':
osflush();
return (EOF);
default:
if (ch == '\t' || (ch >= 0x20 && ch < 0x7F)) {
lbuf[lcount] = ch;
lpos[lcount] = lposition;
if (ch == '\t')
do {
xputc(' ');
} while (++lposition & 7);
else {
xputc(ch); lposition++;
}
lcount++;
}
else {
osflush();
switch (ch) {
case '\003': xltoplevel(); /* control-c */
case '\007': xlcleanup(); /* control-g */
case '\020': xlcontinue(); /* control-p */
case '\032': return (EOF); /* control-z */
default: return (ch);
}
}
}
}
/* osputc - put a character to the terminal */
osputc(ch,fp)
int ch; FILE *fp;
{
/* check for output to something other than stdout */
if (fp != stdout)
return (aputc(ch,fp));
/* check for control characters */
oscheck();
/* output the character */
if (ch == '\n') {
xputc('\r'); xputc('\n');
lposition = 0;
}
else {
xputc(ch);
lposition++;
}
}
/* oscheck - check for control characters during execution */
oscheck()
{
int ch;
if (ch = xcheck())
switch (ch) {
case '\002': osflush(); xlbreak("BREAK",s_unbound); break;
case '\003': osflush(); xltoplevel(); break;
}
}
/* osflush - flush the input line buffer */
osflush()
{
lindex = lcount = 0;
osputc('\n',stdout);
prompt = 1;
}
/* xgetc - get a character from the terminal without echo */
static int xgetc()
{
return (scr_getc() & 0xFF);
}
/* xputc - put a character to the terminal */
static xputc(ch)
int ch;
{
scr_putc(ch);
}
/* xcheck - check for a character */
static int xcheck()
{
if (scr_poll() == -1)
return (0);
return (scr_getc() & 0xFF);
}
/* xdos - execute a dos command */
NODE *xdos(args)
NODE *args;
{
char *cmd;
cmd = xlmatch(STR,&args)->n_str;
xllastarg(args);
return (system(cmd) == -1 ? cvfixnum((FIXNUM)errno) : true);
}
/* xgetkey - get a key from the keyboard */
NODE *xgetkey(args)
NODE *args;
{
xllastarg(args);
return (cvfixnum((FIXNUM)scr_getc()));
}
/* xcursor - set the cursor position */
NODE *xcursor(args)
NODE *args;
{
int row,col;
row = xlmatch(INT,&args)->n_int;
col = xlmatch(INT,&args)->n_int;
xllastarg(args);
scr_curs(row,col);
return (NIL);
}
/* xclear - clear the screen */
NODE *xclear(args)
NODE *args;
{
xllastarg(args);
scr_clear();
return (NIL);
}
/* xeol - clear to end of line */
NODE *xeol(args)
NODE *args;
{
xllastarg(args);
scr_eol();
return (NIL);
}
/* xeos - clear to end of screen */
NODE *xeos(args)
NODE *args;
{
xllastarg(args);
scr_eos();
return (NIL);
}
/* xlinsert - insert line */
NODE *xlinsert(args)
NODE *args;
{
xllastarg(args);
scr_linsert();
return (NIL);
}
/* xldelete - delete line */
NODE *xldelete(args)
NODE *args;
{
xllastarg(args);
scr_ldelete();
return (NIL);
}
/* xcinsert - insert character */
NODE *xcinsert(args)
NODE *args;
{
xllastarg(args);
scr_cinsert();
return (NIL);
}
/* xcdelete - delete character */
NODE *xcdelete(args)
NODE *args;
{
xllastarg(args);
scr_cdelete();
return (NIL);
}
/* xinverse - set/clear inverse video */
NODE *xinverse(args)
NODE *args;
{
NODE *val;
val = xlarg(&args);
xllastarg(args);
scr_invers(val ? 1 : 0);
return (NIL);
}
/* xline - draw a line */
NODE *xline(args)
NODE *args;
{
int x1,y1,x2,y2;
x1 = xlmatch(INT,&args)->n_int;
y1 = xlmatch(INT,&args)->n_int;
x2 = xlmatch(INT,&args)->n_int;
y2 = xlmatch(INT,&args)->n_int;
xllastarg(args);
line(x1,y1,x2,y2);
return (NIL);
}
/* xpoint - draw a point */
NODE *xpoint(args)
NODE *args;
{
int x,y;
x = xlmatch(INT,&args)->n_int;
y = xlmatch(INT,&args)->n_int;
xllastarg(args);
point(x,y);
return (NIL);
}
/* xcircle - draw a circle */
NODE *xcircle(args)
NODE *args;
{
int x,y,r;
x = xlmatch(INT,&args)->n_int;
y = xlmatch(INT,&args)->n_int;
r = xlmatch(INT,&args)->n_int;
xllastarg(args);
circle(x,y,r);
return (NIL);
}
/* xaspect - set the aspect ratio */
NODE *xaspect(args)
NODE *args;
{
int x,y;
x = xlmatch(INT,&args)->n_int;
y = xlmatch(INT,&args)->n_int;
xllastarg(args);
set_asp(x,y);
return (NIL);
}
/* xcolors - setup the display colors */
NODE *xcolors(args)
NODE *args;
{
int c,p,b;
c = xlmatch(INT,&args)->n_int;
p = xlmatch(INT,&args)->n_int;
b = xlmatch(INT,&args)->n_int;
xllastarg(args);
color(c);
palette(p);
ground(b);
return (NIL);
}
/* xmode - set the display mode */
NODE *xmode(args)
NODE *args;
{
int m;
m = xlmatch(INT,&args)->n_int;
xllastarg(args);
mode(m);
return (NIL);
}
/* osfinit - initialize pc specific functions */
osfinit()
{
xlsubr("DOS", SUBR, xdos);
xlsubr("GET-KEY", SUBR, xgetkey);
xlsubr("SET-CURSOR", SUBR, xcursor);
xlsubr("CLEAR", SUBR, xclear);
xlsubr("CLEAR-EOL", SUBR, xeol);
xlsubr("CLEAR-EOS", SUBR, xeos);
xlsubr("INSERT-LINE", SUBR, xlinsert);
xlsubr("DELETE-LINE", SUBR, xldelete);
xlsubr("INSERT-CHAR", SUBR, xcinsert);
xlsubr("DELETE-CHAR", SUBR, xcdelete);
xlsubr("SET-INVERSE", SUBR, xinverse);
xlsubr("LINE", SUBR, xline);
xlsubr("POINT", SUBR, xpoint);
xlsubr("CIRCLE", SUBR, xcircle);
xlsubr("ASPECT-RATIO", SUBR, xaspect);
xlsubr("COLORS", SUBR, xcolors);
xlsubr("MODE", SUBR, xmode);
}
SHAR_EOF
fi # end of overwriting check
if test -f 'readme.1st'
then
echo shar: will not over-write existing file "'readme.1st'"
else
cat << \SHAR_EOF > 'readme.1st'
XLISP version 1.6
January 6, 1985
README 1ST This file
XLISP DOC XLISP documentation
PCFUN DOC PC specific function definitions
XLISPPC EXE XLISP executable for IBM-PC compatibles
XLISPMS EXE XLISP executable for generic MS-DOS
PCTURTLE LSP IBM-PC turtle graphics demo program
INIT LSP XLISP initialization file
FACT LSP Factorial function
FIB LSP Fibonacci function
PROLOG LSP Tiny Prolog interpreter
PT LSP Turtle graphics demo for ANSI terminals
TRACE LSP A simple trace facility
PP LSP Pretty printer
ART LSP Code from my 3/85 Byte article
XLISP ARC XLISP source code (archive)
ARC EXE File archiver program
To extract the XLISP source files from the XLISP.ARC archive, type the
following command:
arc e xlisp *.*
SHAR_EOF
fi # end of overwriting check
if test -f 'unixstuff.c'
then
echo shar: will not over-write existing file "'unixstuff.c'"
else
cat << \SHAR_EOF > 'unixstuff.c'
/* unixstuff.c - unix specific routines */
#include "xlisp.h"
/* external routines */
extern int rand();
/* osinit - initialize */
osinit(banner)
char *banner;
{
printf("%s\n",banner);
}
/* osrand - return a random number between 0 and n-1 */
int osrand(n)
int n;
{
return((int)(rand()/4294967296.0 * (double)n));
}
/* osgetc - get a character from the terminal */
int osgetc(fp)
FILE *fp;
{
return(getc(fp));
}
/* osputc - put a character to the terminal */
osputc(ch,fp)
int ch; FILE *fp;
{
putc(ch, fp);
}
/* oscheck - check for control characters during execution */
oscheck()
{
/* NIX */
}
/* osfinit - initialize pc specific functions */
osfinit()
{
/* NIX */
}
/* osfinish - cleanup before exit */
osfinish()
{
/* NIX */
}
SHAR_EOF
fi # end of overwriting check
if test -f 'xlisp.h'
then
echo shar: will not over-write existing file "'xlisp.h'"
else
cat << \SHAR_EOF > 'xlisp.h'
/* xlisp - a small subset of lisp */
/* Copyright (c) 1985, by David Michael Betz
All Rights Reserved
Permission is granted for unrestricted non-commercial use */
/* system specific definitions */
/* #define unix */
#include <stdio.h>
#include <ctype.h>
#ifndef MEGAMAX
#include <setjmp.h>
#endif
/* NNODES number of nodes to allocate in each request (1000) */
/* TDEPTH trace stack depth (500) */
/* EDEPTH evaluation stack depth (1000) */
/* FORWARD type of a forward declaration () */
/* LOCAL type of a local function (static) */
/* AFMT printf format for addresses ("%x") */
/* FIXNUM data type for fixed point numbers (long) */
/* ITYPE fixed point input conversion routine type (long atol()) */
/* ICNV fixed point input conversion routine (atol) */
/* IFMT printf format for fixed point numbers ("%ld") */
/* FLONUM data type for floating point numbers (float) */
/* SYSTEM enable the control-d command */
/* absolute value macros */
#ifndef abs
#define abs(n) ((n) < 0 ? -(n) : (n))
#endif
#ifndef fabs
#define fabs(n) ((n) < 0.0 ? -(n) : (n))
#endif
/* for the MegaMax compiler */
#ifdef MEGAMAX
#define LOCAL
#define AFMT "%lx"
#endif
/* for the AZTEC C compiler - small model */
#ifdef AZTEC_SM
#define SYSTEM
#define NIL 0
#endif
/* for the AZTEC C compiler - large model */
#ifdef AZTEC_LM
#define FLONUM double
#define SYSTEM
#define NIL 0L
#endif
/* for the Lattice C compiler (Amiga) */
#ifdef LATTICE
#undef fabs
#endif
/* default important definitions */
#ifndef NNODES
#define NNODES 1000
#endif
#ifndef TDEPTH
#define TDEPTH 500
#endif
#ifndef EDEPTH
#define EDEPTH 1000
#endif
#ifndef FORWARD
#define FORWARD
#endif
#ifndef LOCAL
#define LOCAL static
#endif
#ifndef AFMT
#define AFMT "%x"
#endif
#ifndef FIXNUM
#define FIXNUM long
#endif
#ifndef ITYPE
#define ITYPE long atol()
#endif
#ifndef ICNV
#define ICNV(n) atol(n)
#endif
#ifndef IFMT
#define IFMT "%ld"
#endif
#ifndef FLONUM
#define FLONUM float
#endif
/* useful definitions */
#define TRUE 1
#define FALSE 0
#ifndef NIL
#define NIL (NODE *)0
#endif
/* program limits */
#define STRMAX 100 /* maximum length of a string constant */
#define HSIZE 199 /* symbol hash table size */
#define SAMPLE 100 /* control character sample rate */
/* node types */
#define FREE 0
#define SUBR 1
#define FSUBR 2
#define LIST 3
#define SYM 4
#define INT 5
#define STR 6
#define OBJ 7
#define FPTR 8
#define FLOAT 9
#define VECT 10
/* node flags */
#define MARK 1
#define LEFT 2
/* string types */
#define DYNAMIC 0
#define STATIC 1
/* new node access macros */
#define ntype(x) ((x)->n_type)
/* type predicates */
#define atom(x) ((x) == NIL || (x)->n_type != LIST)
#define null(x) ((x) == NIL)
#define listp(x) ((x) == NIL || (x)->n_type == LIST)
#define consp(x) ((x) && (x)->n_type == LIST)
#define subrp(x) ((x) && (x)->n_type == SUBR)
#define fsubrp(x) ((x) && (x)->n_type == FSUBR)
#define stringp(x) ((x) && (x)->n_type == STR)
#define symbolp(x) ((x) && (x)->n_type == SYM)
#define filep(x) ((x) && (x)->n_type == FPTR)
#define objectp(x) ((x) && (x)->n_type == OBJ)
#define fixp(x) ((x) && (x)->n_type == INT)
#define floatp(x) ((x) && (x)->n_type == FLOAT)
#define vectorp(x) ((x) && (x)->n_type == VECT)
/* cons access macros */
#define car(x) ((x)->n_car)
#define cdr(x) ((x)->n_cdr)
#define rplaca(x,y) ((x)->n_car = (y))
#define rplacd(x,y) ((x)->n_cdr = (y))
/* symbol access macros */
#define getvalue(x) ((x)->n_symvalue)
#define setvalue(x,v) ((x)->n_symvalue = (v))
#define getplist(x) ((x)->n_symplist->n_cdr)
#define setplist(x,v) ((x)->n_symplist->n_cdr = (v))
#define getpname(x) ((x)->n_symplist->n_car)
/* vector access macros */
#define getsize(x) ((x)->n_vsize)
#define getelement(x,i) ((x)->n_vdata[i])
#define setelement(x,i,v) ((x)->n_vdata[i] = (v))
/* object access macros */
#define getclass(x) ((x)->n_vdata[0])
#define getivar(x,i) ((x)->n_vdata[i+1])
#define setivar(x,i,v) ((x)->n_vdata[i+1] = (v))
/* subr/fsubr access macros */
#define getsubr(x) ((x)->n_subr)
/* fixnum/flonum access macros */
#define getfixnum(x) ((x)->n_int)
#define getflonum(x) ((x)->n_float)
/* string access macros */
#define getstring(x) ((x)->n_str)
#define setstring(x,v) ((x)->n_str = (v))
/* file access macros */
#define getfile(x) ((x)->n_fp)
#define setfile(x,v) ((x)->n_fp = (v))
#define getsavech(x) ((x)->n_savech)
#define setsavech(x,v) ((x)->n_savech = (v))
/* symbol node */
#define n_symplist n_info.n_xsym.xsy_plist
#define n_symvalue n_info.n_xsym.xsy_value
/* subr/fsubr node */
#define n_subr n_info.n_xsubr.xsu_subr
/* list node */
#define n_car n_info.n_xlist.xl_car
#define n_cdr n_info.n_xlist.xl_cdr
/* integer node */
#define n_int n_info.n_xint.xi_int
/* float node */
#define n_float n_info.n_xfloat.xf_float
/* string node */
#define n_str n_info.n_xstr.xst_str
#define n_strtype n_info.n_xstr.xst_type
/* file pointer node */
#define n_fp n_info.n_xfptr.xf_fp
#define n_savech n_info.n_xfptr.xf_savech
/* vector/object node */
#define n_vsize n_info.n_xvect.xv_size
#define n_vdata n_info.n_xvect.xv_data
/* node structure */
typedef struct node {
char n_type; /* type of node */
char n_flags; /* flag bits */
union { /* value */
struct xsym { /* symbol node */
struct node *xsy_plist; /* symbol plist - (name . plist) */
struct node *xsy_value; /* the current value */
} n_xsym;
struct xsubr { /* subr/fsubr node */
struct node *(*xsu_subr)(); /* pointer to an internal routine */
} n_xsubr;
struct xlist { /* list node (cons) */
struct node *xl_car; /* the car pointer */
struct node *xl_cdr; /* the cdr pointer */
} n_xlist;
struct xint { /* integer node */
FIXNUM xi_int; /* integer value */
} n_xint;
struct xfloat { /* float node */
FLONUM xf_float; /* float value */
} n_xfloat;
struct xstr { /* string node */
int xst_type; /* string type */
char *xst_str; /* string pointer */
} n_xstr;
struct xfptr { /* file pointer node */
FILE *xf_fp; /* the file pointer */
int xf_savech; /* lookahead character for input files */
} n_xfptr;
struct xvect { /* vector node */
int xv_size; /* vector size */
struct node **xv_data; /* vector data */
} n_xvect;
} n_info;
} NODE;
/* execution context flags */
#define CF_GO 1
#define CF_RETURN 2
#define CF_THROW 4
#define CF_ERROR 8
#define CF_CLEANUP 16
#define CF_CONTINUE 32
#define CF_TOPLEVEL 64
/* execution context */
typedef struct context {
int c_flags; /* context type flags */
struct node *c_expr; /* expression (type dependant) */
jmp_buf c_jmpbuf; /* longjmp context */
struct context *c_xlcontext; /* old value of xlcontext */
struct node ***c_xlstack; /* old value of xlstack */
struct node *c_xlenv; /* old value of xlenv */
int c_xltrace; /* old value of xltrace */
} CONTEXT;
/* function table entry structure */
struct fdef {
char *f_name; /* function name */
int f_type; /* function type SUBR/FSUBR */
struct node *(*f_fcn)(); /* function code */
};
/* memory segment structure definition */
struct segment {
int sg_size;
struct segment *sg_next;
struct node sg_nodes[1];
};
/* external procedure declarations */
extern struct node ***xlsave(); /* generate a stack frame */
extern struct node *xleval(); /* evaluate an expression */
extern struct node *xlapply(); /* apply a function to arguments */
extern struct node *xlevlist(); /* evaluate a list of arguments */
extern struct node *xlarg(); /* fetch an argument */
extern struct node *xlevarg(); /* fetch and evaluate an argument */
extern struct node *xlmatch(); /* fetch an typed argument */
extern struct node *xlevmatch(); /* fetch and evaluate a typed arg */
extern struct node *xlgetfile(); /* fetch a file/stream argument */
extern struct node *xlsend(); /* send a message to an object */
extern struct node *xlenter(); /* enter a symbol */
extern struct node *xlsenter(); /* enter a symbol with a static pname */
extern struct node *xlmakesym(); /* make an uninterned symbol */
extern struct node *xlframe(); /* establish a new environment frame */
extern struct node *xlgetvalue(); /* get value of a symbol (checked) */
extern struct node *xlxgetvalue(); /* get value of a symbol */
extern struct node *xlygetvalue(); /* get value of a symbol (no ivars) */
extern struct node *cons(); /* (cons x y) */
extern struct node *consa(); /* (cons x nil) */
extern struct node *consd(); /* (cons nil x) */
extern struct node *cvsymbol(); /* convert a string to a symbol */
extern struct node *cvcsymbol(); /* (same but constant string) */
extern struct node *cvstring(); /* convert a string */
extern struct node *cvcstring(); /* (same but constant string) */
extern struct node *cvfile(); /* convert a FILE * to a file */
extern struct node *cvsubr(); /* convert a function to a subr/fsubr */
extern struct node *cvfixnum(); /* convert a fixnum */
extern struct node *cvflonum(); /* convert a flonum */
extern struct node *newstring(); /* create a new string */
extern struct node *newvector(); /* create a new vector */
extern struct node *newobject(); /* create a new object */
extern struct node *xlgetprop(); /* get the value of a property */
extern char *xlsymname(); /* get the print name of a symbol */
extern void xlsetvalue();
extern void xlprint();
extern void xltest();
SHAR_EOF
fi # end of overwriting check
# End of shell archive
exit 0