shithub: mlisp

Download patch

ref: a88cd71d79e142d686b01ff33624a4cc8febb268
parent: e5cbdb2d92963fccf56980ea7a60ecc2b03204cf
author: aap <aap@papnet.eu>
date: Tue Aug 23 13:31:08 EDT 2022 

variable binding; symbol functions; preliminary IO streams; fixes


--- a/Makefile
+++ b/Makefile
@@ -1,6 +1,7 @@
 CFLAGS=-g -Wall -Wextra -DLISP$(bits)
 LDFLAGS=-lm
-lisp: lisp.o subr.o mem.o
+lisp: lisp.o subr.o mem.o io.o
 lisp.o: lisp.h
 subr.o: lisp.h
 mem.o: lisp.h
+io.o: lisp.h
--- /dev/null
+++ b/io.c
@@ -1,0 +1,370 @@
+#include "lisp.h"
+
+Stream sysout, sysin;
+
+void
+initio(void)
+{
+	sysout.type = IO_FILE;
+	sysout.file = stdout;
+	sysin.type = IO_FILE;
+	sysin.file = stdin;
+}
+
+void
+initbuf(Strbuf *buf)
+{
+	buf->buf = nil;
+	buf->pos = 0;
+	buf->len = 0;
+}
+void
+freebuf(Strbuf *buf)
+{
+	free(buf->buf);
+}
+void
+pushchar(Strbuf *buf, char c)
+{
+	if(buf->buf == nil){
+		buf->len = 128;
+		buf->buf = malloc(buf->len);
+	}
+	while(buf->pos >= buf->len){
+		buf->len *= 2;
+		buf->buf = realloc(buf->buf, buf->len);
+	}
+	buf->buf[buf->pos++] = c;
+}
+
+
+/*
+ * output
+ */
+
+void
+prf(char *fmt, ...)
+{
+	char *s, *p;
+	va_list ap;
+	va_start(ap, fmt);
+	s = vsmprint(fmt, ap);
+	va_end(ap);
+	switch(sysout.type){
+	case IO_FILE:
+		fwrite(s, 1, strlen(s), sysout.file);
+		break;
+	case IO_BUF:
+		for(p = s; *p != '\0'; p++)
+			pushchar(&sysout.strbuf, *p);
+		break;
+	}
+	free(s);
+}
+void
+tyo(char c)
+{
+	switch(sysout.type){
+	case IO_FILE:
+		putc(c, sysout.file);
+		break;
+	case IO_BUF:
+		pushchar(&sysout.strbuf, c);
+		break;
+	}
+}
+
+/* figure out whether |...| are needed to print symbol.
+ * TODO: actually fix this */
+static int
+escname(char *s)
+{
+	if(*s == '\0') return 1;
+	for(; *s != '\0'; s++)
+		if(islower(*s) || strchr(" \t\n\r()'#\"", *s))
+			return 1;
+	return 0;
+}
+
+void
+printatom(C *c, int x)
+{
+	if(c == nil)
+		prf("NIL");
+	else if(fixnump(c))
+		prf("%lld", (long long int)c->fix);
+	else if(flonump(c))
+		prf("%f", c->flo);
+	else if(stringp(c)){
+		if(x)
+			prf("%s", c->str);
+		else
+			prf("\"%s\"", c->str);
+	}else{
+		assert(atom(c));
+		for(; c != nil; c = c->d)
+			if(c->a == pname){
+				c = c->d->a;
+				assert(stringp(c));
+				if(!x && escname(c->str))
+					prf("|%s|", c->str);
+				else
+					prf("%s", c->str);
+				return;
+			}
+		prf("%%ATOM%%");
+	}
+}
+
+void
+printsxp(C *c, int x)
+{
+	int fst;
+	if(c != nil && !cellp(c))
+		prf("#%p", ((F*)c)->p);
+	else if(atom(c))
+		printatom(c, x);
+	else{
+		tyo('(');
+		fst = 1;
+		for(; c != nil; c = c->d){
+			if(!cellp(c) || atom(c)){
+				prf(" . ");
+				printsxp(c, x);
+				break;
+			}
+			if(!fst)
+				tyo(' ');
+			printsxp(c->a, x);
+			fst = 0;
+		}
+		tyo(')');
+	}
+}
+
+void
+lprint(C *c)
+{
+	printsxp(c, 0);
+}
+
+void
+princ(C *c)
+{
+	printsxp(c, 1);
+}
+
+/*
+ * input
+ */
+
+int
+tyi(void)
+{
+	switch(sysin.type){
+	case IO_FILE:
+		return getc(sysin.file);
+	case IO_BUF:
+		if(sysin.strbuf.pos >= sysin.strbuf.len)
+			return EOF;
+		return sysin.strbuf.buf[sysin.strbuf.pos++];
+	}
+	return EOF;
+}
+
+static int
+chsp(void)
+{
+	int c;
+	if(sysin.nextc){
+		c = sysin.nextc;
+		sysin.nextc = 0;
+		return c;
+	}
+	c = tyi();
+	// remove comments
+	if(c == ';')
+		while(c != '\n')
+			c = tyi();
+	if(isspace(c))
+		c = ' ';
+	return c;
+}
+
+static int
+ch(void)
+{
+	int c;
+	while(c = chsp(), c == ' ');
+	return c;
+}
+
+C*
+readnum(char *buf)
+{
+	int c;
+	int type;
+	fixnum oct;
+	fixnum dec;
+	flonum flo, fract, div;
+	int sign;
+	int ndigits;
+
+	sign = 1;
+	type = 0;	/* octal */
+	oct = 0;
+	dec = 0;
+	flo = 0.0;
+	fract = 0.0;
+	div = 10.0;
+	ndigits = 0;
+
+
+	c = *buf;
+	if(c == '-' || c == '+'){
+		sign = c == '-' ? -1 : 1;
+		buf++;
+	}
+
+	while(c = *buf++, c != '\0'){
+		if(c >= '0' && c <= '9'){
+			if(type == 0){
+				oct = oct*8 + c-'0';
+				dec = dec*10 + c-'0';
+				flo = flo*10.0 + c-'0';
+			}else{
+				type = 2;	/* float */
+				fract += (c-'0')/div;
+				div *= 10.0;
+			}
+			ndigits++;
+		}else if(c == '.' && type == 0){
+			type = 1;	/* decimal */
+		}else
+			return nil;
+	}
+	if(ndigits == 0)
+		return nil;
+// use decimal default for now
+//	if(type == 0)
+//		return mkfix(sign*oct);
+//	if(type == 1)
+//		return mkfix(sign*dec);
+	if(type == 0 || type == 1)
+		return mkfix(sign*dec);
+	return mkflo(sign*(flo+fract));
+}
+
+C*
+readstr(void)
+{
+	C *s;
+	int c;
+	Strbuf buf;
+
+	initbuf(&buf);
+	while(c = chsp(), c != EOF){
+		// TODO: some escapes
+		if(c == '"')
+			break;
+		pushchar(&buf, c);
+	}
+	pushchar(&buf, '\0');
+	s = mkstr(buf.buf);
+	freebuf(&buf);
+	return s;
+}
+
+C*
+readatom(void)
+{
+	C *atm;
+	int c;
+	Strbuf buf;
+	char *p;
+	int spec, lc;
+
+	spec = 0;
+	lc = 1;
+	initbuf(&buf);
+	while(c = chsp(), c != EOF){
+		if(!spec && strchr(" ()", c)){
+			sysin.nextc = c;
+			break;
+		}
+		if(c == '|'){
+			lc = 0;
+			spec = !spec;
+			continue;
+		}
+		pushchar(&buf, c);
+	}
+	pushchar(&buf, '\0');
+	if(lc)
+		for(p = buf.buf; *p; p++)
+			*p = toupper(*p);
+	if(strcmp(buf.buf, "NIL") == 0){
+		freebuf(&buf);
+		return nil;
+	}
+	atm = readnum(buf.buf);
+	if(atm == nil)
+		atm = intern(buf.buf);
+	freebuf(&buf);
+	return atm;
+}
+
+C*
+readlist(void)
+{
+	int first;
+	int c;
+	C **p;
+
+	first = 1;
+	p = push(nil);
+	while(c = ch(), c != ')'){
+		/* TODO: only valid when next letter is space */
+		if(c == '.'){
+			if(first)
+				err("error: unexpected '.'");
+			*p = readsxp(0);
+			if(c = ch(), c != ')')
+				err("error: expected ')' (got %c)", c);
+			break;
+		}
+		sysin.nextc = c;
+		*p = cons(readsxp(0), nil);
+		p = &(*p)->d;
+		first = 0;
+	}
+	return pop();
+}
+
+C*
+readsxp(int eofok)
+{
+	int c;
+	c = ch();
+	if(c == EOF){
+		if(eofok)
+			return noval;
+		err("error: EOF while reading s-exp");
+	}
+	if(c == '\'')
+		return cons(quote, cons(readsxp(0), nil));
+	if(c == '#'){
+		c = ch();
+		if(c == '\'')
+			return cons(function, cons(readsxp(0), nil));
+		err("expected '");
+	}
+	if(c == ')')
+		err("error: unexpected ')'");
+	if(c == '(')
+		return readlist();
+	if(c == '"')
+		return readstr();
+	sysin.nextc = c;
+	return readatom();
+}
--- a/lisp.c
+++ b/lisp.c
@@ -9,8 +9,6 @@
 }
 #endif
 
