Amiga-Request@cs.odu.edu (Amiga Sources/Binaries Moderator) (04/15/90)
Submitted-by: rusty@fe2o3.UUCP (Rusty Haddock)
Posting-number: Volume 90, Issue 140
Archive-name: applications/xscheme-0.20/part02
#!/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 2 (of 7)."
# Contents: Src/msstuff.c Src/xsimage.c Src/xsint.c Src/xsobj.c
# Src/xsread.c
# Wrapped by tadguy@xanth on Sat Apr 14 17:07:22 1990
PATH=/bin:/usr/bin:/usr/ucb ; export PATH
if test -f 'Src/msstuff.c' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'Src/msstuff.c'\"
else
echo shar: Extracting \"'Src/msstuff.c'\" \(8253 characters\)
sed "s/^X//" >'Src/msstuff.c' <<'END_OF_FILE'
X/* msstuff.c - ms-dos specific routines */
X
X#include <dos.h>
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 lpos[LBSIZE];
Xstatic int lindex;
Xstatic int lcount;
Xstatic int lposition;
Xstatic long rseed = 1L;
X
X/* osinit - initialize */
Xosinit(banner)
X char *banner;
X{
X printf("%s\n",banner);
X lposition = 0;
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 char bmode[10];
X strcpy(bmode,mode); strcat(bmode,"b");
X return (fopen(name,bmode));
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 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 '\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 & 7);
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 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 case '\023': /* control-s */
X while (xcheck() != '\021')
X ;
X break;
X }
X}
X
X/* xinfo - show information on control-t */
Xstatic xinfo()
X{
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
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 return (bdos(7,0,0) & 0xFF);
X}
X
X/* xputc - put a character to the terminal */
Xstatic xputc(ch)
X int ch;
X{
X bdos(6,ch,0);
X}
X
X/* xcheck - check for a character */
Xstatic int xcheck()
X{
X return (bdos(6,0xFF,0) & 0xFF);
X}
X
X/* xinbyte - read a byte from an input port */
XLVAL xinbyte()
X{
X int portno;
X LVAL val;
X val = xlgafixnum(); portno = (int)getfixnum(val);
X xllastarg();
X return (cvfixnum((FIXTYPE)inp(portno)));
X}
X
X/* xoutbyte - write a byte to an output port */
XLVAL xoutbyte()
X{
X int portno,byte;
X LVAL val;
X val = xlgafixnum(); portno = (int)getfixnum(val);
X val = xlgafixnum(); byte = (int)getfixnum(val);
X xllastarg();
X outp(portno,byte);
X return (NIL);
X}
X
X/* xint86 - invoke a system interrupt */
XLVAL xint86()
X{
X union REGS inregs,outregs;
X struct SREGS sregs;
X LVAL inv,outv,val;
X int intno;
X
X /* get the interrupt number and the list of register values */
X val = xlgafixnum(); intno = (int)getfixnum(val);
X inv = xlgavector();
X outv = xlgavector();
X xllastarg();
X
X /* check the vector lengths */
X if (getsize(inv) != 9)
X xlerror("incorrect vector length",inv);
X if (getsize(outv) != 9)
X xlerror("incorrect vector length",outv);
X
X /* load each register from the input vector */
X val = getelement(inv,0);
X inregs.x.ax = (fixp(val) ? (int)getfixnum(val) : 0);
X val = getelement(inv,1);
X inregs.x.bx = (fixp(val) ? (int)getfixnum(val) : 0);
X val = getelement(inv,2);
X inregs.x.cx = (fixp(val) ? (int)getfixnum(val) : 0);
X val = getelement(inv,3);
X inregs.x.dx = (fixp(val) ? (int)getfixnum(val) : 0);
X val = getelement(inv,4);
X inregs.x.si = (fixp(val) ? (int)getfixnum(val) : 0);
X val = getelement(inv,5);
X inregs.x.di = (fixp(val) ? (int)getfixnum(val) : 0);
X val = getelement(inv,6);
X sregs.es = (fixp(val) ? (int)getfixnum(val) : 0);
X val = getelement(inv,7);
X sregs.ds = (fixp(val) ? (int)getfixnum(val) : 0);
X val = getelement(inv,8);
X inregs.x.cflag = (fixp(val) ? (int)getfixnum(val) : 0);
X
X /* do the system interrupt */
X int86x(intno,&inregs,&outregs,&sregs);
X
X /* store the results in the output vector */
X setelement(outv,0,cvfixnum((FIXTYPE)outregs.x.ax));
X setelement(outv,1,cvfixnum((FIXTYPE)outregs.x.bx));
X setelement(outv,2,cvfixnum((FIXTYPE)outregs.x.cx));
X setelement(outv,3,cvfixnum((FIXTYPE)outregs.x.dx));
X setelement(outv,4,cvfixnum((FIXTYPE)outregs.x.si));
X setelement(outv,5,cvfixnum((FIXTYPE)outregs.x.di));
X setelement(outv,6,cvfixnum((FIXTYPE)sregs.es));
X setelement(outv,7,cvfixnum((FIXTYPE)sregs.ds));
X setelement(outv,8,cvfixnum((FIXTYPE)outregs.x.cflag));
X
X /* return the result list */
X return (outv);
X}
X
X/* getnext - get the next fixnum from a list */
Xstatic int getnext(plist)
X LVAL *plist;
X{
X LVAL val;
X if (consp(*plist)) {
X val = car(*plist);
X *plist = cdr(*plist);
X if (!fixp(val))
X xlerror("expecting an integer",val);
X return ((int)getfixnum(val));
X }
X return (0);
X}
X
X/* xsystem - execute a system command */
XLVAL xsystem()
X{
X char *cmd="COMMAND";
X if (moreargs())
X cmd = (char *)getstring(xlgastring());
X xllastarg();
X return (system(cmd) == 0 ? true : cvfixnum((FIXTYPE)errno));
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 8253 -ne `wc -c <'Src/msstuff.c'`; then
echo shar: \"'Src/msstuff.c'\" unpacked with wrong size!
fi
# end of 'Src/msstuff.c'
fi
if test -f 'Src/xsimage.c' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'Src/xsimage.c'\"
else
echo shar: Extracting \"'Src/xsimage.c'\" \(8825 characters\)
sed "s/^X//" >'Src/xsimage.c' <<'END_OF_FILE'
X/* xsimage.c - xscheme memory image save/restore functions */
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/* virtual machine registers */
Xextern LVAL xlfun; /* current function */
Xextern LVAL xlenv; /* current environment */
Xextern LVAL xlval; /* value of most recent instruction */
X
X/* stack limits */
Xextern LVAL *xlstkbase; /* base of value stack */
Xextern LVAL *xlstktop; /* top of value stack */
X
X/* node space */
Xextern NSEGMENT *nsegments; /* list of node segments */
X
X/* vector (and string) space */
Xextern VSEGMENT *vsegments; /* list of vector segments */
Xextern LVAL *vfree; /* next free location in vector space */
Xextern LVAL *vtop; /* top of vector space */
X
X/* global variables */
Xextern LVAL obarray,eof_object,default_object;
Xextern jmp_buf top_level;
Xextern FUNDEF funtab[];
X
X/* local variables */
Xstatic OFFTYPE off,foff;
Xstatic FILE *fp;
X
X/* external routines */
Xextern FILE *osbopen();
X
X/* forward declarations */
XOFFTYPE readptr();
XOFFTYPE cvoptr();
XLVAL cviptr();
X
X/* xlisave - save the memory image */
Xint xlisave(fname)
X char *fname;
X{
X unsigned char *cp;
X NSEGMENT *nseg;
X int size,n;
X LVAL p,*vp;
X
X /* open the output file */
X if ((fp = osbopen(fname,"w")) == NULL)
X return (FALSE);
X
X /* first call the garbage collector to clean up memory */
X gc();
X
X /* write out the stack size */
X writeptr((OFFTYPE)(xlstktop-xlstkbase));
X
X /* write out the *obarray* symbol and various constants */
X writeptr(cvoptr(obarray));
X writeptr(cvoptr(eof_object));
X writeptr(cvoptr(default_object));
X
X /* setup the initial file offsets */
X off = foff = (OFFTYPE)2;
X
X /* write out all nodes that are still in use */
X for (nseg = nsegments; nseg != NULL; nseg = nseg->ns_next) {
X p = &nseg->ns_data[0];
X n = nseg->ns_size;
X for (; --n >= 0; ++p, off += sizeof(NODE))
X switch (ntype(p)) {
X case FREE:
X break;
X case CONS:
X case CLOSURE:
X case METHOD:
X case PROMISE:
X case ENV:
X setoffset();
X osbputc(p->n_type,fp);
X writeptr(cvoptr(car(p)));
X writeptr(cvoptr(cdr(p)));
X foff += sizeof(NODE);
X break;
X case SYMBOL:
X case OBJECT:
X case VECTOR:
X case CODE:
X case CONTINUATION:
X setoffset();
X osbputc(p->n_type,fp);
X size = getsize(p);
X writeptr((OFFTYPE)size);
X for (vp = p->n_vdata; --size >= 0; )
X writeptr(cvoptr(*vp++));
X foff += sizeof(NODE);
X break;
X case STRING:
X setoffset();
X osbputc(p->n_type,fp);
X size = getslength(p);
X writeptr((OFFTYPE)size);
X for (cp = getstring(p); --size >= 0; )
X osbputc(*cp++,fp);
X foff += sizeof(NODE);
X break;
X default:
X setoffset();
X writenode(p);
X foff += sizeof(NODE);
X break;
X }
X }
X
X /* write the terminator */
X osbputc(FREE,fp);
X writeptr((OFFTYPE)0);
X
X /* close the output file */
X osclose(fp);
X
X /* return successfully */
X return (TRUE);
X}
X
X/* xlirestore - restore a saved memory image */
Xint xlirestore(fname)
X char *fname;
X{
X LVAL *getvspace();
X unsigned int ssize;
X unsigned char *cp;
X int size,type;
X LVAL p,*vp;
X
X /* open the file */
X if ((fp = osbopen(fname,"r")) == NULL)
X return (FALSE);
X
X /* free the old memory image */
X freeimage();
X
X /* read the stack size */
X ssize = (unsigned int)readptr();
X
X /* allocate memory for the workspace */
X xlminit(ssize);
X
X /* read the *obarray* symbol and various constants */
X obarray = cviptr(readptr());
X eof_object = cviptr(readptr());
X default_object = cviptr(readptr());
X
X /* read each node */
X for (off = (OFFTYPE)2; (type = osbgetc(fp)) >= 0; )
X switch (type) {
X case FREE:
X if ((off = readptr()) == (OFFTYPE)0)
X goto done;
X break;
X case CONS:
X case CLOSURE:
X case METHOD:
X case PROMISE:
X case ENV:
X p = cviptr(off);
X p->n_type = type;
X rplaca(p,cviptr(readptr()));
X rplacd(p,cviptr(readptr()));
X off += sizeof(NODE);
X break;
X case SYMBOL:
X case OBJECT:
X case VECTOR:
X case CODE:
X case CONTINUATION:
X p = cviptr(off);
X p->n_type = type;
X p->n_vsize = size = (int)readptr();
X p->n_vdata = getvspace(p,size);
X for (vp = p->n_vdata; --size >= 0; )
X *vp++ = cviptr(readptr());
X off += sizeof(NODE);
X break;
X case STRING:
X p = cviptr(off);
X p->n_type = type;
X p->n_vsize = size = (int)readptr();
X p->n_vdata = getvspace(p,btow_size(size));
X for (cp = getstring(p); --size >= 0; )
X *cp++ = osbgetc(fp);
X off += sizeof(NODE);
X break;
X case PORT:
X p = cviptr(off);
X readnode(type,p);
X setfile(p,NULL);
X off += sizeof(NODE);
X break;
X case SUBR:
X case XSUBR:
X p = cviptr(off);
X readnode(type,p);
X p->n_subr = funtab[getoffset(p)].fd_subr;
X off += sizeof(NODE);
X break;
X default:
X readnode(type,cviptr(off));
X off += sizeof(NODE);
X break;
X }
Xdone:
X
X /* close the input file */
X osclose(fp);
X
X /* collect to initialize the free space */
X gc();
X
X /* lookup all of the symbols the interpreter uses */
X xlsymbols();
X
X /* return successfully */
X return (TRUE);
X}
X
X/* freeimage - free the current memory image */
XLOCAL freeimage()
X{
X NSEGMENT *nextnseg;
X VSEGMENT *nextvseg;
X FILE *fp;
X LVAL p;
X int n;
X
X /* close all open ports and free each node segment */
X for (; nsegments != NULL; nsegments = nextnseg) {
X nextnseg = nsegments->ns_next;
X p = &nsegments->ns_data[0];
X n = nsegments->ns_size;
X for (; --n >= 0; ++p)
X switch (ntype(p)) {
X case PORT:
X if ((fp = getfile(p))
X && (fp != stdin && fp != stdout && fp != stderr))
X osclose(getfile(p));
X break;
X }
X free(nsegments);
X }
X
X /* free each vector segment */
X for (; vsegments != NULL; vsegments = nextvseg) {
X nextvseg = vsegments->vs_next;
X free(vsegments);
X }
X
X /* free the stack */
X if (xlstkbase)
X free(xlstkbase);
X}
X
X/* setoffset - output a positioning command if nodes have been skipped */
XLOCAL setoffset()
X{
X if (off != foff) {
X osbputc(FREE,fp);
X writeptr(off);
X foff = off;
X }
X}
X
X/* writenode - write a node to a file */
XLOCAL writenode(node)
X LVAL node;
X{
X char *p = (char *)&node->n_info;
X int n = sizeof(union ninfo);
X osbputc(node->n_type,fp);
X while (--n >= 0)
X osbputc(*p++,fp);
X}
X
X/* writeptr - write a pointer to a file */
XLOCAL writeptr(off)
X OFFTYPE off;
X{
X char *p = (char *)&off;
X int n = sizeof(OFFTYPE);
X while (--n >= 0)
X osbputc(*p++,fp);
X}
X
X/* readnode - read a node */
XLOCAL readnode(type,node)
X int type; LVAL node;
X{
X char *p = (char *)&node->n_info;
X int n = sizeof(union ninfo);
X node->n_type = type;
X while (--n >= 0)
X *p++ = osbgetc(fp);
X}
X
X/* readptr - read a pointer */
XLOCAL OFFTYPE readptr()
X{
X OFFTYPE off;
X char *p = (char *)&off;
X int n = sizeof(OFFTYPE);
X while (--n >= 0)
X *p++ = osbgetc(fp);
X return (off);
X}
X
X/* cviptr - convert a pointer on input */
XLOCAL LVAL cviptr(o)
X OFFTYPE o;
X{
X NSEGMENT *newnsegment(),*nseg;
X OFFTYPE off = (OFFTYPE)2;
X OFFTYPE nextoff;
X
X /* check for nil and small fixnums */
X if (o == (OFFTYPE)0 || (o & 1) == 1)
X return ((LVAL)o);
X
X /* compute a pointer for this offset */
X for (nseg = nsegments; nseg != NULL; nseg = nseg->ns_next) {
X nextoff = off + (OFFTYPE)(nseg->ns_size * sizeof(NODE));
X if (o >= off && o < nextoff)
X return ((LVAL)((OFFTYPE)&nseg->ns_data[0] + o - off));
X off = nextoff;
X }
X
X /* create new segments if necessary */
X for (;;) {
X
X /* create the next segment */
X if ((nseg = newnsegment(NSSIZE)) == NULL)
X xlfatal("insufficient memory - segment");
X
X /* check to see if the offset is in this segment */
X nextoff = off + (OFFTYPE)(nseg->ns_size * sizeof(NODE));
X if (o >= off && o < nextoff)
X return ((LVAL)((OFFTYPE)&nseg->ns_data[0] + o - off));
X off = nextoff;
X }
X}
X
X/* cvoptr - convert a pointer on output */
XLOCAL OFFTYPE cvoptr(p)
X LVAL p;
X{
X OFFTYPE off = (OFFTYPE)2;
X NSEGMENT *nseg;
X
X /* check for nil and small fixnums */
X if (p == NIL || !ispointer(p))
X return ((OFFTYPE)p);
X
X /* compute an offset for this pointer */
X for (nseg = nsegments; nseg != NULL; nseg = nseg->ns_next) {
X if (INSEGMENT(p,nseg))
X return (off + ((OFFTYPE)p - (OFFTYPE)&nseg->ns_data[0]));
X off += (OFFTYPE)(nseg->ns_size * sizeof(NODE));
X }
X
X /* pointer not within any segment */
X xlerror("bad pointer found during image save",p);
X}
X
X/* getvspace - allocate vector space */
XLOCAL LVAL *getvspace(node,size)
X LVAL node; unsigned int size;
X{
X LVAL *p;
X ++size; /* space for the back pointer */
X if (vfree + size >= vtop) {
X makevmemory(size);
X if (vfree + size >= vtop)
X xlfatal("insufficient vector space");
X }
X p = vfree;
X vfree += size;
X *p++ = node;
X return (p);
X}
END_OF_FILE
if test 8825 -ne `wc -c <'Src/xsimage.c'`; then
echo shar: \"'Src/xsimage.c'\" unpacked with wrong size!
fi
# end of 'Src/xsimage.c'
fi
if test -f 'Src/xsint.c' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'Src/xsint.c'\"
else
echo shar: Extracting \"'Src/xsint.c'\" \(10297 characters\)
sed "s/^X//" >'Src/xsint.c' <<'END_OF_FILE'
X/* xsint.c - xscheme bytecode interpreter */
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/* sample rate (instructions per sample) */
X#define SRATE 1000
X
X/* macros to get the address of the code string for a code object */
X#define getcodestr(x) ((unsigned char *)getstring(getbcode(x)))
X
X/* globals */
Xint trace=FALSE; /* trace enable */
Xint xlargc; /* argument count */
Xjmp_buf bc_dispatch; /* bytecode dispatcher */
X
X/* external variables */
Xextern LVAL xlfun,xlenv,xlval;
Xextern LVAL s_stdin,s_stdout,s_unbound;
Xextern LVAL s_unassigned,default_object,true;
X
X/* external routines */
Xextern LVAL xadd(),xsub(),xmul(),xdiv(),xlss(),xeql(),xgtr();
X
X/* local variables */
Xstatic unsigned char *base,*pc;
Xstatic int sample=SRATE;
X
X/* xtraceon - built-in function 'trace-on' */
XLVAL xtraceon()
X{
X xllastarg()
X trace = TRUE;
X return (NIL);
X}
X
X/* xtraceoff - built-in function 'trace-off' */
XLVAL xtraceoff()
X{
X xllastarg()
X trace = FALSE;
X return (NIL);
X}
X
X/* xlexecute - execute byte codes */
Xxlexecute(fun)
X LVAL fun;
X{
X LVAL findvar(),make_continuation();
X register LVAL tmp;
X register unsigned int i;
X register int k;
X int off;
X
X /* initialize the registers */
X xlfun = getcode(fun);
X xlenv = getenv(fun);
X xlval = NIL;
X
X /* initialize the argument count */
X xlargc = 0;
X
X /* set the initial pc */
X base = pc = getcodestr(xlfun);
X
X /* setup a target for the error handler */
X setjmp(bc_dispatch);
X
X /* execute the code */
X for (;;) {
X
X /* check for control codes */
X if (--sample <= 0) {
X sample = SRATE;
X oscheck();
X }
X
X /* print the trace information */
X if (trace)
X decode_instruction(curoutput(),xlfun,(int)(pc-base),xlenv);
X
X /* execute the next bytecode instruction */
X switch (*pc++) {
X case OP_BRT:
X i = *pc++ << 8; i |= *pc++;
X if (xlval) pc = base + i;
X break;
X case OP_BRF:
X i = *pc++ << 8; i |= *pc++;
X if (!xlval) pc = base + i;
X break;
X case OP_BR:
X i = *pc++ << 8; i |= *pc++;
X pc = base + i;
X break;
X case OP_LIT:
X xlval = getelement(xlfun,*pc++);
X break;
X case OP_GREF:
X tmp = getelement(xlfun,*pc++);
X if ((xlval = getvalue(tmp)) == s_unbound) {
X if (xlval = getvalue(xlenter("*UNBOUND-HANDLER*"))) {
X oscheck();
X pc -= 2; /* backup the pc */
X tmp = make_continuation();
X check(2);
X push(tmp);
X push(getelement(xlfun,pc[1]));
X xlargc = 2;
X xlapply();
X }
X else
X xlerror("unbound variable",tmp);
X }
X break;
X case OP_GSET:
X setvalue(getelement(xlfun,*pc++),xlval);
X break;
X case OP_EREF:
X k = *pc++;
X tmp = xlenv;
X while (--k >= 0) tmp = cdr(tmp);
X xlval = getelement(car(tmp),*pc++);
X break;
X case OP_ESET:
X k = *pc++;
X tmp = xlenv;
X while (--k >= 0) tmp = cdr(tmp);
X setelement(car(tmp),*pc++,xlval);
X break;
X case OP_AREF:
X i = *pc++;
X tmp = xlval;
X if (!envp(tmp)) badargtype(tmp);
X if ((tmp = findvar(tmp,getelement(xlfun,i),&off)) != NIL)
X xlval = getelement(car(tmp),off);
X else
X xlval = s_unassigned;
X break;
X case OP_ASET:
X i = *pc++;
X tmp = pop();
X if (!envp(tmp)) badargtype(tmp);
X if ((tmp = findvar(tmp,getelement(xlfun,i),&off)) == NIL)
X xlerror("no binding for variable",getelement(xlfun,i));
X setelement(car(tmp),off,xlval);
X break;
X case OP_SAVE: /* save a continuation */
X i = *pc++ << 8; i |= *pc++;
X check(3);
X push(cvsfixnum((FIXTYPE)i));
X push(xlfun);
X push(xlenv);
X break;
X case OP_CALL: /* call a function (or built-in) */
X xlargc = *pc++; /* get argument count */
X xlapply(); /* apply the function */
X break;
X case OP_RETURN: /* return to the continuation on the stack */
X xlreturn();
X break;
X case OP_FRAME: /* create an environment frame */
X i = *pc++; /* get the frame size */
X xlenv = newframe(xlenv,i);
X setelement(car(xlenv),0,getvnames(xlfun));
X break;
X case OP_MVARG: /* move required argument to frame slot */
X i = *pc++; /* get the slot number */
X if (--xlargc < 0)
X xlfail("too few arguments");
X setelement(car(xlenv),i,pop());
X break;
X case OP_MVOARG: /* move optional argument to frame slot */
X i = *pc++; /* get the slot number */
X if (xlargc > 0) {
X setelement(car(xlenv),i,pop());
X --xlargc;
X }
X else
X setelement(car(xlenv),i,default_object);
X break;
X case OP_MVRARG: /* build rest argument and move to frame slot */
X i = *pc++; /* get the slot number */
X for (xlval = NIL, k = xlargc; --k >= 0; )
X xlval = cons(xlsp[k],xlval);
X setelement(car(xlenv),i,xlval);
X drop(xlargc);
X break;
X case OP_ALAST: /* make sure there are no more arguments */
X if (xlargc > 0)
X xlfail("too many arguments");
X break;
X case OP_T:
X xlval = true;
X break;
X case OP_NIL:
X xlval = NIL;
X break;
X case OP_PUSH:
X cpush(xlval);
X break;
X case OP_CLOSE:
X if (!codep(xlval)) badargtype(xlval);
X xlval = cvclosure(xlval,xlenv);
X break;
X case OP_DELAY:
X if (!codep(xlval)) badargtype(xlval);
X xlval = cvpromise(xlval,xlenv);
X break;
X case OP_ATOM:
X xlval = (atom(xlval) ? true : NIL);
X break;
X case OP_EQ:
X xlval = (xlval == pop() ? true : NIL);
X break;
X case OP_NULL:
X xlval = (xlval ? NIL : true);
X break;
X case OP_CONS:
X xlval = cons(xlval,pop());
X break;
X case OP_CAR:
X if (!listp(xlval)) badargtype(xlval);
X xlval = (xlval ? car(xlval) : NIL);
X break;
X case OP_CDR:
X if (!listp(xlval)) badargtype(xlval);
X xlval = (xlval ? cdr(xlval) : NIL);
X break;
X case OP_SETCAR:
X if (!consp(xlval)) badargtype(xlval);
X rplaca(xlval,pop());
X break;
X case OP_SETCDR:
X if (!consp(xlval)) badargtype(xlval);
X rplacd(xlval,pop());
X break;
X case OP_ADD:
X tmp = pop();
X if (fixp(xlval) && fixp(tmp))
X xlval = cvfixnum(getfixnum(xlval) + getfixnum(tmp));
X else {
X push(tmp); push(xlval); xlargc = 2;
X xlval = xadd();
X }
X break;
X case OP_SUB:
X tmp = pop();
X if (fixp(xlval) && fixp(tmp))
X xlval = cvfixnum(getfixnum(xlval) - getfixnum(tmp));
X else {
X push(tmp); push(xlval); xlargc = 2;
X xlval = xsub();
X }
X break;
X case OP_MUL:
X tmp = pop();
X if (fixp(xlval) && fixp(tmp))
X xlval = cvfixnum(getfixnum(xlval) * getfixnum(tmp));
X else {
X push(tmp); push(xlval); xlargc = 2;
X xlval = xmul();
X }
X break;
X case OP_QUO:
X tmp = pop();
X if (fixp(xlval) && fixp(tmp))
X xlval = cvfixnum(getfixnum(xlval) / getfixnum(tmp));
X else if (fixp(xlval))
X badargtype(tmp);
X else
X badargtype(xlval);
X break;
X case OP_LSS:
X tmp = pop();
X if (fixp(xlval) && fixp(tmp))
X xlval = (getfixnum(xlval) < getfixnum(tmp) ? true : NIL);
X else {
X push(tmp); push(xlval); xlargc = 2;
X xlval = xlss();
X }
X break;
X case OP_EQL:
X tmp = pop();
X if (fixp(xlval) && fixp(tmp))
X xlval = (getfixnum(xlval) == getfixnum(tmp) ? true : NIL);
X else {
X push(tmp); push(xlval); xlargc = 2;
X xlval = xeql();
X }
X break;
X case OP_GTR:
X tmp = pop();
X if (fixp(xlval) && fixp(tmp))
X xlval = (getfixnum(xlval) > getfixnum(tmp) ? true : NIL);
X else {
X push(tmp); push(xlval); xlargc = 2;
X xlval = xgtr();
X }
X break;
X default:
X xlerror("bad opcode",cvsfixnum((FIXTYPE)*--pc));
X break;
X }
X }
X}
X
X/* findvar - find a variable in an environment */
XLOCAL LVAL findvar(env,var,poff)
X LVAL env,var; int *poff;
X{
X LVAL names;
X int off;
X for (; env != NIL; env = cdr(env)) {
X names = getelement(car(env),0);
X for (off = 1; names != NIL; ++off, names = cdr(names))
X if (var == car(names)) {
X *poff = off;
X return (env);
X }
X }
X return (NIL);
X}
X
X/* xlapply - apply a function to arguments */
X/* The function should be in xlval and the arguments should
X be on the stack. The number of arguments should be in xlargc.
X*/
Xxlapply()
X{
X LVAL tmp;
X
X /* check for null function */
X if (null(xlval))
X badfuntype(xlval);
X
X /* dispatch on function type */
X switch (ntype(xlval)) {
X case SUBR:
X xlval = (*getsubr(xlval))();
X xlreturn();
X break;
X case XSUBR:
X (*getsubr(xlval))();
X break;
X case CLOSURE:
X xlfun = getcode(xlval);
X xlenv = getenv(xlval);
X base = pc = getcodestr(xlfun);
X break;
X case OBJECT:
X xlsend(xlval,xlgasymbol());
X break;
X case METHOD:
X xlfun = getcode(xlval);
X xlenv = cons(top(),getenv(xlval));
X base = pc = getcodestr(xlfun);
X break;
X case CONTINUATION:
X tmp = xlgetarg();
X xllastarg();
X restore_continuation();
X xlval = tmp;
X xlreturn();
X break;
X default:
X badfuntype(xlval);
X }
X}
X
X/* xlreturn - return to a continuation on the stack */
Xxlreturn()
X{
X LVAL tmp;
X
X /* restore the enviroment and the continuation function */
X xlenv = pop();
X tmp = pop();
X
X /* dispatch on the function type */
X switch (ntype(tmp)) {
X case CODE:
X xlfun = tmp;
X tmp = pop();
X base = getcodestr(xlfun);
X pc = base + (int)getsfixnum(tmp);
X break;
X case CSUBR:
X (*getsubr(tmp))();
X break;
X default:
X xlerror("bad continuation",tmp);
X }
X}
X
X/* make_continuation - make a continuation */
XLOCAL LVAL make_continuation()
X{
X LVAL cont,*src,*dst;
X int size;
X
X /* save a continuation on the stack */
X check(3);
X push(cvsfixnum((FIXTYPE)(pc - base)));
X push(xlfun);
X push(xlenv);
X
X /* create and initialize a continuation object */
X size = (int)(xlstktop - xlsp);
X cont = newcontinuation(size);
X for (src = xlsp, dst = &cont->n_vdata[0]; --size >= 0; )
X *dst++ = *src++;
X
X /* return the continuation */
X return (cont);
X}
X
X/* restore_continuation - restore a continuation to the stack */
X/* The continuation should be in xlval.
X*/
XLOCAL restore_continuation()
X{
X LVAL *src;
X int size;
X size = getsize(xlval);
X for (src = &xlval->n_vdata[size], xlsp = xlstktop; --size >= 0; )
X *--xlsp = *--src;
X}
X
X/* gc_protect - protect the state of the interpreter from the collector */
Xgc_protect(protected_fcn)
X int (*protected_fcn)();
X{
X int pcoff;
X pcoff = pc - base;
X (*protected_fcn)();
X if (xlfun) {
X base = getcodestr(xlfun);
X pc = base + pcoff;
X }
X}
X
X/* badfuntype - bad function error */
XLOCAL badfuntype(arg)
X LVAL arg;
X{
X xlerror("bad function type",arg);
X}
X
X/* badargtype - bad argument type error */
XLOCAL badargtype(arg)
X LVAL arg;
X{
X xlbadtype(arg);
X}
X
X/* xlstkover - value stack overflow */
Xxlstkover()
X{
X xlabort("value stack overflow");
X}
END_OF_FILE
if test 10297 -ne `wc -c <'Src/xsint.c'`; then
echo shar: \"'Src/xsint.c'\" unpacked with wrong size!
fi
# end of 'Src/xsint.c'
fi
if test -f 'Src/xsobj.c' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'Src/xsobj.c'\"
else
echo shar: Extracting \"'Src/xsobj.c'\" \(9292 characters\)
sed "s/^X//" >'Src/xsobj.c' <<'END_OF_FILE'
X/* xsobj.c - xscheme object-oriented programming support */
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 xlenv,xlval;
Xextern LVAL s_stdout;
X
X/* local variables */
Xstatic LVAL s_self,k_isnew;
Xstatic LVAL class,object;
X
X/* instance variable numbers for the class 'Class' */
X#define MESSAGES 2 /* list of messages */
X#define IVARS 3 /* list of instance variable names */
X#define CVARS 4 /* env containing class variables */
X#define SUPERCLASS 5 /* pointer to the superclass */
X#define IVARCNT 6 /* number of class instance variables */
X#define IVARTOTAL 7 /* total number of instance variables */
X
X/* number of instance variables for the class 'Class' */
X#define CLASSSIZE 6
X
X/* forward declarations */
XFORWARD LVAL entermsg();
XFORWARD LVAL copylists();
X
X/* xlsend - send a message to an object */
Xxlsend(obj,sym)
X LVAL obj,sym;
X{
X LVAL msg,cls,p;
X
X /* look for the message in the class or superclasses */
X for (cls = getclass(obj); cls; cls = getivar(cls,SUPERCLASS))
X for (p = getivar(cls,MESSAGES); p; p = cdr(p))
X if ((msg = car(p)) && car(msg) == sym) {
X push(obj); ++xlargc; /* insert 'self' argument */
X xlval = cdr(msg); /* get the method */
X xlapply(); /* invoke the method */
X return;
X }
X
X /* message not found */
X xlerror("no method for this message",sym);
X}
X
X/* xsendsuper - built-in function 'send-super' */
XLVAL xsendsuper()
X{
X LVAL obj,sym,msg,cls,p;
X
X /* get the message selector */
X sym = xlgasymbol();
X
X /* find the 'self' object */
X for (obj = xlenv; obj; obj = cdr(obj))
X if (ntype(car(obj)) == OBJECT)
X goto find_method;
X xlerror("not in a method",sym);
X
Xfind_method:
X /* get the message class and the 'self' object */
X cls = getivar(getelement(car(cdr(obj)),0),SUPERCLASS);
X obj = car(obj);
X
X /* look for the message in the class or superclasses */
X for (; cls; cls = getivar(cls,SUPERCLASS))
X for (p = getivar(cls,MESSAGES); p; p = cdr(p))
X if ((msg = car(p)) && car(msg) == sym) {
X push(obj); ++xlargc; /* insert 'self' argument */
X xlval = cdr(msg); /* get the method */
X xlapply(); /* invoke the method */
X return;
X }
X
X /* message not found */
X xlerror("no method for this message",sym);
X}
X
X/* obisnew - default 'isnew' method */
XLVAL obisnew()
X{
X LVAL self;
X self = xlgaobject();
X xllastarg();
X return (self);
X}
X
X/* obclass - get the class of an object */
XLVAL obclass()
X{
X LVAL self;
X self = xlgaobject();
X xllastarg();
X return (getclass(self));
X}
X
X/* obshow - show the instance variables of an object */
XLVAL obshow()
X{
X LVAL self,fptr,cls,names;
X int maxi,i;
X
X /* get self and the file pointer */
X self = xlgaobject();
X fptr = (moreargs() ? xlgaoport() : getvalue(s_stdout));
X xllastarg();
X
X /* get the object's class */
X cls = getclass(self);
X
X /* print the object and class */
X xlputstr(fptr,"Object is ");
X xlprin1(self,fptr);
X xlputstr(fptr,", Class is ");
X xlprin1(cls,fptr);
X xlterpri(fptr);
X
X /* print the object's instance variables */
X names = cdr(getivar(cls,IVARS));
X maxi = getivcnt(cls,IVARTOTAL)+1;
X for (i = 2; i <= maxi; ++i) {
X xlputstr(fptr," ");
X xlprin1(car(names),fptr);
X xlputstr(fptr," = ");
X xlprin1(getivar(self,i),fptr);
X xlterpri(fptr);
X names = cdr(names);
X }
X
X /* return the object */
X return (self);
X}
X
X/* clnew - create a new object instance */
XLVAL clnew()
X{
X LVAL self;
X
X /* create a new object */
X self = xlgaobject();
X xlval = newobject(self,getivcnt(self,IVARTOTAL));
X
X /* send the 'isnew' message */
X xlsend(xlval,k_isnew);
X}
X
X/* clisnew - initialize a new class */
XLVAL clisnew()
X{
X LVAL self,ivars,cvars,super;
X int n;
X
X /* get self, the ivars, cvars and superclass */
X self = xlgaobject();
X ivars = xlgalist();
X cvars = (moreargs() ? xlgalist() : NIL);
X super = (moreargs() ? xlgaobject() : object);
X xllastarg();
X
X /* create the class variable name list */
X cpush(cons(xlenter("%%CLASS"),copylists(cvars,NIL)));
X
X /* create the class variable environment */
X xlval = newframe(getivar(super,CVARS),listlength(xlval)+1);
X setelement(car(xlval),0,pop());
X setelement(car(xlval),1,self);
X push(xlval);
X
X /* store the instance and class variable lists and the superclass */
X setivar(self,IVARS,copylists(getivar(super,IVARS),ivars));
X setivar(self,CVARS,pop());
X setivar(self,SUPERCLASS,super);
X
X /* compute the instance variable count */
X n = listlength(ivars);
X setivar(self,IVARCNT,cvfixnum((FIXTYPE)n));
X n += getivcnt(super,IVARTOTAL);
X setivar(self,IVARTOTAL,cvfixnum((FIXTYPE)n));
X
X /* return the new class object */
X return (self);
X}
X
X/* clanswer - define a method for answering a message */
XLVAL clanswer()
X{
X extern LVAL xlfunction();
X LVAL self,msg,fargs,code,mptr;
X
X /* message symbol, formal argument list and code */
X self = xlgaobject();
X msg = xlgasymbol();
X fargs = xlgetarg();
X code = xlgalist();
X xllastarg();
X
X /* make a new message list entry */
X mptr = entermsg(self,msg);
X
X /* add 'self' to the argument list */
X cpush(cons(s_self,fargs));
X
X /* extend the class variable environment with the instance variables */
X xlval = newframe(getivar(self,CVARS),1);
X setelement(car(xlval),0,getivar(self,IVARS));
X
X /* compile and store the method */
X xlval = xlfunction(msg,top(),code,xlval);
X rplacd(mptr,cvmethod(xlval,getivar(self,CVARS)));
X drop(1);
X
X /* return the object */
X return (self);
X}
X
X/* addivar - enter an instance variable */
XLOCAL addivar(cls,var)
X LVAL cls; char *var;
X{
X setivar(cls,IVARS,cons(xlenter(var),getivar(cls,IVARS)));
X}
X
X/* addmsg - add a message to a class */
XLOCAL addmsg(cls,msg,fname)
X LVAL cls; char *msg,*fname;
X{
X LVAL mptr;
X
X /* enter the message selector */
X mptr = entermsg(cls,xlenter(msg));
X
X /* store the method for this message */
X rplacd(mptr,getvalue(xlenter(fname)));
X}
X
X/* entermsg - add a message to a class */
XLOCAL LVAL entermsg(cls,msg)
X LVAL cls,msg;
X{
X LVAL lptr,mptr;
X
X /* lookup the message */
X for (lptr = getivar(cls,MESSAGES); lptr; lptr = cdr(lptr))
X if (car(mptr = car(lptr)) == msg)
X return (mptr);
X
X /* allocate a new message entry if one wasn't found */
X cpush(cons(msg,NIL));
X setivar(cls,MESSAGES,cons(top(),getivar(cls,MESSAGES)));
X
X /* return the symbol node */
X return (pop());
X}
X
X/* getivcnt - get the number of instance variables for a class */
XLOCAL int getivcnt(cls,ivar)
X LVAL cls; int ivar;
X{
X LVAL cnt;
X if ((cnt = getivar(cls,ivar)) == NIL || !fixp(cnt))
X xlerror("bad value for instance variable count",cnt);
X return ((int)getfixnum(cnt));
X}
X
X/* copylist - make a copy of a list */
XLOCAL LVAL copylists(list1,list2)
X LVAL list1,list2;
X{
X LVAL last,next;
X
X /* initialize */
X cpush(NIL); last = NIL;
X
X /* copy the first list */
X for (; consp(list1); list1 = cdr(list1)) {
X next = cons(car(list1),NIL);
X if (last) rplacd(last,next);
X else settop(next);
X last = next;
X }
X
X /* append the second list */
X for (; consp(list2); list2 = cdr(list2)) {
X next = cons(car(list2),NIL);
X if (last) rplacd(last,next);
X else settop(next);
X last = next;
X }
X return (pop());
X}
X
X/* listlength - find the length of a list */
XLOCAL int listlength(list)
X LVAL list;
X{
X int len;
X for (len = 0; consp(list); len++)
X list = cdr(list);
X return (len);
X}
X
X/* obsymbols - initialize symbols */
Xobsymbols()
X{
X /* enter the object related symbols */
X s_self = xlenter("SELF");
X k_isnew = xlenter("ISNEW");
X
X /* get the Object and Class symbol values */
X object = getvalue(xlenter("OBJECT"));
X class = getvalue(xlenter("CLASS"));
X}
X
X/* xloinit - object function initialization routine */
Xxloinit()
X{
X LVAL sym;
X
X /* create the 'Object' object */
X sym = xlenter("OBJECT");
X object = newobject(NIL,CLASSSIZE);
X setvalue(sym,object);
X setivar(object,IVARS,cons(xlenter("%%CLASS"),NIL));
X setivar(object,IVARCNT,cvfixnum((FIXTYPE)0));
X setivar(object,IVARTOTAL,cvfixnum((FIXTYPE)0));
X addmsg(object,"ISNEW","%OBJECT-ISNEW");
X addmsg(object,"CLASS","%OBJECT-CLASS");
X addmsg(object,"SHOW","%OBJECT-SHOW");
X
X /* create the 'Class' object */
X sym = xlenter("CLASS");
X class = newobject(NIL,CLASSSIZE);
X setvalue(sym,class);
X addivar(class,"IVARTOTAL"); /* ivar number 6 */
X addivar(class,"IVARCNT"); /* ivar number 5 */
X addivar(class,"SUPERCLASS");/* ivar number 4 */
X addivar(class,"CVARS"); /* ivar number 3 */
X addivar(class,"IVARS"); /* ivar number 2 */
X addivar(class,"MESSAGES"); /* ivar number 1 */
X setivar(class,IVARS,cons(xlenter("%%CLASS"),getivar(class,IVARS)));
X setivar(class,IVARCNT,cvfixnum((FIXTYPE)CLASSSIZE));
X setivar(class,IVARTOTAL,cvfixnum((FIXTYPE)CLASSSIZE));
X setivar(class,SUPERCLASS,object);
X addmsg(class,"NEW","%CLASS-NEW");
X addmsg(class,"ISNEW","%CLASS-ISNEW");
X addmsg(class,"ANSWER","%CLASS-ANSWER");
X
X /* patch the class into 'object' and 'class' */
X setclass(object,class);
X setclass(class,class);
X}
END_OF_FILE
if test 9292 -ne `wc -c <'Src/xsobj.c'`; then
echo shar: \"'Src/xsobj.c'\" unpacked with wrong size!
fi
# end of 'Src/xsobj.c'
fi
if test -f 'Src/xsread.c' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'Src/xsread.c'\"
else
echo shar: Extracting \"'Src/xsread.c'\" \(9004 characters\)
sed "s/^X//" >'Src/xsread.c' <<'END_OF_FILE'
X/* xsread.c - xscheme input 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 true;
X
X/* external routines */
Xextern double atof();
Xextern ITYPE;
X
X/* forward declarations */
XLVAL read_list(),read_quote(),read_comma(),read_symbol();
XLVAL read_radix(),read_string(),read_special();
X
X/* xlread - read an expression */
Xint xlread(fptr,pval)
X LVAL fptr,*pval;
X{
X int ch;
X
X /* check the next non-blank character */
X while ((ch = scan(fptr)) != EOF)
X switch (ch) {
X case '(':
X *pval = read_list(fptr);
X return (TRUE);
X case ')':
X xlfail("misplaced right paren");
X case '\'':
X *pval = read_quote(fptr,"QUOTE");
X return (TRUE);
X case '`':
X *pval = read_quote(fptr,"QUASIQUOTE");
X return (TRUE);
X case ',':
X *pval = read_comma(fptr);
X return (TRUE);
X case '"':
X *pval = read_string(fptr);
X return (TRUE);
X case '#':
X *pval = read_special(fptr);
X return (TRUE);
X case ';':
X read_comment(fptr);
X break;
X default:
X xlungetc(fptr,ch);
X *pval = read_symbol(fptr);
X return (TRUE);
X }
X return (FALSE);
X}
X
X/* read_list - read a list */
XLOCAL LVAL read_list(fptr)
X LVAL fptr;
X{
X LVAL last,val;
X int ch;
X
X cpush(NIL); last = NIL;
X while ((ch = scan(fptr)) != EOF)
X switch (ch) {
X case ';':
X read_comment(fptr);
X break;
X case ')':
X return (pop());
X default:
X xlungetc(fptr,ch);
X if (!xlread(fptr,&val))
X xlfail("unexpected EOF");
X if (val == xlenter(".")) {
X if (last == NIL)
X xlfail("misplaced dot");
X read_cdr(fptr,last);
X return (pop());
X }
X else {
X val = cons(val,NIL);
X if (last) rplacd(last,val);
X else settop(val);
X last = val;
X }
X break;
X }
X xlfail("unexpected EOF");
X}
X
X/* read_cdr - read the cdr of a dotted pair */
XLOCAL read_cdr(fptr,last)
X LVAL fptr,last;
X{
X LVAL val;
X int ch;
X
X /* read the cdr expression */
X if (!xlread(fptr,&val))
X xlfail("unexpected EOF");
X rplacd(last,val);
X
X /* check for the close paren */
X while ((ch = scan(fptr)) == ';')
X read_comment(fptr);
X if (ch != ')')
X xlfail("missing right paren");
X}
X
X/* read_comment - read a comment (to end of line) */
XLOCAL read_comment(fptr)
X LVAL fptr;
X{
X int ch;
X while ((ch = xlgetc(fptr)) != EOF && ch != '\n')
X ;
X if (ch != EOF) xlungetc(fptr,ch);
X}
X
X/* read_vector - read a vector */
XLOCAL LVAL read_vector(fptr)
X LVAL fptr;
X{
X int len=0,ch,i;
X LVAL last,val;
X
X cpush(NIL); last = NIL;
X while ((ch = scan(fptr)) != EOF)
X switch (ch) {
X case ';':
X read_comment(fptr);
X break;
X case ')':
X val = newvector(len);
X for (last = pop(), i = 0; i < len; ++i, last = cdr(last))
X setelement(val,i,car(last));
X return (val);
X default:
X xlungetc(fptr,ch);
X if (!xlread(fptr,&val))
X xlfail("unexpected EOF");
X val = cons(val,NIL);
X if (last) rplacd(last,val);
X else settop(val);
X last = val;
X ++len;
X break;
X }
X xlfail("unexpected EOF");
X}
X
X/* read_comma - read a unquote or unquote-splicing expression */
XLOCAL LVAL read_comma(fptr)
X LVAL fptr;
X{
X int ch;
X if ((ch = xlgetc(fptr)) == '@')
X return (read_quote(fptr,"UNQUOTE-SPLICING"));
X else {
X xlungetc(fptr,ch);
X return (read_quote(fptr,"UNQUOTE"));
X }
X}
X
X/* read_quote - parse the tail of a quoted expression */
XLOCAL LVAL read_quote(fptr,sym)
X LVAL fptr; char *sym;
X{
X LVAL val;
X if (!xlread(fptr,&val))
X xlfail("unexpected EOF");
X cpush(cons(val,NIL));
X settop(cons(xlenter(sym),top()));
X return (pop());
X}
X
X/* read_symbol - parse a symbol name (or a number) */
XLOCAL LVAL read_symbol(fptr)
X LVAL fptr;
X{
X char buf[STRMAX+1];
X LVAL val;
X if (!getsymbol(fptr,buf))
X xlfail("expecting symbol name");
X return (isnumber(buf,&val) ? val : xlenter(buf));
X}
X
X/* read_string - parse a string */
XLOCAL LVAL read_string(fptr)
X LVAL fptr;
X{
X char buf[STRMAX+1];
X int ch,i;
X
X /* get symbol name */
X for (i = 0; (ch = checkeof(fptr)) != '"'; ) {
X if (ch == '\\')
X ch = checkeof(fptr);
X if (i < STRMAX)
X buf[i++] = ch;
X }
X buf[i] = '\0';
X
X /* return a string */
X return (cvstring(buf));
X}
X
X/* read_special - parse an atom starting with '#' */
XLOCAL LVAL read_special(fptr)
X LVAL fptr;
X{
X char buf[STRMAX+1],buf2[STRMAX+3];
X int ch;
X switch (ch = checkeof(fptr)) {
X case '!':
X if (getsymbol(fptr,buf)) {
X if (strcmp(buf,"TRUE") == 0)
X return (true);
X else if (strcmp(buf,"FALSE") == 0)
X return (NIL);
X else if (strcmp(buf,"NULL") == 0)
X return (NIL);
X else {
X sprintf(buf2,"#!%s",buf);
X return (xlenter(buf2));
X }
X }
X else
X xlfail("expecting symbol after '#!'");
X break;
X case '\\':
X ch = checkeof(fptr); /* get the next character */
X xlungetc(fptr,ch); /* but allow getsymbol to get it also */
X if (getsymbol(fptr,buf)) {
X if (strcmp(buf,"NEWLINE") == 0)
X ch = '\n';
X else if (strcmp(buf,"SPACE") == 0)
X ch = ' ';
X else if (strlen(buf) > 1)
X xlerror("unexpected symbol after '#\\'",cvstring(buf));
X }
X else /* wasn't a symbol, get the character */
X ch = checkeof(fptr);
X return (cvchar(ch));
X case '(':
X return (read_vector(fptr));
X case 'b':
X case 'B':
X return (read_radix(fptr,2));
X case 'o':
X case 'O':
X return (read_radix(fptr,8));
X case 'd':
X case 'D':
X return (read_radix(fptr,10));
X case 'x':
X case 'X':
X return (read_radix(fptr,16));
X default:
X xlungetc(fptr,ch);
X if (getsymbol(fptr,buf)) {
X if (strcmp(buf,"T") == 0)
X return (true);
X else if (strcmp(buf,"F") == 0)
X return (NIL);
X else
X xlerror("unexpected symbol after '#'",cvstring(buf));
X }
X else
X xlerror("unexpected character after '#'",cvchar(xlgetc(fptr)));
X break;
X }
X}
X
X/* read_radix - read a number in a specified radix */
XLOCAL LVAL read_radix(fptr,radix)
X LVAL fptr; int radix;
X{
X FIXTYPE val;
X int ch;
X
X /* get symbol name */
X for (val = (FIXTYPE)0; (ch = xlgetc(fptr)) != EOF && issym(ch); ) {
X if (islower(ch)) ch = toupper(ch);
X if (!isradixdigit(ch,radix))
X xlerror("invalid digit",cvchar(ch));
X val = val * radix + getdigit(ch);
X }
X
X /* save the break character */
X xlungetc(fptr,ch);
X
X /* return the number */
X return (cvfixnum(val));
X}
X
X/* isradixdigit - check to see if a character is a digit in a radix */
XLOCAL int isradixdigit(ch,radix)
X int ch,radix;
X{
X switch (radix) {
X case 2: return (ch >= '0' && ch <= '1');
X case 8: return (ch >= '0' && ch <= '7');
X case 10: return (ch >= '0' && ch <= '9');
X case 16: return ((ch >= '0' && ch <= '9')
X || (ch >= 'A' && ch <= 'F'));
X }
X}
X
X/* getdigit - convert an ascii code to a digit */
XLOCAL int getdigit(ch)
X int ch;
X{
X return (ch <= '9' ? ch - '0' : ch - 'A' + 10);
X}
X
X/* getsymbol - get a symbol name */
XLOCAL int getsymbol(fptr,buf)
X LVAL fptr; char *buf;
X{
X int ch,i;
X
X /* get symbol name */
X for (i = 0; (ch = xlgetc(fptr)) != EOF && issym(ch); )
X if (i < STRMAX)
X buf[i++] = (islower(ch) ? toupper(ch) : ch);
X buf[i] = '\0';
X
X /* save the break character */
X xlungetc(fptr,ch);
X return (buf[0] != '\0');
X}
X
X/* isnumber - check if this string is a number */
XLOCAL int isnumber(str,pval)
X char *str; LVAL *pval;
X{
X int dl,dot,dr;
X char *p;
X
X /* initialize */
X p = str; dl = dot = dr = 0;
X
X /* check for a sign */
X if (*p == '+' || *p == '-')
X p++;
X
X /* check for a string of digits */
X while (isdigit(*p))
X p++, dl++;
X
X /* check for a decimal point */
X if (*p == '.') {
X p++; dot = 1;
X while (isdigit(*p))
X p++, dr++;
X }
X
X /* check for an exponent */
X if ((dl || dr) && *p == 'E') {
X p++; dot = 1;
X
X /* check for a sign */
X if (*p == '+' || *p == '-')
X p++;
X
X /* check for a string of digits */
X while (isdigit(*p))
X p++, dr++;
X }
X
X /* make sure there was at least one digit and this is the end */
X if ((dl == 0 && dr == 0) || *p)
X return (FALSE);
X
X /* convert the string to an integer and return successfully */
X if (pval) {
X if (*str == '+') ++str;
X if (str[strlen(str)-1] == '.') str[strlen(str)-1] = 0;
X *pval = (dot ? cvflonum(atof(str)) : cvfixnum(ICNV(str)));
X }
X return (TRUE);
X}
X
X/* scan - scan for the first non-blank character */
XLOCAL int scan(fptr)
X LVAL fptr;
X{
X int ch;
X
X /* look for a non-blank character */
X while ((ch = xlgetc(fptr)) != EOF && isspace(ch))
X ;
X
X /* return the character */
X return (ch);
X}
X
X/* checkeof - get a character and check for end of file */
XLOCAL int checkeof(fptr)
X LVAL fptr;
X{
X int ch;
X if ((ch = xlgetc(fptr)) == EOF)
X xlfail("unexpected EOF");
X return (ch);
X}
X
X/* issym - is this a symbol character? */
XLOCAL int issym(ch)
X int ch;
X{
X register char *p;
X if (!isspace(ch)) {
X for (p = "()';"; *p != '\0'; )
X if (*p++ == ch)
X return (FALSE);
X return (TRUE);
X }
X return (FALSE);
X}
END_OF_FILE
if test 9004 -ne `wc -c <'Src/xsread.c'`; then
echo shar: \"'Src/xsread.c'\" unpacked with wrong size!
fi
# end of 'Src/xsread.c'
fi
echo shar: End of archive 2 \(of 7\).
cp /dev/null ark2isdone
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.