ref: a88cd71d79e142d686b01ff33624a4cc8febb268
parent: e5cbdb2d92963fccf56980ea7a60ecc2b03204cf
author: aap <[email protected]>
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)