-FILE *sysin, *sysout, *syserr;
-
 C *fclist;
 F *fflist;
 C *pdl[PDLSZ];
@@ -35,6 +33,7 @@
 /* some important atoms */
 C *pname;
 C *value;
+C *unbound;	// not interned
 C *expr;
 C *subr;
 C *lsubr;
@@ -56,7 +55,8 @@
 C *star;
 C *digits[10];
 
-jmp_buf tljmp;
+jmp_buf errlabel[10];
+int errsp;
 
 /* print error and jmp back into toplevel */
 void
@@ -64,10 +64,10 @@
 {
 	va_list ap;
 	va_start(ap, fmt);
-	vfprintf(syserr, fmt, ap);
-	fprintf(syserr, "\n");
+	vfprintf(stderr, fmt, ap);
+	fprintf(stderr, "\n");
 	va_end(ap);
-	longjmp(tljmp, 1);
+	longjmp(errlabel[errsp], 1);
 }
 
 void
@@ -75,8 +75,8 @@
 {
 	va_list ap;
 	va_start(ap, fmt);
-	vfprintf(syserr, fmt, ap);
-	fprintf(syserr, "\n");
+	vfprintf(stderr, fmt, ap);
+	fprintf(stderr, "\n");
 	va_end(ap);
 #ifdef PLAN9
 	exits("panic");
@@ -85,6 +85,32 @@
 #endif
 }
 
