Amiga-Request@cs.odu.edu (Amiga Sources/Binaries Moderator) (04/15/90)
Submitted-by: rusty@fe2o3.UUCP (Rusty Haddock)
Posting-number: Volume 90, Issue 139
Archive-name: applications/xscheme-0.20/part01
[ This is what's available via anonymous ftp from uunet.uu.net. ...tad ]
This is David Betz's XScheme 0.20 (yes, not even 1.0 yet) with my
Amiga/Manx modifications.
Enjoy!
-Rusty-
#!/bin/sh
# This is a shell archive. Remove anything before this line, then unpack
# it by saving it into a file and typing "sh file". To overwrite existing
# files, type "sh file -c". You can also feed this as standard input via
# unshar, or by typing "sh <file", e.g.. If this archive is complete, you
# will see the following message at the end:
# "End of archive 1 (of 7)."
# Contents: README.mwh2 Src Src/Makefile Src/amistuff.c Src/unixstuf.c
# Src/xsbcode.h Src/xscheme.c Src/xsinit.c Src/xsio.c Src/xsprint.c
# Src/xssym.c david.betz histogram.s macros.s mystuff.s.uu pi-calc.s
# qquote.s xscheme.ini
# Wrapped by tadguy@xanth on Sat Apr 14 17:07:19 1990
PATH=/bin:/usr/bin:/usr/ucb ; export PATH
if test -f 'README.mwh2' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'README.mwh2'\"
else
echo shar: Extracting \"'README.mwh2'\" \(2910 characters\)
sed "s/^X//" >'README.mwh2' <<'END_OF_FILE'
XHi there fellow Amiga Schemers!
X
X Here is the XScheme I downloaded from the MIPS Magazine's BBS. I got
Xamistuff.c from XLisp2.0's amigastuff.c file. About the only changes I
Xmade here involved changing MS-DOS's EOF character from ^Z (control-Z)
Xto the Amiga's ^\ (control-\) and changing the tab stops from every
Xeight columns to every four.
X
X I also modified what was needed to get this version (0.20) of XScheme
Xto compile under Manx 3.6. The makefile is intended for Manx's Make
Xprogram although it's simple enough that almost any make in the world
Xcould use it.
X
X Here are some problems that I've encountered so far:
X
X The first one looks like some kind of unsigned/signed extension
Xproblem with the 68000 byte-ordering. Remember, XScheme was originally
Xwritten for 80x86 which has a different byte-ordering.
X
X1] > (list->string '(#\A #\b #\C #\?))
X "AbC\37777777662" but it should produce "AbC?"
X
X > #\?
X #\?
X
X >
X
X2] (transcript-on "file.nam") doesn't work!!!
X
X3] Not a problem with XScheme itself but the some of the bogus
X '881 assembler code generated by the Manx C compiler.
X If you use the -A option (don't assemble) when compiling
X XSMATH.C then you'll get the assembler output from the C
X compiler. It is this that you can edit manually and assemble
X after changing the following lines according to the sample
X change given thereafter.
X
X Aztec 68000 Assembler 3.6a 12-18-87
X sin.l d0
X ^
X File xsmath.s; Line 1571 # Unknown opcode or directive.
X cos.l d0
X ^
X File xsmath.s; Line 1583 # Unknown opcode or directive.
X tan.l d0
X ^
X File xsmath.s; Line 1591 # Unknown opcode or directive.
X asin.l d0
X ^
X File xsmath.s; Line 1599 # Unknown opcode or directive.
X acos.l d0
X ^
X File xsmath.s; Line 1607 # Unknown opcode or directive.
X atan.l d0
X ^
X File xsmath.s; Line 1615 # Unknown opcode or directive.
X etox.l d0
X ^
X File xsmath.s; Line 1623 # Unknown opcode or directive.
X logn.l d0
X ^
X File xsmath.s; Line 1631 # Unknown opcode or directive.
X sqrt.l d0
X ^
X File xsmath.s; Line 1642 # Unknown opcode or directive.
X 9 errors
X
X
X Around the aforementioned errors you'll see code something
X like this:
X
X move.l -12(a5),d0
X sin.l d0
X fmove.l d0,fp0
X
X Change that to this:
X
X fsin.l -12(a5),fp0
X
X
X Heck, I'll tell you what... I'll include an '881 version of XScheme
Xalong with the assembly language source code PLUS I'll even give you the
Xpatched assembler output. Naturally, this is for you folks with an
X68020/'881 combination. How's that for service? :-)
X
X4] Remember to set the system stack to something appropriate. I was
X running into problems with munching lists of 360 floats and my stack
X was set at 20000. Enlarging it to 65000 ``seemed'' to fix my
X problems.
X
X
X
X
X Rusty Haddock
X US Snail: 8719 Contee Rd. Apt. #103
X Laurel, Maryland
X USA 20708-1907
X
X USENET: uunet!mimsy!fe2o3!rusty
X INTERNET: rusty%fe2o3@mimsy.umd.edu
END_OF_FILE
if test 2910 -ne `wc -c <'README.mwh2'`; then
echo shar: \"'README.mwh2'\" unpacked with wrong size!
fi
# end of 'README.mwh2'
fi
if test ! -d 'Src' ; then
echo shar: Creating directory \"'Src'\"
mkdir 'Src'
fi
if test -f 'Src/Makefile' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'Src/Makefile'\"
else
echo shar: Extracting \"'Src/Makefile'\" \(1463 characters\)
sed "s/^X//" >'Src/Makefile' <<'END_OF_FILE'
X# Makefile for XScheme Amiga/Manx version 0.20
X# This version of Makefile by Rusty Haddock (rusty%fe2o3@mimsy.umd.edu)
X# February 5, 1990
X
XOBJ1=xscheme.o xsdmem.o xsftab.o xsimage.o xsio.o xsobj.o \
Xxsprint.o xsread.o xssym.o xsfun1.o xsfun2.o amistuff.o
X# unixstuf.o msstuff.o
X
XOBJ2=xsinit.o xscom.o xsint.o
XOBJM=xsmath.o
X
X# ----------------------------------------------------
X
X# +fi for "new" 1.2.1 Amiga IEEE Double Precision math & transcendental libs
X# FPFORMAT=+fi
X
X# +f8 for inline 68881 FPU code -- *BUT* Manx 3.6 produces bad opcodes
X# for xsmath.c! If the assembler output is saved it's rather trivial
X# to edit and run through the assembler. See the file "README.MWH2".
XFPFORMAT=+f8
X
X# FPLIB=mtl32
XFPLIB=m8l32
X
X# ----------------------------------------------------
X
X# +P => Large data & code, 32-bit ints
X# +m => stack checking
X# -Z4096 => Use a literal table having 4K bytes
X# -E256 => Use an expression table having 256 entries
XCFLAGS=+P -Z4096 -E256 $(FPFORMAT) +m
X
X# -C => Use large CODE memory model with assembler
X# -D => Use large DATA memory model with assembler
XAFLAGS=-C -D
X
X# ----------------------------------------------------
X
Xxscheme: $(OBJ1) $(OBJ2) $(OBJM)
X ln -o xscheme $(OBJ1) $(OBJ2) $(OBJM) -l$(FPLIB) -lcl32
X
X$(OBJ1): xscheme.h
X$(OBJ2): xscheme.h xsbcode.h
X
X# Uncomment for IEEE library math functions
X# $(OBJM): xsmath.c xscheme.h
X
X# Uncomment for 68881 inline code
X$(OBJM): xscheme.h
X as $(AFLAGS) -o xsmath.o xsmath881.s
END_OF_FILE
if test 1463 -ne `wc -c <'Src/Makefile'`; then
echo shar: \"'Src/Makefile'\" unpacked with wrong size!
fi
# end of 'Src/Makefile'
fi
if test -f 'Src/amistuff.c' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'Src/amistuff.c'\"
else
echo shar: Extracting \"'Src/amistuff.c'\" \(5953 characters\)
sed "s/^X//" >'Src/amistuff.c' <<'END_OF_FILE'
X/* amistuff.c - amiga specific routines */
X/* A good portion of this file (mostly all of it) came from XLisp 2.0. */
X#include "xscheme.h"
X
X#define LBSIZE 200
X
X/* external variables */
Xextern LVAL s_unbound,true;
Xextern FILE *tfp;
Xextern int errno;
X
X/* local variables */
Xstatic long wfd;
Xstatic char lbuf[LBSIZE];
Xstatic int lpos[LBSIZE];
Xstatic int lindex;
Xstatic int lcount;
Xstatic int lposition;
Xstatic long rseed = 1L;
X
X/* external routines */
Xextern long Open();
Xextern long WaitForChar();
Xextern long Execute();
X
X/* osinit - initialize */
Xosinit(banner)
X char *banner;
X{
X wfd = Open("RAW:0/0/640/200/XScheme Version 0.20, by David Betz",1006L);
X if (wfd == 0L)
X exit(1);
X while (*banner)
X xputc(*banner++);
X xputc('\r'); xputc('\n');
X lposition = 0;
X lindex = 0;
X lcount = 0;
X}
X
X/* osfinish - clean up before returning to the operating system */
Xosfinish()
X{
X Close(wfd);
X}
X
X/* oserror - print an error message */
Xoserror(msg)
X char *msg;
X{
X char buf[100],*p;
X sprintf("error: %s\n",msg);
X for (p = buf; *p; )
X xputc(*p++);
X}
X
X/* osrand - return a random number between 0 and n-1 */
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
X/* osaopen - open an ascii file */
XFILE *osaopen(name,mode)
X char *name,*mode;
X{
X return (fopen(name,mode));
X}
X
X/* osbopen - open a binary file */
XFILE *osbopen(name,mode)
X char *name,*mode;
X{
X return (fopen(name,mode));
X}
X
X/* osclose - close a file */
Xint osclose(fp)
X FILE *fp;
X{
X return (fclose(fp));
X}
X
X/* ostell - get the current file position */
Xlong ostell(fp)
X FILE *fp;
X{
X return (ftell(fp));
X}
X
X/* osseek - set the current file position */
Xint osseek(fp,offset,whence)
X FILE *fp; long offset; int whence;
X{
X return (fseek(fp,offset,whence));
X}
X
X/* osagetc - get a character from an ascii file */
Xint osagetc(fp)
X FILE *fp;
X{
X return (agetc(fp));
X}
X
X/* osaputc - put a character to an ascii file */
Xint osaputc(ch,fp)
X int ch; FILE *fp;
X{
X return (aputc(ch,fp));
X}
X
X/* osbgetc - get a character from a binary file */
Xint osbgetc(fp)
X FILE *fp;
X{
X return (getc(fp));
X}
X
X/* osbputc - put a character to a binary file */
Xint osbputc(ch,fp)
X int ch; FILE *fp;
X{
X return (putc(ch,fp));
X}
X
X/* ostgetc - get a character from the terminal */
Xint ostgetc()
X{
X int ch;
X
X /* check for a buffered character */
X if (lcount--)
X return (lbuf[lindex++]);
X
X /* get an input line */
X for (lcount = 0; ; )
X switch (ch = xgetc()) {
X case '\r':
X lbuf[lcount++] = '\n';
X xputc('\r'); xputc('\n'); lposition = 0;
X if (tfp)
X for (lindex = 0; lindex < lcount; ++lindex)
X osaputc(lbuf[lindex],tfp);
X lindex = 0; lcount--;
X return (lbuf[lindex++]);
X case '\010':
X case '\177':
X if (lcount) {
X lcount--;
X while (lposition > lpos[lcount]) {
X xputc('\010'); xputc(' '); xputc('\010');
X lposition--;
X }
X }
X break;
X case '\034': /* Amiga's natural EOF */
X /* MS-DOS CTRL-Z EOF case '\032': */
X xflush();
X return (EOF);
X default:
X if (ch == '\t' || (ch >= 0x20 && ch < 0x7F)) {
X lbuf[lcount] = ch;
X lpos[lcount] = lposition;
X if (ch == '\t')
X do {
X xputc(' ');
X } while (++lposition & 3); /* This was 7 but I
X like tabs every 4.*/
X else {
X xputc(ch); lposition++;
X }
X lcount++;
X }
X else {
X xflush();
X switch (ch) {
X case '\003': xltoplevel(); /* control-c */
X case '\007': xlcleanup(); /* control-g */
X case '\020': xlcontinue(); /* control-p */
X/* case '\032': return (EOF); * control-z */
X case '\034': return (EOF); /* control-\ */
X default: return (ch);
X }
X }
X }
X}
X
X/* ostputc - put a character to the terminal */
Xostputc(ch)
X int ch;
X{
X /* check for control characters */
X oscheck();
X
X /* output the character */
X if (ch == '\n') {
X xputc('\r'); xputc('\n');
X lposition = 0;
X }
X else {
X xputc(ch);
X lposition++;
X }
X
X /* output the character to the transcript file */
X if (tfp)
X osaputc(ch,tfp);
X}
X
X/* osflush - flush the terminal input buffer */
Xosflush()
X{
X lindex = lcount = lposition = 0;
X}
X
X/* oscheck - check for control characters during execution */
Xoscheck()
X{
X int ch;
X if (ch = xcheck())
X switch (ch) {
X case '\002': /* control-b */
X xflush();
X xlbreak("BREAK",s_unbound);
X break;
X case '\003': /* control-c */
X xflush();
X xltoplevel();
X break;
X case '\024': /* control-t */
X xinfo();
X break;
X }
X}
X
X/* xinfo - show information on control-t */
Xstatic xinfo()
X{
X extern int nfree,gccalls;
X extern long total;
X char buf[80];
X sprintf(buf,"\n[ Free: %d, GC calls: %d, Total: %ld ]",
X nfree,gccalls,total);
X errputstr(buf);
X}
X
X/* xflush - flush the input line buffer and start a new line */
Xstatic xflush()
X{
X osflush();
X ostputc('\n');
X}
X
X/* xgetc - get a character from the terminal without echo */
Xstatic int xgetc()
X{
X unsigned char buf;
X Read(wfd,&buf,1L);
X return (buf);
X}
X
X/* xputc - put a character to the terminal */
Xstatic xputc(ch)
X int ch;
X{
X unsigned char buf;
X buf = ch;
X Write(wfd,&buf,1L);
X}
X
X/* xcheck - check for a character */
Xstatic int xcheck()
X{
X if (WaitForChar(wfd,0L) == 0L)
X return (0);
X return (xgetc());
X}
X
X/* xsystem - execute a system command */
XLVAL xsystem()
X{
X unsigned char *cmd;
X cmd = getstring(xlgastring());
X xllastarg();
X return (Execute(cmd,0L,wfd) == -1 ? cvfixnum((FIXTYPE)errno) : true);
X}
X
X/* xgetkey - get a key from the keyboard */
XLVAL xgetkey()
X{
X xllastarg();
X return (cvfixnum((FIXTYPE)xgetc()));
X}
X
X/* ossymbols - enter os specific symbols */
Xossymbols()
X{
X}
END_OF_FILE
if test 5953 -ne `wc -c <'Src/amistuff.c'`; then
echo shar: \"'Src/amistuff.c'\" unpacked with wrong size!
fi
# end of 'Src/amistuff.c'
fi
if test -f 'Src/unixstuf.c' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'Src/unixstuf.c'\"
else
echo shar: Extracting \"'Src/unixstuf.c'\" \(3218 characters\)
sed "s/^X//" >'Src/unixstuf.c' <<'END_OF_FILE'
X/* unixstuff.c - unix specific routines */
X
X#include "xscheme.h"
X
X#define LBSIZE 200
X
X/* external variables */
Xextern LVAL s_unbound,true;
Xextern FILE *tfp;
Xextern int errno;
X
X/* local variables */
Xstatic char lbuf[LBSIZE];
Xstatic int lindex;
Xstatic int lcount;
Xstatic long rseed = 1L;
X
X/* osinit - initialize */
Xosinit(banner)
X char *banner;
X{
X printf("%s\n",banner);
X lindex = 0;
X lcount = 0;
X}
X
X/* osfinish - clean up before returning to the operating system */
Xosfinish()
X{
X}
X
X/* oserror - print an error message */
Xoserror(msg)
X char *msg;
X{
X printf("error: %s\n",msg);
X}
X
X/* osrand - return a random number between 0 and n-1 */
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
X/* osaopen - open an ascii file */
XFILE *osaopen(name,mode)
X char *name,*mode;
X{
X return (fopen(name,mode));
X}
X
X/* osbopen - open a binary file */
XFILE *osbopen(name,mode)
X char *name,*mode;
X{
X return (fopen(name,mode));
X}
X
X/* osclose - close a file */
Xint osclose(fp)
X FILE *fp;
X{
X return (fclose(fp));
X}
X
X/* ostell - get the current file position */
Xlong ostell(fp)
X FILE *fp;
X{
X return (ftell(fp));
X}
X
X/* osseek - set the current file position */
Xint osseek(fp,offset,whence)
X FILE *fp; long offset; int whence;
X{
X return (fseek(fp,offset,whence));
X}
X
X/* osagetc - get a character from an ascii file */
Xint osagetc(fp)
X FILE *fp;
X{
X return (getc(fp));
X}
X
X/* osaputc - put a character to an ascii file */
Xint osaputc(ch,fp)
X int ch; FILE *fp;
X{
X return (putc(ch,fp));
X}
X
X/* osbgetc - get a character from a binary file */
Xint osbgetc(fp)
X FILE *fp;
X{
X return (getc(fp));
X}
X
X/* osbputc - put a character to a binary file */
Xint osbputc(ch,fp)
X int ch; FILE *fp;
X{
X return (putc(ch,fp));
X}
X
X/* ostgetc - get a character from the terminal */
Xint ostgetc()
X{
X /* check for a buffered character */
X if (lcount--)
X return (lbuf[lindex++]);
X
X /* get an input line */
X do {
X fgets(lbuf,LBSIZE,stdin);
X } while ((lcount = strlen(lbuf)) == 0);
X
X /* write it to the transcript file */
X if (tfp)
X for (lindex = 0; lindex < lcount; ++lindex)
X osaputc(lbuf[lindex],tfp);
X lindex = 0; lcount--;
X
X /* return the first character */
X return (lbuf[lindex++]);
X}
X
X/* ostputc - put a character to the terminal */
Xostputc(ch)
X int ch;
X{
X /* check for control characters */
X oscheck();
X
X /* output the character */
X putchar(ch);
X
X /* output the character to the transcript file */
X if (tfp)
X osaputc(ch,tfp);
X}
X
X/* osflush - flush the terminal input buffer */
Xosflush()
X{
X lindex = lcount = 0;
X}
X
X/* oscheck - check for control characters during execution */
Xoscheck()
X{
X}
X
X/* xsystem - execute a system command */
XLVAL xsystem()
X{
X char *cmd="sh";
X if (moreargs())
X cmd = (char *)getstring(xlgastring());
X xllastarg();
X return (system(cmd) == 0 ? true : cvfixnum((FIXTYPE)errno));
X}
END_OF_FILE
if test 3218 -ne `wc -c <'Src/unixstuf.c'`; then
echo shar: \"'Src/unixstuf.c'\" unpacked with wrong size!
fi
# end of 'Src/unixstuf.c'
fi
if test -f 'Src/xsbcode.h' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'Src/xsbcode.h'\"
else
echo shar: Extracting \"'Src/xsbcode.h'\" \(2118 characters\)
sed "s/^X//" >'Src/xsbcode.h' <<'END_OF_FILE'
X/* xsbcode.h - xscheme compiler byte code definitions */
X/* Copyright (c) 1988, by David Michael Betz
X All Rights Reserved
X Permission is granted for unrestricted non-commercial use */
X
X#define OP_BRT 0x01 /* branch on true */
X#define OP_BRF 0x02 /* branch on false */
X#define OP_BR 0x03 /* branch unconditionally */
X#define OP_LIT 0x04 /* load literal */
X#define OP_GREF 0x05 /* global symbol value */
X#define OP_GSET 0x06 /* set global symbol value */
X#define OP_EREF 0x09 /* environment variable value */
X#define OP_ESET 0x0A /* set environment variable value */
X#define OP_SAVE 0x0B /* save a continuation */
X#define OP_CALL 0x0C /* call a function */
X#define OP_RETURN 0x0D /* return from a function */
X#define OP_T 0x0E /* load 'val' with t */
X#define OP_NIL 0x0F /* load 'val' with nil */
X#define OP_PUSH 0x10 /* push the 'val' register */
X#define OP_CLOSE 0x11 /* create a closure */
X
X#define OP_FRAME 0x12 /* create a new enviroment frame */
X#define OP_MVARG 0x13 /* move required argument to frame slot */
X#define OP_MVOARG 0x14 /* move optional argument to frame slot */
X#define OP_MVRARG 0x15 /* build rest argument and move to frame slot */
X#define OP_ADROP 0x19 /* drop the rest of the arguments */
X#define OP_ALAST 0x1A /* make sure there are no more arguments */
X#define OP_DELAY 0x1B /* create a promise */
X
X#define OP_AREF 0x1C /* access a variable in an environment */
X#define OP_ASET 0x1D /* set a variable in an environment */
X
X#define OP_ATOM 0x1E /* atom predicate */
X#define OP_EQ 0x1F /* eq? predicate */
X#define OP_NULL 0x20 /* null? (or not) predicate */
X#define OP_CONS 0x21 /* cons */
X#define OP_CAR 0x22 /* car */
X#define OP_CDR 0x23 /* cdr */
X#define OP_SETCAR 0x24 /* set-car! */
X#define OP_SETCDR 0x25 /* set-cdr! */
X
X#define OP_ADD 0x40 /* add two numeric expressions */
X#define OP_SUB 0x41 /* subtract two numeric expressions */
X#define OP_MUL 0x42 /* multiply two numeric expressions */
X#define OP_QUO 0x43 /* divide two integer expressions */
X#define OP_LSS 0x44 /* less than */
X#define OP_EQL 0x45 /* equal to */
X#define OP_GTR 0x46 /* greater than */
END_OF_FILE
if test 2118 -ne `wc -c <'Src/xsbcode.h'`; then
echo shar: \"'Src/xsbcode.h'\" unpacked with wrong size!
fi
# end of 'Src/xsbcode.h'
fi
if test -f 'Src/xscheme.c' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'Src/xscheme.c'\"
else
echo shar: Extracting \"'Src/xscheme.c'\" \(3864 characters\)
sed "s/^X//" >'Src/xscheme.c' <<'END_OF_FILE'
X/* xscheme.c - xscheme main routine */
X/* Copyright (c) 1988, by David Michael Betz
X All Rights Reserved
X Permission is granted for unrestricted non-commercial use */
X
X#include "xscheme.h"
X
X/* the program banner */
X#define BANNER "XScheme - Version 0.20 - Amiga/Manx"
X
X/* global variables */
Xjmp_buf top_level;
Xint clargc; /* command line argument count */
Xchar **clargv; /* array of command line arguments */
X
X/* trace file pointer */
XFILE *tfp=NULL;
X
X/* external variables */
Xextern LVAL xlfun,xlenv,xlval;
Xextern LVAL s_stdin,s_stdout,s_stderr,s_unbound;
Xextern int trace;
X
X/* main - the main routine */
Xmain(argc,argv)
X int argc; char *argv[];
X{
X int src,dst;
X LVAL code;
X char *p;
X
X /* process the arguments */
X for (src = dst = 1, clargv = argv, clargc = 1; src < argc; ++src) {
X
X /* handle options */
X if (argv[src][0] == '-') {
X for (p = &argv[src][1]; *p != '\0'; )
X switch (*p++) {
X case 't': /* root directory */
X trace = TRUE;
X break;
X default:
X usage();
X }
X }
X
X /* handle a filename */
X else {
X argv[dst++] = argv[src];
X ++clargc;
X }
X }
X
X /* setup an initialization error handler */
X if (setjmp(top_level))
X exit(1);
X
X /* initialize */
X osinit(BANNER);
X
X /* restore the default workspace, otherwise create a new one */
X if (!xlirestore("xscheme.wks"))
X xlinitws(5000);
X
X /* do the initialization code first */
X code = xlenter("*INITIALIZE*");
X code = (boundp(code) ? getvalue(code) : NIL);
X
X /* trap errors */
X if (setjmp(top_level)) {
X code = xlenter("*TOPLEVEL*");
X code = (boundp(code) ? getvalue(code) : NIL);
X xlfun = xlenv = xlval = NIL;
X xlsp = xlstktop;
X }
X
X /* execute the main loop */
X if (code != NIL)
X xlexecute(code);
X wrapup();
X}
X
Xusage()
X{
X info("usage: xscheme [-t]\n");
X exit(1);
X}
X
Xxlload() {}
Xxlcontinue() {}
Xxlbreak() { xltoplevel(); }
Xxlcleanup() {}
X
X/* xltoplevel - return to the top level */
Xxltoplevel()
X{
X stdputstr("[ back to top level ]\n");
X longjmp(top_level,1);
X}
X
X/* xlfail - report an error */
Xxlfail(msg)
X char *msg;
X{
X xlerror(msg,s_unbound);
X}
X
X/* xlerror - report an error */
Xxlerror(msg,arg)
X char *msg; LVAL arg;
X{
X /* display the error message */
X errputstr("Error: ");
X errputstr(msg);
X errputstr("\n");
X
X /* print the argument on a separate line */
X if (arg != s_unbound) {
X errputstr(" ");
X errprint(arg);
X }
X
X /* print the function where the error occurred */
X errputstr("happened in: ");
X errprint(xlfun);
X
X /* call the handler */
X callerrorhandler();
X}
X
X/* callerrorhandler - call the error handler */
Xcallerrorhandler()
X{
X extern jmp_buf bc_dispatch;
X
X /* invoke the error handler */
X if (xlval = getvalue(xlenter("*ERROR-HANDLER*"))) {
X oscheck(); /* an opportunity to break out of a bad handler */
X check(2);
X push(xlenv);
X push(xlfun);
X xlargc = 2;
X xlapply();
X longjmp(bc_dispatch,1);
X }
X
X /* no handler, just reset back to the top level */
X longjmp(top_level,1);
X}
X
X/* xlabort - print an error message and abort */
Xxlabort(msg)
X char *msg;
X{
X /* display the error message */
X errputstr("Abort: ");
X errputstr(msg);
X errputstr("\n");
X
X /* print the function where the error occurred */
X errputstr("happened in: ");
X errprint(xlfun);
X
X /* reset back to the top level */
X oscheck(); /* an opportunity to break out */
X longjmp(top_level,1);
X}
X
X/* xlfatal - print a fatal error message and exit */
Xxlfatal(msg)
X char *msg;
X{
X oserror(msg);
X exit(1);
X}
X
X/* info - display debugging information */
Xinfo(fmt,a1,a2,a3,a4)
X char *fmt;
X{
X char buf[100],*p;
X sprintf(buf,fmt,a1,a2,a3,a4);
X for (p = buf; *p != '\0'; )
X ostputc(*p++);
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}
END_OF_FILE
if test 3864 -ne `wc -c <'Src/xscheme.c'`; then
echo shar: \"'Src/xscheme.c'\" unpacked with wrong size!
fi
# end of 'Src/xscheme.c'
fi
if test -f 'Src/xsinit.c' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'Src/xsinit.c'\"
else
echo shar: Extracting \"'Src/xsinit.c'\" \(7877 characters\)
sed "s/^X//" >'Src/xsinit.c' <<'END_OF_FILE'
X/* xsinit.c - xscheme initialization routines */
X/* Copyright (c) 1988, by David Michael Betz
X All Rights Reserved
X Permission is granted for unrestricted non-commercial use */
X
X#include "xscheme.h"
X#include "xsbcode.h"
X
X/* macro to store a byte into a bytecode vector */
X#define pb(x) (*bcode++ = (x))
X
X/* global variables */
XLVAL lk_optional,lk_rest;
XLVAL obarray,true,eof_object,default_object,s_unassigned;
XLVAL cs_map1,cs_foreach1,cs_withfile1,cs_load1,cs_force1;
XLVAL c_lpar,c_rpar,c_dot,c_quote,s_quote;
XLVAL s_eval,s_unbound,s_stdin,s_stdout,s_stderr;
XLVAL s_printcase,k_upcase,k_downcase;
XLVAL s_fixfmt,s_flofmt;
X
X/* external variables */
Xextern jmp_buf top_level;
Xextern FUNDEF funtab[];
Xextern int xsubrcnt;
Xextern int csubrcnt;
X
X/* xlinitws - create an initial workspace */
Xxlinitws(ssize)
X unsigned int ssize;
X{
X unsigned char *bcode;
X int type,i;
X LVAL code;
X FUNDEF *p;
X
X /* allocate memory for the workspace */
X xlminit(ssize);
X
X /* initialize the obarray */
X s_unbound = NIL; /* to make cvsymbol work */
X obarray = cvsymbol("*OBARRAY*");
X setvalue(obarray,newvector(HSIZE));
X
X /* add the symbol *OBARRAY* to the obarray */
X setelement(getvalue(obarray),
X hash(getstring(getpname(obarray)),HSIZE),
X cons(obarray,NIL));
X
X /* enter the eof object */
X eof_object = cons(xlenter("**EOF**"),NIL);
X
X /* enter the default object */
X default_object = cons(xlenter("**DEFAULT**"),NIL);
X
X /* initialize the error handlers */
X setvalue(xlenter("*ERROR-HANDLER*"),NIL);
X setvalue(xlenter("*UNBOUND-HANDLER*"),NIL);
X
X /* install the built-in functions */
X for (i = 0, p = funtab; p->fd_subr != NULL; ++i, ++p) {
X type = (i < xsubrcnt ? XSUBR : (i < csubrcnt ? CSUBR : SUBR));
X xlsubr(p->fd_name,type,p->fd_subr,i);
X }
X xloinit(); /* initialize xsobj.c */
X
X /* setup some synonyms */
X setvalue(xlenter("NOT"),getvalue(xlenter("NULL?")));
X setvalue(xlenter("PRIN1"),getvalue(xlenter("WRITE")));
X setvalue(xlenter("PRINC"),getvalue(xlenter("DISPLAY")));
X
X /* enter all of the symbols used by the runtime system */
X xlsymbols();
X
X /* set the initial values of the symbols #T, T and NIL */
X setvalue(true,true);
X setvalue(xlenter("T"),true);
X setvalue(xlenter("NIL"),NIL);
X
X /* default to lowercase output of symbols */
X setvalue(s_printcase,k_downcase);
X
X /* setup the print formats for numbers */
X s_fixfmt = xlenter("*FIXNUM-FORMAT*");
X setvalue(s_fixfmt,cvstring(IFMT));
X s_flofmt = xlenter("*FLONUM-FORMAT*");
X setvalue(s_flofmt,cvstring(FFMT));
X
X /* build the 'eval' function */
X code = newcode(4); cpush(code);
X setelement(code,0,newstring(0x12));
X setelement(code,1,xlenter("EVAL"));
X setelement(code,2,cons(xlenter("X"),NIL));
X setelement(code,3,xlenter("COMPILE"));
X drop(1);
X
X /* store the byte codes */
X bcode = (unsigned char *)getstring(getbcode(code));
X
Xpb(OP_FRAME);pb(0x02); /* 0000 12 02 FRAME 02 */
Xpb(OP_MVARG);pb(0x01); /* 0002 13 01 MVARG 01 */
Xpb(OP_ALAST); /* 0004 1a ALAST */
Xpb(OP_SAVE);pb(0x00);pb(0x10); /* 0005 0b 00 10 SAVE 0010 */
Xpb(OP_EREF);pb(0x00);pb(0x01); /* 0008 09 00 01 EREF 00 01 ; x */
Xpb(OP_PUSH); /* 000b 10 PUSH */
Xpb(OP_GREF);pb(0x03); /* 000c 05 03 GREF 03 ; compile */
Xpb(OP_CALL);pb(0x01); /* 000e 0c 01 CALL 01 */
Xpb(OP_CALL);pb(0x00); /* 0010 0c 00 CALL 00 */
X
X setvalue(getelement(code,1),cvclosure(code,NIL));
X
X /* setup the initialization code */
X code = newcode(6); cpush(code);
X setelement(code,0,newstring(0x11));
X setelement(code,1,xlenter("*INITIALIZE*"));
X setelement(code,3,cvstring("xscheme.ini"));
X setelement(code,4,xlenter("LOAD"));
X setelement(code,5,xlenter("*TOPLEVEL*"));
X drop(1);
X
X /* store the byte codes */
X bcode = (unsigned char *)getstring(getbcode(code));
X
Xpb(OP_FRAME);pb(0x01); /* 0000 12 01 FRAME 01 */
Xpb(OP_ALAST); /* 0002 1a ALAST */
Xpb(OP_SAVE); pb(0x00); pb(0x0d);/* 0003 0b 00 0d SAVE 000d */
Xpb(OP_LIT); pb(0x03); /* 0006 04 03 LIT 03 ; "xscheme.ini" */
Xpb(OP_PUSH); /* 0008 10 PUSH */
Xpb(OP_GREF); pb(0x04); /* 0009 05 04 GREF 04 ; load */
Xpb(OP_CALL); pb(0x01); /* 000b 0c 01 CALL 01 */
Xpb(OP_GREF); pb(0x05); /* 000d 05 05 GREF 05 ; *toplevel* */
Xpb(OP_CALL); pb(0x00); /* 000f 0c 00 CALL 00 */
X
X setvalue(getelement(code,1),cvclosure(code,NIL));
X
X /* setup the main loop code */
X code = newcode(9); cpush(code);
X setelement(code,0,newstring(0x28));
X setelement(code,1,xlenter("*TOPLEVEL*"));
X setelement(code,3,cvstring("\n> "));
X setelement(code,4,xlenter("DISPLAY"));
X setelement(code,5,xlenter("READ"));
X setelement(code,6,xlenter("EVAL"));
X setelement(code,7,xlenter("WRITE"));
X setelement(code,8,xlenter("*TOPLEVEL*"));
X drop(1);
X
X /* store the byte codes */
X bcode = (unsigned char *)getstring(getbcode(code));
X
Xpb(OP_FRAME);pb(0x01); /* 0000 12 01 FRAME 01 */
Xpb(OP_ALAST); /* 0002 1a ALAST */
Xpb(OP_SAVE); pb(0x00); pb(0x0d);/* 0003 0b 00 0d SAVE 000d */
Xpb(OP_LIT); pb(0x03); /* 0006 04 03 LIT 03 ; "\n> " */
Xpb(OP_PUSH); /* 0008 10 PUSH */
Xpb(OP_GREF); pb(0x04); /* 0009 05 04 GREF 04 ; display */
Xpb(OP_CALL); pb(0x01); /* 000b 0c 01 CALL 01 */
Xpb(OP_SAVE); pb(0x00); pb(0x24);/* 000d 0b 00 24 SAVE 0024 */
Xpb(OP_SAVE); pb(0x00); pb(0x1f);/* 0010 0b 00 1f SAVE 001f */
Xpb(OP_SAVE); pb(0x00); pb(0x1a);/* 0013 0b 00 1a SAVE 001a */
Xpb(OP_GREF); pb(0x05); /* 0016 05 05 GREF 05 ; read */
Xpb(OP_CALL); pb(0x00); /* 0018 0c 00 CALL 00 */
Xpb(OP_PUSH); /* 001a 10 PUSH */
Xpb(OP_GREF); pb(0x06); /* 001b 05 06 GREF 06 ; eval */
Xpb(OP_CALL); pb(0x01); /* 001d 0c 01 CALL 01 */
Xpb(OP_PUSH); /* 001f 10 PUSH */
Xpb(OP_GREF); pb(0x07); /* 0020 05 07 GREF 07 ; write */
Xpb(OP_CALL); pb(0x01); /* 0022 0c 01 CALL 01 */
Xpb(OP_GREF); pb(0x08); /* 0024 05 08 GREF 08 ; *toplevel* */
Xpb(OP_CALL); pb(0x00); /* 0026 0c 00 CALL 00 */
X
X setvalue(getelement(code,1),cvclosure(code,NIL));
X}
X
X/* xlsymbols - lookup/enter all symbols used by the runtime system */
Xxlsymbols()
X{
X LVAL sym;
X
X /* top-level procedure symbol */
X s_eval = xlenter("EVAL");
X
X /* enter the symbols used by the system */
X true = xlenter("#T");
X s_unbound = xlenter("*UNBOUND*");
X s_unassigned = xlenter("#!UNASSIGNED");
X
X /* enter the i/o symbols */
X s_stdin = xlenter("*STANDARD-INPUT*");
X s_stdout = xlenter("*STANDARD-OUTPUT*");
X s_stderr = xlenter("*ERROR-OUTPUT*");
X
X /* enter the symbols used by the printer */
X s_fixfmt = xlenter("*FIXNUM-FORMAT*");
X s_flofmt = xlenter("*FLONUM-FORMAT*");
X
X /* enter the lambda list keywords */
X lk_optional = xlenter("#!OPTIONAL");
X lk_rest = xlenter("#!REST");
X
X /* enter symbols needed by the reader */
X c_lpar = xlenter("(");
X c_rpar = xlenter(")");
X c_dot = xlenter(".");
X c_quote = xlenter("'");
X s_quote = xlenter("QUOTE");
X
X /* 'else' is a useful synonym for #t in cond clauses */
X sym = xlenter("ELSE");
X setvalue(sym,true);
X
X /* setup stdin/stdout/stderr */
X setvalue(s_stdin,cvport(stdin,PF_INPUT));
X setvalue(s_stdout,cvport(stdout,PF_OUTPUT));
X setvalue(s_stderr,cvport(stderr,PF_OUTPUT));
X
X /* enter *print-case* and its keywords */
X k_upcase = xlenter("UPCASE");
X k_downcase = xlenter("DOWNCASE");
X s_printcase = xlenter("*PRINT-CASE*");
X
X /* get the built-in continuation subrs */
X cs_map1 = getvalue(xlenter("%MAP1"));
X cs_foreach1 = getvalue(xlenter("%FOR-EACH1"));
X cs_withfile1 = getvalue(xlenter("%WITH-FILE1"));
X cs_load1 = getvalue(xlenter("%LOAD1"));
X cs_force1 = getvalue(xlenter("%FORCE1"));
X
X /* initialize xsobj.c */
X obsymbols();
X}
END_OF_FILE
if test 7877 -ne `wc -c <'Src/xsinit.c'`; then
echo shar: \"'Src/xsinit.c'\" unpacked with wrong size!
fi
# end of 'Src/xsinit.c'
fi
if test -f 'Src/xsio.c' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'Src/xsio.c'\"
else
echo shar: Extracting \"'Src/xsio.c'\" \(2030 characters\)
sed "s/^X//" >'Src/xsio.c' <<'END_OF_FILE'
X/* xsio - xscheme i/o routines */
X/* Copyright (c) 1988, by David Michael Betz
X All Rights Reserved
X Permission is granted for unrestricted non-commercial use */
X
X#include "xscheme.h"
X
X/* global variables */
XFIXTYPE xlfsize;
X
X/* external variables */
Xextern LVAL s_stdin,s_stdout,s_stderr,s_unbound;
X
X/* xlgetc - get a character from a file or stream */
Xint xlgetc(fptr)
X LVAL fptr;
X{
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 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 if ((getpflags(fptr) & PF_BINARY) != 0)
X ch = osbgetc(fp);
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 /* check for ungetc from nil */
X if (fptr == NIL)
X ;
X
X /* otherwise, it must be a file */
X else
X setsavech(fptr,ch);
X}
X
X/* xlputc - put a character to a file or stream */
Xxlputc(fptr,ch)
X LVAL fptr; int ch;
X{
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 terminal output or file output */
X else {
X fp = getfile(fptr);
X if (fp == stdout || fp == stderr)
X ostputc(ch);
X else if ((getpflags(fptr) & PF_BINARY) != 0)
X osbputc(ch,fp);
X else
X osaputc(ch,fp);
X }
X}
X
X/* xlflush - flush the input buffer */
Xint xlflush()
X{
X osflush();
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 xlprin1(expr,getvalue(s_stderr));
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}
END_OF_FILE
if test 2030 -ne `wc -c <'Src/xsio.c'`; then
echo shar: \"'Src/xsio.c'\" unpacked with wrong size!
fi
# end of 'Src/xsio.c'
fi
if test -f 'Src/xsprint.c' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'Src/xsprint.c'\"
else
echo shar: Extracting \"'Src/xsprint.c'\" \(6278 characters\)
sed "s/^X//" >'Src/xsprint.c' <<'END_OF_FILE'
X/* xsprint.c - xscheme print routine */
X/* Copyright (c) 1988, by David Michael Betz
X All Rights Reserved
X Permission is granted for unrestricted non-commercial use */
X
X#include "xscheme.h"
X
X/* global variables */
Xint prbreadth = -1;
Xint prdepth = -1;
X
X/* local variables */
Xstatic char buf[200];
X
X/* external variables */
Xextern LVAL true,s_printcase,k_downcase;
Xextern LVAL s_fixfmt,s_flofmt,s_unbound;
X
X/* xlprin1 - print an expression with quoting */
Xxlprin1(expr,file)
X LVAL expr,file;
X{
X print(file,expr,TRUE,0);
X}
X
X/* xlprinc - print an expression without quoting */
Xxlprinc(expr,file)
X LVAL expr,file;
X{
X print(file,expr,FALSE,0);
X}
X
X/* xlterpri - terminate the current print line */
Xxlterpri(fptr)
X LVAL fptr;
X{
X xlputc(fptr,'\n');
X}
X
X/* xlputstr - output a string */
Xxlputstr(fptr,str)
X LVAL fptr; char *str;
X{
X while (*str)
X xlputc(fptr,*str++);
X}
X
X/* print - internal print routine */
XLOCAL print(fptr,vptr,escflag,depth)
X LVAL fptr,vptr; int escflag,depth;
X{
X int breadth,size,i;
X LVAL nptr,next;
X
X /* print nil */
X if (vptr == NIL) {
X xlputstr(fptr,"()");
X return;
X }
X
X /* check value type */
X switch (ntype(vptr)) {
X case SUBR:
X case XSUBR:
X putsubr(fptr,"Subr",vptr);
X break;
X case CSUBR:
X putsubr(fptr,"CSubr",vptr);
X break;
X case CONS:
X if (prdepth >= 0 && depth >= prdepth) {
X xlputstr(fptr,"(...)");
X break;
X }
X xlputc(fptr,'(');
X breadth = 0;
X for (nptr = vptr; nptr != NIL; nptr = next) {
X if (prbreadth >= 0 && breadth++ >= prbreadth) {
X xlputstr(fptr,"...");
X break;
X }
X print(fptr,car(nptr),escflag,depth+1);
X if (next = cdr(nptr))
X if (consp(next))
X xlputc(fptr,' ');
X else {
X xlputstr(fptr," . ");
X print(fptr,next,escflag,depth+1);
X break;
X }
X }
X xlputc(fptr,')');
X break;
X case VECTOR:
X xlputstr(fptr,"#(");
X for (i = 0, size = getsize(vptr); i < size; ++i) {
X if (i != 0) xlputc(fptr,' ');
X print(fptr,getelement(vptr,i),escflag,depth+1);
X }
X xlputc(fptr,')');
X break;
X case OBJECT:
X putatm(fptr,"Object",vptr);
X break;
X case SYMBOL:
X putsym(fptr,getstring(getpname(vptr)),escflag);
X break;
X case PROMISE:
X if (getpproc(vptr) != NIL)
X putatm(fptr,"Promise",vptr);
X else
X putatm(fptr,"Forced-promise",vptr);
X break;
X case CLOSURE:
X putclosure(fptr,"Procedure",vptr);
X break;
X case METHOD:
X putclosure(fptr,"Method",vptr);
X break;
X case FIXNUM:
X putnumber(fptr,getfixnum(vptr));
X break;
X case FLONUM:
X putflonum(fptr,getflonum(vptr));
X break;
X case CHAR:
X if (escflag)
X putcharacter(fptr,getchcode(vptr));
X else
X xlputc(fptr,getchcode(vptr));
X break;
X case STRING:
X if (escflag)
X putstring(fptr,getstring(vptr));
X else
X xlputstr(fptr,getstring(vptr));
X break;
X case PORT:
X putatm(fptr,"Port",vptr);
X break;
X case CODE:
X putcode(fptr,"Code",vptr);
X break;
X case CONTINUATION:
X putatm(fptr,"Escape-procedure",vptr);
X break;
X case ENV:
X putatm(fptr,"Environment",vptr);
X break;
X case FREE:
X putatm(fptr,"Free",vptr);
X break;
X default:
X putatm(fptr,"Foo",vptr);
X break;
X }
X}
X
X/* putatm - output an atom */
XLOCAL putatm(fptr,tag,val)
X LVAL fptr; char *tag; LVAL val;
X{
X sprintf(buf,"#<%s #",tag); xlputstr(fptr,buf);
X sprintf(buf,AFMT,val); xlputstr(fptr,buf);
X xlputc(fptr,'>');
X}
X
X/* putstring - output a string */
XLOCAL putstring(fptr,str)
X LVAL fptr; char *str;
X{
X int ch;
X
X /* output the initial quote */
X xlputc(fptr,'"');
X
X /* output each character in the string */
X while (ch = *str++)
X
X /* check for a control character */
X if (ch < 040 || ch == '\\' || ch == '"') {
X xlputc(fptr,'\\');
X switch (ch) {
X case '\033':
X xlputc(fptr,'e');
X break;
X case '\n':
X xlputc(fptr,'n');
X break;
X case '\r':
X xlputc(fptr,'r');
X break;
X case '\t':
X xlputc(fptr,'t');
X break;
X case '\\':
X case '"':
X xlputc(fptr,ch);
X break;
X default:
X putoct(fptr,ch);
X break;
X }
X }
X
X /* output a normal character */
X else
X xlputc(fptr,ch);
X
X /* output the terminating quote */
X xlputc(fptr,'"');
X}
X
X/* putsym - output a symbol */
XLOCAL putsym(fptr,str,escflag)
X LVAL fptr; char *str; int escflag;
X{
X int ch;
X
X /* check for printing without escapes */
X if (!escflag) {
X xlputstr(fptr,str);
X return;
X }
X
X /* output each character */
X if (getvalue(s_printcase) == k_downcase) {
X while ((ch = *str++) != '\0')
X xlputc(fptr,isupper(ch) ? tolower(ch) : ch);
X }
X else {
X while ((ch = *str++) != '\0')
X xlputc(fptr,islower(ch) ? toupper(ch) : ch);
X }
X}
X
X/* putsubr - output a subr/fsubr */
XLOCAL putsubr(fptr,tag,val)
X LVAL fptr; char *tag; LVAL val;
X{
X extern FUNDEF funtab[];
X sprintf(buf,"#<%s %s>",tag,funtab[getoffset(val)].fd_name);
X xlputstr(fptr,buf);
X}
X
X/* putclosure - output a closure */
XLOCAL putclosure(fptr,tag,val)
X LVAL fptr; char *tag; LVAL val;
X{
X putcode(fptr,tag,getcode(val));
X}
X
X/* putcode - output a code object */
XLOCAL putcode(fptr,tag,val)
X LVAL fptr; char *tag; LVAL val;
X{
X LVAL name;
X if (name = getelement(val,1)) {
X sprintf(buf,"#<%s %s>",tag,getstring(getpname(name)));
X xlputstr(fptr,buf);
X }
X else
X putatm(fptr,tag,val);
X}
X
X/* putnumber - output a number */
XLOCAL putnumber(fptr,n)
X LVAL fptr; FIXTYPE n;
X{
X LVAL fmt = getvalue(s_fixfmt);
X sprintf(buf,(stringp(fmt) ? (char *)getstring(fmt) : IFMT),n);
X xlputstr(fptr,buf);
X}
X
X/* putoct - output an octal byte value */
XLOCAL putoct(fptr,n)
X LVAL fptr; int n;
X{
X sprintf(buf,"%03o",n);
X xlputstr(fptr,buf);
X}
X
X/* putflonum - output a flonum */
XLOCAL putflonum(fptr,n)
X LVAL fptr; FLOTYPE n;
X{
X LVAL fmt = getvalue(s_flofmt);
X sprintf(buf,(stringp(fmt) ? (char *)getstring(fmt) : FFMT),n);
X xlputstr(fptr,buf);
X}
X
X/* putcharacter - output a character value */
XLOCAL putcharacter(fptr,ch)
X LVAL fptr; int ch;
X{
X switch (ch) {
X case '\n':
X xlputstr(fptr,"#\\Newline");
X break;
X case ' ':
X xlputstr(fptr,"#\\Space");
X break;
X default:
X sprintf(buf,"#\\%c",ch);
X xlputstr(fptr,buf);
X break;
X }
X}
END_OF_FILE
if test 6278 -ne `wc -c <'Src/xsprint.c'`; then
echo shar: \"'Src/xsprint.c'\" unpacked with wrong size!
fi
# end of 'Src/xsprint.c'
fi
if test -f 'Src/xssym.c' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'Src/xssym.c'\"
else
echo shar: Extracting \"'Src/xssym.c'\" \(1934 characters\)
sed "s/^X//" >'Src/xssym.c' <<'END_OF_FILE'
X/* xssym.c - symbol handling routines */
X/* Copyright (c) 1988, by David Michael Betz
X All Rights Reserved
X Permission is granted for unrestricted non-commercial use */
X
X#include "xscheme.h"
X
X/* external variables */
Xextern LVAL obarray;
X
X/* forward declarations */
XLVAL findprop();
X
X/* xlsubr - define a builtin function */
Xxlsubr(sname,type,fcn,offset)
X char *sname; int type; LVAL (*fcn)(); int offset;
X{
X LVAL sym;
X sym = xlenter(sname);
X setvalue(sym,cvsubr(type,fcn,offset));
X}
X
X/* xlenter - enter a symbol into the obarray */
XLVAL xlenter(name)
X char *name;
X{
X LVAL array,sym;
X int i;
X
X /* get the current obarray and the hash index for this symbol */
X array = getvalue(obarray);
X i = hash(name,HSIZE);
X
X /* check if symbol is already in table */
X for (sym = getelement(array,i); sym; sym = cdr(sym))
X if (strcmp(name,getstring(getpname(car(sym)))) == 0)
X return (car(sym));
X
X /* make a new symbol node and link it into the list */
X sym = cons(cvsymbol(name),getelement(array,i));
X setelement(array,i,sym);
X sym = car(sym);
X
X /* return the new symbol */
X return (sym);
X}
X
X/* xlgetprop - get the value of a property */
XLVAL xlgetprop(sym,prp)
X LVAL sym,prp;
X{
X LVAL p;
X return ((p = findprop(sym,prp)) ? car(p) : NIL);
X}
X
X/* xlputprop - put a property value onto the property list */
Xxlputprop(sym,val,prp)
X LVAL sym,val,prp;
X{
X LVAL pair;
X if (pair = findprop(sym,prp))
X rplaca(pair,val);
X else
X setplist(sym,cons(prp,cons(val,getplist(sym))));
X}
X
X/* findprop - find a property pair */
XLOCAL LVAL findprop(sym,prp)
X LVAL sym,prp;
X{
X LVAL p;
X for (p = getplist(sym); consp(p) && consp(cdr(p)); p = cdr(cdr(p)))
X if (car(p) == prp)
X return (cdr(p));
X return (NIL);
X}
X
X/* hash - hash a symbol name string */
Xint hash(str,len)
X char *str;
X{
X int i;
X for (i = 0; *str; )
X i = (i << 2) ^ *str++;
X i %= len;
X return (i < 0 ? -i : i);
X}
END_OF_FILE
if test 1934 -ne `wc -c <'Src/xssym.c'`; then
echo shar: \"'Src/xssym.c'\" unpacked with wrong size!
fi
# end of 'Src/xssym.c'
fi
if test -f 'david.betz' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'david.betz'\"
else
echo shar: Extracting \"'david.betz'\" \(1083 characters\)
sed "s/^X//" >'david.betz' <<'END_OF_FILE'
XFrom mimsy!haven!aplcen!uunet!mitel!sce!ulysses!garym Fri Nov 17 02:00:09 EST 1989
XArticle 59 of comp.lang.lisp.x:
XPath: fe2o3!mimsy!haven!aplcen!uunet!mitel!sce!ulysses!garym
X>From: garym@ulysses.UUCP (Gary Murphy)
XNewsgroups: comp.lang.lisp.x
XSubject: Re: Author! Author!
XSummary: Lists the phone number for MIPS (XLisp) BBS
XKeywords: XLisp Betz MIPS
XMessage-ID: <7472@ulysses.UUCP>
XDate: 13 Nov 89 19:36:35 GMT
XReferences: <1989Nov9.180124.24190@rpi.edu> <6327@tekgvs.LABS.TEK.COM>
XReply-To: garym@cognos.UUCP (Gary Murphy)
XOrganization: Cognos Inc., Ottawa, Canada
XLines: 15
X
XI know this has been posted before, because this is where I got it.
X
XDavid Betz _may_ be reached at the MIPS Magazine BBS
X(603) 882-1599, 2400BAUD, 8-N-1
X
XThis BBS also carries the latest versions of XLisp and XScheme.
X
X
X
X
X--
XGary Murphy decvax!utzoo!dciem!nrcaer!cognos!garym
X (garym%cognos.uucp@uunet.uu.net)
X(613) 738-1338 x5537 Cognos Inc. P.O. Box 9707 Ottawa K1G 3N3
X"There are many things which do not concern the process" - Joan of Arc
X
X
END_OF_FILE
if test 1083 -ne `wc -c <'david.betz'`; then
echo shar: \"'david.betz'\" unpacked with wrong size!
fi
# end of 'david.betz'
fi
if test -f 'histogram.s' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'histogram.s'\"
else
echo shar: Extracting \"'histogram.s'\" \(748 characters\)
sed "s/^X//" >'histogram.s' <<'END_OF_FILE'
X(define (histogram data-list)
X (let* ((high (apply max data-list))
X (low (apply min data-list))
X (how-many (- high low -1))
X (hist (make-vector how-many 0))
X (index 0)
X (answer nil)
X )
X (do ((i data-list (cdr i)))
X ((null? i))
X (set! index (- (car i) low))
X (vector-set! hist index (1+ (vector-ref hist index)))
X )
X (set! answer (vector->list hist))
X (list low high answer)
X )
X)
X
X(define (hist-graph hist)
X (let ((start (car hist))
X (end (cadr hist))
X (hmax (apply max (caddr hist)))
X (hmin (apply min (caddr hist))))
X (begin
X (newline)
X (do ((i start (1+ i))
X (tbl (caddr hist) (cdr tbl)))
X ((> i end) "Done")
X (writeln i #\ (make-string (round (* (/ (car tbl) hmax) 40)) #\*))
X )
X )))
END_OF_FILE
if test 748 -ne `wc -c <'histogram.s'`; then
echo shar: \"'histogram.s'\" unpacked with wrong size!
fi
# end of 'histogram.s'
fi
if test -f 'macros.s' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'macros.s'\"
else
echo shar: Extracting \"'macros.s'\" \(2613 characters\)
sed "s/^X//" >'macros.s' <<'END_OF_FILE'
X(define %compile compile)
X
X(define (%expand-macros expr)
X (if (pair? expr)
X (if (symbol? (car expr))
X (let ((expander (get (car expr) '%syntax)))
X (if expander
X (expander expr)
X (let ((expander (get (car expr) '%macro)))
X (if expander
X (%expand-macros (expander expr))
X (cons (car expr) (%expand-list (cdr expr)))))))
X (%expand-list expr))
X expr))
X
X(define (%expand-list lyst)
X (if (pair? lyst)
X (cons (%expand-macros (car lyst)) (%expand-list (cdr lyst)))
X lyst))
X
X(define (compile expr #!optional env)
X (if (default-object? env)
X (%compile (%expand-macros expr))
X (%compile (%expand-macros expr) env)))
X
X(put 'macro '%macro
X (lambda (form)
X (list 'put
X (list 'quote (cadr form))
X (list 'quote '%macro)
X (caddr form))))
X
X(macro syntax
X (lambda (form)
X #f))
X
X(macro compiler-syntax
X (lambda (form)
X (list 'put
X (list 'quote (cadr form))
X (list 'quote '%syntax)
X (caddr form))))
X
X(compiler-syntax quote
X (lambda (form) form))
X
X(compiler-syntax lambda
X (lambda (form)
X (cons
X 'lambda
X (cons
X (cadr form)
X (%expand-list (cddr form))))))
X
X(compiler-syntax define
X (lambda (form)
X (cons
X 'define
X (cons
X (cadr form)
X (%expand-list (cddr form))))))
X
X(compiler-syntax set!
X (lambda (form)
X (cons
X 'set!
X (cons
X (cadr form)
X (%expand-list (cddr form))))))
X
X(define (%cond-expander lyst)
X (cond
X ((pair? lyst)
X (cons
X (if (pair? (car lyst))
X (%expand-list (car lyst))
X (car lyst))
X (%cond-expander (cdr lyst))))
X (else lyst)))
X
X(compiler-syntax cond
X (lambda (form)
X (cons 'cond (%cond-expander (cdr form)))))
X
X; The following code for expanding let/let*/letrec was donated by:
X;
X; Harald Hanche-Olsen
X; The University of Trondheim
X; The Norwegian Institute of Technology
X; Division of Mathematics
X; N-7034 Trondheim NTH
X; Norway
X
X(define (%expand-let-assignment pair)
X (if (pair? pair)
X (cons
X (car pair)
X (%expand-macros (cdr pair)))
X pair))
X
X(define (%expand-let-form form)
X (cons
X (car form)
X (cons
X (let ((lyst (cadr form)))
X (if (pair? lyst)
X (map %expand-let-assignment lyst)
X lyst))
X (%expand-list (cddr form)))))
X
X(compiler-syntax let %expand-let-form)
X(compiler-syntax let* %expand-let-form)
X(compiler-syntax letrec %expand-let-form)
X
X(macro define-integrable
X (lambda (form)
X (cons 'define (cdr form))))
X
X(macro declare
X (lambda (form) #f))
END_OF_FILE
if test 2613 -ne `wc -c <'macros.s'`; then
echo shar: \"'macros.s'\" unpacked with wrong size!
fi
# end of 'macros.s'
fi
if test -f 'mystuff.s.uu' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'mystuff.s.uu'\"
else
echo shar: Extracting \"'mystuff.s.uu'\" \(3155 characters\)
sed "s/^X//" >'mystuff.s.uu' <<'END_OF_FILE'
Xbegin 664 mystuff.s
XM.R`@06-K97)M86YN(&9U;F-T:6]N("TM("AA8VL@-"`Q*2!T86ME<R!A($Q/$
XM3D<L($Q/3D<@=&EM92$A(0HH9&5F:6YE("AA8VL@;2!N*0H@("`@("`H8V]N-
XM9"`H*#T@;2`P*2`@*#$K(&XI*0H@("`@("`@("`@("`H*#T@;B`P*2`@*&%C%
XM:R`H+3$K(&TI(#$I*0H@("`@("`@("`@("`H96QS92`@("`@*&%C:R`H+3$KX
XM(&TI("AA8VL@;2`H+3$K(&XI*2DI*2D*"CL@4')O<&5R;'D@=&%I;"UR96-U!
XM<G-I=F4@9F%C=&]R:6%L(&9U;F-T:6]N"BAD969I;F4@*&9A8W0@;BD*"2AD=
XM969I;F4@*&9A8W0M:71E<B!C;W5N="!A;G-W97(I"@D)*&EF("@\(&-O=6YT0
XM(#(I"@D)("`@(&%N<W=E<@H)"2`@("`H9F%C="UI=&5R("@M,2L@8V]U;G0IM
XM("@J(&-O=6YT(&%N<W=E<BDI*2D*"2AF86-T+6ET97(@;B`Q*2D*"CL@4W1A1
XM;F1A<F0H/RD@1FEB;VYA8V-I('-E<75E;F-E(&9U;F-T:6]N"CL@1FEB;VYAJ
XM8V-I('-E<75E;F-E<B`@(#$@,2`R(#,@-2`X(#$S(#(Q(#,T(#4U(#@Y("X@E
XM+B`N"BAD969I;F4@*&9I8B!N*0H@("`@*&EF("@\(&X@,BD*"0DQ"@D)*"L@S
XM*&9I8B`H+2!N(#(I*0H)"2`@("AF:6(@*"T@;B`Q*2D*"0DI"@DI"BD*"CL@>
XM4')O9'5C92!A(&QI<W0@;V8@:6YT96=E<G,@9G)O;2!-5TBR+4E/5$$M0D%34
XM12!T;R!N+@H[(%-I;6EL87(@=&\@05!,)W,@(&EO=&$@9G5N8W1I;VXN"BAD+
XM969I;F4@*&EO=&$@;BD*"2AD969I;F4@*&EO=&$M:71E<B!S=&%R="!C;W5N2
XM="!A;G-W97(I"@D)*&EF("AP;W-I=&EV93\@8V]U;G0I"@D)"2AA<'!E;F0@Q
XM*&QI<W0@<W1A<G0I("AI;W1A+6ET97(@*#$K('-T87)T*2`H+3$K(&-O=6YTF
XM*2!A;G-W97(I*0H)"0EA;G-W97(I*0H@("`@*&EO=&$M:71E<B!-5TBR+4E/U
XM5$$M0D%312!N("@I*0HI"BAD969I;F4@35=(LBU)3U1!+4)!4T4@,2D**&1IN
XM<W!L87D@(DU72+(M24]402U"05-%('-E="!T;R`Q(BD**&YE=VQI;F4I"@H[2
XM($9O<B!T:&4@=VEN=&5R("TM(%=I;F0@0VAI;&P@26YD97@@8V%L8W5L871O)
XM<@HH9&5F:6YE("AF+3YC(&9A:'(I"@DH+2`H+R`H*B`H*R!F86AR(#0P+C`I%
XM"@D)"2`U+C`I"@D)("`Y+C`I"B`@("`@("`T,"XP*0HI"BAD969I;F4@*&,M:
XM/F8@8V5L<VEU<RD*"2@M("@O("@J("@K(&-E;'-I=7,@-#`N,"D*"0D)(#DNX
XM,"D*"0D@(#4N,"D*("`@("`@(#0P+C`I"BD**&1E9FEN92`H=V-I(&8M=&5M:
XM<"!M<&@M=VEN9"D*("`H9&5F:6YE("AM<&@M=&\M;7!S(&UP:"D*("`@("@J^
XM(&UP:`H@("`@("`@*"\@*"H@-3(X,"XP(#$R+C`@,C4N-"D@*"H@,S8P,"XP1
XM(#$P,#`N,"DI*2D*("`H9&5F:6YE("AW:6YD+6-H:6QL+69A8W1O<B!C+71EH
XM;7`@;7!S+7=I;F0I"B`@("`H*B`H*R`Q,"XT-0H)("`H*B`Q,"XP("AS<7)T2
XM(&UP<RUW:6YD*2D*"2`@*"T@;7!S+7=I;F0I*0H@("`@("`@*"T@,S,N,"!C0
XM+71E;7`I*2D*("`H;&5T*B`H*&UE=')I8RTT;7!H("AM<&@M=&\M;7!S(#0NU
XM,"DI"@D@*&UE=')I8RUT96UP("AF+3YC(&8M=&5M<"DI"@D@*&UE=')I8RUW^
XM:6YD("AI9B`H/"!M<&@M=VEN9"`T+C`I"@D)"2`@;65T<FEC+31M<&@*"0D)I
XM*&UP:"UT;RUM<',@;7!H+7=I;F0I*2D*"2`H;7DM=V-F("AW:6YD+6-H:6QL:
XM+69A8W1O<B!M971R:6,M=&5M<"!M971R:6,M=VEN9"DI"@D@*0H@("`@*&EFE
XM("@\/2!M<&@M=VEN9"`T-2XP*0H)*&,M/F8@*"T@,S,N,`H)"2`H+R!M>2UW:
XM8V8*"0D@("`@*"L@,3`N-#4*"0D@("`@("`@*"H@,3`N,"`H<W%R="!M971RG
XM:6,M-&UP:"DI"@D)("`@("`@("@M(&UE=')I8RTT;7!H*2DI*2D*("`@("`@V
XM*'!R:6YT(")%<G)O<CH@5VEN9"!S<&5E9"!T;V\@:&EG:"!;/C0U+6UP:%TB#
XM*2DI*0H**&1I<W!L87D@(E5S86=E.B`H=V-I(&9A:')E;FAE:70M=&5M<"!W*
XM:6YD+7-P965D+6UP:"DB*0HH;F5W;&EN92D*"BAD969I;F4@*&9R965S<"D*3
XM"2AL970@*"AM96TM=7-A9V4@*&=C(#`@,"DI*0H)"2AW<FET96QN(")#86QL;
XM<R!T;R!'0SHC7`D)(B`H8V%R(&UE;2UU<V%G92DI"@D)*'=R:71E;&X@(DYO&
XM9&5S.B-<"0D)(B`H8V%D<B!M96TM=7-A9V4I*0H)"2AW<FET96QN(")&<F5E4
XM(&YO9&5S.B-<"0DB("AC861D<B!M96TM=7-A9V4I*0H)"2AW<FET96QN(").X
XM;V1E('-E9VUE;G1S.B-<"0DB("AC861D9'(@;65M+75S86=E*2D*"0DH=W)I>
XM=&5L;B`B5F5C=&]R('-E9VUE;G1S.B-<"2(@*&-A<B`H8V1D9&1R(&UE;2UU^
XM<V%G92DI*0H)"2AW<FET96QN(")(96%P('-I>F4Z(UP)"2(@*&-A9'(@*&-D=
X59&1D<B!M96TM=7-A9V4I*2D*"2DI?
X``
Xend
Xsize 2226
END_OF_FILE
if test 3155 -ne `wc -c <'mystuff.s.uu'`; then
echo shar: \"'mystuff.s.uu'\" unpacked with wrong size!
fi
# end of 'mystuff.s.uu'
fi
if test -f 'pi-calc.s' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'pi-calc.s'\"
else
echo shar: Extracting \"'pi-calc.s'\" \(578 characters\)
sed "s/^X//" >'pi-calc.s' <<'END_OF_FILE'
X(define (pi-calc n)
X (define (a n)
X (if (zero? n)
X 1
X (/ (+ (a (-1+ n))
X (b (-1+ n)))
X 2)))
X (define (b n)
X (if (zero? n)
X (/ (sqrt 2))
X (sqrt (* (a (-1+ n))
X (b (-1+ n))))))
X (define (square x)
X (* x x))
X (define (two2theN n)
X (if (zero? n)
X 1
X (* 2 (two2theN (-1+ n)))))
X (define (sumof start end func)
X (let ((first (func start)))
X (if (= start end)
X first
X (+ first (sumof (1+ start) end func)))))
X (define (denom-func i)
X (* (two2theN i)
X (square (- (a i) (b i)))))
X (/ (* 4 (a n) (b n))
X (- 1 (sumof 0 (-1+ n) denom-func))))
END_OF_FILE
if test 578 -ne `wc -c <'pi-calc.s'`; then
echo shar: \"'pi-calc.s'\" unpacked with wrong size!
fi
# end of 'pi-calc.s'
fi
if test -f 'qquote.s' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'qquote.s'\"
else
echo shar: Extracting \"'qquote.s'\" \(2744 characters\)
sed "s/^X//" >'qquote.s' <<'END_OF_FILE'
X;;; QQUOTE.S 01-14-89 11:34 AM by John Armstrong
X
X;; Expands QUASIQUOTE/UNQUOTE/UNQUOTE according to Rev^3 Report specs.
X;;
X;; This file can be included as is in XSCHEME.INI, or can be incorporated
X;; into MACROS.S, with expander functions anywhere and macros after
X;; after definition of COMPILER-SYNTAX
X
X;;; EXPANDER-FUNCTIONS: compilable under the core XSCHEME, can be evaluated
X;;; independently of MACRO system
X
X(define APPEND-ME-SYM (gensym)) ;; must be a gensym to avoid capture in
X ;; certain (pathological) situations
X
X(define QQ-EXPANDER
X (lambda (l)
X (letrec
X (
X (qq-lev 0) ; always >= 0
X (QQ-CAR-CDR
X (lambda (exp)
X (let ((qq-car (qq (car exp)))
X (qq-cdr (qq (cdr exp))))
X (if (and (pair? qq-car)
X (eq? (car qq-car) append-me-sym))
X (list 'append (cdr qq-car) qq-cdr)
X (list 'cons qq-car qq-cdr)))))
X (QQ
X (lambda (exp)
X (cond ((symbol? exp)
X (list 'quote exp))
X ((vector? exp)
X (list 'list->vector (qq (vector->list exp))))
X ((atom? exp) ; nil, number or boolean
X exp)
X ((eq? (car exp) 'quasiquote)
X (set! qq-lev (1+ qq-lev))
X (let ((qq-val
X (if (= qq-lev 1) ; min val after inc
X ; --> outermost level
X (qq (cadr exp))
X (qq-car-cdr exp))))
X (set! qq-lev (-1+ qq-lev))
X qq-val))
X ((or (eq? (car exp) 'unquote)
X (eq? (car exp) 'unquote-splicing))
X (set! qq-lev (-1+ qq-lev))
X (let ((qq-val
X (if (= qq-lev 0) ; min val
X ; --> outermost level
X (if (eq? (car exp) 'unquote-splicing)
X (cons append-me-sym
X (%expand-macros (cadr exp)))
X (%expand-macros (cadr exp)))
X (qq-car-cdr exp))))
X (set! qq-lev (1+ qq-lev))
X qq-val))
X (else
X (qq-car-cdr exp)))))
X )
X (let ((expansion (qq l)))
X (if check-qq-expansion-flag
X (check-qq-expansion expansion)) ; error on failure
X expansion))))
X
X(define CHECK-QQ-EXPANSION
X (lambda (exp)
X (cond ((vector? exp)
X (check-qq-expansion (vector->list exp)))
X ((atom? exp)
X #f)
X (else
X (if (eq? (car exp) append-me-sym)
X (error "UNQUOTE-SPLICING in unspliceable position"
X (list 'unquote-splicing (cdr exp)))
X (or (check-qq-expansion (car exp))
X (check-qq-expansion (cdr exp))))))))
X
X(define CHECK-QQ-EXPANSION-FLAG #t) ; do checking
X
X(define UNQ-EXPANDER
X (lambda (l) (error "UNQUOTE outside QUASIQUOTE" l)))
X
X(define UNQ-SPL-EXPANDER
X (lambda (l) (error "UNQUOTE SPLICING outside QUASIQUOTE" l)))
X
X;;; MACROS: must be evaluated with MACRO system in place
X
X(compiler-syntax QUASIQUOTE qq-expander)
X(compiler-syntax UNQUOTE unq-expander)
X(compiler-syntax UNQUOTE-SPLICING unq-spl-expander)
X
X;;; END
X
END_OF_FILE
if test 2744 -ne `wc -c <'qquote.s'`; then
echo shar: \"'qquote.s'\" unpacked with wrong size!
fi
# end of 'qquote.s'
fi
if test -f 'xscheme.ini' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'xscheme.ini'\"
else
echo shar: Extracting \"'xscheme.ini'\" \(1486 characters\)
sed "s/^X//" >'xscheme.ini' <<'END_OF_FILE'
X; xscheme.ini - initialization code for XScheme version 0.16
X
X(load "macros.s")
X(load "qquote.s")
X
X; this version of EVAL knows about the optional enviroment parameter
X(define (eval x #!optional env)
X ((if (default-object? env)
X (compile x)
X (compile x env))))
X
X(define (autoload-from-file file syms #!optional env)
X (map (lambda (sym) (put sym '%autoload file)) syms)
X '())
X
X(define (*unbound-handler* sym cont)
X (let ((file (get sym '%autoload)))
X (if file (load file))
X (if (not (bound? sym))
X (error "unbound variable" sym))
X (cont '())))
X
X(define head car)
X(define (tail x) (force (cdr x)))
X(define empty-stream? null?)
X(define the-empty-stream '())
X
X(macro cons-stream
X (lambda (x)
X (list 'cons (cadr x) (list 'delay (caddr x)))))
X
X(macro make-environment
X (lambda (x)
X (append '(let ()) (cdr x) '((the-environment)))))
X
X(define initial-user-environment (the-environment))
X
X(macro case
X (lambda (form)
X (let ((test (cadr form))
X (sym (gensym)))
X `(let ((,sym ,test))
X (cond ,@(map (lambda (x)
X (if (eq? (car x) 'else)
X x
X `((memv ,sym ',(car x)) ,@(cdr x))))
X (cddr form)))))))
X(define writeln
X (lambda (#!OPTIONAL ovar . rvar)
X (if (not (default-object? ovar))
X (begin
X (display ovar)
X (while (not (null? rvar))
X (display (car rvar))
X (set! rvar (cdr rvar))
X )
X ))
X (newline)))
X
X(load "mystuff.s")
END_OF_FILE
if test 1486 -ne `wc -c <'xscheme.ini'`; then
echo shar: \"'xscheme.ini'\" unpacked with wrong size!
fi
# end of 'xscheme.ini'
fi
echo shar: End of archive 1 \(of 7\).
cp /dev/null ark1isdone
MISSING=""
for I in 1 2 3 4 5 6 7 ; do
if test ! -f ark${I}isdone ; then
MISSING="${MISSING} ${I}"
fi
done
if test "${MISSING}" = "" ; then
echo You have unpacked all 7 archives.
rm -f ark[1-9]isdone
else
echo You still need to unpack the following archives:
echo " " ${MISSING}
fi
## End of shell archive.
exit 0
--
Mail submissions (sources or binaries) to <amiga@cs.odu.edu>.
Mail comments to the moderator at <amiga-request@cs.odu.edu>.
Post requests for sources, and general discussion to comp.sys.amiga.