From 537aa6e4045a2f87424e22529af81f5e13abcdd0 Mon Sep 17 00:00:00 2001 From: "Javier B. Torres" Date: Sun, 11 Jan 2026 13:25:58 -0300 Subject: [PATCH] sdkhjfdsv --- README.md | 3 +- include/wolflisp.h | 46 +++++++- meson.build | 5 +- src/error.c | 58 ++++++++++ src/interp.c | 99 +++++++++++------ src/lex.c | 117 ++++++++++++++++++++ src/main.c | 30 +++-- src/pair.c | 14 +-- src/prim.c | 269 ++++++++++++++++++++++++++++++++++++++++++--- src/prim.h | 14 +++ src/print.c | 9 +- src/read.c | 80 ++++++++++++++ src/string.c | 0 src/symbol.c | 6 +- src/type.c | 1 + test.lisp | 3 + 16 files changed, 683 insertions(+), 71 deletions(-) create mode 100644 src/error.c create mode 100644 src/lex.c create mode 100644 src/read.c create mode 100644 src/string.c create mode 100644 test.lisp diff --git a/README.md b/README.md index 15b4d47..1288ea7 100644 --- a/README.md +++ b/README.md @@ -1,3 +1,2 @@ # wolflisp - -a lisp but wolfy +a lisp but wolfy. right now it's very minimal... :^) \ No newline at end of file diff --git a/include/wolflisp.h b/include/wolflisp.h index 05dff12..2369679 100644 --- a/include/wolflisp.h +++ b/include/wolflisp.h @@ -1,6 +1,7 @@ #ifndef WOLFLISP_H #define WOLFLISP_H +#include #include #include @@ -107,13 +108,48 @@ typedef struct Gc { } roots; } Gc; +// Error context +typedef struct Er { + jmp_buf handler; + int active; + char message[512]; + struct { + const char *frames[32]; + int count; + } stack; +} Er; + // Interpreter context typedef struct In { Gc gc; St symtab; O env; + Er err; + O t; // the T symbol } In; +enum { + TOK_EOF = 0, + TOK_COMMENT = ';', + TOK_WORD = 'a', + TOK_LPAREN = '(', + TOK_RPAREN = ')', + TOK_STRING = '"', + TOK_QUOTE = '\'', + TOK_DOT = '.', +}; + +#include + +#define LEXER_CAP 1024 + +typedef struct Lx { + int kind; + int cursor; + FILE *input; + char buffer[1024]; +} Lx; + /// * Function declarations // Get the type of an object @@ -136,6 +172,12 @@ V gc_init(Gc *gc); // Finalize a GC context. V gc_finalize(Gc *gc); +void error_init(Er *err); +void error_throw(In *in, const char *fmt, ...); +void error_push_frame(In *in, const char *frame); +void error_pop_frame(In *in); +void error_print(In *in); + // Initialize an interpreter context. V interp_init(In *in); // Finalize an interpreter context. @@ -151,7 +193,7 @@ O interp_eval(In *in, O obj, O env); Sy *intern(St *tab, const char *str, Z len); // Create a pair -O pair_make(Gc *gc, O head, O tail); +O pair_make(In *in, O head, O tail); // Unwrap a pair Pa *pair_unwrap(O obj); @@ -164,4 +206,6 @@ O prim_make(In *in, const char *name, O (*fn)(In *, O, O)); O list_assoc(O key, O alist); O list_reverse(O list); +int nexttoken(Lx *lex); + #endif diff --git a/meson.build b/meson.build index 7d5f4e7..a22f9ca 100644 --- a/meson.build +++ b/meson.build @@ -3,18 +3,21 @@ project( 'c', meson_version : '>= 1.3.0', version : '0.1', - default_options : ['c_std=gnu11', 'buildtype=debugoptimized', 'warning_level=3'], + default_options : ['c_std=c11', 'buildtype=debugoptimized', 'warning_level=3'], ) inc = include_directories('include', 'src') src = [ + 'src/error.c', 'src/gc.c', 'src/interp.c', + 'src/lex.c', 'src/list.c', 'src/main.c', 'src/pair.c', 'src/prim.c', 'src/print.c', + 'src/read.c', 'src/symbol.c', 'src/type.c', ] diff --git a/src/error.c b/src/error.c new file mode 100644 index 0000000..9ab07b4 --- /dev/null +++ b/src/error.c @@ -0,0 +1,58 @@ +#include +#include +#include +#include + +void error_init(Er *err) { + err->active = 0; + err->message[0] = '\0'; + err->stack.count = 0; +} + +void error_throw(In *in, const char *fmt, ...) { + if (!in->err.active) { + // No error handler active, fall back to abort + fprintf(stderr, "fatal error: "); + va_list args; + va_start(args, fmt); + vfprintf(stderr, fmt, args); + va_end(args); + fprintf(stderr, "\n"); + abort(); + } + + // Format error message + va_list args; + va_start(args, fmt); + vsnprintf(in->err.message, 512, fmt, args); + va_end(args); + + // Jump back to error handler + longjmp(in->err.handler, 1); +} + +void error_push_frame(In *in, const char *frame) { + if (in->err.stack.count < 32) { + in->err.stack.frames[in->err.stack.count++] = frame; + } +} + +void error_pop_frame(In *in) { + if (in->err.stack.count > 0) { + in->err.stack.count--; + } +} + +void error_print(In *in) { + fprintf(stderr, "error: %s\n", in->err.message); + + if (in->err.stack.count > 0) { + fprintf(stderr, "stack trace:\n"); + for (int i = in->err.stack.count - 1; i >= 0; i--) { + fprintf(stderr, " %s\n", in->err.stack.frames[i]); + } + } + + // Reset stack for next error + in->err.stack.count = 0; +} diff --git a/src/interp.c b/src/interp.c index 5056d16..a1f2a10 100644 --- a/src/interp.c +++ b/src/interp.c @@ -1,4 +1,3 @@ -#include #include #include @@ -8,14 +7,36 @@ V interp_init(In *in) { memset(&in->symtab, 0, sizeof(St)); gc_init(&in->gc); - + gc_addroot(&in->gc, &in->env); + in->t = symbol_make(in, "t"); in->env = NIL; - in->env = pair_make(&in->gc, prim_make(in, "cons", prim_cons), in->env); - in->env = pair_make(&in->gc, prim_make(in, "head", prim_head), in->env); - in->env = pair_make(&in->gc, prim_make(in, "tail", prim_tail), in->env); - in->env = pair_make(&in->gc, prim_make(in, "quote", prim_quote), in->env); - in->env = pair_make(&in->gc, prim_make(in, "print", prim_print), in->env); - in->env = pair_make(&in->gc, prim_make(in, "println", prim_println), in->env); + in->env = pair_make(in, pair_make(in, in->t, in->t), in->env); + +#define PRIM(name, prim) \ + in->env = pair_make(in, prim_make(in, name, prim), in->env) + + PRIM("progn", prim_progn); + PRIM("def", prim_def); + PRIM("defn", prim_defn); + PRIM("cons", prim_cons); + PRIM("head", prim_head); + PRIM("tail", prim_tail); + PRIM("list", prim_list); + PRIM("quote", prim_quote); + PRIM("print", prim_print); + PRIM("println", prim_println); + PRIM("if", prim_if); + PRIM("+", prim_add); + PRIM("-", prim_sub); + PRIM("*", prim_mul); + PRIM("/", prim_div); + PRIM("<", prim_lt); + PRIM(">", prim_gt); + + PRIM("=", prim_equal); + PRIM("fn", prim_fn); + PRIM("gc", prim_gc); +#undef PRIM } V interp_finalize(In *in) { @@ -23,26 +44,25 @@ V interp_finalize(In *in) { gc_finalize(&in->gc); } -static O bind(Gc *gc, O params, O args, O env) { - I mark = gc_rootmark(gc); - gc_addroot(gc, ¶ms); - gc_addroot(gc, &args); - gc_addroot(gc, &env); +static O bind(In *in, O params, O args, O env) { + I mark = gc_rootmark(&in->gc); + gc_addroot(&in->gc, ¶ms); + gc_addroot(&in->gc, &args); + gc_addroot(&in->gc, &env); O res = env; - gc_addroot(gc, &res); + gc_addroot(&in->gc, &res); while (params != NIL) { if (type(params) == TYPE_SYM) { - O pair = pair_make(gc, params, args); - gc_addroot(gc, &pair); - res = pair_make(gc, pair, res); + O pair = pair_make(in, params, args); + gc_addroot(&in->gc, &pair); + res = pair_make(in, pair, res); break; } if (type(params) != TYPE_PAIR) { - fprintf(stderr, "error: expected proper list or symbol for parameters\n"); - abort(); + error_throw(in, "expected proper list or symbol for parameters"); } Pa *p = pair_unwrap(params); @@ -51,22 +71,21 @@ static O bind(Gc *gc, O params, O args, O env) { O val = NIL; if (args != NIL) { if (type(args) != TYPE_PAIR) { - fprintf(stderr, "error: too many parameters for arguments\n"); - abort(); + error_throw(in, "too many parameters for arguments"); } Pa *a = pair_unwrap(args); val = a->head; args = a->tail; } - O pair = pair_make(gc, sym, val); - gc_addroot(gc, &pair); - res = pair_make(gc, pair, res); + O pair = pair_make(in, sym, val); + gc_addroot(&in->gc, &pair); + res = pair_make(in, pair, res); params = p->tail; } - gc_rootreset(gc, mark); + gc_rootreset(&in->gc, mark); return res; } @@ -86,7 +105,7 @@ static O eval_list(In *in, O list, O env) { while (curr != NIL) { Pa *p = pair_unwrap(curr); O obj = eval(in, p->head, env); - head = pair_make(&in->gc, obj, head); + head = pair_make(in, obj, head); curr = p->tail; } @@ -96,22 +115,32 @@ static O eval_list(In *in, O list, O env) { } static O apply(In *in, O fn, O args, O env) { + I mark = gc_rootmark(&in->gc); + gc_addroot(&in->gc, &fn); + gc_addroot(&in->gc, &args); + gc_addroot(&in->gc, &env); + I ty = type(fn); switch (ty) { case TYPE_PRIM: { Pr *pr = (Pr *)UNTAG(fn); - return pr->fn(in, args, env); + O res = pr->fn(in, args, env); + gc_rootreset(&in->gc, mark); + return res; } case TYPE_CLOS: { + args = eval_list(in, args, env); Gh *hdr = UNBOX(fn); Cl *cl = (Cl *)(hdr + 1); - args = eval_list(in, args, env); - O nenv = bind(&in->gc, cl->args, args, cl->env); + 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 + gc_rootreset(&in->gc, mark); return eval(in, cl->body, nenv); } default: - fprintf(stderr, "tried to call non-function value\n"); - abort(); + error_throw(in, "tried to call non-function value"); + return NIL; } } @@ -120,10 +149,12 @@ static O eval(In *in, O obj, O env) { if (ty == TYPE_SYM) { O pair = list_assoc(obj, env); + if (pair == NIL) { + pair = list_assoc(obj, in->env); + } if (pair == NIL) { Sy *s = (Sy *)UNTAG(obj); - fprintf(stderr, "error: undefined symbol '%.*s'\n", (int)s->len, s->data); - abort(); + error_throw(in, "undefined symbol '%.*s'", (int)s->len, s->data); } return pair_unwrap(pair)->tail; } else if (ty != TYPE_PAIR) { @@ -152,5 +183,5 @@ O interp_eval_list(In *in, O list, O env) { O interp_eval(In *in, O obj, O env) { if (env == NIL) env = in->env; - return eval(in, obj, in->env); + return eval(in, obj, env); } diff --git a/src/lex.c b/src/lex.c new file mode 100644 index 0000000..a0126a2 --- /dev/null +++ b/src/lex.c @@ -0,0 +1,117 @@ +#include +#include + +#include + +// 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: + fprintf(stderr, "unterminated string literal"); + abort(); +} + +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 != EOF; ch = getc(lex->input)) + ; + return nexttoken(lex); + 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; +} diff --git a/src/main.c b/src/main.c index d024013..8cdac9d 100644 --- a/src/main.c +++ b/src/main.c @@ -1,19 +1,31 @@ +#include #include +// TODO: here til I figure out a better interface for this +int read_expr(In *in, Lx *lex, O *result); + int main(void) { In interp; interp_init(&interp); - // Build code - O s_println = symbol_make(&interp, "println"); - O s_quote = symbol_make(&interp, "quote"); + Lx lex = {0, 0, stdin, {0}}; + nexttoken(&lex); - O data = pair_make( - &interp.gc, s_quote, - pair_make(&interp.gc, pair_make(&interp.gc, NUM(1), NUM(2)), NIL)); - - O code = pair_make(&interp.gc, s_println, pair_make(&interp.gc, data, NIL)); - (void)interp_eval(&interp, code, NIL); + while (lex.kind != TOK_EOF) { + O expr = NIL; + I mark = gc_rootmark(&interp.gc); + gc_addroot(&interp.gc, &expr); + if (read_expr(&interp, &lex, &expr) == -1) + break; + if (setjmp(interp.err.handler) == 0) { + interp.err.active = 1; + (void)interp_eval(&interp, expr, NIL); + } else { + error_print(&interp); + } + gc_rootreset(&interp.gc, mark); + nexttoken(&lex); + } interp_finalize(&interp); } diff --git a/src/pair.c b/src/pair.c index b860b0d..cd24e5b 100644 --- a/src/pair.c +++ b/src/pair.c @@ -2,20 +2,20 @@ #include #include -O pair_make(Gc *gc, O head, O tail) { - I mark = gc_rootmark(gc); - gc_addroot(gc, &head); - gc_addroot(gc, &tail); +O pair_make(In *in, O head, O tail) { + I mark = gc_rootmark(&in->gc); + gc_addroot(&in->gc, &head); + gc_addroot(&in->gc, &tail); Z size = sizeof(Gh) + sizeof(Pa); - Gh *hdr = gc_alloc(gc, size); + Gh *hdr = gc_alloc(&in->gc, size); hdr->type = TYPE_PAIR; Pa *pair = (Pa *)(hdr + 1); pair->head = head; pair->tail = tail; - gc_rootreset(gc, mark); + gc_rootreset(&in->gc, mark); return BOX(hdr); } @@ -25,4 +25,4 @@ Pa *pair_unwrap(O obj) { abort(); } return (Pa *)(UNBOX(obj) + 1); -} +} \ No newline at end of file diff --git a/src/prim.c b/src/prim.c index d51f38f..e890fba 100644 --- a/src/prim.c +++ b/src/prim.c @@ -2,43 +2,58 @@ #include #include +static O nextarg(O *list) { + if (*list == NIL) + return NIL; + O arg = pair_unwrap(*list)->head; + *list = pair_unwrap(*list)->tail; + return arg; +} + +static O bool(In *in, I i) { + if (i) + return in->t; + else + return NIL; +} + O prim_make(In *in, const char *name, O (*fn)(In *, O, O)) { Pr *pr = malloc(sizeof(Pr)); pr->name = name; pr->fn = fn; O sym = BOX(TAG(intern(&in->symtab, name, 0), TAG_SYM)); O prim = BOX(TAG(pr, TAG_PRIM)); - return pair_make(&in->gc, sym, prim); + return pair_make(in, sym, prim); } O prim_cons(In *in, O args, O env) { args = interp_eval_list(in, args, env); - O head = pair_unwrap(args)->head; - args = pair_unwrap(args)->tail; - O tail = pair_unwrap(args)->head; - return pair_make(&in->gc, head, tail); + O head = nextarg(&args); + O tail = nextarg(&args); + return pair_make(in, head, tail); } +O prim_list(In *in, O args, O env) { return interp_eval_list(in, args, env); } + O prim_head(In *in, O args, O env) { args = interp_eval_list(in, args, env); - return pair_unwrap(pair_unwrap(args)->head)->head; + return pair_unwrap(nextarg(&args))->head; } O prim_tail(In *in, O args, O env) { args = interp_eval_list(in, args, env); - return pair_unwrap(pair_unwrap(args)->head)->tail; + return pair_unwrap(nextarg(&args))->tail; } O prim_print(In *in, O args, O env) { args = interp_eval_list(in, args, env); - O arg = pair_unwrap(args)->head; - print(arg); + print(nextarg(&args)); return NIL; } O prim_println(In *in, O args, O env) { args = interp_eval_list(in, args, env); - O arg = pair_unwrap(args)->head; + O arg = nextarg(&args); println(arg); return NIL; } @@ -46,8 +61,234 @@ O prim_println(In *in, O args, O env) { O prim_quote(In *in, O args, O env) { (void)in; (void)env; - - if (args == NIL) - return NIL; - return pair_unwrap(args)->head; + return nextarg(&args); +} + +O prim_if(In *in, O args, O env) { + O cond_expr = nextarg(&args); + O then_expr = nextarg(&args); + O else_expr = nextarg(&args); + + if (cond_expr == NIL || then_expr == NIL) { + fprintf(stderr, "if: expected at least 2 arguments\n"); + abort(); + } + + if (interp_eval(in, cond_expr, env) != NIL) { + return interp_eval(in, then_expr, env); + } else { + return interp_eval(in, else_expr, env); + } +} + +O prim_progn(In *in, O args, O env) { + O result = NIL; + for (O expr = nextarg(&args); expr != NIL; expr = nextarg(&args)) + result = interp_eval(in, expr, env); + return result; +} + +O prim_add(In *in, O args, O env) { + args = interp_eval_list(in, args, env); + I result = nextarg(&args); + if (result == NIL) { + return NUM(0); + } else { + result = ORD(result); + } + for (O arg = nextarg(&args); arg != NIL; arg = nextarg(&args)) { + if (!IMM(arg)) { + error_throw(in, "+: non numeric argument"); + } + result += ORD(arg); + } + return NUM(result); +} + +O prim_sub(In *in, O args, O env) { + args = interp_eval_list(in, args, env); + I result = nextarg(&args); + if (result == NIL) { + return NUM(0); + } else { + result = ORD(result); + } + for (O arg = nextarg(&args); arg != NIL; arg = nextarg(&args)) { + if (!IMM(arg)) { + error_throw(in, "-: non numeric argument"); + } + result -= ORD(arg); + } + return NUM(result); +} + +O prim_mul(In *in, O args, O env) { + args = interp_eval_list(in, args, env); + I result = nextarg(&args); + if (result == NIL) { + return NUM(1); + } else { + result = ORD(result); + } + for (O arg = nextarg(&args); arg != NIL; arg = nextarg(&args)) { + if (!IMM(arg)) { + error_throw(in, "*: non numeric argument"); + } + result *= ORD(arg); + } + return NUM(result); +} + +O prim_div(In *in, O args, O env) { + args = interp_eval_list(in, args, env); + I result = nextarg(&args); + if (result == NIL) { + return NUM(1); + } else { + result = ORD(result); + } + for (O arg = nextarg(&args); arg != NIL; arg = nextarg(&args)) { + if (!IMM(arg)) { + error_throw(in, "/: non numeric argument"); + } + if (ORD(arg) == 0) { + error_throw(in, "/: division by zero"); + } + result /= ORD(arg); + } + return NUM(result); +} + +O prim_equal(In *in, O args, O env) { + args = interp_eval_list(in, args, env); + I result = NIL; + + O fst = nextarg(&args); + for (O next = nextarg(&args); next != NIL; next = nextarg(&args)) { + if (fst == next) { + result = in->t; + } else { + return NIL; + } + fst = next; + } + return result; +} + +O prim_lt(In *in, O args, O env) { + args = interp_eval_list(in, args, env); + O fst = nextarg(&args); + O snd = nextarg(&args); + if (IMM(fst) && IMM(snd)) { + return bool(in, ORD(fst) < ORD(snd)); + } else { + error_throw(in, "<: expected numeric arguments"); + return NIL; + }; +} + +O prim_gt(In *in, O args, O env) { + args = interp_eval_list(in, args, env); + O fst = nextarg(&args); + O snd = nextarg(&args); + if (IMM(fst) && IMM(snd)) { + return bool(in, ORD(fst) > ORD(snd)); + } else { + error_throw(in, ">: expected numeric arguments"); + return NIL; + }; +} + +O prim_fn(In *in, O args, O env) { + O params = nextarg(&args); + O body = args; + + I mark = gc_rootmark(&in->gc); + gc_addroot(&in->gc, ¶ms); + gc_addroot(&in->gc, &env); + gc_addroot(&in->gc, &body); + + O progn = symbol_make(in, "progn"); + O body_form = pair_make(in, progn, body); + gc_addroot(&in->gc, &body_form); + + Gh *hdr = gc_alloc(&in->gc, sizeof(Gh) + sizeof(Cl)); + hdr->type = TYPE_CLOS; + Cl *cl = (Cl *)(hdr + 1); + cl->args = params; + cl->env = env; + cl->body = body_form; + + gc_rootreset(&in->gc, mark); + return BOX(hdr); +} + +O prim_gc(In *in, O args, O env) { + (void)in; + (void)args; + (void)env; + gc_collect(&in->gc); + return NIL; +} + +O prim_def(In *in, O args, O env) { + O sym = nextarg(&args); + O val_expr = nextarg(&args); + + if (type(sym) != TYPE_SYM) { + error_throw(in, "def: expected symbol"); + } + + I mark = gc_rootmark(&in->gc); + gc_addroot(&in->gc, &sym); + gc_addroot(&in->gc, &env); + + O val = interp_eval(in, val_expr, env); + gc_addroot(&in->gc, &val); + + O pair = pair_make(in, sym, val); + gc_addroot(&in->gc, &pair); + + in->env = pair_make(in, pair, in->env); + + gc_rootreset(&in->gc, mark); + return sym; +} + +O prim_defn(In *in, O args, O env) { + O sym = nextarg(&args); + O params = nextarg(&args); + O body = args; + + if (type(sym) != TYPE_SYM) { + error_throw(in, "defn: expected symbol"); + } + + I mark = gc_rootmark(&in->gc); + gc_addroot(&in->gc, &sym); + gc_addroot(&in->gc, ¶ms); + gc_addroot(&in->gc, &body); + gc_addroot(&in->gc, &env); + + O progn = symbol_make(in, "progn"); + O body_form = pair_make(in, progn, body); + gc_addroot(&in->gc, &body_form); + + Gh *hdr = gc_alloc(&in->gc, sizeof(Gh) + sizeof(Cl)); + hdr->type = TYPE_CLOS; + Cl *cl = (Cl *)(hdr + 1); + cl->args = params; + cl->env = env; + cl->body = body_form; + + O fn = BOX(hdr); + gc_addroot(&in->gc, &fn); + + O pair = pair_make(in, sym, fn); + gc_addroot(&in->gc, &pair); + + in->env = pair_make(in, pair, in->env); + + gc_rootreset(&in->gc, mark); + return sym; } diff --git a/src/prim.h b/src/prim.h index 093e6e0..6bb3b11 100644 --- a/src/prim.h +++ b/src/prim.h @@ -1,8 +1,22 @@ #include +O prim_progn(In *in, O args, O env); O prim_cons(In *in, O args, O env); O prim_head(In *in, O args, O env); O prim_tail(In *in, O args, O env); +O prim_list(In *in, O args, O env); O prim_quote(In *in, O args, O env); O prim_print(In *in, O args, O env); O prim_println(In *in, O args, O env); +O prim_if(In *in, O args, O env); +O prim_add(In *in, O args, O env); +O prim_sub(In *in, O args, O env); +O prim_mul(In *in, O args, O env); +O prim_div(In *in, O args, O env); +O prim_equal(In *in, O args, O env); +O prim_lt(In *in, O args, O env); +O prim_gt(In *in, O args, O env); +O prim_fn(In *in, O args, O env); +O prim_gc(In *in, O args, O env); +O prim_def(In *in, O args, O env); +O prim_defn(In *in, O args, O env); \ No newline at end of file diff --git a/src/print.c b/src/print.c index 418b653..884b8cd 100644 --- a/src/print.c +++ b/src/print.c @@ -34,7 +34,7 @@ void print_pair(O obj) { void print(O obj) { if (obj == NIL) { - printf("()"); + printf("NIL"); } else if (IMM(obj)) { printf("%" PRIdPTR, ORD(obj)); } else { @@ -55,6 +55,13 @@ void print(O obj) { case TYPE_PAIR: print_pair(obj); break; + case TYPE_CLOS: { + Cl *cl = (Cl *)(h + 1); + printf("<#fn "); + print(cl->args); + printf(">"); + break; + } default: printf("<#obj type=%" PRId32 " @ %p>", h->type, (void *)h); break; diff --git a/src/read.c b/src/read.c new file mode 100644 index 0000000..88bb67c --- /dev/null +++ b/src/read.c @@ -0,0 +1,80 @@ +#include +#include +#include + +static int is_number(const char *str) { + if (*str == '-' || *str == '+') + str++; + if (!*str) + return 0; + while (*str) { + if (!isdigit(*str)) + return 0; + str++; + } + return 1; +} + +int read_expr(In *in, Lx *lex, O *result) { + I mark = gc_rootmark(&in->gc); + gc_addroot(&in->gc, result); + + switch (lex->kind) { + case TOK_EOF: + return -1; + + case TOK_LPAREN: { + nexttoken(lex); + O list = NIL, tail = NIL; + gc_addroot(&in->gc, &list); + gc_addroot(&in->gc, &tail); + + while (lex->kind != TOK_RPAREN && lex->kind != TOK_EOF) { + O elem; + read_expr(in, lex, &elem); + nexttoken(lex); + + O cell = pair_make(in, elem, NIL); + + if (list == NIL) { + list = tail = cell; + } else { + pair_unwrap(tail)->tail = cell; + tail = cell; + } + } + + if (lex->kind != TOK_RPAREN) + error_throw(in, "expected closing parenthesis\n"); + *result = list; + break; + } + + case TOK_QUOTE: { + nexttoken(lex); + O quoted; + read_expr(in, lex, "ed); + O quote_sym = symbol_make(in, "quote"); + *result = pair_make(in, quote_sym, pair_make(in, quoted, NIL)); + break; + } + + case TOK_STRING: + *result = symbol_make(in, lex->buffer); + break; + + case TOK_WORD: + if (is_number(lex->buffer)) { + *result = NUM(atoi(lex->buffer)); + } else { + *result = symbol_make(in, lex->buffer); + } + break; + + default: + error_throw(in, "unexpected token: %c", lex->kind); + } + + gc_rootreset(&in->gc, mark); + return 0; +} diff --git a/src/string.c b/src/string.c new file mode 100644 index 0000000..e69de29 diff --git a/src/symbol.c b/src/symbol.c index 67d049c..ab28c00 100644 --- a/src/symbol.c +++ b/src/symbol.c @@ -6,7 +6,7 @@ #define ALIGN(n) (((n) + 7) & ~7) -static Sy *find(St *tab, U32 hash, Z len) { +static Sy *find(St *tab, const char *str, U32 hash, Z len) { if (tab->capacity == 0) return NULL; @@ -17,6 +17,8 @@ static Sy *find(St *tab, U32 hash, Z len) { return NULL; if (s->hash == hash && s->len == len) return s; + if (memcmp(s->data, str, len) == 0) + return s; ix = (ix + 1) % tab->capacity; } return NULL; @@ -55,7 +57,7 @@ Sy *intern(St *tab, const char *str, Z len) { if (len == 0) len = strlen(str); U32 hash = hashstr(str, len); - Sy *sym = find(tab, hash, len); + Sy *sym = find(tab, str, hash, len); if (sym) return sym; diff --git a/src/type.c b/src/type.c index 49ab75c..1dbd440 100644 --- a/src/type.c +++ b/src/type.c @@ -11,6 +11,7 @@ static const char *typenames[] = { [TYPE_PRIM] = "primitive", [TYPE_PAIR] = "pair", [TYPE_CLOS] = "closure", + [TYPE_CODE] = "code", }; // clang-format on diff --git a/test.lisp b/test.lisp new file mode 100644 index 0000000..f9e1fbf --- /dev/null +++ b/test.lisp @@ -0,0 +1,3 @@ +(defn fib (n) + (if (< n 2) n (+ (fib (- n 1)) (fib (- n 2))))) +(println (fib 10))