remove old/
This commit is contained in:
parent
537aa6e404
commit
44237a650d
14 changed files with 5 additions and 1122 deletions
|
|
@ -1,9 +0,0 @@
|
||||||
CFLAGS := -std=gnu99 -Og -g -Wpedantic -Wall
|
|
||||||
OBJS := util.o symbol.o object.o gc.o print.o lex.o read.o eval.o main.o
|
|
||||||
|
|
||||||
wscm: $(OBJS)
|
|
||||||
$(CC) $(OBJS) -o wscm
|
|
||||||
|
|
||||||
.PHONY: clean
|
|
||||||
clean:
|
|
||||||
rm -f wscm $(OBJS)
|
|
||||||
|
|
@ -1,14 +0,0 @@
|
||||||
# wolfscheme
|
|
||||||
|
|
||||||
An experiment in how quick I can get from zero to a decent Lisp.
|
|
||||||
Don't know why I called it `wolfscheme`.
|
|
||||||
|
|
||||||
## Day 1:
|
|
||||||
|
|
||||||
- Symbol interning
|
|
||||||
- Garbage collector and cons pairs
|
|
||||||
- Object printing
|
|
||||||
|
|
||||||
## Day 2:
|
|
||||||
|
|
||||||
- Tree-walking evaluator with a few primitives
|
|
||||||
226
old/eval.c
226
old/eval.c
|
|
@ -1,226 +0,0 @@
|
||||||
#include <stdio.h>
|
|
||||||
#include <stdlib.h>
|
|
||||||
|
|
||||||
#include "wscm.h"
|
|
||||||
|
|
||||||
static O listrev(O list) {
|
|
||||||
O prev = NIL;
|
|
||||||
O curr = list;
|
|
||||||
O next;
|
|
||||||
|
|
||||||
while (curr != NIL) {
|
|
||||||
C *c = uncons(curr);
|
|
||||||
next = c->cdr;
|
|
||||||
c->cdr = prev;
|
|
||||||
prev = curr;
|
|
||||||
curr = next;
|
|
||||||
}
|
|
||||||
return prev;
|
|
||||||
}
|
|
||||||
|
|
||||||
O pair_assoc(O v, O env) {
|
|
||||||
while (kind(env) == KIND_CONS) {
|
|
||||||
C *c = uncons(env);
|
|
||||||
O pair = c->car;
|
|
||||||
if (pair == NIL) {
|
|
||||||
env = c->cdr;
|
|
||||||
continue;
|
|
||||||
}
|
|
||||||
if (kind(pair) == KIND_CONS) {
|
|
||||||
C *kv = uncons(pair);
|
|
||||||
if (kv->car == v)
|
|
||||||
return pair;
|
|
||||||
}
|
|
||||||
env = c->cdr;
|
|
||||||
}
|
|
||||||
return NIL;
|
|
||||||
}
|
|
||||||
|
|
||||||
O bind(O params, O args, O env) {
|
|
||||||
I mark = rootmark();
|
|
||||||
addroot(¶ms);
|
|
||||||
addroot(&args);
|
|
||||||
addroot(&env);
|
|
||||||
|
|
||||||
O res = env;
|
|
||||||
addroot(&res);
|
|
||||||
|
|
||||||
while (params != NIL) {
|
|
||||||
if (kind(params) == KIND_SYM) {
|
|
||||||
O pair = cons(params, args);
|
|
||||||
addroot(&pair);
|
|
||||||
res = cons(pair, res);
|
|
||||||
break;
|
|
||||||
}
|
|
||||||
|
|
||||||
if (kind(params) != KIND_CONS) {
|
|
||||||
fprintf(stderr, "error: expected proper list or symbol for parameters\n");
|
|
||||||
abort();
|
|
||||||
}
|
|
||||||
|
|
||||||
C *p = uncons(params);
|
|
||||||
O sym = p->car;
|
|
||||||
|
|
||||||
O val = NIL;
|
|
||||||
if (args != NIL) {
|
|
||||||
if (kind(args) != KIND_CONS) {
|
|
||||||
fprintf(stderr, "error: too many parameters for arguments\n");
|
|
||||||
abort();
|
|
||||||
}
|
|
||||||
C *a = uncons(args);
|
|
||||||
val = a->car;
|
|
||||||
args = a->cdr;
|
|
||||||
}
|
|
||||||
|
|
||||||
O pair = cons(sym, val);
|
|
||||||
addroot(&pair);
|
|
||||||
res = cons(pair, res);
|
|
||||||
|
|
||||||
params = p->cdr;
|
|
||||||
}
|
|
||||||
|
|
||||||
rootreset(mark);
|
|
||||||
return res;
|
|
||||||
}
|
|
||||||
|
|
||||||
O eval(O obj, O env);
|
|
||||||
|
|
||||||
static O evallist(O list, O env) {
|
|
||||||
I mark = rootmark();
|
|
||||||
addroot(&list);
|
|
||||||
addroot(&env);
|
|
||||||
|
|
||||||
O head = NIL;
|
|
||||||
addroot(&head);
|
|
||||||
|
|
||||||
O curr = list;
|
|
||||||
addroot(&curr);
|
|
||||||
|
|
||||||
while (curr != NIL) {
|
|
||||||
C *c = uncons(curr);
|
|
||||||
O val = eval(c->car, env);
|
|
||||||
head = cons(val, head);
|
|
||||||
curr = c->cdr;
|
|
||||||
}
|
|
||||||
|
|
||||||
O res = listrev(head);
|
|
||||||
|
|
||||||
rootreset(mark);
|
|
||||||
return res;
|
|
||||||
}
|
|
||||||
|
|
||||||
/* primitives */
|
|
||||||
|
|
||||||
O prim_cons(O args, O env) {
|
|
||||||
args = evallist(args, env);
|
|
||||||
|
|
||||||
O x = uncons(args)->car;
|
|
||||||
args = uncons(args)->cdr;
|
|
||||||
O y = uncons(args)->car;
|
|
||||||
return cons(x, y);
|
|
||||||
}
|
|
||||||
|
|
||||||
O prim_car(O args, O env) {
|
|
||||||
args = evallist(args, env);
|
|
||||||
O list = uncons(args)->car;
|
|
||||||
return uncons(list)->car;
|
|
||||||
}
|
|
||||||
|
|
||||||
O prim_cdr(O args, O env) {
|
|
||||||
args = evallist(args, env);
|
|
||||||
O list = uncons(args)->car;
|
|
||||||
return uncons(list)->cdr;
|
|
||||||
}
|
|
||||||
|
|
||||||
O prim_quote(O args, O env) {
|
|
||||||
if (args == NIL)
|
|
||||||
return NIL;
|
|
||||||
return uncons(args)->car;
|
|
||||||
}
|
|
||||||
|
|
||||||
O prim_if(O args, O env) {
|
|
||||||
C *ac = uncons(args);
|
|
||||||
O cond = eval(ac->car, env);
|
|
||||||
args = ac->cdr;
|
|
||||||
if (args == NIL)
|
|
||||||
return NIL;
|
|
||||||
ac = uncons(args);
|
|
||||||
if (cond != NIL) {
|
|
||||||
return eval(ac->car, env);
|
|
||||||
} else {
|
|
||||||
if (ac->cdr == NIL)
|
|
||||||
return NIL;
|
|
||||||
return eval(uncons(ac->cdr)->car, env);
|
|
||||||
}
|
|
||||||
}
|
|
||||||
|
|
||||||
O mkprim(const char *name, O (*fn)(O, O)) {
|
|
||||||
P *p = malloc(sizeof(P));
|
|
||||||
p->name = name;
|
|
||||||
p->fn = fn;
|
|
||||||
O sym = BOX(TAG(intern(name, -1), TAG_SYM));
|
|
||||||
O prim = BOX(TAG(p, TAG_PRIM));
|
|
||||||
return cons(sym, prim);
|
|
||||||
}
|
|
||||||
|
|
||||||
V setupenv(O *env) {
|
|
||||||
O t = BOX(TAG(intern("t", 1), TAG_SYM));
|
|
||||||
*env = cons(cons(t, t), *env);
|
|
||||||
|
|
||||||
O nil = BOX(TAG(intern("nil", 3), TAG_SYM));
|
|
||||||
*env = cons(cons(nil, NIL), *env);
|
|
||||||
|
|
||||||
*env = cons(mkprim("cons", prim_cons), *env);
|
|
||||||
*env = cons(mkprim("car", prim_car), *env);
|
|
||||||
*env = cons(mkprim("cdr", prim_cdr), *env);
|
|
||||||
*env = cons(mkprim("quote", prim_quote), *env);
|
|
||||||
*env = cons(mkprim("if", prim_if), *env);
|
|
||||||
}
|
|
||||||
|
|
||||||
O apply(O fn, O args, O env) {
|
|
||||||
I k = kind(fn);
|
|
||||||
switch (k) {
|
|
||||||
case KIND_PRIM: {
|
|
||||||
P *p = (P *)UNTAG(fn);
|
|
||||||
return p->fn(args, env);
|
|
||||||
}
|
|
||||||
case KIND_CLOS: {
|
|
||||||
H *h = UNBOX(fn);
|
|
||||||
L *l = (L *)(h + 1);
|
|
||||||
args = evallist(args, env);
|
|
||||||
O nenv = bind(l->args, args, l->env);
|
|
||||||
return eval(l->body, nenv);
|
|
||||||
}
|
|
||||||
default:
|
|
||||||
fprintf(stderr, "tried to call non-function value\n");
|
|
||||||
abort();
|
|
||||||
}
|
|
||||||
}
|
|
||||||
|
|
||||||
O eval(O obj, O env) {
|
|
||||||
I k = kind(obj);
|
|
||||||
|
|
||||||
if (k == KIND_SYM) {
|
|
||||||
O pair = pair_assoc(obj, env);
|
|
||||||
if (pair == NIL) {
|
|
||||||
S *s = (S *)UNTAG(obj);
|
|
||||||
fprintf(stderr, "error: undefined symbol '%.*s'\n", (int)s->len, s->data);
|
|
||||||
abort();
|
|
||||||
}
|
|
||||||
return uncons(pair)->cdr;
|
|
||||||
} else if (k != KIND_CONS) {
|
|
||||||
return obj;
|
|
||||||
}
|
|
||||||
|
|
||||||
I mark = rootmark();
|
|
||||||
addroot(&obj);
|
|
||||||
addroot(&env);
|
|
||||||
|
|
||||||
C *c = uncons(obj);
|
|
||||||
O fn = eval(c->car, env);
|
|
||||||
addroot(&fn);
|
|
||||||
|
|
||||||
O res = apply(fn, c->cdr, env);
|
|
||||||
rootreset(mark);
|
|
||||||
return res;
|
|
||||||
}
|
|
||||||
136
old/gc.c
136
old/gc.c
|
|
@ -1,136 +0,0 @@
|
||||||
#include <assert.h>
|
|
||||||
#include <stdio.h>
|
|
||||||
#include <string.h>
|
|
||||||
|
|
||||||
#include "inttypes.h"
|
|
||||||
#include "stdlib.h"
|
|
||||||
#include "wscm.h"
|
|
||||||
|
|
||||||
E heap;
|
|
||||||
|
|
||||||
// roots management
|
|
||||||
void addroot(O *ptr) {
|
|
||||||
if (heap.root_count >= heap.root_capacity) {
|
|
||||||
Z cap = heap.root_capacity == 0 ? 16 : heap.root_capacity * 2;
|
|
||||||
O **roots = realloc(heap.roots, cap * sizeof(O *));
|
|
||||||
if (!roots)
|
|
||||||
abort();
|
|
||||||
heap.roots = roots;
|
|
||||||
heap.root_capacity = cap;
|
|
||||||
}
|
|
||||||
heap.roots[heap.root_count++] = ptr;
|
|
||||||
}
|
|
||||||
|
|
||||||
I rootmark(void) { return heap.root_count; }
|
|
||||||
void rootreset(I mark) { heap.root_count = mark; }
|
|
||||||
|
|
||||||
// garbage collection
|
|
||||||
static O copy(H *obj, U8 **freep) {
|
|
||||||
assert(INFROM(obj));
|
|
||||||
assert(obj->type != OBJ_FWD);
|
|
||||||
|
|
||||||
Z sz = ALIGN(obj->size);
|
|
||||||
H *new = (H *)*freep;
|
|
||||||
*freep += sz;
|
|
||||||
memcpy(new, obj, sz);
|
|
||||||
obj->type = OBJ_FWD;
|
|
||||||
O *o = (O *)(obj + 1);
|
|
||||||
*o = BOX(new);
|
|
||||||
return *o;
|
|
||||||
}
|
|
||||||
|
|
||||||
static O forward(O obj, U8 **freep) {
|
|
||||||
if (obj == NIL)
|
|
||||||
return NIL;
|
|
||||||
if (IMM(obj))
|
|
||||||
return obj;
|
|
||||||
if (TYPE(obj) != TAG_GC)
|
|
||||||
return obj;
|
|
||||||
|
|
||||||
H *h = UNBOX(obj);
|
|
||||||
if (!INFROM(h))
|
|
||||||
return obj;
|
|
||||||
|
|
||||||
if (h->type == OBJ_FWD) {
|
|
||||||
O *o = (O *)(h + 1);
|
|
||||||
return *o;
|
|
||||||
} else {
|
|
||||||
return copy(h, freep);
|
|
||||||
}
|
|
||||||
}
|
|
||||||
|
|
||||||
void collect(void) {
|
|
||||||
U8 *freep = heap.to.start;
|
|
||||||
U8 *scan = freep;
|
|
||||||
|
|
||||||
for (I i = 0; i < heap.root_count; i++) {
|
|
||||||
O *o = heap.roots[i];
|
|
||||||
*o = forward(*o, &freep);
|
|
||||||
}
|
|
||||||
|
|
||||||
while (scan < freep) {
|
|
||||||
H *h = (H *)scan;
|
|
||||||
switch (h->type) {
|
|
||||||
case OBJ_CONS: {
|
|
||||||
C *c = (C *)(h + 1);
|
|
||||||
c->car = forward(c->car, &freep);
|
|
||||||
c->cdr = forward(c->cdr, &freep);
|
|
||||||
break;
|
|
||||||
}
|
|
||||||
case OBJ_FWD:
|
|
||||||
fprintf(stderr, "gc internal error: forwarding pointer in to-space\n");
|
|
||||||
abort();
|
|
||||||
default:
|
|
||||||
fprintf(stderr, "gc internal error: junk object type %" PRIdPTR "\n",
|
|
||||||
h->type);
|
|
||||||
abort();
|
|
||||||
}
|
|
||||||
scan += ALIGN(h->size);
|
|
||||||
}
|
|
||||||
|
|
||||||
U8 *tmp_start, *tmp_end;
|
|
||||||
tmp_start = heap.from.start;
|
|
||||||
tmp_end = heap.from.end;
|
|
||||||
|
|
||||||
heap.from = heap.to;
|
|
||||||
heap.from.free = freep;
|
|
||||||
|
|
||||||
heap.to.start = tmp_start;
|
|
||||||
heap.to.end = tmp_end;
|
|
||||||
heap.to.free = tmp_start;
|
|
||||||
}
|
|
||||||
|
|
||||||
// allocation
|
|
||||||
H *alloc(Z sz) {
|
|
||||||
sz = ALIGN(sz);
|
|
||||||
if (heap.from.free + sz > heap.from.end) {
|
|
||||||
collect();
|
|
||||||
if (heap.from.free + sz > heap.from.end) {
|
|
||||||
fprintf(stderr, "out of memory (requested %zu bytes)\n", sz);
|
|
||||||
abort();
|
|
||||||
}
|
|
||||||
}
|
|
||||||
H *p = (H *)heap.from.free;
|
|
||||||
heap.from.free += sz;
|
|
||||||
p->size = sz;
|
|
||||||
return p;
|
|
||||||
}
|
|
||||||
|
|
||||||
void gcinit(void) {
|
|
||||||
heap.from.start = malloc(GC_HEAP_BYTES);
|
|
||||||
if (!heap.from.start)
|
|
||||||
abort();
|
|
||||||
heap.from.free = heap.from.start;
|
|
||||||
heap.from.end = heap.from.start + GC_HEAP_BYTES;
|
|
||||||
|
|
||||||
heap.to.start = malloc(GC_HEAP_BYTES);
|
|
||||||
if (!heap.to.start)
|
|
||||||
abort();
|
|
||||||
heap.to.free = heap.to.start;
|
|
||||||
heap.to.end = heap.to.start + GC_HEAP_BYTES;
|
|
||||||
}
|
|
||||||
|
|
||||||
void gcfinalize(void) {
|
|
||||||
free(heap.from.start);
|
|
||||||
free(heap.to.start);
|
|
||||||
}
|
|
||||||
119
old/lex.c
119
old/lex.c
|
|
@ -1,119 +0,0 @@
|
||||||
|
|
||||||
#include <err.h>
|
|
||||||
#include <stdio.h>
|
|
||||||
#include <stdlib.h>
|
|
||||||
|
|
||||||
#include "wscm.h"
|
|
||||||
|
|
||||||
// helpers
|
|
||||||
static int iswhite(int ch) { return ch == ' ' || ch == '\t' || ch == '\n'; }
|
|
||||||
|
|
||||||
static int isdelim(int ch) {
|
|
||||||
return ch == '(' || ch == ')' || ch == '\'' || ch == ';';
|
|
||||||
}
|
|
||||||
|
|
||||||
static inline void appendchar(Lx *lex, char ch) {
|
|
||||||
if (lex->cursor > LEXER_CAP) {
|
|
||||||
fprintf(stderr, "lexer buffer overflow");
|
|
||||||
abort();
|
|
||||||
}
|
|
||||||
lex->buffer[lex->cursor++] = ch;
|
|
||||||
}
|
|
||||||
|
|
||||||
static int getcws(Lx *lex) {
|
|
||||||
if (feof(lex->input))
|
|
||||||
return EOF;
|
|
||||||
for (;;) {
|
|
||||||
int ch = getc(lex->input);
|
|
||||||
if (iswhite(ch))
|
|
||||||
continue;
|
|
||||||
return ch;
|
|
||||||
}
|
|
||||||
}
|
|
||||||
|
|
||||||
static int scanword(Lx *lex) {
|
|
||||||
int ch = getc(lex->input);
|
|
||||||
for (;;) {
|
|
||||||
if (ch == EOF) {
|
|
||||||
if (lex->cursor == 0)
|
|
||||||
lex->kind = TOK_EOF;
|
|
||||||
appendchar(lex, 0);
|
|
||||||
return lex->kind;
|
|
||||||
} else if (iswhite(ch) || isdelim(ch)) {
|
|
||||||
ungetc(ch, lex->input);
|
|
||||||
appendchar(lex, 0);
|
|
||||||
return lex->kind;
|
|
||||||
} else {
|
|
||||||
appendchar(lex, ch);
|
|
||||||
ch = getc(lex->input);
|
|
||||||
}
|
|
||||||
}
|
|
||||||
}
|
|
||||||
|
|
||||||
static int scanstring(Lx *lex) {
|
|
||||||
int ch;
|
|
||||||
for (;;) {
|
|
||||||
ch = getc(lex->input);
|
|
||||||
switch (ch) {
|
|
||||||
case EOF:
|
|
||||||
goto eof;
|
|
||||||
case '\\':
|
|
||||||
ch = getc(lex->input);
|
|
||||||
if (ch == EOF)
|
|
||||||
goto eof;
|
|
||||||
switch (ch) {
|
|
||||||
case 'n':
|
|
||||||
appendchar(lex, '\n');
|
|
||||||
break;
|
|
||||||
case 't':
|
|
||||||
appendchar(lex, '\t');
|
|
||||||
break;
|
|
||||||
case '"':
|
|
||||||
appendchar(lex, '"');
|
|
||||||
break;
|
|
||||||
}
|
|
||||||
break;
|
|
||||||
case '"':
|
|
||||||
appendchar(lex, 0);
|
|
||||||
return (lex->kind = TOK_STRING);
|
|
||||||
default:
|
|
||||||
appendchar(lex, ch);
|
|
||||||
}
|
|
||||||
}
|
|
||||||
|
|
||||||
eof:
|
|
||||||
errx(1, "unterminated string literal");
|
|
||||||
}
|
|
||||||
|
|
||||||
int nexttoken(Lx *lex) {
|
|
||||||
int ch;
|
|
||||||
lex->cursor = 0;
|
|
||||||
|
|
||||||
if (feof(lex->input)) {
|
|
||||||
lex->kind = TOK_EOF;
|
|
||||||
*lex->buffer = 0;
|
|
||||||
return 0;
|
|
||||||
}
|
|
||||||
|
|
||||||
ch = getcws(lex);
|
|
||||||
switch (ch) {
|
|
||||||
case ';':
|
|
||||||
for (; ch != '\n'; ch = getc(lex->input))
|
|
||||||
appendchar(lex, ch);
|
|
||||||
appendchar(lex, 0);
|
|
||||||
return (lex->kind = TOK_COMMENT);
|
|
||||||
case '(':
|
|
||||||
case ')':
|
|
||||||
case '.':
|
|
||||||
case '\'':
|
|
||||||
return (lex->kind = ch);
|
|
||||||
case '"':
|
|
||||||
return scanstring(lex);
|
|
||||||
default:
|
|
||||||
ungetc(ch, lex->input);
|
|
||||||
lex->kind = TOK_WORD;
|
|
||||||
return scanword(lex);
|
|
||||||
}
|
|
||||||
|
|
||||||
return 0;
|
|
||||||
}
|
|
||||||
23
old/main.c
23
old/main.c
|
|
@ -1,23 +0,0 @@
|
||||||
#include <stdio.h>
|
|
||||||
|
|
||||||
#include "wscm.h"
|
|
||||||
|
|
||||||
int main(void) {
|
|
||||||
gcinit();
|
|
||||||
|
|
||||||
O env = NIL;
|
|
||||||
addroot(&env);
|
|
||||||
setupenv(&env);
|
|
||||||
|
|
||||||
// IF
|
|
||||||
O code = readfile(stdin);
|
|
||||||
addroot(&code);
|
|
||||||
|
|
||||||
// collect();
|
|
||||||
println(code);
|
|
||||||
printf("=> ");
|
|
||||||
println(eval(code, env));
|
|
||||||
|
|
||||||
gcfinalize();
|
|
||||||
return 0;
|
|
||||||
}
|
|
||||||
103
old/object.c
103
old/object.c
|
|
@ -1,103 +0,0 @@
|
||||||
#include <inttypes.h>
|
|
||||||
#include <stdio.h>
|
|
||||||
#include <stdlib.h>
|
|
||||||
|
|
||||||
#include "wscm.h"
|
|
||||||
|
|
||||||
// clang-format off
|
|
||||||
static const char *kindnames[] = {
|
|
||||||
[KIND_NIL] = "nil",
|
|
||||||
[KIND_NUM] = "number",
|
|
||||||
[KIND_SYM] = "symbol",
|
|
||||||
[KIND_PRIM] = "primitive",
|
|
||||||
[KIND_CONS] = "cons",
|
|
||||||
[KIND_CLOS] = "closure",
|
|
||||||
};
|
|
||||||
// clang-format on
|
|
||||||
|
|
||||||
I kind(O obj) {
|
|
||||||
if (obj == NIL)
|
|
||||||
return KIND_NIL;
|
|
||||||
if (IMM(obj))
|
|
||||||
return KIND_NUM;
|
|
||||||
|
|
||||||
switch (TYPE(obj)) {
|
|
||||||
case TAG_SYM:
|
|
||||||
return KIND_SYM;
|
|
||||||
case TAG_PRIM:
|
|
||||||
return KIND_PRIM;
|
|
||||||
case TAG_GC: {
|
|
||||||
H *h = UNBOX(obj);
|
|
||||||
return h->type;
|
|
||||||
}
|
|
||||||
default:
|
|
||||||
fprintf(stderr, "unknown pointer tag %" PRIdPTR "\n", TYPE(obj));
|
|
||||||
abort();
|
|
||||||
}
|
|
||||||
}
|
|
||||||
|
|
||||||
const char *kindname(I k) {
|
|
||||||
if (k >= KIND__MAX)
|
|
||||||
return "??";
|
|
||||||
return kindnames[k];
|
|
||||||
}
|
|
||||||
|
|
||||||
// cons lists
|
|
||||||
O cons(O head, O tail) {
|
|
||||||
I mark = rootmark();
|
|
||||||
addroot(&head);
|
|
||||||
addroot(&tail);
|
|
||||||
|
|
||||||
const Z sz = sizeof(H) + sizeof(C);
|
|
||||||
H *h = alloc(sz);
|
|
||||||
h->size = sz;
|
|
||||||
h->type = OBJ_CONS;
|
|
||||||
|
|
||||||
C *c = (C *)(h + 1);
|
|
||||||
c->car = head;
|
|
||||||
c->cdr = tail;
|
|
||||||
|
|
||||||
rootreset(mark);
|
|
||||||
return BOX(h);
|
|
||||||
}
|
|
||||||
|
|
||||||
C *uncons(O obj) {
|
|
||||||
I k = kind(obj);
|
|
||||||
if (k != KIND_CONS) {
|
|
||||||
fprintf(stderr, "expected cons, got %s\n", kindnames[k]);
|
|
||||||
abort();
|
|
||||||
}
|
|
||||||
H *h = UNBOX(obj);
|
|
||||||
return (C *)(h + 1);
|
|
||||||
}
|
|
||||||
|
|
||||||
// closures
|
|
||||||
O mkclos(O args, O body, O env) {
|
|
||||||
I mark = rootmark();
|
|
||||||
addroot(&args);
|
|
||||||
addroot(&body);
|
|
||||||
addroot(&env);
|
|
||||||
|
|
||||||
const Z sz = sizeof(H) + sizeof(L);
|
|
||||||
H *h = alloc(sz);
|
|
||||||
h->size = sz;
|
|
||||||
h->type = OBJ_CLOS;
|
|
||||||
|
|
||||||
L *l = (L *)(h + 1);
|
|
||||||
l->args = args;
|
|
||||||
l->body = body;
|
|
||||||
l->env = env;
|
|
||||||
|
|
||||||
rootreset(mark);
|
|
||||||
return BOX(h);
|
|
||||||
}
|
|
||||||
|
|
||||||
L *unclos(O obj) {
|
|
||||||
I k = kind(obj);
|
|
||||||
if (k != KIND_CONS) {
|
|
||||||
fprintf(stderr, "expected closure, got %s\n", kindnames[k]);
|
|
||||||
abort();
|
|
||||||
}
|
|
||||||
H *h = UNBOX(obj);
|
|
||||||
return (L *)(h + 1);
|
|
||||||
}
|
|
||||||
71
old/print.c
71
old/print.c
|
|
@ -1,71 +0,0 @@
|
||||||
#include "wscm.h"
|
|
||||||
|
|
||||||
#include <stdio.h>
|
|
||||||
#include <inttypes.h>
|
|
||||||
|
|
||||||
void print(O obj);
|
|
||||||
|
|
||||||
static void printcons(O obj) {
|
|
||||||
O c = obj;
|
|
||||||
I f = 1;
|
|
||||||
|
|
||||||
printf("(");
|
|
||||||
while (c != NIL && !IMM(c)) {
|
|
||||||
H *h = UNBOX(c);
|
|
||||||
if (h->type != OBJ_CONS) {
|
|
||||||
printf(" . ");
|
|
||||||
print(c);
|
|
||||||
printf(")");
|
|
||||||
return;
|
|
||||||
}
|
|
||||||
C *p = (C *)(h + 1);
|
|
||||||
if (!f)
|
|
||||||
printf(" ");
|
|
||||||
f = 0;
|
|
||||||
print(p->car);
|
|
||||||
c = p->cdr;
|
|
||||||
}
|
|
||||||
if (c != NIL) {
|
|
||||||
printf(" . ");
|
|
||||||
print(c);
|
|
||||||
}
|
|
||||||
printf(")");
|
|
||||||
}
|
|
||||||
|
|
||||||
void print(O obj) {
|
|
||||||
if (obj == NIL) {
|
|
||||||
printf("()");
|
|
||||||
} else if (IMM(obj)) {
|
|
||||||
printf("%" PRIdPTR, ORD(obj));
|
|
||||||
} else {
|
|
||||||
void *x = (void *)UNBOX(obj);
|
|
||||||
switch (TYPE(obj)) {
|
|
||||||
case TAG_SYM: {
|
|
||||||
S *s = (S *)((U)x & ~7);
|
|
||||||
printf("%.*s", (int)s->len, s->data);
|
|
||||||
break;
|
|
||||||
}
|
|
||||||
case TAG_PRIM: {
|
|
||||||
P *p = (P *)((U)x & ~7);
|
|
||||||
printf("<#primitive %s>", p->name);
|
|
||||||
break;
|
|
||||||
}
|
|
||||||
default: {
|
|
||||||
H *h = (H *)x;
|
|
||||||
switch (h->type) {
|
|
||||||
case OBJ_CONS:
|
|
||||||
printcons(obj);
|
|
||||||
break;
|
|
||||||
default:
|
|
||||||
printf("<#obj type=%" PRIdPTR " @ %p>", h->type, (void *)h);
|
|
||||||
break;
|
|
||||||
}
|
|
||||||
}
|
|
||||||
}
|
|
||||||
}
|
|
||||||
}
|
|
||||||
|
|
||||||
void println(O obj) {
|
|
||||||
print(obj);
|
|
||||||
putchar('\n');
|
|
||||||
}
|
|
||||||
156
old/read.c
156
old/read.c
|
|
@ -1,156 +0,0 @@
|
||||||
#include <stdio.h>
|
|
||||||
#include <stdlib.h>
|
|
||||||
#include <string.h>
|
|
||||||
|
|
||||||
#include "wscm.h"
|
|
||||||
|
|
||||||
static O read(Lx *lex);
|
|
||||||
|
|
||||||
static void skipcomments(Lx *lex) {
|
|
||||||
while (lex->kind == TOK_COMMENT) {
|
|
||||||
if (!nexttoken(lex))
|
|
||||||
break;
|
|
||||||
}
|
|
||||||
}
|
|
||||||
|
|
||||||
static O makeobject(Lx *lex) {
|
|
||||||
if (lex->kind == TOK_WORD) {
|
|
||||||
char *tok = lex->buffer;
|
|
||||||
char *end;
|
|
||||||
long v = strtol(tok, &end, 10);
|
|
||||||
if (end != tok && *end == '\0') {
|
|
||||||
nexttoken(lex);
|
|
||||||
return NUM((I)v);
|
|
||||||
} else {
|
|
||||||
S *s = intern(tok, (I)strlen(tok));
|
|
||||||
O sym = BOX(TAG(s, TAG_SYM));
|
|
||||||
nexttoken(lex);
|
|
||||||
return sym;
|
|
||||||
}
|
|
||||||
} else if (lex->kind == TOK_STRING) {
|
|
||||||
// TODO: string type
|
|
||||||
char *tok = lex->buffer;
|
|
||||||
S *s = intern(tok, (I)strlen(tok));
|
|
||||||
O sym = BOX(TAG(s, TAG_SYM));
|
|
||||||
nexttoken(lex);
|
|
||||||
return sym;
|
|
||||||
}
|
|
||||||
return NIL;
|
|
||||||
}
|
|
||||||
|
|
||||||
static void lastcdr(O list, O cdr_val) {
|
|
||||||
O curr = list;
|
|
||||||
while (1) {
|
|
||||||
C *c = uncons(curr);
|
|
||||||
if (c->cdr == NIL) {
|
|
||||||
c->cdr = cdr_val;
|
|
||||||
return;
|
|
||||||
}
|
|
||||||
curr = c->cdr;
|
|
||||||
}
|
|
||||||
}
|
|
||||||
|
|
||||||
static O readlist(Lx *lex) {
|
|
||||||
nexttoken(lex);
|
|
||||||
skipcomments(lex);
|
|
||||||
|
|
||||||
if (lex->kind == TOK_RPAREN) {
|
|
||||||
nexttoken(lex);
|
|
||||||
return NIL;
|
|
||||||
}
|
|
||||||
|
|
||||||
O head = NIL;
|
|
||||||
while (lex->kind != TOK_EOF) {
|
|
||||||
skipcomments(lex);
|
|
||||||
if (lex->kind == TOK_RPAREN) {
|
|
||||||
nexttoken(lex);
|
|
||||||
break;
|
|
||||||
}
|
|
||||||
|
|
||||||
if (lex->kind == TOK_DOT) {
|
|
||||||
nexttoken(lex);
|
|
||||||
skipcomments(lex);
|
|
||||||
if (lex->kind == TOK_EOF) {
|
|
||||||
fprintf(stderr, "reader error: unexpected EOF after '.'\n");
|
|
||||||
abort();
|
|
||||||
}
|
|
||||||
O cdr_val = read(lex);
|
|
||||||
skipcomments(lex);
|
|
||||||
if (lex->kind != TOK_RPAREN) {
|
|
||||||
fprintf(stderr, "reader error: expected ')' after dotted pair cdr\n");
|
|
||||||
abort();
|
|
||||||
}
|
|
||||||
nexttoken(lex);
|
|
||||||
O normal = listreverse(head);
|
|
||||||
if (normal == NIL) {
|
|
||||||
fprintf(stderr, "reader error: '.' with no preceding elements\n");
|
|
||||||
abort();
|
|
||||||
}
|
|
||||||
lastcdr(normal, cdr_val);
|
|
||||||
return normal;
|
|
||||||
}
|
|
||||||
O elem = read(lex);
|
|
||||||
head = cons(elem, head);
|
|
||||||
skipcomments(lex);
|
|
||||||
}
|
|
||||||
|
|
||||||
return listreverse(head);
|
|
||||||
}
|
|
||||||
|
|
||||||
static O readquote(Lx *lex) {
|
|
||||||
nexttoken(lex);
|
|
||||||
skipcomments(lex);
|
|
||||||
O e = read(lex);
|
|
||||||
O qsym = BOX(TAG(intern("quote", -1), TAG_SYM));
|
|
||||||
return cons(qsym, cons(e, NIL));
|
|
||||||
}
|
|
||||||
|
|
||||||
static O read(Lx *lex) {
|
|
||||||
skipcomments(lex);
|
|
||||||
|
|
||||||
switch (lex->kind) {
|
|
||||||
case TOK_EOF:
|
|
||||||
return NIL;
|
|
||||||
case TOK_LPAREN:
|
|
||||||
return readlist(lex);
|
|
||||||
case TOK_QUOTE:
|
|
||||||
return readquote(lex);
|
|
||||||
case TOK_WORD:
|
|
||||||
case TOK_STRING:
|
|
||||||
return makeobject(lex);
|
|
||||||
case TOK_COMMENT:
|
|
||||||
nexttoken(lex);
|
|
||||||
return read(lex);
|
|
||||||
default:
|
|
||||||
nexttoken(lex);
|
|
||||||
return NIL;
|
|
||||||
}
|
|
||||||
}
|
|
||||||
|
|
||||||
O readfile(FILE *f) {
|
|
||||||
if (!f)
|
|
||||||
return NIL;
|
|
||||||
|
|
||||||
Lx lex;
|
|
||||||
lex.kind = TOK_EOF;
|
|
||||||
lex.cursor = 0;
|
|
||||||
lex.input = f;
|
|
||||||
lex.buffer[0] = '\0';
|
|
||||||
|
|
||||||
nexttoken(&lex);
|
|
||||||
skipcomments(&lex);
|
|
||||||
|
|
||||||
if (lex.kind == TOK_EOF)
|
|
||||||
return NIL;
|
|
||||||
return read(&lex);
|
|
||||||
}
|
|
||||||
|
|
||||||
O readstring(const char *s) {
|
|
||||||
if (!s)
|
|
||||||
return NIL;
|
|
||||||
size_t len = strlen(s);
|
|
||||||
FILE *f = fmemopen((void *)s, len, "r");
|
|
||||||
O res = readfile(f);
|
|
||||||
fclose(f);
|
|
||||||
return res;
|
|
||||||
}
|
|
||||||
81
old/symbol.c
81
old/symbol.c
|
|
@ -1,81 +0,0 @@
|
||||||
#include <stdlib.h>
|
|
||||||
#include <string.h>
|
|
||||||
|
|
||||||
#include "wscm.h"
|
|
||||||
|
|
||||||
St syms = {0, 0, NULL};
|
|
||||||
|
|
||||||
static S *findsym(const char *str, Z len, U32 hash) {
|
|
||||||
if (syms.capacity == 0)
|
|
||||||
return NULL;
|
|
||||||
|
|
||||||
Z ix = hash % syms.capacity;
|
|
||||||
for (Z i = 0; i < syms.capacity; i++) {
|
|
||||||
S *s = syms.data[ix];
|
|
||||||
if (!s)
|
|
||||||
return NULL;
|
|
||||||
if (s->hash == hash && s->len == len)
|
|
||||||
return s;
|
|
||||||
ix = (ix + 1) % syms.capacity;
|
|
||||||
}
|
|
||||||
return NULL;
|
|
||||||
}
|
|
||||||
|
|
||||||
static void symtabresize(void) {
|
|
||||||
Z cap = syms.capacity;
|
|
||||||
if (cap == 0) {
|
|
||||||
syms.capacity = 16;
|
|
||||||
} else {
|
|
||||||
syms.capacity *= 2;
|
|
||||||
}
|
|
||||||
S **nb = calloc(syms.capacity, sizeof(S *));
|
|
||||||
for (Z i = 0; i < cap; i++) {
|
|
||||||
if (syms.data[i]) {
|
|
||||||
S *s = syms.data[i];
|
|
||||||
Z ix = s->hash % syms.capacity;
|
|
||||||
while (nb[ix])
|
|
||||||
ix = (ix + 1) % syms.capacity;
|
|
||||||
nb[ix] = s;
|
|
||||||
}
|
|
||||||
}
|
|
||||||
if (syms.data != NULL)
|
|
||||||
free(syms.data);
|
|
||||||
syms.data = nb;
|
|
||||||
}
|
|
||||||
|
|
||||||
U32 hashstring(const char *data, I len) {
|
|
||||||
U32 hash = 2166136261u;
|
|
||||||
for (I i = 0; i < len; i++) {
|
|
||||||
hash ^= (uint8_t)data[i];
|
|
||||||
hash *= 16777619u;
|
|
||||||
}
|
|
||||||
return hash;
|
|
||||||
}
|
|
||||||
|
|
||||||
S *intern(const char *str, I len) {
|
|
||||||
if (len < 0)
|
|
||||||
len = strlen(str);
|
|
||||||
|
|
||||||
U32 hash = hashstring(str, len);
|
|
||||||
S *s = findsym(str, len, hash);
|
|
||||||
if (s)
|
|
||||||
return s;
|
|
||||||
|
|
||||||
s = malloc(sizeof(S));
|
|
||||||
s->data = malloc(len);
|
|
||||||
memcpy(s->data, str, len);
|
|
||||||
s->len = len;
|
|
||||||
s->hash = hash;
|
|
||||||
|
|
||||||
if (syms.count + 1 > syms.capacity)
|
|
||||||
symtabresize();
|
|
||||||
|
|
||||||
Z ix = hash % syms.capacity;
|
|
||||||
while (syms.data[ix])
|
|
||||||
ix = (ix + 1) % syms.capacity;
|
|
||||||
|
|
||||||
syms.data[ix] = s;
|
|
||||||
syms.count++;
|
|
||||||
|
|
||||||
return s;
|
|
||||||
}
|
|
||||||
16
old/util.c
16
old/util.c
|
|
@ -1,16 +0,0 @@
|
||||||
#include "wscm.h"
|
|
||||||
|
|
||||||
O listreverse(O list) {
|
|
||||||
O prev = NIL;
|
|
||||||
O curr = list;
|
|
||||||
O next;
|
|
||||||
|
|
||||||
while (curr != NIL) {
|
|
||||||
C *c = uncons(curr);
|
|
||||||
next = c->cdr;
|
|
||||||
c->cdr = prev;
|
|
||||||
prev = curr;
|
|
||||||
curr = next;
|
|
||||||
}
|
|
||||||
return prev;
|
|
||||||
}
|
|
||||||
166
old/wscm.h
166
old/wscm.h
|
|
@ -1,166 +0,0 @@
|
||||||
#include <stddef.h>
|
|
||||||
#include <stdint.h>
|
|
||||||
|
|
||||||
// common types
|
|
||||||
typedef void V;
|
|
||||||
|
|
||||||
typedef uintptr_t U;
|
|
||||||
typedef intptr_t I;
|
|
||||||
|
|
||||||
typedef uint8_t U8;
|
|
||||||
typedef uint32_t U32;
|
|
||||||
typedef int32_t I32;
|
|
||||||
typedef size_t Z;
|
|
||||||
|
|
||||||
// objects
|
|
||||||
typedef uintptr_t O;
|
|
||||||
|
|
||||||
// cons pair
|
|
||||||
typedef struct C C;
|
|
||||||
struct C {
|
|
||||||
O car, cdr;
|
|
||||||
};
|
|
||||||
|
|
||||||
// lambda
|
|
||||||
typedef struct L L;
|
|
||||||
struct L {
|
|
||||||
O args, body, env;
|
|
||||||
};
|
|
||||||
|
|
||||||
// symbol
|
|
||||||
typedef struct S S;
|
|
||||||
struct S {
|
|
||||||
U8 *data;
|
|
||||||
U32 hash;
|
|
||||||
Z len;
|
|
||||||
};
|
|
||||||
|
|
||||||
// symbol table
|
|
||||||
typedef struct St St;
|
|
||||||
struct St {
|
|
||||||
I count;
|
|
||||||
Z capacity;
|
|
||||||
S **data;
|
|
||||||
};
|
|
||||||
|
|
||||||
#define TYPE_MASK 7
|
|
||||||
|
|
||||||
enum {
|
|
||||||
TAG_GC = 0, // GC-managed object
|
|
||||||
TAG_NUM = 1, // Immediate number
|
|
||||||
TAG_SYM = 2, // Pointer to symbol
|
|
||||||
TAG_PRIM = 4, // Pointer to primitive
|
|
||||||
};
|
|
||||||
|
|
||||||
enum {
|
|
||||||
KIND_NIL = 0,
|
|
||||||
KIND_NUM = 1,
|
|
||||||
KIND_SYM = 2,
|
|
||||||
KIND_PRIM = 4,
|
|
||||||
KIND_CONS = 5,
|
|
||||||
KIND_CLOS = 6,
|
|
||||||
KIND__MAX,
|
|
||||||
};
|
|
||||||
|
|
||||||
#define TYPE(x) (((U)(x)) & TYPE_MASK)
|
|
||||||
#define UNTAG(x) (((U)(x)) & ~TYPE_MASK)
|
|
||||||
#define TAG(x, t) (void *)(((U)(x)) | t)
|
|
||||||
|
|
||||||
enum { OBJ_CONS = 5, OBJ_CLOS = 6, OBJ_FWD = 7 };
|
|
||||||
|
|
||||||
// gc header
|
|
||||||
typedef struct H H;
|
|
||||||
struct H {
|
|
||||||
I type;
|
|
||||||
Z size;
|
|
||||||
};
|
|
||||||
|
|
||||||
// heap
|
|
||||||
typedef struct E E;
|
|
||||||
struct E {
|
|
||||||
struct {
|
|
||||||
U8 *start, *end;
|
|
||||||
U8 *free;
|
|
||||||
} from, to;
|
|
||||||
|
|
||||||
I root_count;
|
|
||||||
Z root_capacity;
|
|
||||||
O **roots;
|
|
||||||
};
|
|
||||||
|
|
||||||
// primitive
|
|
||||||
typedef struct P P;
|
|
||||||
struct P {
|
|
||||||
const char *name;
|
|
||||||
O (*fn)(O, O);
|
|
||||||
};
|
|
||||||
|
|
||||||
extern E heap;
|
|
||||||
extern St syms;
|
|
||||||
|
|
||||||
#define ALIGN(n) (((n) + 7) & ~7)
|
|
||||||
#define INFROM(x) \
|
|
||||||
(((const U8 *)x) >= heap.from.start && ((const U8 *)x) < heap.from.end)
|
|
||||||
|
|
||||||
#define IMM(x) ((x) & 1)
|
|
||||||
#define NUM(x) (((O)((I)(x) << 1)) | (O)1)
|
|
||||||
#define ORD(x) ((I)(x) >> 1)
|
|
||||||
#define BOX(x) ((O)(x))
|
|
||||||
#define UNBOX(x) ((H *)(x))
|
|
||||||
|
|
||||||
#define SYM(s) BOX(TAG(intern(s, -1), TAG_SYM))
|
|
||||||
|
|
||||||
#define NIL ((O)0)
|
|
||||||
#define GC_HEAP_BYTES (1024 * 1024)
|
|
||||||
|
|
||||||
// GC
|
|
||||||
void addroot(O *ptr);
|
|
||||||
I rootmark(void);
|
|
||||||
void rootreset(I mark);
|
|
||||||
void collect(void);
|
|
||||||
H *alloc(Z sz);
|
|
||||||
void gcinit(void);
|
|
||||||
void gcfinalize(void);
|
|
||||||
|
|
||||||
I kind(O obj);
|
|
||||||
const char *kindname(I k);
|
|
||||||
|
|
||||||
S *intern(const char *str, I len);
|
|
||||||
O mksym(const char *str);
|
|
||||||
|
|
||||||
O cons(O head, O tail);
|
|
||||||
C *uncons(O obj);
|
|
||||||
|
|
||||||
O listreverse(O list);
|
|
||||||
|
|
||||||
V setupenv(O *env);
|
|
||||||
O eval(O obj, O env);
|
|
||||||
|
|
||||||
void print(O obj);
|
|
||||||
void println(O obj);
|
|
||||||
|
|
||||||
enum {
|
|
||||||
TOK_EOF = 0,
|
|
||||||
TOK_COMMENT = ';',
|
|
||||||
TOK_WORD = 'a',
|
|
||||||
TOK_LPAREN = '(',
|
|
||||||
TOK_RPAREN = ')',
|
|
||||||
TOK_STRING = '"',
|
|
||||||
TOK_QUOTE = '\'',
|
|
||||||
TOK_DOT = '.',
|
|
||||||
};
|
|
||||||
|
|
||||||
#include <stdio.h>
|
|
||||||
|
|
||||||
#define LEXER_CAP 1024
|
|
||||||
|
|
||||||
typedef struct Lx {
|
|
||||||
int kind;
|
|
||||||
int cursor;
|
|
||||||
FILE *input;
|
|
||||||
char buffer[1024];
|
|
||||||
} Lx;
|
|
||||||
|
|
||||||
int nexttoken(Lx *lex);
|
|
||||||
O readfile(FILE *f);
|
|
||||||
O readstring(const char *s);
|
|
||||||
|
|
@ -2,6 +2,9 @@
|
||||||
pkgs.mkShell {
|
pkgs.mkShell {
|
||||||
name = "rufus";
|
name = "rufus";
|
||||||
packages = with pkgs; [
|
packages = with pkgs; [
|
||||||
|
rlwrap
|
||||||
|
gemini-cli-bin
|
||||||
|
vscodium
|
||||||
clang-tools
|
clang-tools
|
||||||
meson
|
meson
|
||||||
ninja
|
ninja
|
||||||
|
|
|
||||||
|
|
@ -133,8 +133,8 @@ static O apply(In *in, O fn, O args, O env) {
|
||||||
Gh *hdr = UNBOX(fn);
|
Gh *hdr = UNBOX(fn);
|
||||||
Cl *cl = (Cl *)(hdr + 1);
|
Cl *cl = (Cl *)(hdr + 1);
|
||||||
O nenv = bind(in, cl->args, args, cl->env);
|
O nenv = bind(in, cl->args, args, cl->env);
|
||||||
cl = (Cl *)(UNBOX(fn) +
|
// `bind' may have moved the closure if a GC was triggered
|
||||||
1); // `bind' may have moved the closure if a GC was triggered
|
cl = (Cl *)(UNBOX(fn) + 1);
|
||||||
gc_rootreset(&in->gc, mark);
|
gc_rootreset(&in->gc, mark);
|
||||||
return eval(in, cl->body, nenv);
|
return eval(in, cl->body, nenv);
|
||||||
}
|
}
|
||||||
|
|
|
||||||
Loading…
Add table
Add a link
Reference in a new issue