+void*
+emalloc(ulong size)
+{
+	char *p;
+	p = malloc(size);
+	if(p == nil)
+		panic("out of memory");
+	return p;
+}
+void*
+erealloc(void *p, ulong size)
+{
+	p = realloc(p, size);
+	if(p == nil)
+		panic("out of memory");
+	return p;
+}
+char*
+estrdup(char *s)
+{
+	char *t;
+	t = emalloc(strlen(s)+1);
+	strcpy(t, s);
+	return t;
+}
+
 C**
 push(C *c)
 {
@@ -102,6 +128,10 @@
 	return pdl[--pdp];
 }
 
+/*
+ * Type constructors
+ */
+
 C*
 cons(void *a, C *d)
 {
@@ -159,7 +189,7 @@
 {
 	C *c;
 	c = cons(String, nil);
-	c->str = s;
+	c->str = estrdup(s);
 	return c;
 }
 
@@ -174,6 +204,16 @@
 	return cons(temlis.ca, temlis.cd);
 }
 
+C*
+mksym(char *name)
+{
+	return cons(Atom, cons(pname, cons(mkstr(name), nil)));
+}
+
+/*
+ * Type predicates
+ */
+
 int
 atom(C *c)
 {
@@ -216,6 +256,9 @@
 	return c != nil && c->ap & CAR_ATOM && c->ap & CAR_STR;
 }
 
+/*
+ * Elementary functions
+ */
 
 fixnum
 length(C *c)
