Relay-Version: version B 2.10 5/3/83; site utzoo.UUCP
Posting-Version: version B 2.10.2 9/17/84; site cwruecmp.UUCP
Path: utzoo!watmath!clyde!burl!ulysses!ucbvax!decvax!cwruecmp!bammi
From: bammi@cwruecmp.UUCP (Jwahar R. Bammi)
Newsgroups: net.micro.atari
Subject: xlisp (PART 3 of 6)
Message-ID: <1381@cwruecmp.UUCP>
Date: Sat, 18-Jan-86 15:00:13 EST
Article-I.D.: cwruecmp.1381
Posted: Sat Jan 18 15:00:13 1986
Date-Received: Mon, 20-Jan-86 05:18:58 EST
Organization: CWRU Dept. Computer Eng., Cleveland, OH
Lines: 501

#!/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:
#	makefile
#	ctype.h
#	math.h
#	setjmp.h
#	xlisp.h
#	xlisp.bat
#	xlisp.inp
# This archive created: Sat Jan 18 14:32:21 1986
# By:	Jwahar R. Bammi ()
export PATH; PATH=/bin:$PATH
echo shar: extracting "'makefile'" '(618 characters)'
if test -f 'makefile'
then
	echo shar: over-writing existing file "'makefile'"
fi
sed 's/^X//' << \SHAR_EOF > 'makefile'
X# BIN is the directory where you want the executable to go
XBIN = /u/bammi/etc/bin
X
XSRC = xlbfun.c xlcont.c xldbug.c xldmem.c xleval.c xlfio.c xlftab1.c \
Xxlftab2.c xlglob.c xlinit.c xlio.c xlisp.c xljump.c xllist.c xlmath.c \
Xxlobj.c xlprin.c xlread.c xlstr.c xlsubr.c xlsym.c xlsys.c
X
XOBJ = xlbfun.o xlcont.o xldbug.o xldmem.o xleval.o xlfio.o xlftab1.o \
Xxlftab2.o xlglob.o xlinit.o xlio.o xlisp.o xljump.o xllist.o xlmath.o \
Xxlobj.o xlprin.o xlread.o xlstr.o xlsubr.o xlsym.o xlsys.o
X
XCFLAGS= -O
X
Xxlisp: $(OBJ)
X	cc -O -o xlisp $(OBJ) -lm -s
X
Xinstall: xlisp
X	cp xlisp $(BIN)
X	cp init.lsp $(BIN)
X
Xclean:
X	rm -f *.o
X
SHAR_EOF
if test 618 -ne "`wc -c 'makefile'`"
then
	echo shar: error transmitting "'makefile'" '(should have been 618 characters)'
fi
echo shar: extracting "'ctype.h'" '(260 characters)'
if test -f 'ctype.h'
then
	echo shar: over-writing existing file "'ctype.h'"
fi
sed 's/^X//' << \SHAR_EOF > 'ctype.h'
X
X#define isupper(ch)	((ch) >= 'A' && (ch) <= 'Z')
X#define islower(ch)	((ch) >= 'a' && (ch) <= 'z')
X#define toupper(ch)	((ch) - 'a' + 'A')
X#define tolower(ch)	((ch) - 'A' + 'a')
X#define isdigit(ch)	((ch) >= '0' && (ch) <= '9')
X#define isspace(ch)	((ch) <= ' ')
SHAR_EOF
if test 260 -ne "`wc -c 'ctype.h'`"
then
	echo shar: error transmitting "'ctype.h'" '(should have been 260 characters)'
fi
echo shar: extracting "'math.h'" '(45 characters)'
if test -f 'math.h'
then
	echo shar: over-writing existing file "'math.h'"
fi
sed 's/^X//' << \SHAR_EOF > 'math.h'
Xdouble sin(),cos(),tan(),exp(),pow(),sqrt();
SHAR_EOF
if test 45 -ne "`wc -c 'math.h'`"
then
	echo shar: error transmitting "'math.h'" '(should have been 45 characters)'
fi
echo shar: extracting "'setjmp.h'" '(26 characters)'
if test -f 'setjmp.h'
then
	echo shar: over-writing existing file "'setjmp.h'"
fi
sed 's/^X//' << \SHAR_EOF > 'setjmp.h'
Xtypedef long jmp_buf[16];
SHAR_EOF
if test 26 -ne "`wc -c 'setjmp.h'`"
then
	echo shar: error transmitting "'setjmp.h'" '(should have been 26 characters)'
