From 7d538647f4835171b5cce8560c91154c46c31535 Mon Sep 17 00:00:00 2001 From: Alexander Rosenberg Date: Tue, 8 Sep 2026 06:33:15 -0700 Subject: [PATCH] Refactor files --- src/base.c | 252 ++++++++++++--------------------------- src/base.h | 110 +---------------- src/function.c | 5 +- src/function.h | 2 - src/gc.c | 3 +- src/hashtable.c | 3 +- src/{lisp.c => interp.c} | 134 +++++++++------------ src/{lisp.h => interp.h} | 21 +--- src/lisp_string.c | 93 +++++++++++++++ src/lisp_string.h | 27 ++++- src/macro.c | 3 +- src/main.c | 5 +- src/print.c | 8 +- src/read.c | 1 + src/stack.c | 67 ++--------- src/stack.h | 7 +- src/symbol.c | 93 +++++++++++++++ src/symbol.h | 95 +++++++++++++++ 18 files changed, 489 insertions(+), 440 deletions(-) rename src/{lisp.c => interp.c} (65%) rename src/{lisp.h => interp.h} (55%) create mode 100644 src/symbol.c create mode 100644 src/symbol.h diff --git a/src/base.c b/src/base.c index b272d33..0d772cc 100644 --- a/src/base.c +++ b/src/base.c @@ -3,10 +3,11 @@ #include "function.h" #include "gc.h" #include "hashtable.h" -#include "io.h" -#include "lisp.h" +#include "init_globals.h" +#include "lisp_math.h" #include "list.h" #include "stack.h" +#include "symbol.h" #include #include @@ -184,176 +185,6 @@ DEFUN(length, "length", (LispVal * seq), "(seq)", "") { signal_type_error(seq, LIST(Qlist, Qvector, Qstring, Qhash_table)); } -// ################ -// # Constructors # -// ################ -LispVal *make_vector(LispVal **data, size_t length, bool take) { - LispVector *obj = lisp_alloc_object(sizeof(LispVector), TYPE_VECTOR); - obj->length = length; - if (take) { - obj->data = data; - for (size_t i = 0; i < length; ++i) { - MARK_OBJECT_ADDED(data[i], obj); - } - } else { - obj->data = lisp_malloc(sizeof(LispVal *) * length); - for (size_t i = 0; i < length; ++i) { - MARK_OBJECT_ADDED(data[i], obj); - obj->data[i] = data[i]; - } - } - return obj; -} - -DEFUN(vector, "vector", (LispVal * data), "(&rest data)", "") { - intptr_t length = list_length(data); - if (length == -1) { - lisp_signal(Qcircular_list_error, Qnil); - } - LispVal **vec_data = lisp_malloc(sizeof(LispVal *) * length); - size_t i = 0; - DOLIST(datum, data) { - vec_data[i++] = datum; - } - return make_vector(vec_data, length, true); -} - -DEFUN(make_symbol, "make-symbol", (LispVal * name), "(name)", - "Return an uninterned symbol called NAME.") { - LispSymbol *obj = lisp_alloc_object(sizeof(LispSymbol), TYPE_SYMBOL); - obj->name = name; - obj->function = Qnil; - obj->plist = Qnil; - obj->value_type = SYMBOL_NORMAL; - if (KEYWORDP(obj)) { - obj->value.normal = obj; - obj->flags |= SYMBOL_CONST_VALUE; - } else { - obj->value.normal = Qunbound; - } - return obj; -} - -DEFUN(vectorp, "vectorp", (LispVal * data), "(data)", "") { - return VECTORP(data) ? Qt : Qnil; -} - -DEFUN(symbolp, "symbolp", (LispVal * data), "(data)", "") { - return SYMBOLP(data) ? Qt : Qnil; -} - -DEFUN(intern, "intern", (LispVal * name), "(name)", "") { - CHECK_TYPE(name, TYPE_STRING); - LispVal *res = Fgethash(obarray, name, Qunbound); - if (res != Qunbound) { - return res; - } - LispVal *newsym = Fmake_symbol(name); - Fputhash(obarray, name, newsym); - return newsym; -} - -DEFUN(symbol_value, "symbol-value", (LispVal * sym), "(sym)", "") { - CHECK_TYPE(sym, TYPE_SYMBOL); - return SYMBOL_VALUE(sym); -} - -DEFUN(symbol_function, "symbol-function", (LispVal * sym, LispVal *resolve), - "(sym &optional resolve)", "") { - CHECK_TYPE(sym, TYPE_SYMBOL); - if (NILP(resolve)) { - return ((LispSymbol *) sym)->function; - } - while (!NILP(sym) && SYMBOLP(sym)) { - sym = ((LispSymbol *) sym)->function; - } - return sym; -} - -DEFUN(symbol_plist, "symbol-plist", (LispVal * sym), "(sym)", "") { - CHECK_TYPE(sym, TYPE_SYMBOL); - return ((LispSymbol *) sym)->plist; -} - -DEFUN(set, "set", (LispVal * sym, LispVal *value), "(sym value)", "") { - CHECK_TYPE(sym, TYPE_SYMBOL); - SET_SYMBOL_VALUE(sym, value); - return value; -} - -DEFUN(fset, "fset", (LispVal * sym, LispVal *value), "(sym value)", "") { - CHECK_TYPE(sym, TYPE_SYMBOL); - if (CONST_FUNCTION_P(sym)) { - signal_value_constant(sym); - } - ((LispSymbol *) sym)->function = value; - MARK_OBJECT_ADDED(value, sym); - return value; -} - -DEFUN(setplist, "setplist", (LispVal * sym, LispVal *plist), "(sym plist)", - "") { - CHECK_TYPE(sym, TYPE_SYMBOL); - ((LispSymbol *) sym)->plist = plist; - MARK_OBJECT_ADDED(plist, sym); - return plist; -} - -DEFUN(get, "get", (LispVal * sym, LispVal *key, LispVal *def), - "(sym key &optional def)", "") { - return Fplist_get(Fsymbol_plist(sym), key, def); -} - -DEFUN(put, "put", (LispVal * sym, LispVal *key, LispVal *val), "(sym key val)", - "") { - return Fsetplist(sym, Fplist_put(Fsymbol_plist(sym), key, val)); -} - -static size_t check_index_in_range(LispVal *val, size_t size) { - if (FIXNUMP(val)) { - fixnum_t fn = XFIXNUM(val); - if (fn < 0 || fn >= size) { - goto out_of_bounds; - } - return fn; - } else if (LISP_GMP_P(val)) { - if (mpz_sgn(((LispGmp *) val)->val) < 0) { - goto out_of_bounds; - } - size_t out = mpz_get_ui(((LispGmp *) val)->val); - if (out >= size) { - goto out_of_bounds; - } - return out; - } - signal_type_error(val, Qinteger); -out_of_bounds: - lisp_signal(Qout_of_bounds_error, LIST(val, make_number_unsigned(size))); -} - -DEFUN(aref, "aref", (LispVal * arr, LispVal *idx), "(arr idx)", "") { - if (VECTORP(arr)) { - LispVector *v = arr; - size_t i = check_index_in_range(idx, v->length); - return v->data[i]; - } else if (STRINGP(arr)) { - LispString *s = arr; - size_t i = check_index_in_range(idx, s->length); - return MAKE_FIXNUM(s->data[i]); - } - signal_type_error(arr, LIST(Qstring, Qvector)); -} - -DEFUN(aset, "aset", (LispVal * arr, LispVal *idx, LispVal *data), - "(arr idx data)", "") { - CHECK_TYPE(arr, TYPE_VECTOR); - CHECK_TYPE(idx, TYPE_FIXNUM, TYPE_GMP); - LispVector *v = arr; - size_t i = check_index_in_range(idx, v->length); - v->data[i] = data; - return data; -} - noreturn void signal_value_constant(LispVal *value) { lisp_signal(Qvalue_constant_error, LIST(value)); } @@ -441,8 +272,6 @@ DEFUN(condition_printer, "condition-printer", (LispVal * val), "(val)", "") { return Fget(val, Qcondition_printer, Qnil); } -DEFINE_SYMBOL(kw_success, ":success"); - DEFUN(signal, "signal", (LispVal * name, LispVal *data), "(name data)", "") { lisp_signal(name, data); // the above is a non-local exit, if we come back here something has gone @@ -503,3 +332,78 @@ DEFINE_CONDITION_CLASS(out_of_bounds_error, error); DEFINE_SYMBOL(backquote, "`"); DEFINE_SYMBOL(comma, ","); DEFINE_SYMBOL(comma_at, ",@"); + +// ##################### +// # VM Initialization # +// ##################### +static void construct_manual_symbols(void) { + // IMPORTANT: the symbols listed here need to also be set as special in + // gen-init-globals.awk + Qnil = Fmake_symbol(LISP_LITSTR("nil")); + ((LispSymbol *) Qnil)->flags = SYMBOL_CONST_VALUE | SYMBOL_CONST_FUNCTION; + ((LispSymbol *) Qnil)->value.normal = Qnil; + ((LispSymbol *) Qnil)->function = Qnil; + ((LispSymbol *) Qnil)->plist = Qnil; + lisp_gc_register_static_object(Qnil); + Qt = Fmake_symbol(LISP_LITSTR("t")); + ((LispSymbol *) Qt)->flags = SYMBOL_CONST_VALUE | SYMBOL_CONST_FUNCTION; + ((LispSymbol *) Qt)->value.normal = Qt; + lisp_gc_register_static_object(Qt); + Qunbound = Fmake_symbol(LISP_LITSTR("unbound")); + ((LispSymbol *) Qunbound)->value.normal = Qunbound; + lisp_gc_register_static_object(Qunbound); + Qlexical_environment = Fmake_symbol(LISP_LITSTR("lexical-environment")); + ((LispSymbol *) Qlexical_environment)->value_type = SYMBOL_NATIVE; + ((LispSymbol *) Qlexical_environment)->value.native = &Vlexical_environment; + lisp_gc_register_static_object(Qlexical_environment); + Qlexical_tags = Fmake_symbol(LISP_LITSTR("lexical-tags")); + lisp_gc_register_static_object(Qlexical_tags); + + Qhash_string = Fmake_symbol(LISP_LITSTR("hash-string")); + lisp_gc_register_static_object(Qhash_string); + Qstrings_equal = Fmake_symbol(LISP_LITSTR("strings-equal")); + lisp_gc_register_static_object(Qstrings_equal); +} + +static void register_manual_symbols(void) { +#define INTERN(cname) \ + Fputhash(obarray, ((LispSymbol *) Q##cname)->name, Q##cname); + INTERN(nil); + INTERN(t); + // don't INTERN(unbound); + // don't INTERN(lexical_environment); + // don't INTERN(lexical_tags); + INTERN(hash_string); + INTERN(strings_equal); +#undef INTERN +} + +void lisp_init(void) { + mp_set_memory_functions(lisp_malloc, lisp_realloc_gmp, lisp_free_gmp); + construct_manual_symbols(); + Vlexical_environment = Qnil; + obarray = Fmake_hash_table(Qhash_string, Qstrings_equal); + lisp_gc_register_static_object(obarray); + + // Needed to register functions + REGISTER_GLOBAL_SYMBOL(and_allow_other_keys); + REGISTER_GLOBAL_SYMBOL(and_optional); + REGISTER_GLOBAL_SYMBOL(and_key); + REGISTER_GLOBAL_SYMBOL(and_rest); + + // these call Fintern, so they need to have obarray constructed + ((LispSymbol *) Qhash_string)->function = BUILTIN_FUNCTION_OBJ(hash_string); + ((LispSymbol *) Qstrings_equal)->function = + BUILTIN_FUNCTION_OBJ(hash_string); + + register_manual_symbols(); + register_globals(); + + lisp_init_stack(); + lisp_gc_on_alloc = true; +} + +void lisp_shutdown(void) { + lisp_teardown_stack(); + lisp_gc_teardown(); +} diff --git a/src/base.h b/src/base.h index d8d5f9c..a845774 100644 --- a/src/base.h +++ b/src/base.h @@ -196,48 +196,6 @@ noreturn void signal_type_error(LispVal *obj, LispVal *typespec); } \ struct __ignored -DEFOBJTYPE(String, STRING, STRINGP, { - size_t length; - char *data; - bool owned; -}); - -enum SymbolValueType { - SYMBOL_NORMAL, - SYMBOL_NATIVE, -}; - -enum SymbolFlags { - SYMBOL_DYNAMIC = 1, - SYMBOL_CONST_VALUE = 2, - SYMBOL_CONST_FUNCTION = 4, -}; - -DEFOBJTYPE(Symbol, SYMBOL, SYMBOLP, { - LispVal *name; // string - enum SymbolValueType value_type : 1; - enum SymbolFlags flags : 7; - LispVal *function; - union { - LispVal *normal; - LispVal **native; - } value; - LispVal *plist; -}); - -static ALWAYS_INLINE bool KEYWORDP(LispVal *val) { - if (!SYMBOLP(val)) { - return false; - } - LispString *sym = (LispString *) ((LispSymbol *) val)->name; - return sym->length && *sym->data == ':'; -} - -DEFOBJTYPE(Vector, VECTOR, VECTORP, { - size_t length; - LispVal **data; -}); - // Defined here instead of in function.h so that headers don't have to include // it just to define functions #define DECLARE_SYMBOL(cname) \ @@ -377,69 +335,9 @@ DECLARE_FUNCTION(equal, (LispVal * obj1, LispVal *obj2)); DECLARE_FUNCTION(length, (LispVal * seq)); // TODO probably move these to another file -LispVal *make_vector(LispVal **data, size_t length, bool take); -DECLARE_FUNCTION(vector, (LispVal * data)); -DECLARE_FUNCTION(make_symbol, (LispVal * name)); -DECLARE_FUNCTION(vectorp, (LispVal * data)); -DECLARE_FUNCTION(symbolp, (LispVal * data)); -DECLARE_FUNCTION(intern, (LispVal * name)); -DECLARE_FUNCTION(symbol_value, (LispVal * sym)); -DECLARE_FUNCTION(symbol_function, (LispVal * sym, LispVal *resolve)); -DECLARE_FUNCTION(symbol_plist, (LispVal * sym)); -DECLARE_FUNCTION(set, (LispVal * sym, LispVal *value)); -DECLARE_FUNCTION(fset, (LispVal * sym, LispVal *value)); -DECLARE_FUNCTION(setplist, (LispVal * sym, LispVal *plist)); -DECLARE_FUNCTION(get, (LispVal * sym, LispVal *key, LispVal *def)); -DECLARE_FUNCTION(put, (LispVal * sym, LispVal *key, LispVal *val)); - -DECLARE_FUNCTION(aref, (LispVal * arr, LispVal *idx)); -DECLARE_FUNCTION(aset, (LispVal * arr, LispVal *idx, LispVal *data)); noreturn void signal_value_constant(LispVal *value); -static ALWAYS_INLINE LispVal *SYMBOL_VALUE(LispVal *sym) { - assert(SYMBOLP(sym)); - LispSymbol *s = (LispSymbol *) sym; - switch (s->value_type) { - case SYMBOL_NORMAL: - return s->value.normal; - case SYMBOL_NATIVE: - return *s->value.native; - } -} - -static ALWAYS_INLINE bool CONST_VALUE_P(LispVal *sym) { - assert(SYMBOLP(sym)); - return ((LispSymbol *) sym)->flags & SYMBOL_CONST_VALUE; -} - -static ALWAYS_INLINE bool CONST_FUNCTION_P(LispVal *sym) { - assert(SYMBOLP(sym)); - return ((LispSymbol *) sym)->flags & SYMBOL_CONST_FUNCTION; -} - -static ALWAYS_INLINE bool DYNAMIC_SYMBOL_P(LispVal *sym) { - assert(SYMBOLP(sym)); - return ((LispSymbol *) sym)->flags & SYMBOL_DYNAMIC; -} - -static inline void SET_SYMBOL_VALUE(LispVal *sym, LispVal *value) { - assert(SYMBOLP(sym)); - LispSymbol *s = (LispSymbol *) sym; - if (CONST_VALUE_P(sym)) { - signal_value_constant(sym); - } - switch (s->value_type) { - case SYMBOL_NORMAL: - s->value.normal = value; - break; - case SYMBOL_NATIVE: - *s->value.native = value; - break; - } - MARK_OBJECT_ADDED(value, sym); -} - // needed for conditions DECLARE_SYMBOL(fixnum); DECLARE_SYMBOL(float); @@ -463,8 +361,6 @@ DECLARE_FUNCTION(condition_class_p, (LispVal * val)); DECLARE_FUNCTION(condition_subclass_p, (LispVal * child, LispVal *parent)); DECLARE_FUNCTION(condition_printer, (LispVal * val)); -DECLARE_SYMBOL(kw_success); - DECLARE_FUNCTION(signal, (LispVal * name, LispVal *data)); DECLARE_FUNCTION(handler_bind, (LispVal * thunk, LispVal *handlers)); DECLARE_FUNCTION(error, (LispVal * data)); @@ -484,4 +380,10 @@ DECLARE_SYMBOL(backquote); DECLARE_SYMBOL(comma); DECLARE_SYMBOL(comma_at); +// ##################### +// # VM Initialization # +// ##################### +void lisp_init(void); +void lisp_shutdown(void); + #endif diff --git a/src/function.c b/src/function.c index 3826f47..d131f21 100644 --- a/src/function.c +++ b/src/function.c @@ -1,11 +1,14 @@ #include "function.h" #include "hashtable.h" -#include "lisp.h" +#include "interp.h" #include "lisp_string.h" #include "list.h" +#include "macro.h" +#include "print.h" #include "read.h" #include "stack.h" +#include "symbol.h" #include #include diff --git a/src/function.h b/src/function.h index 6e39883..8d19565 100644 --- a/src/function.h +++ b/src/function.h @@ -2,9 +2,7 @@ #define INCLUDED_FUNCTION_H #include "base.h" -#include "lisp_string.h" #include "list.h" -#include "stack.h" DECLARE_SYMBOL(and_optional); DECLARE_SYMBOL(and_rest); diff --git a/src/gc.c b/src/gc.c index e32f05c..08e15fa 100644 --- a/src/gc.c +++ b/src/gc.c @@ -2,10 +2,11 @@ #include "function.h" #include "hashtable.h" -#include "lisp.h" #include "lisp_math.h" +#include "lisp_string.h" #include "list.h" #include "stack.h" +#include "symbol.h" #include #include diff --git a/src/hashtable.c b/src/hashtable.c index ff71c77..ca7c4f0 100644 --- a/src/hashtable.c +++ b/src/hashtable.c @@ -1,6 +1,7 @@ #include "hashtable.h" -#include "lisp.h" +#include "function.h" +#include "lisp_math.h" #include "lisp_string.h" #define INITIAL_SIZE 32 diff --git a/src/lisp.c b/src/interp.c similarity index 65% rename from src/lisp.c rename to src/interp.c index 936f8c0..0a311e8 100644 --- a/src/lisp.c +++ b/src/interp.c @@ -1,82 +1,11 @@ -#include "lisp.h" +#include "interp.h" -#include "hashtable.h" -#include "init_globals.h" +#include "function.h" #include "lisp_string.h" - -LispVal *obarray; - -static void construct_manual_symbols(void) { - // IMPORTANT: the symbols listed here need to also be set as special in - // gen-init-globals.awk - Qnil = Fmake_symbol(LISP_LITSTR("nil")); - ((LispSymbol *) Qnil)->flags = SYMBOL_CONST_VALUE | SYMBOL_CONST_FUNCTION; - ((LispSymbol *) Qnil)->value.normal = Qnil; - ((LispSymbol *) Qnil)->function = Qnil; - ((LispSymbol *) Qnil)->plist = Qnil; - lisp_gc_register_static_object(Qnil); - Qt = Fmake_symbol(LISP_LITSTR("t")); - ((LispSymbol *) Qt)->flags = SYMBOL_CONST_VALUE | SYMBOL_CONST_FUNCTION; - ((LispSymbol *) Qt)->value.normal = Qt; - lisp_gc_register_static_object(Qt); - Qunbound = Fmake_symbol(LISP_LITSTR("unbound")); - ((LispSymbol *) Qunbound)->value.normal = Qunbound; - lisp_gc_register_static_object(Qunbound); - Qlexical_environment = Fmake_symbol(LISP_LITSTR("lexical-environment")); - ((LispSymbol *) Qlexical_environment)->value_type = SYMBOL_NATIVE; - ((LispSymbol *) Qlexical_environment)->value.native = &Vlexical_environment; - lisp_gc_register_static_object(Qlexical_environment); - Qlexical_tags = Fmake_symbol(LISP_LITSTR("lexical-tags")); - lisp_gc_register_static_object(Qlexical_tags); - - Qhash_string = Fmake_symbol(LISP_LITSTR("hash-string")); - lisp_gc_register_static_object(Qhash_string); - Qstrings_equal = Fmake_symbol(LISP_LITSTR("strings-equal")); - lisp_gc_register_static_object(Qstrings_equal); -} - -static void register_manual_symbols(void) { -#define INTERN(cname) \ - Fputhash(obarray, ((LispSymbol *) Q##cname)->name, Q##cname); - INTERN(nil); - INTERN(t); - // don't INTERN(unbound); - // don't INTERN(lexical_environment); - // don't INTERN(lexical_tags); - INTERN(hash_string); - INTERN(strings_equal); -#undef INTERN -} - -void lisp_init(void) { - mp_set_memory_functions(lisp_malloc, lisp_realloc_gmp, lisp_free_gmp); - construct_manual_symbols(); - Vlexical_environment = Qnil; - obarray = Fmake_hash_table(Qhash_string, Qstrings_equal); - lisp_gc_register_static_object(obarray); - - // Needed to register functions - REGISTER_GLOBAL_SYMBOL(and_allow_other_keys); - REGISTER_GLOBAL_SYMBOL(and_optional); - REGISTER_GLOBAL_SYMBOL(and_key); - REGISTER_GLOBAL_SYMBOL(and_rest); - - // these call Fintern, so they need to have obarray constructed - ((LispSymbol *) Qhash_string)->function = BUILTIN_FUNCTION_OBJ(hash_string); - ((LispSymbol *) Qstrings_equal)->function = - BUILTIN_FUNCTION_OBJ(hash_string); - - register_manual_symbols(); - register_globals(); - - lisp_init_stack(); - lisp_gc_on_alloc = true; -} - -void lisp_shutdown(void) { - lisp_teardown_stack(); - lisp_gc_teardown(); -} +#include "list.h" +#include "macro.h" +#include "stack.h" +#include "symbol.h" static inline LispVal *lookup_variable(LispSymbol *name) { LispVal *lexval = Fplist_get(Vlexical_environment, name, Qunbound); @@ -251,5 +180,56 @@ DEFUN(not, "not", (LispVal * datum), "(datum)", "") { return NILP(datum) ? Qt : Qnil; } +DEFSPECIAL(block, "block", (LispVal * name, LispVal *body), "(name &rest body)", + "") { + CHECK_TYPE(name, TYPE_SYMBOL); + if (!SYMBOLP(name)) + CHECK_TYPE(name, TYPE_SYMBOL); + LispVal *volatile return_value = Qnil; + jmp_buf target; + StackFrame *stack_ref = LISP_STACK_REF(); + LispVal *tag = Fmake_symbol(((LispSymbol *) name)->name); + LispVal *cur_tags = Fplist_get(Vlexical_environment, name, Qnil); + push_copy_lexenv(); + new_lexical_variable(Qlexical_tags, CONS(CONS(name, tag), cur_tags)); + push_block_frame(tag, &target, &return_value, stack_ref); + if (setjmp(target) == 0) { + return UNWIND_AND_RETURN(stack_ref, Fprogn(body)); + } else { + // return-from handles unwinding and putting the return value in a local + // references frame + return return_value; + } +} + +static LispVal *lookup_block_tag(LispVal *name) { + LispVal *tags = Fplist_get(Vlexical_environment, Qlexical_tags, Qnil); + LispVal *ent = Fassoc(name, tags, Qnil); + return CONSP(ent) ? XCDR(ent) : Qunbound; +} + +DEFSPECIAL(return_from, "return-from", (LispVal * name, LispVal *value), + "(name &optional value)", "") { + CHECK_TYPE(name, TYPE_SYMBOL); + value = eval(value); + LispVal *tag = lookup_block_tag(name); + if (tag != Qunbound) { + for (ptrdiff_t i = the_stack.depth; i >= 0; --i) { + StackFrame *restrict frame = &the_stack.frames[i]; + if (frame->kind == STACK_FRAME_BLOCK && EQ(frame->block.tag, tag)) { + add_local_reference(frame->block.unwind_to, value); + *frame->block.value_ptr = value; + unwind_to(frame->block.unwind_to); + longjmp(*frame->block.target, 1); + } + } + // block went out of scope + lisp_signal(Qblock_out_of_scope_error, LIST(name)); + } else { + // block never existed + lisp_signal(Qno_such_block_error, LIST(name)); + } +} + DEFINE_SYMBOL(unbound_variable_error, "unbound-variable-error"); DEFINE_CONDITION_CLASS(unbound_variable_error, error); diff --git a/src/lisp.h b/src/interp.h similarity index 55% rename from src/lisp.h rename to src/interp.h index a5d6560..03cc54e 100644 --- a/src/lisp.h +++ b/src/interp.h @@ -1,21 +1,7 @@ -#ifndef INCLUDED_LISP_H -#define INCLUDED_LISP_H +#ifndef INCLUDED_INTERP_H +#define INCLUDED_INTERP_H #include "base.h" -#include "function.h" // IWYU pragma: export -#include "hashtable.h" // IWYU pragma: export -#include "lisp_math.h" // IWYU pragma: export -#include "lisp_string.h" // IWYU pragma: export -#include "list.h" // IWYU pragma: export -#include "macro.h" // IWYU pragma: export -#include "print.h" // IWYU pragma: export -#include "stack.h" // IWYU pragma: export - -extern LispVal *obarray; - -void lisp_init(void); - -void lisp_shutdown(void); LispVal *eval(LispVal *form); DECLARE_FUNCTION(eval, (LispVal * form, LispVal *lexenv)); @@ -28,6 +14,9 @@ DECLARE_FUNCTION(or, (LispVal * forms)); DECLARE_FUNCTION(null, (LispVal * datum)); DECLARE_FUNCTION(not, (LispVal * datum)); +DECLARE_FUNCTION(block, (LispVal * name, LispVal *body)); +DECLARE_FUNCTION(return_from, (LispVal * name, LispVal *value)); + DECLARE_SYMBOL(unbound_variable_error); MAKE_CONDITION_CLASS(unbound_variable_error); diff --git a/src/lisp_string.c b/src/lisp_string.c index 9a4a895..c4d3be0 100644 --- a/src/lisp_string.c +++ b/src/lisp_string.c @@ -1,9 +1,16 @@ #include "lisp_string.h" +#include "lisp_math.h" +#include "list.h" +#include "stack.h" + #include #include #include +// ########### +// # Strings # +// ########### LispVal *make_lisp_string(const char *data, size_t length, bool take, bool copy) { LispString *obj = lisp_alloc_object(sizeof(LispString), TYPE_STRING); @@ -77,3 +84,89 @@ DEFUN(charp, "charp", (LispVal * obj), "(obj)", "") { } DEFINE_SYMBOL(char, "char"); + +// ########### +// # Vectors # +// ########### +LispVal *make_vector(LispVal **data, size_t length, bool take) { + LispVector *obj = lisp_alloc_object(sizeof(LispVector), TYPE_VECTOR); + obj->length = length; + if (take) { + obj->data = data; + for (size_t i = 0; i < length; ++i) { + MARK_OBJECT_ADDED(data[i], obj); + } + } else { + obj->data = lisp_malloc(sizeof(LispVal *) * length); + for (size_t i = 0; i < length; ++i) { + MARK_OBJECT_ADDED(data[i], obj); + obj->data[i] = data[i]; + } + } + return obj; +} + +DEFUN(vector, "vector", (LispVal * data), "(&rest data)", "") { + intptr_t length = list_length(data); + if (length == -1) { + lisp_signal(Qcircular_list_error, Qnil); + } + LispVal **vec_data = lisp_malloc(sizeof(LispVal *) * length); + size_t i = 0; + DOLIST(datum, data) { + vec_data[i++] = datum; + } + return make_vector(vec_data, length, true); +} + +DEFUN(vectorp, "vectorp", (LispVal * data), "(data)", "") { + return VECTORP(data) ? Qt : Qnil; +} + +// ######## +// # Both # +// ######## +static size_t check_index_in_range(LispVal *val, size_t size) { + if (FIXNUMP(val)) { + fixnum_t fn = XFIXNUM(val); + if (fn < 0 || fn >= size) { + goto out_of_bounds; + } + return fn; + } else if (LISP_GMP_P(val)) { + if (mpz_sgn(((LispGmp *) val)->val) < 0) { + goto out_of_bounds; + } + size_t out = mpz_get_ui(((LispGmp *) val)->val); + if (out >= size) { + goto out_of_bounds; + } + return out; + } + signal_type_error(val, Qinteger); +out_of_bounds: + lisp_signal(Qout_of_bounds_error, LIST(val, make_number_unsigned(size))); +} + +DEFUN(aref, "aref", (LispVal * arr, LispVal *idx), "(arr idx)", "") { + if (VECTORP(arr)) { + LispVector *v = arr; + size_t i = check_index_in_range(idx, v->length); + return v->data[i]; + } else if (STRINGP(arr)) { + LispString *s = arr; + size_t i = check_index_in_range(idx, s->length); + return MAKE_FIXNUM(s->data[i]); + } + signal_type_error(arr, LIST(Qstring, Qvector)); +} + +DEFUN(aset, "aset", (LispVal * arr, LispVal *idx, LispVal *data), + "(arr idx data)", "") { + CHECK_TYPE(arr, TYPE_VECTOR); + CHECK_TYPE(idx, TYPE_FIXNUM, TYPE_GMP); + LispVector *v = arr; + size_t i = check_index_in_range(idx, v->length); + v->data[i] = data; + return data; +} diff --git a/src/lisp_string.h b/src/lisp_string.h index 27101e4..f34fce6 100644 --- a/src/lisp_string.h +++ b/src/lisp_string.h @@ -5,7 +5,14 @@ #include -// LispString (the type) is defined in base.h +// ########### +// # Strings # +// ########### +DEFOBJTYPE(String, STRING, STRINGP, { + size_t length; + char *data; + bool owned; +}); LispVal *make_lisp_string(const char *data, size_t length, bool take, bool copy); @@ -23,4 +30,22 @@ DECLARE_FUNCTION(hash_string, (LispVal * string)); DECLARE_FUNCTION(charp, (LispVal * obj)); DECLARE_SYMBOL(char); +// ########### +// # Vectors # +// ########### +DEFOBJTYPE(Vector, VECTOR, VECTORP, { + size_t length; + LispVal **data; +}); + +LispVal *make_vector(LispVal **data, size_t length, bool take); +DECLARE_FUNCTION(vector, (LispVal * data)); +DECLARE_FUNCTION(vectorp, (LispVal * data)); + +// ######## +// # Both # +// ######## +DECLARE_FUNCTION(aref, (LispVal * arr, LispVal *idx)); +DECLARE_FUNCTION(aset, (LispVal * arr, LispVal *idx, LispVal *data)); + #endif diff --git a/src/macro.c b/src/macro.c index ee2da79..17f5396 100644 --- a/src/macro.c +++ b/src/macro.c @@ -1,8 +1,9 @@ #include "macro.h" #include "function.h" -#include "lisp.h" +#include "interp.h" #include "list.h" +#include "symbol.h" DEFINE_SYMBOL(macro, "macro"); diff --git a/src/main.c b/src/main.c index 4eae3cb..e5b09dd 100644 --- a/src/main.c +++ b/src/main.c @@ -1,6 +1,9 @@ +#include "interp.h" #include "io.h" -#include "lisp.h" +#include "list.h" +#include "print.h" #include "read.h" +#include "stack.h" #include #include diff --git a/src/print.c b/src/print.c index f392663..ccefa32 100644 --- a/src/print.c +++ b/src/print.c @@ -1,9 +1,13 @@ #include "print.h" +#include "function.h" +#include "hashtable.h" #include "io.h" -#include "lisp.h" -// for WHITESPACEP, READ_EOS, and SYMBOL_END_P +#include "lisp_math.h" +#include "lisp_string.h" #include "read.h" +#include "stack.h" +#include "symbol.h" #include #include diff --git a/src/read.c b/src/read.c index 2813341..1d521b5 100644 --- a/src/read.c +++ b/src/read.c @@ -7,6 +7,7 @@ #include "lisp_string.h" #include "list.h" #include "stack.h" +#include "symbol.h" #include #include diff --git a/src/stack.c b/src/stack.c index fa1f348..c472bf4 100644 --- a/src/stack.c +++ b/src/stack.c @@ -2,10 +2,11 @@ #include "function.h" #include "hashtable.h" -#include "lisp.h" +#include "lisp_string.h" #include "list.h" #include "memory.h" #include "print.h" +#include "symbol.h" #include #include @@ -278,6 +279,15 @@ void new_lexical_variable(LispVal *name, LispVal *value) { } } +void push_block_frame(LispVal *tag, jmp_buf *target, + LispVal *volatile *value_ptr, StackFrame *unwind_to) { + StackFrame *frame = PUSH_NEW_FRAME(STACK_FRAME_BLOCK); + frame->block.tag = tag; + frame->block.target = target; + frame->block.value_ptr = value_ptr; + frame->block.unwind_to = unwind_to; +} + void unwind_to(StackFrame *frame) { while (the_stack.depth && &the_stack.frames[the_stack.depth - 1] > frame) { StackFrame *restrict top = &the_stack.frames[--the_stack.depth]; @@ -366,61 +376,6 @@ noreturn void lisp_signal(LispVal *name, LispVal *data) { top_of_stack_exception_handler(name, data); } -DEFSPECIAL(block, "block", (LispVal * name, LispVal *body), "(name &rest body)", - "") { - CHECK_TYPE(name, TYPE_SYMBOL); - if (!SYMBOLP(name)) - CHECK_TYPE(name, TYPE_SYMBOL); - LispVal *volatile return_value = Qnil; - jmp_buf target; - StackFrame *stack_ref = LISP_STACK_REF(); - LispVal *tag = Fmake_symbol(((LispSymbol *) name)->name); - LispVal *cur_tags = Fplist_get(Vlexical_environment, name, Qnil); - push_copy_lexenv(); - new_lexical_variable(Qlexical_tags, CONS(CONS(name, tag), cur_tags)); - StackFrame *frame = PUSH_NEW_FRAME(STACK_FRAME_BLOCK); - frame->block.tag = tag; - frame->block.target = ⌖ - frame->block.value_ptr = &return_value; - frame->block.unwind_to = stack_ref; - if (setjmp(target) == 0) { - return UNWIND_AND_RETURN(stack_ref, Fprogn(body)); - } else { - // return-from handles unwinding and putting the return value in a local - // references frame - return return_value; - } -} - -static LispVal *lookup_block_tag(LispVal *name) { - LispVal *tags = Fplist_get(Vlexical_environment, Qlexical_tags, Qnil); - LispVal *ent = Fassoc(name, tags, Qnil); - return CONSP(ent) ? XCDR(ent) : Qunbound; -} - -DEFSPECIAL(return_from, "return-from", (LispVal * name, LispVal *value), - "(name &optional value)", "") { - CHECK_TYPE(name, TYPE_SYMBOL); - value = eval(value); - LispVal *tag = lookup_block_tag(name); - if (tag != Qunbound) { - for (ptrdiff_t i = the_stack.depth; i >= 0; --i) { - StackFrame *restrict frame = &the_stack.frames[i]; - if (frame->kind == STACK_FRAME_BLOCK && EQ(frame->block.tag, tag)) { - add_local_reference(frame->block.unwind_to, value); - *frame->block.value_ptr = value; - unwind_to(frame->block.unwind_to); - longjmp(*frame->block.target, 1); - } - } - // block went out of scope - lisp_signal(Qblock_out_of_scope_error, LIST(name)); - } else { - // block never existed - lisp_signal(Qno_such_block_error, LIST(name)); - } -} - DEFUN(backtrace, "backtrace", (void), "()", "") { LispVal *out = Qnil; for (size_t i = 0; i < the_stack.depth; ++i) { diff --git a/src/stack.h b/src/stack.h index da73318..389c57b 100644 --- a/src/stack.h +++ b/src/stack.h @@ -137,6 +137,10 @@ void set_lexical_variable(LispVal *name, LispVal *value); // Just add a new lexical variable without any checking void new_lexical_variable(LispVal *name, LispVal *value); +// blocks +void push_block_frame(LispVal *tag, jmp_buf *target, + LispVal *volatile *value_ptr, StackFrame *unwind_to); + void unwind_to(StackFrame *frame); static ALWAYS_INLINE LispVal *UNWIND_AND_RETURN(StackFrame *frame, LispVal *val) { @@ -147,9 +151,6 @@ static ALWAYS_INLINE LispVal *UNWIND_AND_RETURN(StackFrame *frame, noreturn void lisp_signal(LispVal *name, LispVal *data); -DECLARE_FUNCTION(block, (LispVal * name, LispVal *body)); -DECLARE_FUNCTION(return_from, (LispVal * name, LispVal *value)); - /** * Backtraces have the form (name fobj evaled? args) */ diff --git a/src/symbol.c b/src/symbol.c new file mode 100644 index 0000000..44d21fb --- /dev/null +++ b/src/symbol.c @@ -0,0 +1,93 @@ +#include "symbol.h" + +#include "hashtable.h" +#include "list.h" + +LispVal *obarray; + +DEFUN(make_symbol, "make-symbol", (LispVal * name), "(name)", + "Return an uninterned symbol called NAME.") { + LispSymbol *obj = lisp_alloc_object(sizeof(LispSymbol), TYPE_SYMBOL); + obj->name = name; + obj->function = Qnil; + obj->plist = Qnil; + obj->value_type = SYMBOL_NORMAL; + if (KEYWORDP(obj)) { + obj->value.normal = obj; + obj->flags |= SYMBOL_CONST_VALUE; + } else { + obj->value.normal = Qunbound; + } + return obj; +} + +DEFUN(symbolp, "symbolp", (LispVal * data), "(data)", "") { + return SYMBOLP(data) ? Qt : Qnil; +} + +DEFUN(intern, "intern", (LispVal * name), "(name)", "") { + CHECK_TYPE(name, TYPE_STRING); + LispVal *res = Fgethash(obarray, name, Qunbound); + if (res != Qunbound) { + return res; + } + LispVal *newsym = Fmake_symbol(name); + Fputhash(obarray, name, newsym); + return newsym; +} + +DEFUN(symbol_value, "symbol-value", (LispVal * sym), "(sym)", "") { + CHECK_TYPE(sym, TYPE_SYMBOL); + return SYMBOL_VALUE(sym); +} + +DEFUN(symbol_function, "symbol-function", (LispVal * sym, LispVal *resolve), + "(sym &optional resolve)", "") { + CHECK_TYPE(sym, TYPE_SYMBOL); + if (NILP(resolve)) { + return ((LispSymbol *) sym)->function; + } + while (!NILP(sym) && SYMBOLP(sym)) { + sym = ((LispSymbol *) sym)->function; + } + return sym; +} + +DEFUN(symbol_plist, "symbol-plist", (LispVal * sym), "(sym)", "") { + CHECK_TYPE(sym, TYPE_SYMBOL); + return ((LispSymbol *) sym)->plist; +} + +DEFUN(set, "set", (LispVal * sym, LispVal *value), "(sym value)", "") { + CHECK_TYPE(sym, TYPE_SYMBOL); + SET_SYMBOL_VALUE(sym, value); + return value; +} + +DEFUN(fset, "fset", (LispVal * sym, LispVal *value), "(sym value)", "") { + CHECK_TYPE(sym, TYPE_SYMBOL); + if (CONST_FUNCTION_P(sym)) { + signal_value_constant(sym); + } + ((LispSymbol *) sym)->function = value; + MARK_OBJECT_ADDED(value, sym); + return value; +} + +DEFUN(setplist, "setplist", (LispVal * sym, LispVal *plist), "(sym plist)", + "") { + CHECK_TYPE(sym, TYPE_SYMBOL); + ((LispSymbol *) sym)->plist = plist; + MARK_OBJECT_ADDED(plist, sym); + return plist; +} + +DEFUN(get, "get", (LispVal * sym, LispVal *key, LispVal *def), + "(sym key &optional def)", "") { + return Fplist_get(Fsymbol_plist(sym), key, def); +} + +DEFUN(put, "put", (LispVal * sym, LispVal *key, LispVal *val), "(sym key val)", + "") { + return Fsetplist(sym, Fplist_put(Fsymbol_plist(sym), key, val)); +} diff --git a/src/symbol.h b/src/symbol.h new file mode 100644 index 0000000..d1b038f --- /dev/null +++ b/src/symbol.h @@ -0,0 +1,95 @@ +#ifndef INCLUDED_SYMBOL_H +#define INCLUDED_SYMBOL_H + +#include "base.h" +#include "lisp_string.h" + +extern LispVal *obarray; + +enum SymbolValueType { + SYMBOL_NORMAL, + SYMBOL_NATIVE, +}; + +enum SymbolFlags { + SYMBOL_DYNAMIC = 1, + SYMBOL_CONST_VALUE = 2, + SYMBOL_CONST_FUNCTION = 4, +}; + +DEFOBJTYPE(Symbol, SYMBOL, SYMBOLP, { + LispVal *name; // string + enum SymbolValueType value_type : 1; + enum SymbolFlags flags : 7; + LispVal *function; + union { + LispVal *normal; + LispVal **native; + } value; + LispVal *plist; +}); + +static ALWAYS_INLINE bool KEYWORDP(LispVal *val) { + if (!SYMBOLP(val)) { + return false; + } + LispString *sym = (LispString *) ((LispSymbol *) val)->name; + return sym->length && *sym->data == ':'; +} + +static ALWAYS_INLINE LispVal *SYMBOL_VALUE(LispVal *sym) { + assert(SYMBOLP(sym)); + LispSymbol *s = (LispSymbol *) sym; + switch (s->value_type) { + case SYMBOL_NORMAL: + return s->value.normal; + case SYMBOL_NATIVE: + return *s->value.native; + } +} + +static ALWAYS_INLINE bool CONST_VALUE_P(LispVal *sym) { + assert(SYMBOLP(sym)); + return ((LispSymbol *) sym)->flags & SYMBOL_CONST_VALUE; +} + +static ALWAYS_INLINE bool CONST_FUNCTION_P(LispVal *sym) { + assert(SYMBOLP(sym)); + return ((LispSymbol *) sym)->flags & SYMBOL_CONST_FUNCTION; +} + +static ALWAYS_INLINE bool DYNAMIC_SYMBOL_P(LispVal *sym) { + assert(SYMBOLP(sym)); + return ((LispSymbol *) sym)->flags & SYMBOL_DYNAMIC; +} + +static inline void SET_SYMBOL_VALUE(LispVal *sym, LispVal *value) { + assert(SYMBOLP(sym)); + LispSymbol *s = (LispSymbol *) sym; + if (CONST_VALUE_P(sym)) { + signal_value_constant(sym); + } + switch (s->value_type) { + case SYMBOL_NORMAL: + s->value.normal = value; + break; + case SYMBOL_NATIVE: + *s->value.native = value; + break; + } + MARK_OBJECT_ADDED(value, sym); +} + +DECLARE_FUNCTION(make_symbol, (LispVal * name)); +DECLARE_FUNCTION(symbolp, (LispVal * data)); +DECLARE_FUNCTION(intern, (LispVal * name)); +DECLARE_FUNCTION(symbol_value, (LispVal * sym)); +DECLARE_FUNCTION(symbol_function, (LispVal * sym, LispVal *resolve)); +DECLARE_FUNCTION(symbol_plist, (LispVal * sym)); +DECLARE_FUNCTION(set, (LispVal * sym, LispVal *value)); +DECLARE_FUNCTION(fset, (LispVal * sym, LispVal *value)); +DECLARE_FUNCTION(setplist, (LispVal * sym, LispVal *plist)); +DECLARE_FUNCTION(get, (LispVal * sym, LispVal *key, LispVal *def)); +DECLARE_FUNCTION(put, (LispVal * sym, LispVal *key, LispVal *val)); + +#endif