@@ -234,7 +277,8 @@
 C*
 get(C *l, C *p)
 {
-	assert(l != nil);
+	if(l == nil || !(listp(l) || symbolp(l)))
+		return nil;
 	for(; l->d != nil; l = l->d->d){
 		assert(listp(l->d));
 		if(l->d->a == p){
@@ -244,17 +288,23 @@
 	}
 	return nil;
 }
+
 C*
-getx(C *l, C *p)
+getpname(C *a)
 {
-	for(l = l->d; l != nil; l = l->d->d)
-		if(l->a == p)
-			return l->d;
-	return nil;
+	return get(a, pname);
 }
 
-/* returns noval instead of evaluating a function */
 C*
+symeval(C *s)
+{
+	for(s = s->d; s != nil; s = s->d->d)
+		if(s->a == value)
+			return s->d->a;
+	return unbound;
+}
+
+C*
 assq(C *x, C *y)
 {
 	for(; y != nil; y = y->d)
@@ -267,7 +317,7 @@
 putprop(C *a, C *val, C *ind)
 {
 	C *tt;
-	if(a == nil || numberp(a))
+	if(a == nil || !symbolp(a))
 		err("error: no p-list");
 	for(tt = a->d; tt != nil; tt = tt->d->d)
 		if(tt->a == ind){
@@ -297,9 +347,7 @@
 pair(C *x, C *y)
 {
 	C *m, **p;
-// TODO: must save here?
-	temlis.b = x;
-	temlis.c = y;
+	// args are GC-safe, only called by apply
 	assert(temlis.a == nil);
 	p = (C**)&temlis.a;
 	while(x != nil && y != nil){
@@ -312,20 +360,18 @@
 		err("error: pair not same length");
 	m = temlis.a;
 	temlis.a = nil;
-	temlis.b = nil;
-	temlis.c = nil;
 	return m;
 }
 
 C*
-intern(char *name)
+findsym(char *name)
 {
 	C *c;
 	C *pn;
-	for(c = oblist; c; c = c->d){
-		if(numberp(c->a))
+	for(c = oblist; c != nil; c = c->d){
+		if(!symbolp(c->a))
 			continue;
-		pn = get(c->a, pname);
+		pn = getpname(c->a);
 		if(pn == nil)
 			continue;
 		assert(stringp(pn));
@@ -332,286 +378,21 @@
 		if(strcmp(pn->str, name) == 0)
 			return c->a;
 	}
-	c = cons(Atom,
-		cons(pname, cons(mkstr(strdup(name)), nil)));
-	oblist = cons(c, oblist);
-	return c;
+	return nil;
 }
 
-/*
- * output
- */
-
-/* figure out whether |...| are needed to print symbol.
- * TODO: actually fix this */
-static int
-specname(char *s)
+C*
+intern(char *name)
 {
-	for(; *s != '\0'; s++)
-		if(islower(*s))
-			return 1;
-	return 0;
-}
-
-void
-printatom(C *c, int x)
-{
-	if(c == nil)
-		fprintf(sysout, "NIL");
-	else if(fixnump(c))
-		fprintf(sysout, "%lld", (long long int)c->fix);
-	else if(flonump(c))
-		fprintf(sysout, "%f", c->flo);
-	else if(stringp(c)){
-		if(x)
-			fprintf(sysout, "%s", c->str);
-		else
-			fprintf(sysout, "\"%s\"", c->str);
-	}else{
-		assert(atom(c));
-		for(; c != nil; c = c->d)
-			if(c->a == pname){
-				c = c->d->a;
-				assert(stringp(c));
-				if(!x && specname(c->str))
-					fprintf(sysout, "|%s|", c->str);
-				else
-					fprintf(sysout, "%s", c->str);
-				return;
-			}
-		fprintf(sysout, "%%ATOM%%");
+	C *c;
+	c = findsym(name);
+	if(c == nil){
+		c = mksym(name);
+		oblist = cons(c, oblist);
 	}
-}
-
-void
-printsxp(C *c, int x)
-{
-	int fst;
-	if(atom(c))
-		printatom(c, x);
-	else{
-		putc('(', sysout);
-		fst = 1;
-		for(; c != nil; c = c->d){
-			if(atom(c)){
-				fprintf(sysout, " . ");
-				printatom(c, x);
-				break;
-			}
-			if(!fst)
-				putc(' ', sysout);
-			lprint(c->a);
-			fst = 0;
-		}
-		putc(')', sysout);
-	}
-}
-
-void
-lprint(C *c)
-{
-	printsxp(c, 0);
-}
-
-void
-princ(C *c)
-{
-	printsxp(c, 1);
-}
-
-/*
- * input
- */
-
-int nextc;
-
-static int
-chsp(void)
-{
-	int c;
-	if(nextc){
-		c = nextc;
-		nextc = 0;
-		return c;
-	}
-	c = getc(sysin);
-	// remove comments
-	if(c == ';')
-		while(c != '\n')
-			c = getc(sysin);
-	if(isspace(c))
-		c = ' ';
 	return c;
 }
 
-static int
-ch(void)
-{
-	int c;
-	while(c = chsp(), c == ' ');
-	return c;
-}
-
-C*
-readnum(char *buf)
-{
-	int c;
-	int type;
-	fixnum oct;
-	fixnum dec;
-	flonum flo, fract, div;
-	int sign;
-	int ndigits;
-
-	sign = 1;
-	type = 0;	/* octal */
-	oct = 0;
-	dec = 0;
-	flo = 0.0;
-	fract = 0.0;
-	div = 10.0;
-	ndigits = 0;
-
-
-	c = *buf;
-	if(c == '-' || c == '+'){
-		sign = c == '-' ? -1 : 1;
-		buf++;
-	}
-
-	while(c = *buf++, c != '\0'){
-		if(c >= '0' && c <= '9'){
-			if(type == 0){
-				oct = oct*8 + c-'0';
-				dec = dec*10 + c-'0';
-				flo = flo*10.0 + c-'0';
-			}else{
-				type = 2;	/* float */
-				fract += (c-'0')/div;
-				div *= 10.0;
-			}
-			ndigits++;
-		}else if(c == '.' && type == 0){
-			type = 1;	/* decimal */
-		}else
-			return nil;
-	}
-	if(ndigits == 0)
-		return nil;
-// use decimal default for now
-//	if(type == 0)
-//		return mkfix(sign*oct);
-//	if(type == 1)
-//		return mkfix(sign*dec);
-	if(type == 0 || type == 1)
-		return mkfix(sign*dec);
-	return mkflo(sign*(flo+fract));
-}
-
-C*
-readstr(void)
-{
-	int c;
-	char buf[128], *p;
-
-	p = buf;
-	while(c = chsp(), c != EOF){
-		// TODO: some escapes
-		if(c == '"')
-			break;
-		*p++ = c;	// TODO: overflow
-	}
-	*p = '\0';
-	return mkstr(strdup(buf));
-}
-
-C*
-readatom(void)
-{
-	C *num;
-	int c;
-	char buf[128], *p;
-	int spec, lc;
-
-	p = buf;
-	spec = 0;
-	lc = 1;
-	while(c = chsp(), c != EOF){
-		if(!spec && strchr(" ()", c)){
-			nextc = c;
-			break;
-		}
-		if(c == '|'){
-			lc = 0;
-			spec = !spec;
-			continue;
-		}
-		*p++ = c;	// TODO: overflow
-	}
-	*p = '\0';
-	if(lc)
-		for(p = buf; *p; p++)
-			*p = toupper(*p);
-	if(strcmp(buf, "NIL") == 0)
-		return nil;
-	num = readnum(buf);
-	return num ? num : intern(buf);
-}
-
-C *readsxp(void);
-
-C*
-readlist(void)
-{
-	int first;
-	int c;
-	C **p;
-
-	first = 1;
-	p = push(nil);
-	while(c = ch(), c != ')'){
-		/* TODO: only valid when next letter is space */
-		if(c == '.'){
-			if(first)
-				err("error: unexpected '.'");
-			*p = readsxp();
-			if(c = ch(), c != ')')
-				err("error: expected ')' (got %c)", c);
-			break;
-		}
-		nextc = c;
-		*p = cons(readsxp(), nil);
-		p = &(*p)->d;
-		first = 0;
-	}
-	return pop();
-}
-
-C*
-readsxp(void)
-{
-	int c;
-	c = ch();
-	if(c == EOF)
-		return noval;
-	if(c == '\'')
-		return cons(quote, cons(readsxp(), nil));
-	if(c == '#'){
-		c = ch();
-		if(c == '\'')
-			return cons(function, cons(readsxp(), nil));
-		err("expected '");
-	}
-	if(c == ')')
-		err("error: unexpected ')'");
-	if(c == '(')
-		return readlist();
-	if(c == '"')
-		return readstr();
-	nextc = c;
-	return readatom();
-}
-
 /*
  * Eval Apply
  */
@@ -718,8 +499,8 @@
 	if(atom(form)){
 		if(tt = assq(form, a), tt != nil)
 			return tt->d;
-		if(tt = getx(form, value), tt != nil)
-			return tt->a;
+		if(tt = symeval(form), tt != unbound)
+			return tt;
 		err("error: no value");
 	}
 	if(form->a == cond)
@@ -867,9 +648,7 @@
 {
 	int i;
 
-	sysin = stdin;
-	sysout = stdout;
-	syserr = stderr;
+	initio();
 
 	gc();
 
@@ -878,6 +657,9 @@
 	pname->d = cons(pname, cons(mkstr("PNAME"), nil));
 	oblist = cons(pname, nil);
 
+	unbound = cons(Atom, cons(pname, cons(mkstr("UNBOUND"), nil)));
+	temlis.unbound = unbound;
+
 	/* Now enable GC */
 	gcen = 1;
 
@@ -918,10 +700,10 @@
 
 	putprop(star, star, value);
 	for(;;){
-		putc('\n', sysout);
+		tyo('\n');
 		lprint(eval(star, nil));
-		putc('\n', sysout);
-		e = readsxp();
+		tyo('\n');
+		e = readsxp(1);
 		if(e == noval)
 			return;
 		e = eval(e, nil);
@@ -937,7 +719,7 @@
 {
 	C *e;
 	for(;;){
-		e = readsxp();
+		e = readsxp(1);
 		if(e == noval)
 			return;
 		eval(e, nil);
@@ -947,16 +729,21 @@
 void
 load(char *filename)
 {
-	FILE *oldin, *f;
+	FILE *f;
+	Stream strsv;
+
 	f = fopen(filename, "r");
 	if(f == nil)
 		return;
-	oldin = sysin;
-	sysin = f;
-	if(setjmp(tljmp))
+
+	strsv = sysin;
+	sysin.type = IO_FILE;
+	sysin.file = f;
+	sysin.nextc = 0;
+	if(setjmp(errlabel[errsp]))
 		exit(1);
 	eval_file();
-	sysin = oldin;
+	sysin = strsv;
 	fclose(f);
 }
 
@@ -976,19 +763,18 @@
 	assert(sizeof(void*) == 8);
 #endif
 
+	errsp = 0;
 	init();
 
 	load("lib.l");
 
-//	lprint(oblist);
-//	fprintf(sysout, "\n");
-
-	if(setjmp(tljmp))
-		fprintf(sysout, "→\n");
+	if(setjmp(errlabel[errsp]))
+		fprintf(stdout, "→\n");
 	pdp = 0;
 	alist = nil;
 	memset(&prog, 0, sizeof(prog));
 	memset(&temlis, 0, sizeof(temlis));
+	temlis.unbound = unbound;
 
 	eval_repl();
 #ifdef PLAN9
--- a/lisp.h
+++ b/lisp.h
@@ -52,8 +52,6 @@
 };
 #endif
 
-extern FILE *sysin, *sysout, *syserr;
-
 /* static storage sizes */
 enum
 {
@@ -125,8 +123,8 @@
 	/* arguments to cons */
 	void *ca;
 	void *cd;
-	/* pname */
-	void *pn;
+	/* uninterned symbol for unbound symbols */
+	C *unbound;
 };
 extern Temlis temlis;
 extern C **alist;
@@ -151,8 +149,9 @@
 extern Prog prog;
 
 extern C *noval;
-extern C *t;
+extern C *pname;
 extern C *value;
+extern C *unbound;
 extern C *expr;
 extern C *subr;
 extern C *lsubr;
@@ -159,6 +158,9 @@
 extern C *fexpr;
 extern C *fsubr;
 extern C *macro;
+extern C *t;
+extern C *quote;
+extern C *function;
 extern C *funarg;
 extern C *cond;
 extern C *set;
@@ -166,8 +168,42 @@
 extern C *go;
 extern C *retrn;
 
+extern jmp_buf errlabel[10];
+extern int errsp;
 void err(char *fmt, ...);
 void panic(char *fmt, ...);
+void *emalloc(ulong size);
+void *erealloc(void *p, ulong size);
+char *estrdup(char *s);
+
+typedef struct Strbuf Strbuf;
+struct Strbuf
+{
+	char *buf;
+	int pos;
+	int len;
+};
+void initbuf(Strbuf *buf);
+void freebuf(Strbuf *buf);
+void pushchar(Strbuf *buf, char c);
+
+enum {
+	IO_FILE,
+	IO_BUF
+};
+typedef struct Stream Stream;
+struct Stream
+{
+	int type;
+	FILE *file;
+	Strbuf strbuf;
+	int nextc;
+};
+extern Stream sysout, sysin;
+void initio(void);
+void prf(char *fmt, ...);
+void tyo(char c);
+
 C **push(C *c);
 C *pop(void);
 
@@ -175,19 +211,27 @@
 F *consw(word fw);
 C *mkfix(fixnum fix);
 C *mkflo(flonum flo);
+C *mkstr(char *s);
 C *mksubr(C *(*subr)(void), int n);
+C *mksym(char *name);
+
 int atom(C *c);
+int symbolp(C *c);
 int fixnump(C *c);
 int flonump(C *c);
 int numberp(C *c);
 int listp(C *c);
 int stringp(C *c);
+
 fixnum length(C *c);
 C *get(C *l, C *p);
+C *getpname(C *a);
+C *symeval(C *s);
 C *assq(C *x, C *y);
 C *putprop(C *l, C *p, C *ind);
+C *findsym(char *name);
 C *intern(char *name);
-C *readsxp(void);
+C *readsxp(int eofok);
 void lprint(C *c);
 void princ(C *c);
 void printatom(C *c, int x);
@@ -195,6 +239,8 @@
 C *evlis(C *m, C *a);
 C *apply(C *fn, C *args, C *a);
 
+int cellp(C *c);
+int fwp(C *c);
 void gc(void);
 
 void initsubr(void);
--- a/mem.c
+++ b/mem.c
@@ -4,6 +4,19 @@
 F fstore[NUMFW];
 word fmark[NUMFW/B2W];
 
+int
+cellp(C *c)
+{
+	return c >= &cstore[0] && c < &cstore[NUMCONS];
+}
+int
+fwp(C *c)
+{
+	F *f = (F*)c;
+	return f>= &fstore[0] && f < &fstore[NUMFW];
+}
+
+
 void
 mark(C *c)
 {
@@ -17,7 +30,7 @@
 
 	/* Mark full word */
 	f = (F*)c;
-	if(f >= &fstore[0] && f < &fstore[NUMFW]){
+	if(fwp(c)){
 		n = f - fstore;
 		fmark[n/B2W] |= (word)1 << n%B2W;
 		return;
@@ -24,7 +37,9 @@
 	}
 
 	/* Must be a cons cell */
-	if(c >= &cstore[0] && c < &cstore[NUMCONS]){
+	if(cellp(c)){
+if(c->a == noval) print("car is NOVAL\n");
+if(c->d == noval) print("cdr is NOVAL\n");
 		if(c->ap & CAR_MARK)
 			return;
 		a = c->a;
@@ -67,6 +82,7 @@
 			if(c->ap & CAR_ATOM){
 				/* special handling for atoms */
 				if(c->ap & CAR_STR)
+print("freeing string <%s>\n", c->str),
 					free(c->str);
 			}
 			c->a = nil;
@@ -93,5 +109,5 @@
 		}
 	}
 
-//	fprintf(syserr, "reclaimed: %d %d\n", nc, nf);
+//	fprintf(stderr, "reclaimed: %d %d\n", nc, nf);
 }
--- a/mkfile
+++ b/mkfile
@@ -6,7 +6,8 @@
 OFILES=\
 	lisp.$O\
 	subr.$O\
-	mem.$O
+	mem.$O\
+	io.$O
 
 HFILES=lisp.h
 
--- a/subr.c
+++ b/subr.c
@@ -125,7 +125,7 @@
 C *car(C *pair){
 	if(pair == nil)
 		return nil;
-	if(numberp(pair))
+	if(!listp(pair))
 		err("error: not a pair");
 	return pair->a;
 }
@@ -132,7 +132,7 @@
 C *cdr(C *pair){
 	if(pair == nil)
 		return nil;
-	if(numberp(pair))
+	if(!listp(pair))
 		err("error: not a pair");
 	return pair->d;
 }
@@ -360,8 +360,8 @@
 	last = nil;
 	for(l = alist[0]; l != nil; l = l->d->d){
 		a = l->a;
-		if(!atom(a))
-			err("error: need atom");
+		if(a == nil || !symbolp(a))
+			err("error: need symbol");
 		last = eval(l->d->a, alist[1]);
 		tt = assq(a, alist[1]);
 		if(tt == nil)
@@ -377,8 +377,8 @@
 	last = nil;
 	for(l = alist[0]; l != nil; l = l->d->d){
 		a = eval(l->a, alist[1]);
-		if(!atom(a))
-			err("error: need atom");
+		if(a == nil || !symbolp(a))
+			err("error: need symbol");
 		last = eval(l->d->a, alist[1]);
 		tt = assq(a, alist[1]);
 		if(tt == nil)
@@ -388,6 +388,17 @@
 	}
 	return last;
 }
+C *boundp_subr(void){
+	if(alist[0] == nil || !symbolp(alist[0]))
+		err("error: need symbol");
+	return symeval(alist[0]) == unbound ? nil : t;
+}
+C *makunbound_subr(void){
+	if(alist[0] == nil || !symbolp(alist[0]))
+		err("error: need symbol");
+	putprop(alist[0], unbound, value);
+	return alist[0];
+}
 
 /* Property list */
 
@@ -394,6 +405,22 @@
 C *get_subr(void){
 	return get(alist[0], alist[1]);
 }
+C *getl_subr(void){
+	C *pl, *l;
+	pl = alist[0];
+	if(pl == nil || !(listp(pl) || symbolp(pl)))
+		return nil;
+	for(pl = pl->d; pl != nil; pl = pl->d->d){
+		assert(listp(pl));
+		for(l = alist[1]; l != nil; l = l->d){
+			if(atom(l))
+				err("error: no list");
+			if(pl->a == l->a)
+				return pl;
+		}
+	}
+	return nil;
+}
 C *putprop_subr(void){
 	return putprop(alist[0], alist[1], alist[2]);
 }
@@ -415,6 +442,84 @@
 	return nil;
 }
 
+C*
+mkchar(char c)
+{
+	char str[2];
+	str[0] = c;
+	str[1] = '\0';
+	return intern(str);
+}
+
+#define NEEDNAME(x) if(symbolp(x)) x = getpname(x); if(!stringp(x)) err("error: not a string")
+
+/* pname/string functions */
+C *samepnamep_subr(void){
+	NEEDNAME(alist[0]);
+	NEEDNAME(alist[1]);
+	return strcmp(alist[0]->str, alist[1]->str) == 0 ? t : nil;
+}
+C *alphalessp_subr(void){
+	NEEDNAME(alist[0]);
+	NEEDNAME(alist[1]);
+	return strcmp(alist[0]->str, alist[1]->str) < 0 ? t : nil;
+}
+C *getchar_subr(void){
+	NEEDNAME(alist[0]);
+	if(!fixnump(alist[1])) err("error: not a number");
+	if(alist[1]->fix < 1 || alist[1]->fix > strlen(alist[0]->str))
+		return nil;
+	return mkchar(alist[0]->str[alist[1]->fix-1]);
+}
+C *intern_subr(void){
+	C *c, *name;
+	name = alist[0];
+	NEEDNAME(name);
+	c = findsym(name->str);
+	if(c == nil){
+		if(symbolp(alist[0]))
+			c = alist[0];
+		else
+			c = mksym(name->str);
+		oblist = cons(c, oblist);
+	}
+	return c;
+}
+C *remob_subr(void){
+	C **c;
+	if(!symbolp(alist[0])) err("error: not a symbol");
+	for(c = &oblist; *c != nil; c = &(*c)->d){
+		if((*c)->a == alist[0]){
+			*c = (*c)->d;
+			break;
+		}
+	}
+	return nil;
+}
+C *gensym_lsubr(void){
+	static int num = 1;
+	static char chr = 'G';
+	char str[6];
+
+	if(largs.nargs == 1){
+		if(symbolp(largs.alist[1])) largs.alist[1] = getpname(largs.alist[1]);
+		if(stringp(largs.alist[1]))
+			chr = largs.alist[1]->str[0];
+		else if(fixnump(largs.alist[1]))
+			num = largs.alist[1]->fix;
+		else
+			err("error: not string or number");
+	}
+
+	str[0] = chr;
+	str[1] = '0' + ((num/1000)%10);
+	str[2] = '0' + ((num/100)%10);
+	str[3] = '0' + ((num/10)%10);
+	str[4] = '0' + (num%10);
+	num++;
+	return mksym(str);
+}
+
 /* Number predicates */
 
 C *zerop_subr(void){
@@ -793,6 +898,119 @@
 		return mkfix((word)alist[0]->fix << alist[1]->fix);
 }
 
+/* Character manipulation */
+
+static C *mkfixchar(char c) { return mkfix(c); }
+static C *str2list(char *str, C *(*f)(char)){
+	C **lp;
+	char *s;
+	lp = push(nil);
+	for(s = str; *s != '\0'; s++){
+		*lp = cons(f(*s), nil);
+		lp = &(*lp)->d;
+	}
+	return pop();
+}
+static Strbuf list2str(C *l){
+	Strbuf buf;
+	if(!listp(l)) err("error: not a list");
+	initbuf(&buf);
+	for(; l != nil; l = l->d){
+		if(atom(l)){
+			freebuf(&buf);
+			err("error: no list");
+		}
+		if(symbolp(l->a))
+			pushchar(&buf, getpname(l->a)->str[0]);
+		else if(fixnump(l->a))
+			pushchar(&buf, l->a->fix);
+		else{
+			freebuf(&buf);
+			err("error: not an ascii character");
+		}
+	}
+	pushchar(&buf, '\0');
+	return buf;
+}
+
+C *ascii_subr(void){
+	if(!fixnump(alist[0])) err("error: not a fixnum");
+	return mkchar(alist[0]->fix);
+}
+C *maknam_subr(void){
+	C *l;
+	Strbuf buf;
+	buf = list2str(alist[0]);
+	l = mksym(buf.buf);
+	freebuf(&buf);
+	return l;
+}
+C *implode_subr(void){
+	alist[0] = maknam_subr();
+	return intern_subr();
+}
+C *explode_aux(void (*prnt)(C*), C *(*f)(char)){
+	C *s;
+	Stream strsv;
+
+	strsv = sysout;
+	sysout.type = IO_BUF;
+	initbuf(&sysout.strbuf);
+	prnt(alist[0]);
+	tyo('\0');
+	s = str2list(sysout.strbuf.buf, f);
+	freebuf(&sysout.strbuf);
+	sysout = strsv;
+	return s;
+}
+C *explode_subr(void){ return explode_aux(lprint, mkchar); }
+C *explodec_subr(void){ return explode_aux(princ, mkchar); }
+C *exploden_subr(void){ return explode_aux(princ, mkfixchar); }
+C *flat_aux(void (*prnt)(C*)){
+	C *s;
+	Stream strsv;
+
+	strsv = sysout;
+	sysout.type = IO_BUF;
+	initbuf(&sysout.strbuf);
+	prnt(alist[0]);
+	tyo('\0');
+	s = mkfix(strlen(sysout.strbuf.buf));
+	freebuf(&sysout.strbuf);
+	sysout = strsv;
+	return s;
+}
+C *flatc_subr(void){ return flat_aux(princ); }
+C *flatsize_subr(void){ return flat_aux(lprint); }
+C *readlist_subr(void){
+	C *l;
+	Strbuf buf;
+	Stream strsv;
+
+	buf = list2str(alist[0]);
+	buf.len = buf.pos;
+	buf.pos = 0;
+
+	strsv = sysin;
+	sysin.type = IO_BUF;
+	sysin.strbuf = buf;
+	sysin.nextc = 0;
+
+	// Be careful to clean up after errors here
+	errsp++;
+	if(setjmp(errlabel[errsp])){
+		errsp--;
+		sysin = strsv;
+		freebuf(&buf);
+		longjmp(errlabel[errsp], 1);
+	}
+	l = readsxp(1);
+	errsp--;
+	sysin = strsv;
+	freebuf(&buf);
+	return l;
+}
+
 /* Mapping */
 
 /* zip is for internal use.
@@ -862,7 +1080,7 @@
 /* IO */
 
 C *read_subr(void){
-	return readsxp();
+	return readsxp(1);
 }
 C *prin1_subr(void){
 	lprint(alist[0]);
@@ -869,8 +1087,9 @@
 	return t;
 }
 C *print_subr(void){
-	fprintf(sysout, "\n");
+	tyo('\n');
 	lprint(alist[0]);
+	tyo(' ');
 	return t;
 }
 C *princ_subr(void){
@@ -878,7 +1097,7 @@
 	return t;
 }
 C *terpri_subr(void){
-	fprintf(sysout, "\n");
+	tyo('\n');
 	return nil;
 }
 
@@ -1046,12 +1265,22 @@
 
 	FSUBR("SETQ", setq_fsubr)
 	FSUBR("SET", set_fsubr)
+	SUBR("BOUNDP", boundp_subr, 1);
+	SUBR("MAKUNBOUND", makunbound_subr, 1);
 
 	SUBR("GET", get_subr, 2)
+	SUBR("GETL", getl_subr, 2)
 	SUBR("PUTPROP", putprop_subr, 3)
 	FSUBR("DEFPROP", defprop_fsubr)
 	SUBR("REMPROP", remprop_subr, 2)
 
+	SUBR("SAMEPNAMEP", samepnamep_subr, 2)
+	SUBR("ALPHALESSP", alphalessp_subr, 2)
+	SUBR("GETCHAR", getchar_subr, 2)
+	SUBR("INTERN", intern_subr, 1)
+	SUBR("REMOB", remob_subr, 1)
+	LSUBR("GENSYM", gensym_lsubr)
+
 	SUBR("ZEROP", zerop_subr, 1)
 	SUBR("PLUSP", plusp_subr, 1)
 	SUBR("MINUSP", minusp_subr, 1)
@@ -1073,6 +1302,16 @@
 	LSUBR("LOGAND", logand_lsubr)
 	LSUBR("LOGXOR", logxor_lsubr)
 	SUBR("LSH", lsh_subr, 2)
+
+	SUBR("ASCII", ascii_subr, 1)
+	SUBR("MAKNAM", maknam_subr, 1)
+	SUBR("IMPLODE", implode_subr, 1)
+	SUBR("EXPLODE", explode_subr, 1)
+	SUBR("EXPLODEC", explodec_subr, 1)
+	SUBR("EXPLODEN", exploden_subr, 1)
+	SUBR("FLATC", flatc_subr, 1)
+	SUBR("FLATSIZE", flatsize_subr, 1)
+	SUBR("READLIST", readlist_subr, 1)
 
 	LSUBR("MAPLIST", maplist_lsubr)
 	LSUBR("MAPCAR", mapcar_lsubr)