fi
echo shar: extracting "'xlisp.h'" '(9596 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/* >>>>>>>>>>>>>>>>>>>>>>            BEGIN            <<<<<<<<<<<<<<<<<<<<<< */
X
X/* system specific definitions - Edit and uncomment one of the two */
X#define ATARI
X/* #define unix */
X
X/* Define INITPATH if you want the initialization file in a specific directory
X *   for example
X * #define INITPATH "/u/bammi/etc/lib/init.lsp" on the Vax
X * or
X * #define INITPATH "A:\\mydir\\init.lsp" on the ST and so on.
X */
X
X/* >>>>>>>>>>>>>>>>>>>>>>             END             <<<<<<<<<<<<<<<<<<<<<< */
X/* >>>>>>>>>>>>>>>>>>>>>> SYSTEM SPECIFIC DEFINITIONS <<<<<<<<<<<<<<<<<<<<<< */
X
X
X
X
X
X#include <stdio.h>
X#include <ctype.h>
X#ifndef MEGAMAX
X#include <setjmp.h>
X#endif
X
X/* NNODES	number of nodes to allocate in each request (200) */
X/* TDEPTH	trace stack depth (100) */
X/* FORWARD	type of a forward declaration () */
X/* LOCAL	type of a local function (static) */
X/* AFMT		printf format for addresses ("%x") */
X/* FIXNUM	data type for fixed point numbers (long) */
X/* ITYPE	return type for fixed point conversion routine (long) */
X/* ICNV		fixed point input conversion routine (atol) */
X/* IFMT		printf format for fixed point numbers ("%ld") */
X/* FLONUM	data type for floating point numbers (float) */
X/* FTYPE	return type for floating point conversion routine (double) */
X/* FCNV		floating point input conversion routine (atof) */
X/* FFMT		printf format for floating point numbers ("%f") */
X
X/* for the Computer Innovations compiler */
X#ifdef CI
X#define NNODES		1000
X#define TDEPTH		500
X#define ITYPE		double atoi()
X#define ICNV(n)		atoi(n)
X#define NIL		0
X#endif
X
X/* for the CPM68K compiler */
X#ifdef CPM68K
X#define NNODES		1000
X#define TDEPTH		500
X#define LOCAL
X#define AFMT		"%lx"
X#define FLONUM		double
X#undef NULL
X#define NULL		0L
X#endif
X
X/* for the Atari 520ST (DRI C Compiler) */
X#ifdef ATARI
X#define NNODES		1000
X#define TDEPTH		500
X#define LOCAL
X#define AFMT		"%lx"
X#define FLONUM		double
X#undef NULL
X#define NULL		0L
X#define getc(fp)	stgetc(fp)
X#define putc(ch,fp)	stputc(ch,fp)
X#endif
X
X/* for the DeSmet compiler */
X#ifdef DESMET
X#define NNODES		1000
X#define TDEPTH		500
X#define LOCAL
X#define getc(fp)	getcx(fp)
X#define putc(ch,fp)	putcx(ch,fp)
X#define EOF		-1
X#endif
X
X/* for the MegaMax compiler */
X#ifdef MEGAMAX
X#define NNODES		1000
X#define TDEPTH		500
X#define TSTKSIZE	(4 * TDEPTH)
X#define LOCAL
X#define AFMT		"%lx"
X#define getc(fp)	macgetc(fp)
X#define putc(ch,fp)	macputc(ch,fp)
X#endif
X
X/* for the VAX-11 C compiler */
X#ifdef vms
X#define NNODES		2000
X#define TDEPTH		1000
X#endif
X
X/* for the DECUS C compiler */
X#ifdef decus
X#define NNODES		200
X#define TDEPTH		100
X#define FORWARD		extern
X#endif
X
X/* for unix compilers */
X#ifdef unix
X#define NNODES		200
X#define TDEPTH		100
X#endif
X
X/* for the AZTEC C compiler (8086) */
X#ifdef AZTEC
X#define NNODES		1000
X#define TDEPTH		500
X#define FLONUM		double
X#define getc(fp)	agetc(fp)
X#define putc(ch,fp)	aputc(ch,fp)
X#define NIL		0
X#endif
X
X/* default important definitions */
X#ifndef NNODES
X#define NNODES		200
X#endif
X#ifndef TDEPTH
X#define TDEPTH		100
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 FIXNUM
X#define FIXNUM		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 FLONUM
X#define FLONUM		float
X#endif
X#ifndef FTYPE
X#define FTYPE		double atof()
X#endif
X#ifndef FCNV
X#define FCNV(n)		atof(n)
X#endif
X#ifndef FFMT
X#define FFMT		"%f"
X#endif
X#ifndef TSTKSIZE
X#define TSTKSIZE	(sizeof(NODE *) * TDEPTH)
X#endif
X
X/* useful definitions */
X#define TRUE	1
X#define FALSE	0
X#ifndef NIL
X#define NIL	(NODE *)0
X#endif
X
X/* absolute value macros */
X#define abs(n)	((n) < 0 ? -(n) : (n))
X#define fabs(n)	((n) < 0.0 ? -(n) : (n))
X
X/* program limits */
X#define STRMAX		100		/* maximum length of a string constant */
X	
X/* node types */
X#define FREE	0
X#define SUBR	1
X#define FSUBR	2
X#define LIST	3
X#define SYM	4
X#define INT	5
X#define STR	6
X#define OBJ	7
X#define FPTR	8
X#define FLOAT	9
X
X/* node flags */
X#define MARK	1
X#define LEFT	2
X
X/* string types */
X#define DYNAMIC	0
X#define STATIC	1
X
X/* new node access macros */
X#define ntype(x)	((x)->n_type)
X#define atom(x)		((x) == NIL || (x)->n_type != LIST)
X#define null(x)		((x) == NIL)
X#define listp(x)	((x) == NIL || (x)->n_type == LIST)
X#define consp(x)	((x) && (x)->n_type == LIST)
X#define subrp(x)	((x) && (x)->n_type == SUBR)
X#define fsubrp(x)	((x) && (x)->n_type == FSUBR)
X#define stringp(x)	((x) && (x)->n_type == STR)
X#define symbolp(x)	((x) && (x)->n_type == SYM)
X#define filep(x)	((x) && (x)->n_type == FPTR)
X#define objectp(x)	((x) && (x)->n_type == OBJ)
X#define fixp(x)		((x) && (x)->n_type == INT)
X#define floatp(x)	((x) && (x)->n_type == FLOAT)
X#define car(x)		((x)->n_car)
X#define cdr(x)		((x)->n_cdr)
X#define rplaca(x,y)	((x)->n_car = (y))
X#define rplacd(x,y)	((x)->n_cdr = (y))
X#define getvalue(x)	((x)->n_symvalue)
X#define setvalue(x,v)	((x)->n_symvalue = (v))
X
X/* symbol node */
X#define n_symplist	n_info.n_xsym.xsy_plist
X#define n_symvalue	n_info.n_xsym.xsy_value
X
X/* subr/fsubr node */
X#define n_subr		n_info.n_xsubr.xsu_subr
X
X/* list node */
X#define n_car		n_info.n_xlist.xl_car
X#define n_cdr		n_info.n_xlist.xl_cdr
X#define n_ptr		n_info.n_xlist.xl_car
X
X/* integer node */
X#define n_int		n_info.n_xint.xi_int
X
X/* float node */
X#define n_float		n_info.n_xfloat.xf_float
X
X/* string node */
X#define n_str		n_info.n_xstr.xst_str
X#define n_strtype	n_info.n_xstr.xst_type
X
X/* object node */
X#define n_obclass	n_info.n_xobj.xo_obclass
X#define n_obdata	n_info.n_xobj.xo_obdata
X
X/* file pointer node */
X#define n_fp		n_info.n_xfptr.xf_fp
X#define n_savech	n_info.n_xfptr.xf_savech
X
X/* node structure */
Xtypedef struct node {
X    char n_type;		/* type of node */
X    char n_flags;		/* flag bits */
X    union {			/* value */
X	struct xsym {		/* symbol node */
X	    struct node *xsy_plist;	/* symbol plist - (name . plist) */
X	    struct node *xsy_value;	/* the current value */
X	} n_xsym;
X	struct xsubr {		/* subr/fsubr node */
X	    struct node *(*xsu_subr)();	/* pointer to an internal routine */
X	} n_xsubr;
X	struct xlist {		/* list node (cons) */
X	    struct node *xl_car;	/* the car pointer */
X	    struct node *xl_cdr;	/* the cdr pointer */
X	} n_xlist;
X	struct xint {		/* integer node */
X	    FIXNUM xi_int;		/* integer value */
X	} n_xint;
X	struct xfloat {		/* float node */
X	    FLONUM xf_float;		/* float value */
X	} n_xfloat;
X	struct xstr {		/* string node */
X	    int xst_type;		/* string type */
X	    char *xst_str;		/* string pointer */
X	} n_xstr;
X	struct xobj {		/* object node */
X	    struct node *xo_obclass;	/* class of object */
X	    struct node *xo_obdata;	/* instance data */
X	} n_xobj;
X	struct xfptr {		/* file pointer node */
X	    FILE *xf_fp;		/* the file pointer */
X	    int xf_savech;		/* lookahead character for input files */
X	} n_xfptr;
X    } n_info;
X} NODE;
X
X/* execution context flags */
X#define CF_GO		1
X#define CF_RETURN	2
X#define CF_THROW	4
X#define CF_ERROR	8
X#define CF_CLEANUP	16
X#define CF_CONTINUE	32
X
X/* execution context */
Xtypedef struct context {
X    int c_flags;			/* context type flags */
X    struct node *c_expr;		/* expression (type dependant) */
X    jmp_buf c_jmpbuf;			/* longjmp context */
X    struct context *c_xlcontext;	/* old value of xlcontext */
X    struct node *c_xlstack;		/* old value of xlstack */
X    struct node *c_xlenv;		/* old value of xlenv */
X    int c_xltrace;			/* old value of xltrace */
X} CONTEXT;
X
X/* function table entry structure */
Xstruct fdef {
X    char *f_name;			/* function name */
X    int f_type;				/* function type SUBR/FSUBR */
X    struct node *(*f_fcn)();		/* function code */
X};
X
X/* memory segment structure definition */
Xstruct segment {
X    int sg_size;
X    struct segment *sg_next;
X    struct node sg_nodes[1];
X};
X
X/* external procedure declarations */
Xextern struct node *xleval();		/* evaluate an expression */
Xextern struct node *xlapply();		/* apply a function to arguments */
Xextern struct node *xlevlist();		/* evaluate a list of arguments */
Xextern struct node *xlarg();		/* fetch an argument */
Xextern struct node *xlevarg();		/* fetch and evaluate an argument */
Xextern struct node *xlmatch();		/* fetch an typed argument */
Xextern struct node *xlevmatch();	/* fetch and evaluate a typed arg */
Xextern struct node *xlgetfile();	/* fetch a file/stream argument */
Xextern struct node *xlsend();		/* send a message to an object */
Xextern struct node *xlenter();		/* enter a symbol */
Xextern struct node *xlsenter();		/* enter a symbol with a static pname */
Xextern struct node *xlmakesym();	/* make an uninterned symbol */
Xextern struct node *xlsave();		/* generate a stack frame */
Xextern struct node *xlframe();		/* establish a new environment frame */
Xextern struct node *xlgetvalue();	/* get value of a symbol (checked) */
Xextern struct node *xlxgetvalue();	/* get value of a symbol */
Xextern struct node *xlygetvalue();	/* get value of a symbol (no ivars) */
X
Xextern struct node *cvfixnum();		/* convert a fixnum */
Xextern struct node *cvflonum();		/* convert a flonum */
X
Xextern struct node *xlgetprop();	/* get the value of a property */
Xextern char *xlsymname();		/* get the print name of a symbol */
X
Xextern struct node *newnode();		/* allocate a new node */
Xextern char *stralloc();		/* allocate string space */
Xextern char *strsave();			/* make a safe copy of a string */
X
SHAR_EOF
if test 9596 -ne "`wc -c 'xlisp.h'`"
then
	echo shar: error transmitting "'xlisp.h'" '(should have been 9596 characters)'
