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 {
|
||||
name = "rufus";
|
||||
packages = with pkgs; [
|
||||
rlwrap
|
||||
gemini-cli-bin
|
||||
vscodium
|
||||
clang-tools
|
||||
meson
|
||||
ninja
|
||||
|
|
|
|||
|
|
@ -133,8 +133,8 @@ static O apply(In *in, O fn, O args, O env) {
|
|||
Gh *hdr = UNBOX(fn);
|
||||
Cl *cl = (Cl *)(hdr + 1);
|
||||
O nenv = bind(in, cl->args, args, cl->env);
|
||||
cl = (Cl *)(UNBOX(fn) +
|
||||
1); // `bind' may have moved the closure if a GC was triggered
|
||||
// `bind' may have moved the closure if a GC was triggered
|
||||
cl = (Cl *)(UNBOX(fn) + 1);
|
||||
gc_rootreset(&in->gc, mark);
|
||||
return eval(in, cl->body, nenv);
|
||||
}
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue