diff options
| author | LLLL Colonq <llll@colonq> | 2026-08-14 14:51:01 -0400 |
|---|---|---|
| committer | LLLL Colonq <llll@colonq> | 2026-08-14 14:51:01 -0400 |
| commit | fece4fc3d4decb70c94b49ab854fa9ae93b4d887 (patch) | |
| tree | 71e355aaae2381078d0a403f89abfc6e6d7343f6 | |
| parent | 7b9c4a3ac265026d98624ac614eead866a190042 (diff) | |
pit: More VM-style evaluation
| -rw-r--r-- | pit/Makefile | 2 | ||||
| -rw-r--r-- | pit/include/lcq/pit/runtime.h | 1 | ||||
| -rw-r--r-- | pit/include/lcq/pit/runtime/compile.h | 9 | ||||
| -rw-r--r-- | pit/include/lcq/pit/runtime/eval.h | 3 | ||||
| -rw-r--r-- | pit/include/lcq/pit/runtime/value/func.h | 3 | ||||
| -rw-r--r-- | pit/src/library.c | 126 | ||||
| -rw-r--r-- | pit/src/native.c | 43 | ||||
| -rw-r--r-- | pit/src/runtime.c | 3 | ||||
| -rw-r--r-- | pit/src/runtime/compile.c | 222 | ||||
| -rw-r--r-- | pit/src/runtime/eval.c | 238 | ||||
| -rw-r--r-- | pit/src/runtime/macroexpand.c | 31 | ||||
| -rw-r--r-- | pit/src/runtime/value/func.c | 133 | ||||
| -rw-r--r-- | pit/test/test4.pit | 5 |
13 files changed, 383 insertions, 436 deletions
diff --git a/pit/Makefile b/pit/Makefile index 2802d2e..2f74aba 100644 --- a/pit/Makefile +++ b/pit/Makefile @@ -12,7 +12,7 @@ SRCS_CORE := \ src/utils.c src/arena.c src/lexer.c src/parser.c src/runtime.c \ src/runtime/value.c \ src/runtime/value/small.c src/runtime/value/cell.c src/runtime/value/cons.c src/runtime/value/array.c src/runtime/value/bytes.c src/runtime/value/func.c src/runtime/value/nativedata.c \ - src/runtime/symtab.c src/runtime/dump.c src/runtime/macroexpand.c src/runtime/eval.c src/runtime/gc.c \ + src/runtime/symtab.c src/runtime/dump.c src/runtime/macroexpand.c src/runtime/compile.c src/runtime/eval.c src/runtime/gc.c \ src/library.c OBJECTS_CORE := $(SRCS_CORE:src/%.c=$(BUILD)/%.o) LIB_CORE := libcolonq-pit.a diff --git a/pit/include/lcq/pit/runtime.h b/pit/include/lcq/pit/runtime.h index 075d94c..70e65ca 100644 --- a/pit/include/lcq/pit/runtime.h +++ b/pit/include/lcq/pit/runtime.h @@ -98,6 +98,7 @@ void pit_repl(pit_runtime *rt); #include <lcq/pit/runtime/symtab.h> #include <lcq/pit/runtime/dump.h> #include <lcq/pit/runtime/macroexpand.h> +#include <lcq/pit/runtime/compile.h> #include <lcq/pit/runtime/eval.h> #include <lcq/pit/runtime/gc.h> diff --git a/pit/include/lcq/pit/runtime/compile.h b/pit/include/lcq/pit/runtime/compile.h new file mode 100644 index 0000000..ba0acb3 --- /dev/null +++ b/pit/include/lcq/pit/runtime/compile.h @@ -0,0 +1,9 @@ +#ifndef LCOLONQ_PIT_RUNTIME_COMPILE_H +#define LCOLONQ_PIT_RUNTIME_COMPILE_H + +#include <lcq/pit/runtime.h> + +pit_value pit_compile(pit_runtime *rt, pit_value top); +void pit_compile_install_special_forms(pit_runtime *rt); + +#endif diff --git a/pit/include/lcq/pit/runtime/eval.h b/pit/include/lcq/pit/runtime/eval.h index 41ec046..27df557 100644 --- a/pit/include/lcq/pit/runtime/eval.h +++ b/pit/include/lcq/pit/runtime/eval.h @@ -3,7 +3,8 @@ #include <lcq/pit/runtime.h> -pit_value pit_vm_compile(pit_runtime *rt, pit_value top); +bool pit_vm_run_one(pit_runtime *rt); pit_value pit_vm_eval(pit_runtime *rt, pit_value v); +pit_value pit_vm_apply(pit_runtime *rt, pit_value f, pit_value args); #endif diff --git a/pit/include/lcq/pit/runtime/value/func.h b/pit/include/lcq/pit/runtime/value/func.h index 852c90d..5855047 100644 --- a/pit/include/lcq/pit/runtime/value/func.h +++ b/pit/include/lcq/pit/runtime/value/func.h @@ -7,9 +7,8 @@ /* heavy value - func / nativefunc */ bool pit_value_is_func(pit_runtime *rt, pit_value a); bool pit_value_is_nativefunc(pit_runtime *rt, pit_value a); -pit_value pit_value_func_lambda(pit_runtime *rt, pit_value args, pit_value body); +pit_value pit_value_func_lambda(pit_runtime *rt, pit_value args, pit_value freevars, pit_value compiled); pit_value pit_value_nativefunc_new_with_data(pit_runtime *rt, pit_nativefunc f, void *data); pit_value pit_value_nativefunc_new(pit_runtime *rt, pit_nativefunc f); -pit_value pit_value_apply(pit_runtime *rt, pit_value f, pit_value args); #endif diff --git a/pit/src/library.c b/pit/src/library.c index e70a705..6e87255 100644 --- a/pit/src/library.c +++ b/pit/src/library.c @@ -4,68 +4,6 @@ #include <lcq/pit/runtime.h> #include <lcq/pit/library.h> -static pit_value impl_sf_quote(pit_runtime *rt, pit_value args, void *data) { - (void) data; - pit_traversal_push_value(rt, rt->traversal, - pit_value_list(rt, 2, pit_symtab_intern_cstr(rt, "literal"), pit_value_cons_car(rt, args)) - ); - return PIT_NIL; -} -static pit_value impl_sf_if(pit_runtime *rt, pit_value args, void *data) { - (void) data; - // TODO - // pit_value c = pit_value_cons_car(rt, args); - // if (pit_eval(rt, c) != PIT_NIL) { - // if (pit_vec_push(pit_value)(rt->expr_stack, pit_value_cons_car(rt, pit_value_cons_cdr(rt, args))) < 0) - // pit_error(rt, "in special form \"if\": evaluation stack overflow"); - // } else { - // if (pit_vec_push(pit_value)(rt->expr_stack, pit_value_cons_car(rt, pit_value_cons_cdr(rt, pit_value_cons_cdr(rt, args)))) < 0) - // pit_error(rt, "in special form \"if\": evaluation stack overflow"); - // } - return PIT_NIL; -} -static pit_value impl_sf_cond(pit_runtime *rt, pit_value args, void *data) { - (void) data; - // TODO - // while (args != PIT_NIL) { - // pit_value clause = pit_value_cons_car(rt, args); - // pit_value cond = pit_value_cons_car(rt, clause); - // if (pit_eval(rt, cond) != PIT_NIL) { - // if (pit_vec_push(pit_value)(rt->expr_stack, pit_value_cons(rt, pit_symtab_intern_cstr(rt, "progn"), pit_value_cons_cdr(rt, clause))) < 0) - // pit_error(rt, "in special form \"cond\": evaluation stack overflow"); - // return PIT_NIL; - // } - // args = pit_value_cons_cdr(rt, args); - // } - // if (pit_vec_push(pit_value)(rt->expr_stack, PIT_NIL) < 0) - // pit_error(rt, "in special form \"cond\": evaluation stack overflow"); - return PIT_NIL; -} -static pit_value impl_sf_or(pit_runtime *rt, pit_value args, void *data) { - (void) data; - // TODO - // pit_value bodyforms = args; - // pit_value final = PIT_NIL; - // while (bodyforms != PIT_NIL) { - // final = pit_eval(rt, pit_value_cons_car(rt, bodyforms)); - // if (final != PIT_NIL) break; - // bodyforms = pit_value_cons_cdr(rt, bodyforms); - // } - // pit_traversal_push_value(rt, rt->traversal, final); - return PIT_NIL; -} -static pit_value impl_sf_lambda(pit_runtime *rt, pit_value args, void *data) { - (void) data; - pit_value as = pit_value_cons_car(rt, args); - pit_value body = pit_value_cons_cdr(rt, args); - pit_traversal_push_value(rt, rt->traversal, - pit_value_list(rt, 2, - pit_symtab_intern_cstr(rt, "literal"), - pit_value_func_lambda(rt, as, body) - ) - ); - return PIT_NIL; -} static pit_value impl_m_defun(pit_runtime *rt, pit_value args, void *data) { (void) data; pit_value nm = pit_value_cons_car(rt, args); @@ -77,6 +15,7 @@ static pit_value impl_m_defun(pit_runtime *rt, pit_value args, void *data) { pit_value_cons(rt, pit_symtab_intern_cstr(rt, "lambda"), pit_value_cons(rt, as, body)) ); } + static pit_value impl_m_defmacro(pit_runtime *rt, pit_value args, void *data) { (void) data; pit_value nm = pit_value_cons_car(rt, args); @@ -86,6 +25,7 @@ static pit_value impl_m_defmacro(pit_runtime *rt, pit_value args, void *data) { pit_value_list(rt, 2, pit_symtab_intern_cstr(rt, "set-symbol-macro!"), nm) ); } + static pit_value impl_m_defstruct(pit_runtime *rt, pit_value args, void *data) { (void) data; pit_value ret = PIT_NIL; @@ -192,6 +132,7 @@ static pit_value impl_m_let(pit_runtime *rt, pit_value args, void *data) { application = pit_value_cons(rt, lambda, largs); return application; } + static pit_value impl_m_and(pit_runtime *rt, pit_value args, void *data) { (void) data; pit_value ret = PIT_NIL; @@ -201,11 +142,24 @@ static pit_value impl_m_and(pit_runtime *rt, pit_value args, void *data) { args = pit_value_cons_cdr(rt, args); } while (args != PIT_NIL) { - ret = pit_value_list(rt, 3, pit_symtab_intern_cstr(rt, "if"), pit_value_cons_car(rt, args), ret, PIT_NIL); + ret = pit_value_list(rt, 4, pit_symtab_intern_cstr(rt, "if"), pit_value_cons_car(rt, args), ret, PIT_NIL); + args = pit_value_cons_cdr(rt, args); + } + return ret; +} + +static pit_value impl_m_or(pit_runtime *rt, pit_value args, void *data) { + (void) data; + pit_value ret = PIT_NIL; + args = pit_value_list_reverse(rt, args); + while (args != PIT_NIL) { + pit_value v = pit_value_cons_car(rt, args); + ret = pit_value_list(rt, 4, pit_symtab_intern_cstr(rt, "if"), v, v, ret); args = pit_value_cons_cdr(rt, args); } return ret; } + static pit_value impl_m_setq(pit_runtime *rt, pit_value args, void *data) { (void) data; pit_value sym = pit_value_cons_car(rt, args); @@ -217,6 +171,22 @@ static pit_value impl_m_setq(pit_runtime *rt, pit_value args, void *data) { ); } +static pit_value impl_m_cond(pit_runtime *rt, pit_value args, void *data) { + (void) data; + pit_value ret = PIT_NIL; + pit_value clauses = pit_value_list_reverse(rt, args); + while (clauses != PIT_NIL) { + pit_value c = pit_value_cons_car(rt, clauses); + ret = pit_value_list(rt, 4, pit_symtab_intern_cstr(rt, "if"), + pit_value_cons_car(rt, c), + pit_value_cons_car(rt, pit_value_cons_cdr(rt, c)), + ret + ); + clauses = pit_value_cons_cdr(rt, clauses); + } + return ret; +} + // (case x (y 'foo) (z 'bar)) // (cond ((eq x 'y) 'foo) ((eq x 'z) 'bar)) static pit_value impl_m_case(pit_runtime *rt, pit_value args, void *data) { @@ -224,7 +194,7 @@ static pit_value impl_m_case(pit_runtime *rt, pit_value args, void *data) { pit_value x = pit_value_cons_car(rt, args); pit_value cases = pit_value_cons_cdr(rt, args); pit_value clauses = PIT_NIL; - pit_value xvar = pit_symtab_intern_cstr(rt, "(internal case)"); + pit_value xvar = pit_symtab_intern_cstr(rt, "<<internal case>>"); while (cases != PIT_NIL) { pit_value c = pit_value_cons_car(rt, cases); clauses = pit_value_cons(rt, @@ -278,13 +248,13 @@ static pit_value impl_symbol_mark_macro(pit_runtime *rt, pit_value args, void *d static pit_value impl_funcall(pit_runtime *rt, pit_value args, void *data) { (void) data; pit_value f = pit_value_cons_car(rt, args); - return pit_value_apply(rt, f, pit_value_cons_cdr(rt, args)); + return pit_vm_apply(rt, f, pit_value_cons_cdr(rt, args)); } static pit_value impl_apply(pit_runtime *rt, pit_value args, void *data) { (void) data; pit_value f = pit_value_cons_car(rt, args); pit_value xs = pit_value_cons_car(rt, pit_value_cons_cdr(rt, args)); - return pit_value_apply(rt, f, xs); + return pit_vm_apply(rt, f, xs); } static pit_value impl_error(pit_runtime *rt, pit_value args, void *data) { (void) data; @@ -460,7 +430,7 @@ static pit_value impl_list_map(pit_runtime *rt, pit_value args, void *data) { pit_value xs = pit_value_cons_car(rt, pit_value_cons_cdr(rt, args)); pit_value ret = PIT_NIL; while (xs != PIT_NIL) { - pit_value y = pit_value_apply(rt, func, pit_value_cons(rt, pit_value_cons_car(rt, xs), PIT_NIL)); + pit_value y = pit_vm_apply(rt, func, pit_value_cons(rt, pit_value_cons_car(rt, xs), PIT_NIL)); ret = pit_value_cons(rt, y, ret); xs = pit_value_cons_cdr(rt, xs); } @@ -472,7 +442,7 @@ static pit_value impl_list_foldl(pit_runtime *rt, pit_value args, void *data) { pit_value acc = pit_value_cons_car(rt, pit_value_cons_cdr(rt, args)); pit_value xs = pit_value_cons_car(rt, pit_value_cons_cdr(rt, pit_value_cons_cdr(rt, args))); while (xs != PIT_NIL) { - acc = pit_value_apply(rt, func, pit_value_list(rt, 2, pit_value_cons_car(rt, xs), acc)); + acc = pit_vm_apply(rt, func, pit_value_list(rt, 2, pit_value_cons_car(rt, xs), acc)); xs = pit_value_cons_cdr(rt, xs); } return acc; @@ -484,7 +454,7 @@ static pit_value impl_list_filter(pit_runtime *rt, pit_value args, void *data) { pit_value ret = PIT_NIL; while (xs != PIT_NIL) { pit_value x = pit_value_cons_car(rt, xs); - pit_value y = pit_value_apply(rt, func, pit_value_cons(rt, x, PIT_NIL)); + pit_value y = pit_vm_apply(rt, func, pit_value_cons(rt, x, PIT_NIL)); if (y != PIT_NIL) { ret = pit_value_cons(rt, x, ret); } @@ -498,7 +468,7 @@ static pit_value impl_list_find(pit_runtime *rt, pit_value args, void *data) { pit_value xs = pit_value_cons_car(rt, pit_value_cons_cdr(rt, args)); while (xs != PIT_NIL) { pit_value x = pit_value_cons_car(rt, xs); - pit_value y = pit_value_apply(rt, func, pit_value_cons(rt, x, PIT_NIL)); + pit_value y = pit_vm_apply(rt, func, pit_value_cons(rt, x, PIT_NIL)); if (y != PIT_NIL) { return x; } @@ -522,7 +492,7 @@ static pit_value impl_list_all_p(pit_runtime *rt, pit_value args, void *data) { pit_value xs = pit_value_cons_car(rt, pit_value_cons_cdr(rt, args)); while (xs != PIT_NIL) { pit_value x = pit_value_cons_car(rt, xs); - if (pit_value_apply(rt, f, pit_value_cons(rt, x, PIT_NIL)) == PIT_NIL) { + if (pit_vm_apply(rt, f, pit_value_cons(rt, x, PIT_NIL)) == PIT_NIL) { return PIT_NIL; } xs = pit_value_cons_cdr(rt, xs); @@ -536,7 +506,7 @@ static pit_value impl_list_zip_with(pit_runtime *rt, pit_value args, void *data) pit_value ys = pit_value_cons_car(rt, pit_value_cons_cdr(rt, pit_value_cons_cdr(rt, args))); pit_value ret = PIT_NIL; while (xs != PIT_NIL && ys != PIT_NIL) { - pit_value z = pit_value_apply(rt, f, pit_value_list(rt, 2, pit_value_cons_car(rt, xs), pit_value_cons_car(rt, ys))); + pit_value z = pit_vm_apply(rt, f, pit_value_list(rt, 2, pit_value_cons_car(rt, xs), pit_value_cons_car(rt, ys))); ret = pit_value_cons(rt, z, ret); xs = pit_value_cons_cdr(rt, xs); ys = pit_value_cons_cdr(rt, ys); } @@ -653,7 +623,7 @@ static pit_value impl_array_map(pit_runtime *rt, pit_value args, void *data) { pit_value ret = pit_value_array_new(rt, len); i64 i = 0; for (i = 0; i < len; ++i) { - pit_value y = pit_value_apply(rt, func, pit_value_cons(rt, pit_value_array_get(rt, arr, i), PIT_NIL)); + pit_value y = pit_vm_apply(rt, func, pit_value_cons(rt, pit_value_array_get(rt, arr, i), PIT_NIL)); pit_value_array_set(rt, ret, i, y); } return ret; @@ -665,7 +635,7 @@ static pit_value impl_array_map_mut(pit_runtime *rt, pit_value args, void *data) i64 len = pit_value_array_len(rt, arr); i64 i = 0; for (i = 0; i < len; ++i) { - pit_value y = pit_value_apply(rt, func, pit_value_cons(rt, pit_value_array_get(rt, arr, i), PIT_NIL)); + pit_value y = pit_vm_apply(rt, func, pit_value_cons(rt, pit_value_array_get(rt, arr, i), PIT_NIL)); pit_value_array_set(rt, arr, i, y); } return arr; @@ -797,19 +767,15 @@ static pit_value impl_bitwise_rshift(pit_runtime *rt, pit_value args, void *data return pit_value_integer_new(rt, val); } void pit_install_library_essential(pit_runtime *rt) { - /* special forms */ - pit_symtab_sfset(rt, pit_symtab_intern_cstr(rt, "quote"), pit_value_nativefunc_new(rt, impl_sf_quote)); - pit_symtab_sfset(rt, pit_symtab_intern_cstr(rt, "if"), pit_value_nativefunc_new(rt, impl_sf_if)); - pit_symtab_sfset(rt, pit_symtab_intern_cstr(rt, "cond"), pit_value_nativefunc_new(rt, impl_sf_cond)); - pit_symtab_sfset(rt, pit_symtab_intern_cstr(rt, "or"), pit_value_nativefunc_new(rt, impl_sf_or)); - pit_symtab_sfset(rt, pit_symtab_intern_cstr(rt, "lambda"), pit_value_nativefunc_new(rt, impl_sf_lambda)); /* macros */ pit_symtab_mset(rt, pit_symtab_intern_cstr(rt, "defun!"), pit_value_nativefunc_new(rt, impl_m_defun)); pit_symtab_mset(rt, pit_symtab_intern_cstr(rt, "defmacro!"), pit_value_nativefunc_new(rt, impl_m_defmacro)); pit_symtab_mset(rt, pit_symtab_intern_cstr(rt, "defstruct!"), pit_value_nativefunc_new(rt, impl_m_defstruct)); pit_symtab_mset(rt, pit_symtab_intern_cstr(rt, "let"), pit_value_nativefunc_new(rt, impl_m_let)); pit_symtab_mset(rt, pit_symtab_intern_cstr(rt, "and"), pit_value_nativefunc_new(rt, impl_m_and)); + pit_symtab_mset(rt, pit_symtab_intern_cstr(rt, "or"), pit_value_nativefunc_new(rt, impl_m_or)); pit_symtab_mset(rt, pit_symtab_intern_cstr(rt, "setq!"), pit_value_nativefunc_new(rt, impl_m_setq)); + pit_symtab_mset(rt, pit_symtab_intern_cstr(rt, "cond"), pit_value_nativefunc_new(rt, impl_m_cond)); pit_symtab_mset(rt, pit_symtab_intern_cstr(rt, "case"), pit_value_nativefunc_new(rt, impl_m_case)); /* error */ pit_symtab_fset(rt, pit_symtab_intern_cstr(rt, "error!"), pit_value_nativefunc_new(rt, impl_error)); diff --git a/pit/src/native.c b/pit/src/native.c index e4e0bf1..b5b13e1 100644 --- a/pit/src/native.c +++ b/pit/src/native.c @@ -95,27 +95,25 @@ static void check_invariants(pit_runtime *rt) { } } pit_value pit_load_file(pit_runtime *rt, char *path) { - // TODO - return PIT_NIL; - // pit_lexer lex; - // pit_parser parse; - // bool eof = false; - // pit_value p = PIT_NIL; - // pit_value ret = PIT_NIL; - // if (pit_lex_file(&lex, path) < 0) { - // pit_error(rt, "failed to lex file: %s", path); - // return PIT_NIL; - // } - // pit_parser_from_lexer(&parse, &lex); - // while (p = pit_parse(rt, &parse, &eof), !eof) { - // check_invariants(rt); if (pit_runtime_print_error(rt)) return PIT_NIL; - // ret = pit_eval(rt, p); - // check_invariants(rt); if (pit_runtime_print_error(rt)) return PIT_NIL; - // pit_gc(rt); - // check_invariants(rt); if (pit_runtime_print_error(rt)) return PIT_NIL; - // } - // check_invariants(rt); if (pit_runtime_print_error(rt)) return PIT_NIL; - // return ret; + pit_lexer lex; + pit_parser parse; + bool eof = false; + pit_value p = PIT_NIL; + pit_value ret = PIT_NIL; + if (pit_lex_file(&lex, path) < 0) { + pit_error(rt, "failed to lex file: %s", path); + return PIT_NIL; + } + pit_parser_from_lexer(&parse, &lex); + while (p = pit_parse(rt, &parse, &eof), !eof) { + check_invariants(rt); if (pit_runtime_print_error(rt)) return PIT_NIL; + ret = pit_vm_eval(rt, pit_compile(rt, pit_macroexpand(rt, p))); + check_invariants(rt); if (pit_runtime_print_error(rt)) return PIT_NIL; + pit_gc(rt); + check_invariants(rt); if (pit_runtime_print_error(rt)) return PIT_NIL; + } + check_invariants(rt); if (pit_runtime_print_error(rt)) return PIT_NIL; + return ret; } void pit_repl(pit_runtime *rt) { @@ -155,8 +153,7 @@ void pit_repl(pit_runtime *rt) { pit_parser_from_lexer(&parse, &lex); while (p = pit_parse(rt, &parse, &eof), !eof) { check_invariants(rt); - // res = pit_eval(rt, p); - res = pit_vm_eval(rt, pit_vm_compile(rt, p)); + res = pit_vm_eval(rt, pit_compile(rt, pit_macroexpand(rt, p))); check_invariants(rt); } if (pit_runtime_print_error(rt)) { diff --git a/pit/src/runtime.c b/pit/src/runtime.c index bef7578..de0b2a2 100644 --- a/pit/src/runtime.c +++ b/pit/src/runtime.c @@ -18,7 +18,7 @@ enum pit_value_sort pit_value_sort(pit_value v) { } u64 pit_value_data(pit_value v) { - /* return v & 0b0000000000000001111111111111111111111111111111111111111111111111; */ + /* return v & 0b0000000000000001111111111111111111111111111111111111111111111111; */ return v & 0x1ffffffffffff; } @@ -53,6 +53,7 @@ pit_runtime *pit_runtime_new(u8 *buf, i64 len) { pit_symtab_set(ret, nil, PIT_NIL); pit_value truth = pit_symtab_intern_cstr(ret, "t"); pit_symtab_set(ret, truth, truth); + pit_compile_install_special_forms(ret); pit_runtime_freeze(ret); return ret; } diff --git a/pit/src/runtime/compile.c b/pit/src/runtime/compile.c new file mode 100644 index 0000000..a676a61 --- /dev/null +++ b/pit/src/runtime/compile.c @@ -0,0 +1,222 @@ +#include <lcq/pit/runtime/compile.h> + +#include <stdio.h> + +static void call_special_form(pit_runtime *rt, pit_value f, pit_value args) { + char buf[256] = {0}; + switch (pit_value_sort(f)) { + case PIT_VALUE_SORT_REF: { + pit_value_heavy *h = pit_value_ref_deref(rt, pit_value_as_ref(rt, f)); + if (!h) { pit_error(rt, "bad ref for special form"); return; } + switch (h->hsort) { + case PIT_VALUE_HEAVY_SORT_NATIVEFUNC: + h->in.nativefunc.f(rt, args, h->in.nativefunc.data); + break; + default: { + i64 end = pit_dump(rt, buf, sizeof(buf) - 1, f, true); + buf[end] = 0; + pit_error(rt, "attempted to apply non-nativefunc special form: %s", buf); + return; + } + } + break; + } + default: { + i64 end = pit_dump(rt, buf, sizeof(buf) - 1, f, true); + buf[end] = 0; + pit_error(rt, "attempted to apply non-function special form: %s", buf); + return; + } + } +} + +static pit_value free_vars(pit_runtime *rt, pit_value initial_bound, pit_value body) { + i64 expr_stack_reset = rt->expr_stack->next; + pit_value ret = PIT_NIL; + if (pit_vec_push(pit_value)(rt->expr_stack, pit_value_cons(rt, initial_bound, body)) < 0) { + pit_error(rt, "free variable search stack overflow"); + return PIT_NIL; + } + while (rt->expr_stack->next > expr_stack_reset) { + pit_value boundscur, bound, cur; + if (pit_vec_pop(pit_value)(rt->expr_stack, &boundscur) < 0) { + pit_error(rt, "free variable search stack underflow"); + return PIT_NIL; + } + bound = pit_value_cons_car(rt, boundscur); + cur = pit_value_cons_cdr(rt, boundscur); + if (pit_value_is_cons(rt, cur)) { + pit_value fsym = pit_value_cons_car(rt, cur); + bool is_symbol = pit_value_is_symbol(rt, fsym); + pit_value fargs = pit_value_cons_cdr(rt, cur); + if (is_symbol && pit_symtab_symbol_name_match_cstr(rt, fsym, "lambda")) { + pit_value new_bound = pit_value_list_append(rt, pit_value_cons_car(rt, fargs), bound); + fargs = pit_value_cons_cdr(rt, fargs); + while (fargs != PIT_NIL) { + if (pit_vec_push(pit_value)(rt->expr_stack, pit_value_cons(rt, new_bound, pit_value_cons_car(rt, fargs))) < 0) { + pit_error(rt, "free variable search stack overflow"); + return PIT_NIL; + } + fargs = pit_value_cons_cdr(rt, fargs); + } + } else if (is_symbol && pit_symtab_symbol_name_match_cstr(rt, fsym, "quote")) { + /* don't look inside quote! + if we add other special forms, make sure to consider them here if necessary! */ + } else { + while (fargs != PIT_NIL) { + if (pit_vec_push(pit_value)(rt->expr_stack, pit_value_cons(rt, bound, pit_value_cons_car(rt, fargs))) < 0) { + pit_error(rt, "free variable search stack overflow"); + return PIT_NIL; + } + fargs = pit_value_cons_cdr(rt, fargs); + } + if (!is_symbol) { + if (pit_vec_push(pit_value)(rt->expr_stack, pit_value_cons(rt, bound, fsym)) < 0) { + pit_error(rt, "free variable search stack overflow"); + return PIT_NIL; + } + } + } + } else if (pit_value_is_symbol(rt, cur)) { + if (pit_value_list_contains_eq(rt, cur, bound) == PIT_NIL) { + ret = pit_value_cons(rt, cur, ret); + } + } + } + rt->expr_stack->next = expr_stack_reset; + return ret; +} + +static pit_value lambda(pit_runtime *rt, pit_value args, pit_value body) { + pit_value expanded = pit_macroexpand(rt, pit_value_cons(rt, pit_symtab_intern_cstr(rt, "progn"), body)); + fprintf(stderr, "lambda: "); pit_dump_to_file(rt, stderr, expanded, false); fprintf(stderr, "\n"); + return pit_value_list(rt, 4, + pit_symtab_intern_cstr(rt, "lambda"), + args, + free_vars(rt, args, expanded), + pit_compile(rt, expanded) + ); +} + +static void c_now(pit_runtime *rt, pit_value v) { + pit_traversal_push_value(rt, rt->traversal, v); +} + +static void c_eval(pit_runtime *rt, pit_value e) { + if (pit_vec_push(pit_value)(rt->expr_stack, e) < 0) + pit_error(rt, "evaluation stack overflow"); +} + +pit_value pit_compile(pit_runtime *rt, pit_value top) { + char buf[256] = {0}; + pit_value ret = PIT_NIL; + i64 expr_stack_reset = rt->expr_stack->next; + i64 traversal_reset = rt->traversal->next; + fprintf(stderr, "compile: "); pit_dump_to_file(rt, stderr, top, false); fprintf(stderr, "\n"); + c_eval(rt, top); + /* convert the expression tree into "polish notation" in traversal */ + while (rt->expr_stack->next > expr_stack_reset) { + pit_value cur = PIT_NIL; + if (rt->error != PIT_NIL) goto end; + if (pit_vec_pop(pit_value)(rt->expr_stack, &cur) < 0) + pit_error(rt, "evaluation stack underflow"); + fprintf(stderr, "cur: "); pit_dump_to_file(rt, stderr, cur, false); fprintf(stderr, "\n"); + if (pit_value_is_cons(rt, cur)) { + pit_value fsym = pit_value_cons_car(rt, cur); + bool is_symbol = pit_value_is_symbol(rt, fsym); + // pit_annotation *ann = pit_annotation_get(rt, pit_value_as_ref(rt, cur)); + if (is_symbol && pit_symtab_is_symbol_special_form(rt, fsym)) { /* special forms */ + pit_value f = pit_symtab_fget(rt, fsym); + pit_value args = pit_value_cons_cdr(rt, cur); + call_special_form(rt, f, args); + } else if (is_symbol && pit_symtab_is_symbol_macro(rt, fsym)) { /* macros */ + i64 end = pit_dump(rt, buf, sizeof(buf) - 1, fsym, true); + buf[end] = 0; + pit_error(rt, "encountered an unexpanded macro while compiling: %s", buf); + } else { /* normal functions */ + pit_value args = pit_value_cons_cdr(rt, cur); + i64 argcount = 0; + while (args != PIT_NIL) { + // fprintf(stderr, "push1: "); pit_dump_to_file(rt, stderr, pit_value_cons_car(rt, args), false); fprintf(stderr, "\n"); + c_eval(rt, pit_value_cons_car(rt, args)); + args = pit_value_cons_cdr(rt, args); + argcount += 1; + } + if (!is_symbol) { + // fprintf(stderr, "push2: "); pit_dump_to_file(rt, stderr, fsym, false); fprintf(stderr, "\n"); + c_eval(rt, fsym); + } + c_now(rt, pit_value_list(rt, 2, pit_symtab_intern_cstr(rt, "apply"), pit_value_integer_new(rt, argcount))); + if (is_symbol) { + c_now(rt, pit_value_list(rt, 1, pit_symtab_intern_cstr(rt, "fget"))); + c_now(rt, pit_value_list(rt, 2, pit_symtab_intern_cstr(rt, "literal"), fsym)); + } + } + } else if (pit_value_is_symbol(rt, cur)) { /* unquoted symbols: variable lookup */ + pit_symtab_entry *ent = pit_symtab_lookup(rt, cur); + if (ent->is_keyword) { + c_now(rt, pit_value_list(rt, 2, pit_symtab_intern_cstr(rt, "literal"), cur)); + } else { + c_now(rt, pit_value_list(rt, 1, pit_symtab_intern_cstr(rt, "get"))); + c_now(rt, pit_value_list(rt, 2, pit_symtab_intern_cstr(rt, "literal"), cur)); + } + } else { /* other expressions evaluate to themselves! */ + c_now(rt, pit_value_list(rt, 2, pit_symtab_intern_cstr(rt, "literal"), cur)); + } + } + for (i64 idx = traversal_reset; idx < rt->traversal->next; idx++) { + pit_traversal_entry *ent = pit_vec_get(pit_traversal_entry)(rt->traversal, idx); + if (ent == NULL) pit_error(rt, "evaluation traversal invalid"); + if (rt->error != PIT_NIL) goto end; + switch (ent->sort) { + case PIT_TRAVERSAL_ENTRY_VALUE: { + ret = pit_value_cons(rt, ent->in.value, ret); + break; + } + default: + pit_error(rt, "unknown traversal entry"); + ret = PIT_NIL; + goto end; + } + } +end: { + rt->expr_stack->next = expr_stack_reset; + rt->traversal->next = traversal_reset; + fprintf(stderr, "compiled: "); pit_dump_to_file(rt, stderr, ret, false); fprintf(stderr, "\n"); + return ret; + } +} + +static pit_value impl_sf_quote(pit_runtime *rt, pit_value args, void *data) { + (void) data; + pit_traversal_push_value(rt, rt->traversal, + pit_value_list(rt, 2, pit_symtab_intern_cstr(rt, "literal"), pit_value_cons_car(rt, args)) + ); + return PIT_NIL; +} +static pit_value impl_sf_if(pit_runtime *rt, pit_value args, void *data) { + (void) data; + pit_value c = pit_value_cons_car(rt, args); + args = pit_value_cons_cdr(rt, args); + pit_value t = pit_value_cons_car(rt, args); + args = pit_value_cons_cdr(rt, args); + pit_value e = pit_value_cons_car(rt, args); + c_now(rt, pit_value_list(rt, 1, pit_symtab_intern_cstr(rt, "if"))); + c_now(rt, lambda(rt, PIT_NIL, pit_value_list(rt, 1, t))); + c_now(rt, lambda(rt, PIT_NIL, pit_value_list(rt, 1, e))); + c_eval(rt, c); + return PIT_NIL; +} +static pit_value impl_sf_lambda(pit_runtime *rt, pit_value args, void *data) { + (void) data; + pit_value as = pit_value_cons_car(rt, args); + pit_value body = pit_value_cons_cdr(rt, args); + c_now(rt, lambda(rt, as, body)); + return PIT_NIL; +} + +void pit_compile_install_special_forms(pit_runtime *rt) { + pit_symtab_sfset(rt, pit_symtab_intern_cstr(rt, "quote"), pit_value_nativefunc_new(rt, impl_sf_quote)); + pit_symtab_sfset(rt, pit_symtab_intern_cstr(rt, "if"), pit_value_nativefunc_new(rt, impl_sf_if)); + pit_symtab_sfset(rt, pit_symtab_intern_cstr(rt, "lambda"), pit_value_nativefunc_new(rt, impl_sf_lambda)); +} diff --git a/pit/src/runtime/eval.c b/pit/src/runtime/eval.c index 1822bc5..3903a64 100644 --- a/pit/src/runtime/eval.c +++ b/pit/src/runtime/eval.c @@ -2,127 +2,8 @@ #include <stdio.h> -void pit_vm_call_special_form(pit_runtime *rt, pit_value f, pit_value args) { - char buf[256] = {0}; - switch (pit_value_sort(f)) { - case PIT_VALUE_SORT_REF: { - pit_value_heavy *h = pit_value_ref_deref(rt, pit_value_as_ref(rt, f)); - if (!h) { pit_error(rt, "bad ref for special form"); return; } - switch (h->hsort) { - case PIT_VALUE_HEAVY_SORT_NATIVEFUNC: - h->in.nativefunc.f(rt, args, h->in.nativefunc.data); - break; - default: { - i64 end = pit_dump(rt, buf, sizeof(buf) - 1, f, true); - buf[end] = 0; - pit_error(rt, "attempted to apply non-nativefunc special form: %s", buf); - return; - } - } - break; - } - default: { - i64 end = pit_dump(rt, buf, sizeof(buf) - 1, f, true); - buf[end] = 0; - pit_error(rt, "attempted to apply non-function special form: %s", buf); - return; - } - } -} - -pit_value pit_vm_compile(pit_runtime *rt, pit_value top) { - pit_value ret = PIT_NIL; - i64 expr_stack_reset = rt->expr_stack->next; - i64 traversal_reset = rt->traversal->next; - if (pit_vec_push(pit_value)(rt->expr_stack, top) < 0) - pit_error(rt, "evaluation stack overflow"); - /* first, convert the expression tree into "polish notation" in traversal */ - while (rt->expr_stack->next > expr_stack_reset) { - pit_value cur = PIT_NIL; - if (rt->error != PIT_NIL) goto end; - if (pit_vec_pop(pit_value)(rt->expr_stack, &cur) < 0) - pit_error(rt, "evaluation stack underflow"); - fprintf(stderr, "cur: "); pit_dump_to_file(rt, stderr, cur, false); fprintf(stderr, "\n"); - if (pit_value_is_cons(rt, cur)) { - pit_value fsym = pit_value_cons_car(rt, cur); - bool is_symbol = pit_value_is_symbol(rt, fsym); - pit_annotation *ann = pit_annotation_get(rt, pit_value_as_ref(rt, cur)); - if (is_symbol && pit_symtab_is_symbol_special_form(rt, fsym)) { /* special forms */ - pit_value f = pit_symtab_fget(rt, fsym); - pit_value args = pit_value_cons_cdr(rt, cur); - pit_vm_call_special_form(rt, f, args); - } else if (is_symbol && pit_symtab_is_symbol_macro(rt, fsym)) { /* macros */ - pit_error(rt, "encountered a macro while evaluating"); - } else { /* normal functions */ - pit_value args = pit_value_cons_cdr(rt, cur); - i64 argcount = 0; - while (args != PIT_NIL) { - if (pit_vec_push(pit_value)(rt->expr_stack, pit_value_cons_car(rt, args)) < 0) - pit_error(rt, "evaluation stack overflow"); - args = pit_value_cons_cdr(rt, args); - argcount += 1; - } - if (!is_symbol) { - if (pit_vec_push(pit_value)(rt->expr_stack, fsym) < 0) - pit_error(rt, "evaluation stack overflow"); - } - pit_traversal_push_value(rt, rt->traversal, - pit_value_list(rt, 2, pit_symtab_intern_cstr(rt, "apply"), pit_value_integer_new(rt, argcount)) - ); - if (is_symbol) { - pit_traversal_push_value(rt, rt->traversal, - pit_value_list(rt, 1, pit_symtab_intern_cstr(rt, "fget")) - ); - pit_traversal_push_value(rt, rt->traversal, - pit_value_list(rt, 2, pit_symtab_intern_cstr(rt, "literal"), fsym) - ); - } - } - } else if (pit_value_is_symbol(rt, cur)) { /* unquoted symbols: variable lookup */ - pit_symtab_entry *ent = pit_symtab_lookup(rt, cur); - if (ent->is_keyword) { - pit_traversal_push_value(rt, rt->traversal, - pit_value_list(rt, 2, pit_symtab_intern_cstr(rt, "literal"), cur) - ); - } else { - pit_traversal_push_value(rt, rt->traversal, - pit_value_list(rt, 1, pit_symtab_intern_cstr(rt, "get")) - ); - pit_traversal_push_value(rt, rt->traversal, - pit_value_list(rt, 2, pit_symtab_intern_cstr(rt, "literal"), cur) - ); - } - } else { /* other expressions evaluate to themselves! */ - pit_traversal_push_value(rt, rt->traversal, - pit_value_list(rt, 2, pit_symtab_intern_cstr(rt, "literal"), cur) - ); - } - } - for (i64 idx = traversal_reset; idx < rt->traversal->next; idx++) { - pit_traversal_entry *ent = pit_vec_get(pit_traversal_entry)(rt->traversal, idx); - if (ent == NULL) pit_error(rt, "evaluation traversal invalid"); - if (rt->error != PIT_NIL) goto end; - switch (ent->sort) { - case PIT_TRAVERSAL_ENTRY_VALUE: { - ret = pit_value_cons(rt, ent->in.value, ret); - break; - } - default: - pit_error(rt, "unknown traversal entry"); - ret = PIT_NIL; - goto end; - } - } -end: { - rt->expr_stack->next = expr_stack_reset; - rt->traversal->next = traversal_reset; - fprintf(stderr, "compiled: "); pit_dump_to_file(rt, stderr, ret, false); fprintf(stderr, "\n"); - return ret; - } -} - /* add a new stack frame to the vm (with a tag and callsite annotation) */ -void pit_vm_push_code_func(pit_runtime *rt, pit_value code, pit_value tag, pit_annotation ann, pit_value bound) { +static void vm_push_code_func(pit_runtime *rt, pit_value code, pit_value tag, pit_annotation ann, pit_value bound) { pit_callstack_entry ent; ent.tag = tag; ent.ann = ann; @@ -135,36 +16,38 @@ void pit_vm_push_code_func(pit_runtime *rt, pit_value code, pit_value tag, pit_a } /* add a new stack frame to the vm (with no annotation) */ -void pit_vm_push_code(pit_runtime *rt, pit_value code) { +static void vm_push_code(pit_runtime *rt, pit_value code) { pit_annotation ann; ann.line = -1; ann.column = -1; - pit_vm_push_code_func(rt, code, PIT_NIL, ann, PIT_NIL); + vm_push_code_func(rt, code, PIT_NIL, ann, PIT_NIL); } -void pit_vm_push(pit_runtime *rt, pit_value v) { - fprintf(stderr, "push: "); pit_dump_to_file(rt, stderr, v, false); fprintf(stderr, "\n"); +static void vm_push(pit_runtime *rt, pit_value v) { + // fprintf(stderr, "push: "); pit_dump_to_file(rt, stderr, v, false); fprintf(stderr, "\n"); if (pit_vec_push(pit_value)(rt->result_stack, v) < 0) { pit_error(rt, "vm stack overflow"); } } -pit_value pit_vm_pop(pit_runtime *rt) { +static pit_value vm_pop(pit_runtime *rt) { pit_value ret = PIT_NIL; if (pit_vec_pop(pit_value)(rt->result_stack, &ret) < 0) { pit_error(rt, "vm stack underflow"); } - fprintf(stderr, "pop: "); pit_dump_to_file(rt, stderr, ret, false); fprintf(stderr, "\n"); + // fprintf(stderr, "pop: "); pit_dump_to_file(rt, stderr, ret, false); fprintf(stderr, "\n"); return ret; } -void pit_vm_call_lisp(pit_runtime *rt, pit_value tag, pit_value closure, pit_value args) { +static void vm_call_lisp(pit_runtime *rt, pit_value tag, pit_value closure, pit_value args) { pit_value bound = PIT_NIL; pit_value env = pit_value_array_get(rt, closure, 0); pit_value anames = pit_value_array_get(rt, closure, 1); pit_value arg_rest_nm = pit_value_array_get(rt, closure, 2); pit_value body = pit_value_array_get(rt, closure, 3); if (rt->error != PIT_NIL) return; + // fprintf(stderr, "call lisp: "); pit_dump_to_file(rt, stderr, closure, false); fprintf(stderr, "\n"); + // fprintf(stderr, "binding: "); pit_dump_to_file(rt, stderr, env, false); fprintf(stderr, "\n"); while (env != PIT_NIL) { /* first, bind all entries in the closure */ pit_value b = pit_value_cons_car(rt, env); pit_value nm = pit_value_cons_car(rt, b); @@ -190,28 +73,28 @@ void pit_vm_call_lisp(pit_runtime *rt, pit_value tag, pit_value closure, pit_val pit_annotation ann; ann.line = -1; ann.column = -1; - pit_vm_push_code_func(rt, body, tag, ann, bound); + vm_push_code_func(rt, body, tag, ann, bound); } -void pit_vm_call(pit_runtime *rt, pit_value f, pit_value args) { +static bool vm_call(pit_runtime *rt, pit_value f, pit_value args) { char buf[256] = {0}; if (pit_value_is_symbol(rt, f)) f = pit_symtab_fget(rt, f); switch (pit_value_sort(f)) { case PIT_VALUE_SORT_REF: { pit_value_heavy *h = pit_value_ref_deref(rt, pit_value_as_ref(rt, f)); - if (!h) { pit_error(rt, "bad ref for function"); return; } + if (!h) { pit_error(rt, "bad ref for function"); return false; } switch (h->hsort) { case PIT_VALUE_HEAVY_SORT_NATIVEFUNC: - pit_vm_push(rt, h->in.nativefunc.f(rt, args, h->in.nativefunc.data)); + vm_push(rt, h->in.nativefunc.f(rt, args, h->in.nativefunc.data)); break; case PIT_VALUE_HEAVY_SORT_FUNC: - pit_vm_call_lisp(rt, h->in.func.nm, h->in.func.closure, args); + vm_call_lisp(rt, h->in.func.nm, h->in.func.closure, args); break; default: { i64 end = pit_dump(rt, buf, sizeof(buf) - 1, f, true); buf[end] = 0; pit_error(rt, "attempted to apply non-function ref: %s", buf); - return; + return false; } } break; @@ -220,20 +103,21 @@ void pit_vm_call(pit_runtime *rt, pit_value f, pit_value args) { i64 end = pit_dump(rt, buf, sizeof(buf) - 1, f, true); buf[end] = 0; pit_error(rt, "attempted to apply non-function value: %s", buf); - return; + return false; } } + return true; } /* run one instruction of the VM */ bool pit_vm_run_one(pit_runtime *rt) { - char buf[256] = {0}; if (rt->callstack->next < 1) return false; pit_callstack_entry *ent = pit_vec_get(pit_callstack_entry)(rt->callstack, rt->callstack->next - 1); if (ent == NULL) { pit_error(rt, "malformed call stack"); return false; } + // fprintf(stderr, "code: "); pit_dump_to_file(rt, stderr, ent->code, false); fprintf(stderr, "\n"); pit_value ins = pit_value_cons_car(rt, ent->code); if (ins == PIT_NIL) { pit_error(rt, "malformed vm instruction"); @@ -246,53 +130,50 @@ bool pit_vm_run_one(pit_runtime *rt) { final = true; pit_vec_pop(pit_callstack_entry)(rt->callstack, NULL); } else ent->code = rest; - fprintf(stderr, "ins: "); pit_dump_to_file(rt, stderr, ins, false); fprintf(stderr, "\n"); + // fprintf(stderr, "ins: "); pit_dump_to_file(rt, stderr, ins, false); fprintf(stderr, "\n"); pit_value op = pit_value_cons_car(rt, ins); if (pit_symtab_symbol_name_match_cstr(rt, op, "literal")) { - pit_vm_push(rt, pit_value_cons_car(rt, pit_value_cons_cdr(rt, ins))); + /* push a lisp value to the vm stack */ + vm_push(rt, pit_value_cons_car(rt, pit_value_cons_cdr(rt, ins))); + } else if (pit_symtab_symbol_name_match_cstr(rt, op, "lambda")) { + /* create and push a function with the given arguments, free variables, and (compiled) body */ + /* notably, this builds the closure by recording the currently-bound cells for each free variable! */ + pit_value args = pit_value_cons_cdr(rt, ins); + pit_value as = pit_value_cons_car(rt, args); + args = pit_value_cons_cdr(rt, args); + pit_value freevars = pit_value_cons_car(rt, args); + args = pit_value_cons_cdr(rt, args); + pit_value body = pit_value_cons_car(rt, args); + vm_push(rt, pit_value_func_lambda(rt, as, freevars, body)); } else if (pit_symtab_symbol_name_match_cstr(rt, op, "get")) { - pit_vm_push(rt, pit_symtab_get(rt, pit_vm_pop(rt))); + pit_value nm = vm_pop(rt); + // fprintf(stderr, "get: "); pit_dump_to_file(rt, stderr, nm, false); fprintf(stderr, "\n"); + vm_push(rt, pit_symtab_get(rt, nm)); + /* pop a symbol and look up its value */ + // vm_push(rt, pit_symtab_get(rt, vm_pop(rt))); } else if (pit_symtab_symbol_name_match_cstr(rt, op, "fget")) { - pit_vm_push(rt, pit_symtab_fget(rt, pit_vm_pop(rt))); + /* pop a symbol and look up its function value */ + vm_push(rt, pit_symtab_fget(rt, vm_pop(rt))); + } else if (pit_symtab_symbol_name_match_cstr(rt, op, "if")) { + /* pop a then-function, an else-function, and a condition */ + /* call (no args) the then-function if the condition is true, otherwise call the else-function */ + pit_value t = vm_pop(rt); + pit_value e = vm_pop(rt); + pit_value c = vm_pop(rt); + if (!vm_call(rt, c != PIT_NIL ? t : e, PIT_NIL)) return false; } else if (pit_symtab_symbol_name_match_cstr(rt, op, "apply")) { + /* pop an arity n and a function, and then n arguments, and apply the function */ i64 arity = pit_value_as_integer(rt, pit_value_cons_car(rt, pit_value_cons_cdr(rt, ins))); - pit_value f = pit_vm_pop(rt); + pit_value f = vm_pop(rt); pit_value args = PIT_NIL; - while (arity-- > 0) args = pit_value_cons(rt, pit_vm_pop(rt), args); - if (pit_value_is_symbol(rt, f)) f = pit_symtab_fget(rt, f); - switch (pit_value_sort(f)) { - case PIT_VALUE_SORT_REF: { - pit_value_heavy *h = pit_value_ref_deref(rt, pit_value_as_ref(rt, f)); - if (!h) { pit_error(rt, "bad ref for function"); return PIT_NIL; } - switch (h->hsort) { - case PIT_VALUE_HEAVY_SORT_NATIVEFUNC: - pit_vm_push(rt, h->in.nativefunc.f(rt, args, h->in.nativefunc.data)); - break; - case PIT_VALUE_HEAVY_SORT_FUNC: - pit_vm_call_lisp(rt, h->in.func.nm, h->in.func.closure, args); - break; - default: { - i64 end = pit_dump(rt, buf, sizeof(buf) - 1, f, true); - buf[end] = 0; - pit_error(rt, "attempted to apply non-function ref: %s", buf); - return false; - } - } - break; - } - default: { - i64 end = pit_dump(rt, buf, sizeof(buf) - 1, f, true); - buf[end] = 0; - pit_error(rt, "attempted to apply non-function value: %s", buf); - return false; - } - } + while (arity-- > 0) args = pit_value_cons(rt, vm_pop(rt), args); + if (!vm_call(rt, f, args)) return false; } else { pit_error(rt, "unknown vm operation"); return false; } if (final) { /* if we have finished this stack frame */ - fprintf(stderr, "unbinding: "); pit_dump_to_file(rt, stderr, bound, false); fprintf(stderr, "\n"); + // fprintf(stderr, "unbinding: "); pit_dump_to_file(rt, stderr, bound, false); fprintf(stderr, "\n"); while (bound != PIT_NIL) { /* unbind everything we bound for the frame, in reverse */ pit_symtab_unbind(rt, pit_value_cons_car(rt, bound)); bound = pit_value_cons_cdr(rt, bound); @@ -301,15 +182,18 @@ bool pit_vm_run_one(pit_runtime *rt) { return true; } -/* run the VM until evaluation finishes, returning the result */ +/* run the VM until evaluation of this code finishes, returning the result */ pit_value pit_vm_eval(pit_runtime *rt, pit_value v) { - pit_vm_push_code(rt, v); - while (pit_vm_run_one(rt)); - pit_vm_pop(rt); + i64 start = rt->callstack->next; + vm_push_code(rt, v); + while (pit_vm_run_one(rt) && rt->callstack->next > start); + return vm_pop(rt); } +/* run the VM until this function call finishes, returning the result */ pit_value pit_vm_apply(pit_runtime *rt, pit_value f, pit_value args) { - pit_vm_call(rt, f, args); - while (pit_vm_run_one(rt)); - pit_vm_pop(rt); + i64 start = rt->callstack->next; + vm_call(rt, f, args); + while (pit_vm_run_one(rt) && rt->callstack->next > start); + return vm_pop(rt); } diff --git a/pit/src/runtime/macroexpand.c b/pit/src/runtime/macroexpand.c index 7ff1a6a..ffa796d 100644 --- a/pit/src/runtime/macroexpand.c +++ b/pit/src/runtime/macroexpand.c @@ -1,6 +1,9 @@ #include <lcq/pit/runtime/macroexpand.h> +#include <stdio.h> + pit_value pit_macroexpand(pit_runtime *rt, pit_value top) { + fprintf(stderr, "macroexpand: "); pit_dump_to_file(rt, stderr, top, false); fprintf(stderr, "\n"); i64 expr_stack_reset = rt->expr_stack->next; i64 result_stack_reset = rt->result_stack->next; i64 traversal_reset = rt->traversal->next; @@ -15,33 +18,14 @@ pit_value pit_macroexpand(pit_runtime *rt, pit_value top) { pit_value fsym = pit_value_cons_car(rt, cur); bool is_symbol = pit_value_is_symbol(rt, fsym); pit_annotation *ann = pit_annotation_get(rt, pit_value_as_ref(rt, cur)); - if (is_symbol && pit_symtab_is_symbol_macro(rt, fsym)) { + if (is_symbol && pit_symtab_is_symbol_special_form(rt, fsym)) { + pit_traversal_push_value(rt, rt->traversal, cur); + } else if (is_symbol && pit_symtab_is_symbol_macro(rt, fsym)) { pit_value f = pit_symtab_fget(rt, fsym); pit_value args = pit_value_cons_cdr(rt, cur); - pit_value res = pit_value_apply(rt, f, args); + pit_value res = pit_vm_apply(rt, f, args); if (pit_vec_push(pit_value)(rt->expr_stack, res) < 0) pit_error(rt, "macro expansion stack overflow"); - } else if (is_symbol && pit_symtab_symbol_name_match_cstr(rt, fsym, "defer")) { - pit_value args = pit_value_cons_cdr(rt, cur); - pit_traversal_push_value(rt, rt->traversal, pit_value_cons_car(rt, args)); - } else if (is_symbol && pit_symtab_symbol_name_match_cstr(rt, fsym, "quote")) { - pit_traversal_push_value(rt, rt->traversal, cur); - } else if (is_symbol && pit_symtab_symbol_name_match_cstr(rt, fsym, "lambda")) { - pit_value args = pit_value_cons_cdr(rt, cur); - pit_value bindings = pit_value_cons_car(rt, args); - pit_value body = pit_value_cons_cdr(rt, args); - i64 argcount = 0; - if (pit_vec_push(pit_value)(rt->expr_stack, pit_value_list(rt, 2, pit_symtab_intern_cstr(rt, "defer"), bindings)) < 0) - pit_error(rt, "macro expansion stack overflow"); - while (body != PIT_NIL) { - pit_value a = pit_value_cons_car(rt, body); - if (pit_vec_push(pit_value)(rt->expr_stack, a) < 0) - pit_error(rt, "macro expansion stack overflow"); - body = pit_value_cons_cdr(rt, body); - argcount += 1; - } - pit_traversal_push_application(rt, rt->traversal, argcount + 1, ann); - pit_traversal_push_value(rt, rt->traversal, fsym); } else { pit_value args = pit_value_cons_cdr(rt, cur); i64 argcount = 0; @@ -106,6 +90,7 @@ end: { rt->expr_stack->next = expr_stack_reset; rt->result_stack->next = result_stack_reset; rt->traversal->next = traversal_reset; + fprintf(stderr, "macroexpand result: "); pit_dump_to_file(rt, stderr, ret, false); fprintf(stderr, "\n"); return ret; } } diff --git a/pit/src/runtime/value/func.c b/pit/src/runtime/value/func.c index 5f88cb0..ad5ce4c 100644 --- a/pit/src/runtime/value/func.c +++ b/pit/src/runtime/value/func.c @@ -1,61 +1,6 @@ #include <lcq/pit/runtime/value/func.h> -static pit_value free_vars(pit_runtime *rt, pit_value initial_bound, pit_value body) { - i64 expr_stack_reset = rt->expr_stack->next; - pit_value ret = PIT_NIL; - if (pit_vec_push(pit_value)(rt->expr_stack, pit_value_cons(rt, initial_bound, body)) < 0) { - pit_error(rt, "free variable search stack overflow"); - return PIT_NIL; - } - while (rt->expr_stack->next > expr_stack_reset) { - pit_value boundscur, bound, cur; - if (pit_vec_pop(pit_value)(rt->expr_stack, &boundscur) < 0) { - pit_error(rt, "free variable search stack underflow"); - return PIT_NIL; - } - bound = pit_value_cons_car(rt, boundscur); - cur = pit_value_cons_cdr(rt, boundscur); - if (pit_value_is_cons(rt, cur)) { - pit_value fsym = pit_value_cons_car(rt, cur); - bool is_symbol = pit_value_is_symbol(rt, fsym); - pit_value fargs = pit_value_cons_cdr(rt, cur); - if (is_symbol && pit_symtab_symbol_name_match_cstr(rt, fsym, "lambda")) { - pit_value new_bound = pit_value_list_append(rt, pit_value_cons_car(rt, fargs), bound); - fargs = pit_value_cons_cdr(rt, fargs); - while (fargs != PIT_NIL) { - if (pit_vec_push(pit_value)(rt->expr_stack, pit_value_cons(rt, new_bound, pit_value_cons_car(rt, fargs))) < 0) { - pit_error(rt, "free variable search stack overflow"); - return PIT_NIL; - } - fargs = pit_value_cons_cdr(rt, fargs); - } - } else if (is_symbol && pit_symtab_symbol_name_match_cstr(rt, fsym, "quote")) { - /* don't look inside quote! - if we add other special forms, make sure to consider them here if necessary! */ - } else { - while (fargs != PIT_NIL) { - if (pit_vec_push(pit_value)(rt->expr_stack, pit_value_cons(rt, bound, pit_value_cons_car(rt, fargs))) < 0) { - pit_error(rt, "free variable search stack overflow"); - return PIT_NIL; - } - fargs = pit_value_cons_cdr(rt, fargs); - } - if (!is_symbol) { - if (pit_vec_push(pit_value)(rt->expr_stack, pit_value_cons(rt, bound, fsym)) < 0) { - pit_error(rt, "free variable search stack overflow"); - return PIT_NIL; - } - } - } - } else if (pit_value_is_symbol(rt, cur)) { - if (pit_value_list_contains_eq(rt, cur, bound) == PIT_NIL) { - ret = pit_value_cons(rt, cur, ret); - } - } - } - rt->expr_stack->next = expr_stack_reset; - return ret; -} +#include <stdio.h> bool pit_value_is_func(pit_runtime *rt, pit_value a) { return pit_value_is_ref_heavy_sort(rt, a, PIT_VALUE_HEAVY_SORT_FUNC); @@ -63,12 +8,13 @@ bool pit_value_is_func(pit_runtime *rt, pit_value a) { bool pit_value_is_nativefunc(pit_runtime *rt, pit_value a) { return pit_value_is_ref_heavy_sort(rt, a, PIT_VALUE_HEAVY_SORT_NATIVEFUNC); } -pit_value pit_value_func_lambda(pit_runtime *rt, pit_value args, pit_value body) { +pit_value pit_value_func_lambda(pit_runtime *rt, pit_value args, pit_value freevars, pit_value compiled) { + // fprintf(stderr, "lambda args: "); pit_dump_to_file(rt, stderr, args, false); fprintf(stderr, "\n"); + // fprintf(stderr, "lambda freevars: "); pit_dump_to_file(rt, stderr, freevars, false); fprintf(stderr, "\n"); + // fprintf(stderr, "lambda compiled: "); pit_dump_to_file(rt, stderr, compiled, false); fprintf(stderr, "\n"); pit_value ret = pit_value_ref_heavy_new(rt); pit_value_heavy *h = pit_value_ref_deref(rt, pit_value_as_ref(rt, ret)); if (!h) { pit_error(rt, "failed to create new heavy value for lambda"); return PIT_NIL; } - pit_value expanded = pit_macroexpand(rt, pit_value_cons(rt, pit_symtab_intern_cstr(rt, "progn"), body)); - pit_value freevars = free_vars(rt, args, expanded); pit_value env = PIT_NIL; while (freevars != PIT_NIL) { pit_value sym = pit_value_cons_car(rt, freevars); @@ -94,7 +40,6 @@ pit_value pit_value_func_lambda(pit_runtime *rt, pit_value args, pit_value body) } } arg_cells = pit_value_list_reverse(rt, arg_cells); - pit_value compiled = pit_vm_compile(rt, expanded); pit_value closure[4] = {env, arg_cells, arg_rest_nm, compiled}; h->in.func.nm = PIT_NIL; h->in.func.closure = pit_value_array_from_buf(rt, closure, 4); @@ -112,71 +57,3 @@ pit_value pit_value_nativefunc_new_with_data(pit_runtime *rt, pit_nativefunc f, pit_value pit_value_nativefunc_new(pit_runtime *rt, pit_nativefunc f) { return pit_value_nativefunc_new_with_data(rt, f, NULL); } -pit_value pit_value_apply(pit_runtime *rt, pit_value f, pit_value args) { - char buf[256] = {0}; - if (pit_value_is_symbol(rt, f)) { - f = pit_symtab_fget(rt, f); - } - /* if f is not a symbol, assume it is a func or nativefunc - most commonly, this happens when you funcall a variable - with a function in the value cell, e.g. passing a lambda to a function */ - switch (pit_value_sort(f)) { - case PIT_VALUE_SORT_REF: { - pit_value_heavy *h = pit_value_ref_deref(rt, pit_value_as_ref(rt, f)); - if (!h) { pit_error(rt, "bad ref"); return PIT_NIL; } - if (h->hsort == PIT_VALUE_HEAVY_SORT_FUNC) { - /* calling a Lisp function is simple! */ - pit_value bound = PIT_NIL; - pit_value env = pit_value_array_get(rt, h->in.func.closure, 0); - pit_value anames = pit_value_array_get(rt, h->in.func.closure, 1); - pit_value arg_rest_nm = pit_value_array_get(rt, h->in.func.closure, 2); - pit_value body = pit_value_array_get(rt, h->in.func.closure, 3); - if (rt->error != PIT_NIL) return PIT_NIL; - while (env != PIT_NIL) { /* first, bind all entries in the closure */ - pit_value b = pit_value_cons_car(rt, env); - pit_value nm = pit_value_cons_car(rt, b); - pit_symtab_bind(rt, nm, pit_value_cons_cdr(rt, b)); - bound = pit_value_cons(rt, nm, bound); - env = pit_value_cons_cdr(rt, env); - } - while (anames != PIT_NIL) { /* bind all argument names to their values */ - pit_value nm = pit_value_cons_car(rt, anames); - pit_value cell = pit_value_cell_new(rt, PIT_NIL); - if (arg_rest_nm != PIT_NIL && pit_value_eq(nm, arg_rest_nm)) { - pit_value_cell_set(rt, cell, args, nm); - pit_symtab_bind(rt, nm, cell); - break; - } else { - pit_value_cell_set(rt, cell, pit_value_cons_car(rt, args), nm); - pit_symtab_bind(rt, nm, cell); - } - bound = pit_value_cons(rt, nm, bound); - args = pit_value_cons_cdr(rt, args); - anames = pit_value_cons_cdr(rt, anames); - } - /* TODO */ - pit_value ret = body; - // pit_value ret = pit_eval(rt, body); /* evaluate the body */ - while (bound != PIT_NIL) { /* unbind everything we bound earlier, in reverse */ - pit_symtab_unbind(rt, pit_value_cons_car(rt, bound)); - bound = pit_value_cons_cdr(rt, bound); - } - return ret; - } else if (h->hsort == PIT_VALUE_HEAVY_SORT_NATIVEFUNC) { - /* calling native functions is even simpler */ - return h->in.nativefunc.f(rt, args, h->in.nativefunc.data); - } else { - i64 end = pit_dump(rt, buf, sizeof(buf) - 1, f, true); - buf[end] = 0; - pit_error(rt, "attempted to apply non-function ref: %s", buf); - return PIT_NIL; - } - } - default: { - i64 end = pit_dump(rt, buf, sizeof(buf) - 1, f, true); - buf[end] = 0; - pit_error(rt, "attempted to apply non-function value: %s", buf); - return PIT_NIL; - } - } -} diff --git a/pit/test/test4.pit b/pit/test/test4.pit new file mode 100644 index 0000000..321a988 --- /dev/null +++ b/pit/test/test4.pit @@ -0,0 +1,5 @@ +(or + (case 'foo + ('foo 1) + ('bar 2)) + 3)
\ No newline at end of file |