fi
echo shar: extracting "'xlisp.bat'" '(99 characters)'
if test -f 'xlisp.bat'
then
	echo shar: over-writing existing file "'xlisp.bat'"
fi
sed 's/^X//' << \SHAR_EOF > 'xlisp.bat'
Xrm B:XLISP.PRG
Xrm B:XLISP.TTP
Xlink68 [tem[b:],com[b:xlisp.inp]]
Xrelmod b:xlisp
Xrm B:XLISP.68K
Xwait
SHAR_EOF
if test 99 -ne "`wc -c 'xlisp.bat'`"
then
	echo shar: error transmitting "'xlisp.bat'" '(should have been 99 characters)'
fi
echo shar: extracting "'xlisp.inp'" '(243 characters)'
if test -f 'xlisp.inp'
then
	echo shar: over-writing existing file "'xlisp.inp'"
fi
sed 's/^X//' << \SHAR_EOF > 'xlisp.inp'
Xb:xlisp.68k=
Xgems,
Xb:xlbfun,b:xlcont,b:xldbug,b:xldmem,b:xleval,b:xlfio,b:xlftab1,b:xlftab2,
Xb:xlglob,b:xlinit,b:xlio,b:xlisp,b:xljump,b:xllist,b:xlmath,b:xlobj,
Xb:xlprin,b:xlread,b:xlstr,b:xlsubr,b:xlsym,b:xlsys,
Xb:ststuff,osbind,gemlib,libf
SHAR_EOF
if test 243 -ne "`wc -c 'xlisp.inp'`"
then
	echo shar: error transmitting "'xlisp.inp'" '(should have been 243 characters)'
fi
#	End of shell archive
exit 0
-- 
					Jwahar R. Bammi
			       Usenet:  .....!decvax!cwruecmp!bammi
			        CSnet:  bammi@case
				 Arpa:  bammi%case@csnet-relay
			   CompuServe:  71515,155