diff options
| -rw-r--r-- | pit/include/lcq/pit/runtime.h | 29 | ||||
| -rw-r--r-- | pit/include/lcq/pit/runtime/macroexpand.h | 3 | ||||
| -rw-r--r-- | pit/include/lcq/pit/runtime/symtab.h | 1 | ||||
| -rw-r--r-- | pit/src/library.c | 10 | ||||
| -rw-r--r-- | pit/src/main.c | 5 | ||||
| -rw-r--r-- | pit/src/native.c | 6 | ||||
| -rw-r--r-- | pit/src/runtime.c | 44 | ||||
| -rw-r--r-- | pit/src/runtime/compile.c | 372 | ||||
| -rw-r--r-- | pit/src/runtime/eval.c | 78 | ||||
| -rw-r--r-- | pit/src/runtime/gc.c | 13 | ||||
| -rw-r--r-- | pit/src/runtime/macroexpand.c | 23 | ||||
| -rw-r--r-- | pit/src/runtime/symtab.c | 7 | ||||
| -rw-r--r-- | pit/src/runtime/value/cell.c | 1 | ||||
| -rw-r--r-- | pit/src/runtime/value/func.c | 5 | ||||
| -rw-r--r-- | pit/src/utils.c | 1 | ||||
| -rw-r--r-- | pit/test/test4.pit | 11 | ||||
| -rw-r--r-- | pit/test/test5.pit | 5 | ||||
| -rw-r--r-- | pit/test/test6.pit | 5 | ||||
| -rw-r--r-- | pit/test/test7.pit | 1 |
19 files changed, 394 insertions, 226 deletions
diff --git a/pit/include/lcq/pit/runtime.h b/pit/include/lcq/pit/runtime.h index 70e65ca..feeb267 100644 --- a/pit/include/lcq/pit/runtime.h +++ b/pit/include/lcq/pit/runtime.h @@ -39,23 +39,47 @@ typedef struct { } pit_callstack_entry; PIT_DECLARE_VEC(pit_callstack_entry) +/* entries on a stack used when compiling expressions */ +typedef struct { + enum { + PIT_COMPILATION_ENTRY_VALUE, + PIT_COMPILATION_ENTRY_DROP, + PIT_COMPILATION_ENTRY_BEGIN_CODE, + PIT_COMPILATION_ENTRY_END_CODE, + } sort; + union { + pit_value value; + /* void end_code; */ + } in; +} pit_compilation_entry; +PIT_DECLARE_VEC(pit_compilation_entry) +void pit_compilation_push_value(struct pit_runtime *rt, pit_vec(pit_compilation_entry) *s, pit_value x); +void pit_compilation_push_drop(struct pit_runtime *rt, pit_vec(pit_compilation_entry) *s); +void pit_compilation_push_begin_code(struct pit_runtime *rt, pit_vec(pit_compilation_entry) *s); +void pit_compilation_push_end_code(struct pit_runtime *rt, pit_vec(pit_compilation_entry) *s); + /* entries on a stack used when traversing trees of values */ typedef struct { enum { PIT_TRAVERSAL_ENTRY_VALUE, PIT_TRAVERSAL_ENTRY_DUMP_STRING, PIT_TRAVERSAL_ENTRY_APPLICATION, + PIT_TRAVERSAL_ENTRY_BEGIN_CODE, + PIT_TRAVERSAL_ENTRY_END_CODE, } sort; union { pit_value value; char *dump_string; struct { i64 arity; pit_annotation *annotation; } application; + /* void end_code; */ } in; } pit_traversal_entry; PIT_DECLARE_VEC(pit_traversal_entry) void pit_traversal_push_value(struct pit_runtime *rt, pit_vec(pit_traversal_entry) *s, pit_value x); void pit_traversal_push_dump_string(struct pit_runtime *rt, pit_vec(pit_traversal_entry) *s, char *m); void pit_traversal_push_application(struct pit_runtime *rt, pit_vec(pit_traversal_entry) *s, i64 arity, pit_annotation *annotation); +void pit_traversal_push_begin_code(struct pit_runtime *rt, pit_vec(pit_traversal_entry) *s); +void pit_traversal_push_end_code(struct pit_runtime *rt, pit_vec(pit_traversal_entry) *s); typedef struct pit_runtime { /* interpreter state */ @@ -67,9 +91,10 @@ typedef struct pit_runtime { pit_hashtable(pit_ref, pit_annotation) *annotations_backbuffer; pit_vec(pit_symtab_entry) *symtab; /* all symbols */ /* temporary/"scratch" memory */ - pit_vec(pit_value) *saved_bindings; /* stack used to save old values of bindings to be restored ("shallow binding") */ + pit_vec(pit_value) *saved_bindings; /* stack used to save old values of bindings ("shallow binding") */ pit_vec(pit_value) *expr_stack; /* stack of subexpressions to evaluate during evaluation */ pit_vec(pit_value) *result_stack; /* stack of intermediate values during evaluation */ + pit_vec(pit_compilation_entry) *compilation_stack; /* stack of subexpressions to compile */ pit_vec(pit_traversal_entry) *traversal; /* intermediate stack used during tree traversal */ pit_vec(pit_callstack_entry) *callstack; /* stack of enclosing function calls */ /* bookkeeping */ @@ -78,6 +103,8 @@ typedef struct pit_runtime { pit_value error; /* error value - if this is non-nil, an error has occured! only tracks the first error */ i64 source_line, source_column; /* for error reporting only; line and column of token start */ i64 error_line, error_column; /* line and column of token start at time of error */ + pit_value msg_out_of_memory; /* a pre-allocated "out of memory" error message */ + /* we make sure to have this ready, since we can't allocate space for it if we run out! */ } pit_runtime; pit_runtime *pit_runtime_new(u8 *buf, i64 len); diff --git a/pit/include/lcq/pit/runtime/macroexpand.h b/pit/include/lcq/pit/runtime/macroexpand.h index bc1f756..db56849 100644 --- a/pit/include/lcq/pit/runtime/macroexpand.h +++ b/pit/include/lcq/pit/runtime/macroexpand.h @@ -3,6 +3,7 @@ #include <lcq/pit/runtime.h> -pit_value pit_macroexpand(pit_runtime *rt, pit_value top); +pit_value pit_macroexpand_1(pit_runtime *rt, pit_value f); +pit_value pit_macroexpand(pit_runtime *rt, pit_value f); #endif diff --git a/pit/include/lcq/pit/runtime/symtab.h b/pit/include/lcq/pit/runtime/symtab.h index ac60523..e385884 100644 --- a/pit/include/lcq/pit/runtime/symtab.h +++ b/pit/include/lcq/pit/runtime/symtab.h @@ -20,7 +20,6 @@ void pit_symtab_symbol_mark_macro(pit_runtime *rt, pit_value sym); void pit_symtab_mset(pit_runtime *rt, pit_value sym, pit_value v); bool pit_symtab_is_symbol_special_form(pit_runtime *rt, pit_value sym); void pit_symtab_symbol_mark_special_form(pit_runtime *rt, pit_value sym); -void pit_symtab_sfset(pit_runtime *rt, pit_value sym, pit_value v); void pit_symtab_bind(pit_runtime *rt, pit_value sym, pit_value v); pit_value pit_symtab_unbind(pit_runtime *rt, pit_value sym); diff --git a/pit/src/library.c b/pit/src/library.c index 6e87255..b911321 100644 --- a/pit/src/library.c +++ b/pit/src/library.c @@ -216,15 +216,6 @@ static pit_value impl_m_case(pit_runtime *rt, pit_value args, void *data) { ); } -static pit_value impl_progn(pit_runtime *rt, pit_value args, void *data) { - (void) data; - pit_value ret = PIT_NIL; - while (args != PIT_NIL) { - ret = pit_value_cons_car(rt, args); - args = pit_value_cons_cdr(rt, args); - } - return ret; -} static pit_value impl_set(pit_runtime *rt, pit_value args, void *data) { (void) data; pit_value sym = pit_value_cons_car(rt, args); @@ -780,7 +771,6 @@ void pit_install_library_essential(pit_runtime *rt) { /* error */ pit_symtab_fset(rt, pit_symtab_intern_cstr(rt, "error!"), pit_value_nativefunc_new(rt, impl_error)); /* basics */ - pit_symtab_fset(rt, pit_symtab_intern_cstr(rt, "progn"), pit_value_nativefunc_new(rt, impl_progn)); pit_symtab_fset(rt, pit_symtab_intern_cstr(rt, "eval!"), pit_value_nativefunc_new(rt, impl_eval)); /* predicates */ pit_symtab_fset(rt, pit_symtab_intern_cstr(rt, "eq?"), pit_value_nativefunc_new(rt, impl_eq_p)); diff --git a/pit/src/main.c b/pit/src/main.c index af759b6..74c2f03 100644 --- a/pit/src/main.c +++ b/pit/src/main.c @@ -7,11 +7,8 @@ #include <lcq/pit/runtime.h> #include <lcq/pit/library.h> -typedef char *mystr; -PIT_DECLARE_HASHTABLE(mystr, double) - int main(int argc, char **argv) { - i64 sz = 256 * 1024 * 1024; + i64 sz = 4 * 1024 * 1024; u8 *buf = malloc((size_t) sz); pit_runtime *rt = pit_runtime_new(buf, sz); pit_install_library_essential(rt); diff --git a/pit/src/native.c b/pit/src/native.c index b5b13e1..d3f2e95 100644 --- a/pit/src/native.c +++ b/pit/src/native.c @@ -36,6 +36,7 @@ bool pit_runtime_print_error(pit_runtime *rt) { for (i64 i = 0; i < rt->callstack->next; ++i) { pit_callstack_entry *a = pit_vec_get(pit_callstack_entry)(rt->callstack, i); if (a == NULL) continue; + if (a->tag == PIT_NIL) continue; fprintf(stderr, "on line %ld, column %ld (call to ", a->ann.line, a->ann.column); pit_dump_to_file(rt, stderr, a->tag, false); fprintf(stderr, "):\n"); @@ -99,6 +100,7 @@ pit_value pit_load_file(pit_runtime *rt, char *path) { pit_parser parse; bool eof = false; pit_value p = PIT_NIL; + pit_value compiled = PIT_NIL; pit_value ret = PIT_NIL; if (pit_lex_file(&lex, path) < 0) { pit_error(rt, "failed to lex file: %s", path); @@ -107,7 +109,9 @@ pit_value pit_load_file(pit_runtime *rt, char *path) { 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))); + compiled = pit_compile(rt, p); + check_invariants(rt); if (pit_runtime_print_error(rt)) return PIT_NIL; + ret = pit_vm_eval(rt, compiled); 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; diff --git a/pit/src/runtime.c b/pit/src/runtime.c index de0b2a2..633bff5 100644 --- a/pit/src/runtime.c +++ b/pit/src/runtime.c @@ -41,6 +41,7 @@ pit_runtime *pit_runtime_new(u8 *buf, i64 len) { ret->symtab = pit_vec_new(pit_symtab_entry)(pit_arena_alloc_back(a, symtab_size), symtab_size); ret->expr_stack = pit_vec_new(pit_value)(pit_arena_alloc_back(a, stack_size), stack_size); ret->result_stack = pit_vec_new(pit_value)(pit_arena_alloc_back(a, stack_size), stack_size); + ret->compilation_stack = pit_vec_new(pit_compilation_entry)(pit_arena_alloc_back(a, stack_size), stack_size); ret->traversal = pit_vec_new(pit_traversal_entry)(pit_arena_alloc_back(a, stack_size), stack_size); ret->callstack = pit_vec_new(pit_callstack_entry)(pit_arena_alloc_back(a, stack_size), stack_size); ret->saved_bindings = pit_vec_new(pit_value)(pit_arena_alloc_back(a, stack_size), stack_size); @@ -54,6 +55,7 @@ pit_runtime *pit_runtime_new(u8 *buf, i64 len) { pit_value truth = pit_symtab_intern_cstr(ret, "t"); pit_symtab_set(ret, truth, truth); pit_compile_install_special_forms(ret); + ret->msg_out_of_memory = pit_value_bytes_new_cstr(ret, "out of memory!"); pit_runtime_freeze(ret); return ret; } @@ -80,9 +82,9 @@ void pit_error(pit_runtime *rt, char *format, ...) { va_start(vargs, format); pit_libc_string_vsnprintf(buf, sizeof(buf), format, vargs); va_end(vargs); - rt->error = PIT_T; /* we set the error now to prevent infinite recursion */ + rt->error = rt->msg_out_of_memory; /* we set the error now to prevent infinite recursion */ rt->error = pit_value_bytes_new_cstr(rt, buf); /* in case this errs also */ - if (rt->error == PIT_NIL) rt->error = PIT_T; + if (rt->error == PIT_NIL) rt->error = rt->msg_out_of_memory; rt->error_line = rt->source_line; rt->error_column = rt->source_column; } @@ -96,6 +98,32 @@ pit_annotation *pit_annotation_get(struct pit_runtime *rt, pit_ref ref) { return pit_hashtable_lookup(pit_ref, pit_annotation)(rt->annotations, ref); } +void pit_compilation_push_value(struct pit_runtime *rt, pit_vec(pit_compilation_entry) *s, pit_value x) { + pit_compilation_entry ent; + ent.sort = PIT_COMPILATION_ENTRY_VALUE; + ent.in.value = x; + if (pit_vec_push(pit_compilation_entry)(s, ent) < 0) + pit_error(rt, "compilation stack overflow"); +} +void pit_compilation_push_drop(struct pit_runtime *rt, pit_vec(pit_compilation_entry) *s) { + pit_compilation_entry ent; + ent.sort = PIT_COMPILATION_ENTRY_DROP; + if (pit_vec_push(pit_compilation_entry)(s, ent) < 0) + pit_error(rt, "compilation stack overflow"); +} +void pit_compilation_push_begin_code(struct pit_runtime *rt, pit_vec(pit_compilation_entry) *s) { + pit_compilation_entry ent; + ent.sort = PIT_COMPILATION_ENTRY_BEGIN_CODE; + if (pit_vec_push(pit_compilation_entry)(s, ent) < 0) + pit_error(rt, "compilation stack overflow"); +} +void pit_compilation_push_end_code(struct pit_runtime *rt, pit_vec(pit_compilation_entry) *s) { + pit_compilation_entry ent; + ent.sort = PIT_COMPILATION_ENTRY_END_CODE; + if (pit_vec_push(pit_compilation_entry)(s, ent) < 0) + pit_error(rt, "compilation stack overflow"); +} + void pit_traversal_push_value(struct pit_runtime *rt, pit_vec(pit_traversal_entry) *s, pit_value x) { pit_traversal_entry ent; ent.sort = PIT_TRAVERSAL_ENTRY_VALUE; @@ -118,3 +146,15 @@ void pit_traversal_push_application(struct pit_runtime *rt, pit_vec(pit_traversa if (pit_vec_push(pit_traversal_entry)(s, ent) < 0) pit_error(rt, "traversal overflow"); } +void pit_traversal_push_begin_code(struct pit_runtime *rt, pit_vec(pit_traversal_entry) *s) { + pit_traversal_entry ent; + ent.sort = PIT_TRAVERSAL_ENTRY_BEGIN_CODE; + if (pit_vec_push(pit_traversal_entry)(s, ent) < 0) + pit_error(rt, "traversal overflow"); +} +void pit_traversal_push_end_code(struct pit_runtime *rt, pit_vec(pit_traversal_entry) *s) { + pit_traversal_entry ent; + ent.sort = PIT_TRAVERSAL_ENTRY_END_CODE; + if (pit_vec_push(pit_traversal_entry)(s, ent) < 0) + pit_error(rt, "traversal overflow"); +} diff --git a/pit/src/runtime/compile.c b/pit/src/runtime/compile.c index a676a61..e7a4ab8 100644 --- a/pit/src/runtime/compile.c +++ b/pit/src/runtime/compile.c @@ -1,35 +1,30 @@ #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; - } - } +/* helper functions for manipulating the compiler state */ +static void c_now(pit_runtime *rt, pit_value v) { + /* push a literal value to the traversal */ + pit_traversal_push_value(rt, rt->traversal, v); +} +static void c_compile(pit_runtime *rt, pit_value e) { + /* schedule an expression to be compiled */ + /* the resulting entries will be pushed to the traversal subsequently */ + pit_compilation_push_value(rt, rt->compilation_stack, e); +} +static void c_drop(pit_runtime *rt) { + /* schedule a drop to be compiled */ + pit_compilation_push_drop(rt, rt->compilation_stack); +} +static void c_code(pit_runtime *rt, pit_value e) { + /* schedule an expression to be compiled, and then captured as code */ + /* this will result in a literal code value being included in the program, */ + /* rather than the code itself (as in c_compile) */ + pit_compilation_push_end_code(rt, rt->compilation_stack); + pit_compilation_push_value(rt, rt->compilation_stack, e); + pit_compilation_push_begin_code(rt, rt->compilation_stack); } +/* given an expression and some initially bound variables (e.g. arguments), */ +/* compute the free variables in the expression */ 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; @@ -46,38 +41,50 @@ static pit_value free_vars(pit_runtime *rt, pit_value initial_bound, pit_value b bound = pit_value_cons_car(rt, boundscur); cur = pit_value_cons_cdr(rt, boundscur); if (pit_value_is_cons(rt, cur)) { + /* if the expression is a list, determine if it is a normal application */ pit_value fsym = pit_value_cons_car(rt, cur); bool is_symbol = pit_value_is_symbol(rt, fsym); + bool is_special_form = is_symbol && pit_symtab_is_symbol_special_form(rt, fsym); pit_value fargs = pit_value_cons_cdr(rt, cur); - if (is_symbol && pit_symtab_symbol_name_match_cstr(rt, fsym, "lambda")) { + /* first, consider special forms that have special behavior with regard to binding */ + if (is_special_form && pit_symtab_symbol_name_match_cstr(rt, fsym, "quote")) { + /* don't look inside quote! + NOTICE if we add other special forms, make sure to consider them here if necessary! */ + } else if (is_special_form && pit_symtab_symbol_name_match_cstr(rt, fsym, "lambda")) { + /* the variables from the lambda argument list are now bound */ pit_value new_bound = pit_value_list_append(rt, pit_value_cons_car(rt, fargs), bound); fargs = pit_value_cons_cdr(rt, fargs); + /* consider all body forms within the lambda with these new bindings in mind */ 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_value bindings_expr_pair = pit_value_cons(rt, new_bound, pit_value_cons_car(rt, fargs)); + if (pit_vec_push(pit_value)(rt->expr_stack, bindings_expr_pair) < 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 { + /* otherwise, this is a normal application form */ + /* first consider all arguments to the application */ 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_value bindings_expr_pair = pit_value_cons(rt, bound, pit_value_cons_car(rt, fargs)); + if (pit_vec_push(pit_value)(rt->expr_stack, bindings_expr_pair) < 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) { + /* ... and then consider the function being applied, if it is not a symbol */ + pit_value bindings_expr_pair = pit_value_cons(rt, bound, fsym); + if (pit_vec_push(pit_value)(rt->expr_stack, bindings_expr_pair) < 0) { pit_error(rt, "free variable search stack overflow"); return PIT_NIL; } } } } else if (pit_value_is_symbol(rt, cur)) { + /* if the expression is a symbol, check if it's free! */ if (pit_value_list_contains_eq(rt, cur, bound) == PIT_NIL) { ret = pit_value_cons(rt, cur, ret); } @@ -87,136 +94,219 @@ static pit_value free_vars(pit_runtime *rt, pit_value initial_bound, pit_value b 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 compile_special_form(pit_runtime *rt, pit_value f, pit_value args) { + char buf[256] = {0}; + if (pit_symtab_symbol_name_match_cstr(rt, f, "quote")) { + /* quote compiles to a literal instruction */ + c_now(rt, + pit_value_list(rt, 2, pit_symtab_intern_cstr(rt, "literal"), pit_value_cons_car(rt, args)) + ); + } else if (pit_symtab_symbol_name_match_cstr(rt, f, "if")) { + /* if compiles the condition, and then code for the branches, and then the if instruction */ + 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_code(rt, e); + c_code(rt, t); + c_compile(rt, c); + } else if (pit_symtab_symbol_name_match_cstr(rt, f, "progn")) { + /* progn simply compiles each of its argument forms in order */ + /* after every form but the final form, it inserts a drop to ignore the return value */ + while (args != PIT_NIL) { + pit_value form = pit_value_cons_car(rt, args); + args = pit_value_cons_cdr(rt, args); + c_compile(rt, form); + if (args != PIT_NIL) { + c_drop(rt); + } + } + } else if (pit_symtab_symbol_name_match_cstr(rt, f, "lambda")) { + pit_value arglist = pit_value_cons_car(rt, args); + pit_value body = pit_value_cons(rt, pit_symtab_intern_cstr(rt, "progn"), pit_value_cons_cdr(rt, args)); + c_now(rt, pit_value_list(rt, 1, pit_symtab_intern_cstr(rt, "lambda"))); + c_now(rt, pit_value_list(rt, 2, pit_symtab_intern_cstr(rt, "literal"), arglist)); + c_now(rt, pit_value_list(rt, 2, pit_symtab_intern_cstr(rt, "literal"), free_vars(rt, arglist, body))); + c_code(rt, body); + } else { + i64 end = pit_dump(rt, buf, sizeof(buf) - 1, f, true); + buf[end] = 0; + pit_error(rt, "unknown special form: %s", buf); + } } -static void c_now(pit_runtime *rt, pit_value v) { - pit_traversal_push_value(rt, rt->traversal, v); +static void compile_output_instruction(pit_runtime *rt, pit_value ins) { + /* write an instruction to the code block at the top of the compilation stack */ + pit_compilation_entry b; + if (pit_vec_pop(pit_compilation_entry)(rt->compilation_stack, &b) < 0) { + pit_error(rt, "compilation block stack underflow"); + return; + } + pit_value new = pit_value_cons(rt, ins, b.in.value); + pit_compilation_push_value(rt, rt->compilation_stack, new); } -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"); +static void compile_interpret_traversal_entry(pit_runtime *rt, pit_traversal_entry *ent) { + if (ent == NULL) { + pit_error(rt, "evaluation traversal invalid"); + return; + } + switch (ent->sort) { + case PIT_TRAVERSAL_ENTRY_VALUE: { + /* normal traversal entries just cons values to the code block at the top of the compilation stack */ + compile_output_instruction(rt, ent->in.value); + return; + } + case PIT_TRAVERSAL_ENTRY_BEGIN_CODE: { + /* starting a new code block pushes a new list to the top of the compilation stack */ + pit_compilation_push_value(rt, rt->compilation_stack, PIT_NIL); + return; + } + case PIT_TRAVERSAL_ENTRY_END_CODE: { + /* ending a code block pops a code block, and pushes it as a literal in the frame below */ + pit_compilation_entry b; + if (pit_vec_pop(pit_compilation_entry)(rt->compilation_stack, &b) < 0) { + pit_error(rt, "compilation block stack underflow"); + return; + } + compile_output_instruction(rt, pit_value_list(rt, 2, pit_symtab_intern_cstr(rt, "literal"), b.in.value)); + return; + } + default: + pit_error(rt, "unknown traversal entry"); + return; + } } pit_value pit_compile(pit_runtime *rt, pit_value top) { + /* compilation proceeds in a somewhat unintuitive manner */ + /* typically, we would simply recursively traverse the tree, accumulating the output code */ + /* (this also has the advantage of allowing the results of the recursive compilation call to */ + /* be used in nonstandard contexts, such as compiling the body of lambdas. */ + /* however, in pit we would like to avoid this sort of recursion, as we'd like to be able to */ + /* make claims about the interpreter's C stack usage (and also, in general, it seems quite */ + /* nice to avoid C stack usage growing with expression size!) */ + /* as such, we must explicitly represent the control/data flow that would otherwise be handled */ + /* implicitly by the recursion. we do this by breaking the compilation step into several steps. */ + /* first, we traverse the expression using a stack (rt->compilation_stack). during this step, we */ + /* push subexpression to be compiled to the stack, and append "generated code" to an intermediate */ + /* structure (rt->traversal). this intermediate structure contains "operations" to later perform */ + /* - think of it as the "continuation" of the code that produced it. finally, these intermediate */ + /* operations are "interpreted" to generate the real compiled code, which is a Lisp list of instructions */ + /* each instruction is itself a list of opcode and operands (see eval.c for more information on this) */ char buf[256] = {0}; - pit_value ret = PIT_NIL; - i64 expr_stack_reset = rt->expr_stack->next; + i64 compilation_stack_reset = rt->compilation_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); + /* before we do anything else, we fully macroexpand the input */ + top = pit_macroexpand(rt, top); + c_compile(rt, top); + while (rt->compilation_stack->next > compilation_stack_reset) { + pit_compilation_entry curent; + if (rt->error != PIT_NIL) goto err; + if (pit_vec_pop(pit_compilation_entry)(rt->compilation_stack, &curent) < 0) { + pit_error(rt, "compilation stack underflow"); + goto err; + } + switch (curent.sort) { + case PIT_COMPILATION_ENTRY_VALUE: { + pit_value cur = curent.in.value; + 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); + if (is_symbol && pit_symtab_is_symbol_special_form(rt, fsym)) { /* special forms */ + pit_value args = pit_value_cons_cdr(rt, cur); + compile_special_form(rt, fsym, 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) { + c_compile(rt, pit_value_cons_car(rt, args)); + args = pit_value_cons_cdr(rt, args); + argcount += 1; + } + if (!is_symbol) { + c_compile(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)); + } } - 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 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"))); + } else { /* other expressions evaluate to themselves! */ 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)); + break; + } + case PIT_COMPILATION_ENTRY_DROP: { + /* a BEGIN_CODE is a marker indicating that a new "block" of code has started */ + c_now(rt, pit_value_list(rt, 1, pit_symtab_intern_cstr(rt, "drop"))); + break; + } + case PIT_COMPILATION_ENTRY_BEGIN_CODE: { + /* a BEGIN_CODE is a marker indicating that a new "block" of code has started */ + pit_traversal_push_begin_code(rt, rt->traversal); + break; + } + case PIT_COMPILATION_ENTRY_END_CODE: { + /* an END_CODE is a marker indicating that the current "block" of code has finished */ + pit_traversal_push_end_code(rt, rt->traversal); + break; + } } } + /* now that we've built up the traversal, we iterate over it to build up the final program */ + /* the "current" code is at the top of the compilation stack (which we now repurpose to this end) */ + /* (note that this usage of the compilation state is entirely separate from the previous usage!) */ + rt->compilation_stack->next = compilation_stack_reset; + pit_compilation_push_value(rt, rt->compilation_stack, PIT_NIL); 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; - } + compile_interpret_traversal_entry(rt, ent); + } + goto end; +err: { + /* in case of error, we should always consider the stack empty, so we don't return something spurious */ + rt->compilation_stack->next = compilation_stack_reset; } end: { - rt->expr_stack->next = expr_stack_reset; + /* finally, we are done (possibly due to an error) */ + pit_value ret = PIT_NIL; + if (rt->compilation_stack->next > compilation_stack_reset) { + /* if the compilation stack is not empty, the top is our compiled code! */ + pit_compilation_entry ent; + pit_vec_pop(pit_compilation_entry)(rt->compilation_stack, &ent); + ret = ent.in.value; + } + if (rt->compilation_stack->next != compilation_stack_reset) { + /* if there was more than one entry on the compilation stack, this is a bug */ + pit_error(rt, "compilation did not reduce stack to single code! this is a bug!"); + } + rt->compilation_stack->next = compilation_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; -} - +/* mark the symbols for the special forms as such */ 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)); + pit_symtab_symbol_mark_special_form(rt, pit_symtab_intern_cstr(rt, "quote")); + pit_symtab_symbol_mark_special_form(rt, pit_symtab_intern_cstr(rt, "if")); + pit_symtab_symbol_mark_special_form(rt, pit_symtab_intern_cstr(rt, "progn")); + pit_symtab_symbol_mark_special_form(rt, pit_symtab_intern_cstr(rt, "lambda")); } diff --git a/pit/src/runtime/eval.c b/pit/src/runtime/eval.c index 3903a64..f149246 100644 --- a/pit/src/runtime/eval.c +++ b/pit/src/runtime/eval.c @@ -4,12 +4,12 @@ /* add a new stack frame to the vm (with a tag and callsite annotation) */ static void vm_push_code_func(pit_runtime *rt, pit_value code, pit_value tag, pit_annotation ann, pit_value bound) { + fprintf(stderr, "running: "); pit_dump_to_file(rt, stderr, code, false); fprintf(stderr, "\n"); pit_callstack_entry ent; ent.tag = tag; ent.ann = ann; ent.code = code; ent.bound = bound; - fprintf(stderr, "push code: "); pit_dump_to_file(rt, stderr, code, false); fprintf(stderr, "\n"); if (pit_vec_push(pit_callstack_entry)(rt->callstack, ent) < 0) { pit_error(rt, "call stack overflow"); } @@ -24,10 +24,10 @@ static void vm_push_code(pit_runtime *rt, pit_value code) { } 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"); } + fprintf(stderr, "result push!: %ld\n", rt->result_stack->next); } static pit_value vm_pop(pit_runtime *rt) { @@ -35,7 +35,7 @@ static pit_value vm_pop(pit_runtime *rt) { 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, "result pop!: %ld\n", rt->result_stack->next); return ret; } @@ -46,8 +46,6 @@ static void vm_call_lisp(pit_runtime *rt, pit_value tag, pit_value closure, pit_ 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); @@ -111,56 +109,54 @@ static bool vm_call(pit_runtime *rt, pit_value f, pit_value args) { /* run one instruction of the VM */ bool pit_vm_run_one(pit_runtime *rt) { +start: 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"); - return false; + if (ent->code == PIT_NIL) { /* if we encounter an empty stack frame... */ + pit_value bound = ent->bound; + 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); + } + pit_vec_pop(pit_callstack_entry)(rt->callstack, NULL); /* pop the frame, and try again */ + goto start; } - pit_value bound = ent->bound; - pit_value rest = pit_value_cons_cdr(rt, ent->code); - bool final = false; - if (rest == PIT_NIL) { - 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"); + pit_value ins = pit_value_cons_car(rt, ent->code); + if (ins == PIT_NIL) { pit_error(rt, "malformed vm instruction"); return false; } + ent->code = pit_value_cons_cdr(rt, ent->code); pit_value op = pit_value_cons_car(rt, ins); + fprintf(stderr, "ins: "); pit_dump_to_file(rt, stderr, ins, false); fprintf(stderr, "\n"); if (pit_symtab_symbol_name_match_cstr(rt, op, "literal")) { /* 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 */ + /* pop an argument list, a free variable list, and a body block */ + /* create and push a function */ /* 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)); + pit_value args = vm_pop(rt); + pit_value freevars = vm_pop(rt); + pit_value body = vm_pop(rt); + vm_push(rt, pit_value_func_lambda(rt, args, freevars, body)); + } else if (pit_symtab_symbol_name_match_cstr(rt, op, "drop")) { + /* pop a value and ignore it */ + vm_pop(rt); } else if (pit_symtab_symbol_name_match_cstr(rt, op, "get")) { - 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))); + vm_push(rt, pit_symtab_get(rt, vm_pop(rt))); } else if (pit_symtab_symbol_name_match_cstr(rt, op, "fget")) { /* 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 */ + /* pop a condition, a then-block, and an else-block */ + /* run the then-block if the condition is true, otherwise run the else-block */ + pit_value c = vm_pop(rt); 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; + vm_push_code(rt, c != PIT_NIL ? t : e); } 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))); @@ -172,13 +168,6 @@ bool pit_vm_run_one(pit_runtime *rt) { 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"); - 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); - } - } return true; } @@ -186,7 +175,12 @@ bool pit_vm_run_one(pit_runtime *rt) { pit_value pit_vm_eval(pit_runtime *rt, pit_value v) { i64 start = rt->callstack->next; vm_push_code(rt, v); - while (pit_vm_run_one(rt) && rt->callstack->next > start); + while (pit_vm_run_one(rt) && rt->callstack->next > start) { + // if (rt->expr_stack->next == 0 && rt->compilation_stack->next == 0) { + // fprintf(stderr, "running gc\n"); + // pit_gc(rt); /* TODO hack to avoid running GC during macroexpansion */ + // } + } return vm_pop(rt); } diff --git a/pit/src/runtime/gc.c b/pit/src/runtime/gc.c index 0880592..1cc6547 100644 --- a/pit/src/runtime/gc.c +++ b/pit/src/runtime/gc.c @@ -37,6 +37,17 @@ void pit_gc(pit_runtime *rt) { pit_arena_reset(tospace); pit_hashtable_reset(pit_ref, pit_annotation)(tospace_ann); /* populate tospace with immediately reachable values */ + /* any values saved directly to the runtime are reachable */ + rt->msg_out_of_memory = gc_copy_value(rt, rt->msg_out_of_memory); + /* everything on the call stack is reachable */ + for (i64 i = 0; i < rt->callstack->next; ++i) { + pit_callstack_entry *ent = pit_vec_get(pit_callstack_entry)(rt->callstack, i); + if (ent == NULL) continue; /* TODO warn on failure here? */ + ent->tag = gc_copy_value(rt, ent->tag); + ent->bound = gc_copy_value(rt, ent->bound); + ent->code = gc_copy_value(rt, ent->code); + } + /* the symbol table is reachable */ for (i64 i = 0; i < rt->symtab->next; ++i) { pit_symtab_entry *ent = pit_vec_get(pit_symtab_entry)(rt->symtab, i); if (ent == NULL) continue; /* TODO warn on failure here? */ @@ -44,10 +55,12 @@ void pit_gc(pit_runtime *rt) { ent->value = gc_copy_value(rt, ent->value); ent->function = gc_copy_value(rt, ent->function); } + /* all saved bindings are reachable */ for (i64 i = 0; i < rt->saved_bindings->next; ++i) { pit_value *v = pit_vec_get(pit_value)(rt->saved_bindings, i); if (v != NULL) *v = gc_copy_value(rt, *v); /* TODO warn on failure here? */ } + /* recursively populate all reachable values from that initial set */ for (i64 scan = 0; scan < tospace->next; ++scan) { pit_value_heavy *h = pit_arena_get(tospace, scan); switch (h->hsort) { diff --git a/pit/src/runtime/macroexpand.c b/pit/src/runtime/macroexpand.c index ffa796d..fdc1f14 100644 --- a/pit/src/runtime/macroexpand.c +++ b/pit/src/runtime/macroexpand.c @@ -1,9 +1,6 @@ #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"); +pit_value pit_macroexpand_1(pit_runtime *rt, pit_value top) { i64 expr_stack_reset = rt->expr_stack->next; i64 result_stack_reset = rt->result_stack->next; i64 traversal_reset = rt->traversal->next; @@ -17,10 +14,14 @@ pit_value pit_macroexpand(pit_runtime *rt, pit_value top) { 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); + bool is_special_form = is_symbol && pit_symtab_is_symbol_special_form(rt, fsym); + bool is_macro = is_symbol && pit_symtab_is_symbol_macro(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)) { + if (is_special_form && pit_symtab_symbol_name_match_cstr(rt, fsym, "quote")) { + /* don't macroexpand inside quote! + NOTICE if we add other special forms, make sure to consider them here if necessary! */ pit_traversal_push_value(rt, rt->traversal, cur); - } else if (is_symbol && pit_symtab_is_symbol_macro(rt, fsym)) { + } else if (is_macro) { pit_value f = pit_symtab_fget(rt, fsym); pit_value args = pit_value_cons_cdr(rt, cur); pit_value res = pit_vm_apply(rt, f, args); @@ -90,7 +91,15 @@ 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; } } + +pit_value pit_macroexpand(pit_runtime *rt, pit_value prev) { + pit_value next = prev; + do { + prev = next; + next = pit_macroexpand_1(rt, prev); + } while (!pit_value_equal(rt, next, prev)); + return next; +} diff --git a/pit/src/runtime/symtab.c b/pit/src/runtime/symtab.c index 33ed3ba..1894208 100644 --- a/pit/src/runtime/symtab.c +++ b/pit/src/runtime/symtab.c @@ -104,21 +104,20 @@ void pit_symtab_symbol_mark_special_form(pit_runtime *rt, pit_value sym) { if (!ent) { pit_error(rt, "bad symbol"); return; } ent->is_special_form = true; } -void pit_symtab_sfset(pit_runtime *rt, pit_value sym, pit_value v) { - pit_symtab_fset(rt, sym, v); - pit_symtab_symbol_mark_special_form(rt, sym); -} +#include <stdio.h> void pit_symtab_bind(pit_runtime *rt, pit_value sym, pit_value cell) { /* although we cannot set frozen symbols, we can still bind them temporarily - no need to check */ pit_symtab_entry *ent = pit_symtab_lookup(rt, sym); if (!ent) { pit_error(rt, "bad symbol"); return; } if (pit_vec_push(pit_value)(rt->saved_bindings, ent->value) < 0) pit_error(rt, "binding stack overflow"); ent->value = cell; + fprintf(stderr, "binding: "); pit_dump_to_file(rt, stderr, sym, false); fprintf(stderr, "\n"); } pit_value pit_symtab_unbind(pit_runtime *rt, pit_value sym) { pit_symtab_entry *ent = pit_symtab_lookup(rt, sym); if (!ent) { pit_error(rt, "bad symbol"); return PIT_NIL; } pit_value old = ent->value; if (pit_vec_pop(pit_value)(rt->saved_bindings, &ent->value) < 0) pit_error(rt, "binding stack underflow"); + fprintf(stderr, "unbinding: "); pit_dump_to_file(rt, stderr, sym, false); fprintf(stderr, "\n"); return old; } diff --git a/pit/src/runtime/value/cell.c b/pit/src/runtime/value/cell.c index a9cbe72..34b9226 100644 --- a/pit/src/runtime/value/cell.c +++ b/pit/src/runtime/value/cell.c @@ -11,7 +11,6 @@ pit_value pit_value_cell_new(pit_runtime *rt, pit_value v) { h->in.cell = v; return ret; } -#include <stdio.h> pit_value pit_value_cell_get(pit_runtime *rt, pit_value cell, pit_value sym) { if (pit_value_sort(cell) != PIT_VALUE_SORT_REF) { char buf[256]; diff --git a/pit/src/runtime/value/func.c b/pit/src/runtime/value/func.c index ad5ce4c..a27a4f9 100644 --- a/pit/src/runtime/value/func.c +++ b/pit/src/runtime/value/func.c @@ -1,7 +1,5 @@ #include <lcq/pit/runtime/value/func.h> -#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); } @@ -9,9 +7,6 @@ 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 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; } diff --git a/pit/src/utils.c b/pit/src/utils.c index a1716b1..75d59a6 100644 --- a/pit/src/utils.c +++ b/pit/src/utils.c @@ -1,5 +1,4 @@ #include <lcq/pit/utils.h> -#include <stdio.h> enum vsnprintf_mode { VSNPRINTF_MODE_NORMAL, diff --git a/pit/test/test4.pit b/pit/test/test4.pit index 321a988..ef8e04c 100644 --- a/pit/test/test4.pit +++ b/pit/test/test4.pit @@ -1,5 +1,6 @@ -(or - (case 'foo - ('foo 1) - ('bar 2)) - 3)
\ No newline at end of file +(print! + (or + (case 'baz + (foo 1) + (bar 2)) + 3))
\ No newline at end of file diff --git a/pit/test/test5.pit b/pit/test/test5.pit new file mode 100644 index 0000000..3ea3fc7 --- /dev/null +++ b/pit/test/test5.pit @@ -0,0 +1,5 @@ +(defun! foo (x) + (print! x) + (foo (+ x 1))) + +(foo 0)
\ No newline at end of file diff --git a/pit/test/test6.pit b/pit/test/test6.pit new file mode 100644 index 0000000..93e5860 --- /dev/null +++ b/pit/test/test6.pit @@ -0,0 +1,5 @@ +(print! + (case 'bar + (foo 1) + (bar 2))) +
\ No newline at end of file diff --git a/pit/test/test7.pit b/pit/test/test7.pit new file mode 100644 index 0000000..48d2c2c --- /dev/null +++ b/pit/test/test7.pit @@ -0,0 +1 @@ +(print! (list/map (lambda (x) (+ x 1)) '(1 2 3)))
\ No newline at end of file |