From f87af5efd2bd764e84cd5df882db34d1d5376983 Mon Sep 17 00:00:00 2001 From: Alexander Rosenberg Date: Sun, 19 Jul 2026 02:23:10 -0700 Subject: [PATCH] Work on dynamic variable --- lisp/kernel.gl | 9 ++- src/base.c | 14 +++-- src/base.h | 79 +++++++++++++++++++++++-- src/gc.c | 2 +- src/gen-init-globals.awk | 5 ++ src/lisp.c | 86 +++------------------------ src/lisp.h | 9 +-- src/print.c | 122 +++++++++++++++++++++++++++++++++++++++ src/print.h | 23 ++++++++ src/stack.c | 44 ++++++++++---- src/stack.h | 4 +- 11 files changed, 285 insertions(+), 112 deletions(-) create mode 100644 src/print.c create mode 100644 src/print.h diff --git a/lisp/kernel.gl b/lisp/kernel.gl index 1e73ac6..f2ef857 100644 --- a/lisp/kernel.gl +++ b/lisp/kernel.gl @@ -1,3 +1,10 @@ ;; -*- mode: lisp-data -*- -(test a) +(fset 'test (lambda () (print print-circular))) + +(print print-circular) + +(let ((print-circular nil)) + (test)) + +(print print-circular) diff --git a/src/base.c b/src/base.c index e537c9a..54f5365 100644 --- a/src/base.c +++ b/src/base.c @@ -74,9 +74,7 @@ noreturn void signal_type_error(LispVal *obj, LispVal *typespec) { DEFINE_SYMBOL(nil, "nil"); DEFINE_SYMBOL(t, "t"); DEFINE_SYMBOL(unbound, "unbound"); -DEFINE_SYMBOL(lexical_environment, "lexical-environment"); - -LispVal *Vlexical_environment; +DEFVAR(lexical_environment, "lexical-environment", "", Qnil); DEFUN(id, "id", (LispVal * obj), "(id)", "") { // TODO not all values are handled here @@ -112,10 +110,12 @@ DEFUN(make_symbol, "make-symbol", (LispVal * name), "(name)", obj->name = name; obj->function = Qnil; obj->plist = Qnil; + obj->value_type = SYMBOL_NORMAL; if (KEYWORDP(obj)) { - obj->value = obj; + obj->value.normal = obj; + obj->flags |= SYMBOL_CONST_VALUE; } else { - obj->value = Qunbound; + obj->value.normal = Qunbound; } return obj; } @@ -161,6 +161,10 @@ DEFUN(set, "set", (LispVal * sym, LispVal *value), "(sym value)", "") { DEFUN(fset, "fset", (LispVal * sym, LispVal *value), "(sym value)", "") { CHECK_TYPE(sym, TYPE_SYMBOL); + if (CONST_FUNCTION_P(sym)) { + // TODO throw + abort(); + } ((LispSymbol *) sym)->function = value; return value; } diff --git a/src/base.h b/src/base.h index 38e0402..9d9c053 100644 --- a/src/base.h +++ b/src/base.h @@ -162,7 +162,6 @@ static ALWAYS_INLINE void internal_CHECK_TYPE(LispVal *obj, size_t count, // Failed internal_CHECK_TYPE_signal_type_error(obj, count, types); } -#define internal_CHECK_TYPE1(obj, type) internal_CHECK_TYPE(obj, v1, ) #define internal_CHECK_TYPE_SUB(obj, count, a1, a2, a3, a4, a5, a6, ...) \ internal_CHECK_TYPE((obj), count, a1, a2, a3, a4, a5, a6) #define CHECK_TYPE(obj, ...) \ @@ -188,10 +187,26 @@ DEFOBJTYPE(String, STRING, STRINGP, { 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; - LispVal *value; + union { + LispVal *normal; + LispVal **native; + } value; LispVal *plist; }); @@ -215,6 +230,11 @@ DEFOBJTYPE(Vector, VECTOR, VECTORP, { extern const size_t internal_Q##cname##_name_len; \ extern LispVal *Q##cname +#define DECLARE_VARIABLE(cname) \ + DECLARE_SYMBOL(cname); \ + extern LispVal *internal_V##cname##_init(void); \ + extern LispVal *V##cname + #define DECLARE_FUNCTION(cname, cargs) \ DECLARE_SYMBOL(cname); \ extern const char *internal_F##cname##_argstr; \ @@ -228,6 +248,13 @@ DEFOBJTYPE(Vector, VECTOR, VECTORP, { const size_t internal_Q##cname##_name_len = sizeof(lisp_name) - 1; \ LispVal *Q##cname +#define DEFVAR(cname, lisp_name, doc, init_val) \ + DEFINE_SYMBOL(cname, lisp_name); \ + LispVal *internal_V##cname##_init(void) { \ + return (init_val); \ + } \ + LispVal *V##cname + #define DEFUN(cname, lisp_name, cargs, lisp_args, doc) \ DEFINE_SYMBOL(cname, lisp_name); \ const char *internal_F##cname##_argstr = lisp_args; \ @@ -244,8 +271,17 @@ DEFOBJTYPE(Vector, VECTOR, VECTORP, { Q##cname = Fintern(make_lisp_string(internal_Q##cname##_name, \ internal_Q##cname##_name_len, \ false, false)); \ + ((LispSymbol *) Q##cname)->value_type = SYMBOL_NORMAL; \ lisp_gc_register_static_object(Q##cname); \ } +#define REGISTER_GLOBAL_VARIABLE(cname) \ + REGISTER_GLOBAL_SYMBOL(cname); \ + { \ + V##cname = internal_V##cname##_init(); \ + ((LispSymbol *) Q##cname)->value_type = SYMBOL_NATIVE; \ + ((LispSymbol *) Q##cname)->value.native = &V##cname; \ + ((LispSymbol *) Q##cname)->flags |= SYMBOL_DYNAMIC; \ + } #define REGISTER_GLOBAL_FUNCTION(cname) \ { \ REGISTER_GLOBAL_SYMBOL(cname); \ @@ -263,7 +299,7 @@ DEFOBJTYPE(Vector, VECTOR, VECTORP, { DECLARE_SYMBOL(nil); DECLARE_SYMBOL(t); DECLARE_SYMBOL(unbound); -DECLARE_SYMBOL(lexical_environment); +DECLARE_VARIABLE(lexical_environment); extern LispVal *Vlexical_environment; @@ -295,12 +331,45 @@ DECLARE_FUNCTION(put, (LispVal * sym, LispVal *key, LispVal *val)); static ALWAYS_INLINE LispVal *SYMBOL_VALUE(LispVal *sym) { assert(SYMBOLP(sym)); - return ((LispSymbol *) sym)->value; + 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 ALWAYS_INLINE void SET_SYMBOL_VALUE(LispVal *sym, LispVal *value) { assert(SYMBOLP(sym)); - ((LispSymbol *) sym)->value = value; + LispSymbol *s = (LispSymbol *) sym; + if (CONST_VALUE_P(sym)) { + // TODO throw + abort(); + } + switch (s->value_type) { + case SYMBOL_NORMAL: + s->value.normal = value; + break; + case SYMBOL_NATIVE: + *s->value.native = value; + break; + } } // condition stuff diff --git a/src/gc.c b/src/gc.c index 446c51e..095cb9a 100644 --- a/src/gc.c +++ b/src/gc.c @@ -206,7 +206,7 @@ static void mark_object(LispVal *val) { case TYPE_SYMBOL: { LispSymbol *sym = val; make_grey_if_white(sym->name); - make_grey_if_white(sym->value); + make_grey_if_white(SYMBOL_VALUE(sym)); make_grey_if_white(sym->function); make_grey_if_white(sym->plist); break; diff --git a/src/gen-init-globals.awk b/src/gen-init-globals.awk index 4d4ec57..521d8f3 100644 --- a/src/gen-init-globals.awk +++ b/src/gen-init-globals.awk @@ -91,6 +91,11 @@ function maybe_emit_next_symbol(entity) { maybe_emit_next_symbol("SYMBOL") } +/DEFVAR\(/ { + maybe_print_file_header() + maybe_emit_next_symbol("VARIABLE") +} + END { print "}" } diff --git a/src/lisp.c b/src/lisp.c index cf24269..0e55848 100644 --- a/src/lisp.c +++ b/src/lisp.c @@ -10,18 +10,21 @@ 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)->value = Qnil; + ((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)->value = Qt; + ((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 = Qunbound; + ((LispSymbol *) Qunbound)->value.normal = Qunbound; lisp_gc_register_static_object(Qunbound); Qlexical_environment = Fmake_symbol(LISP_LITSTR("lexical-environment")); - ((LispSymbol *) Qlexical_environment)->value = Qnil; + ((LispSymbol *) Qlexical_environment)->value_type = SYMBOL_NATIVE; + ((LispSymbol *) Qlexical_environment)->value.native = &Vlexical_environment; lisp_gc_register_static_object(Qlexical_environment); Qhash_string = Fmake_symbol(LISP_LITSTR("hash-string")); @@ -184,78 +187,3 @@ DEFSPECIAL(or, "or", (LispVal * forms), "(&rest forms)", "") { DEFUN(null, "null", (LispVal * datum), "(datum)", "") { return NILP(datum) ? Qt : Qnil; } - -void debug_print(FILE *file, LispVal *obj) { - switch (TYPE_OF(obj)) { - case TYPE_FIXNUM: - fprintf(file, "%jd", (intmax_t) XFIXNUM(obj)); - break; - case TYPE_FLOAT: - fprintf(file, "%f", (double) XLISP_FLOAT(obj)); - break; - case TYPE_STRING: { - LispString *s = obj; - fputc('"', file); - fwrite(s->data, 1, s->length, file); - fputc('"', file); - break; - } - case TYPE_SYMBOL: { - LispString *name = ((LispSymbol *) obj)->name; - fwrite(name->data, 1, name->length, file); - break; - } - case TYPE_HASH_TABLE: { - fprintf(file, "", - ((LispHashTable *) obj)->count, (uintmax_t) obj); - break; - } - case TYPE_FUNCTION: { - LispFunction *fobj = obj; - if (NILP(fobj->name)) { - fprintf(file, "", (uintmax_t) obj); - } else { - fprintf(file, "name); - fprintf(file, " at 0x%jx>", (uintmax_t) obj); - } - break; - } - case TYPE_CONS: { - fputc('(', file); - DOTAILS(tail, obj) { - if (CONSP(tail)) { - debug_print(file, XCAR(tail)); - if (!NILP(XCDR(tail))) { - fputc(' ', file); - } - } else { - fwrite(". ", 1, 2, file); - debug_print(file, tail); - } - } - fputc(')', file); - break; - } - case TYPE_VECTOR: { - LispVector *v = obj; - fputc('[', file); - for (size_t i = 0; i < v->length; ++i) { - debug_print(file, v->data[i]); - if (i < v->length - 1) { - fputc(' ', file); - } - } - fputc(']', file); - break; - } - default: - abort(); - } -} - -void debug_obj_info(FILE *file, LispVal *obj) { - fprintf(file, "%s -> ", LISP_TYPE_NAMES[TYPE_OF(obj)]); - debug_print(file, obj); - fputc('\n', file); -} diff --git a/src/lisp.h b/src/lisp.h index 8e63118..b8b2912 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -6,10 +6,9 @@ #include "hashtable.h" // IWYU pragma: export #include "lisp_string.h" // IWYU pragma: export #include "list.h" // IWYU pragma: export +#include "print.h" // IWYU pragma: export #include "stack.h" // IWYU pragma: export -#include - extern LispVal *obarray; void lisp_init(void); @@ -24,10 +23,4 @@ DECLARE_FUNCTION(and, (LispVal * forms)); DECLARE_FUNCTION(or, (LispVal * forms)); DECLARE_FUNCTION(null, (LispVal * datum)); -__attribute__((no_sanitize("address"))) void debug_print(FILE *file, - LispVal *obj); - -__attribute__((no_sanitize("address"))) void debug_obj_info(FILE *file, - LispVal *obj); - #endif diff --git a/src/print.c b/src/print.c new file mode 100644 index 0000000..a41109e --- /dev/null +++ b/src/print.c @@ -0,0 +1,122 @@ +#include "print.h" + +#include "lisp.h" + +DEFVAR(print_circular, "print-circular", "", Qt); +DEFVAR(print_length, "print-length", "", MAKE_FIXNUM(100)); +DEFVAR(print_level, "print-level", "", Qnil); + +struct PrintContext { + bool circle; + bool length; +}; + +static void init_print_context(struct PrintContext *restrict pc) { + pc->circle = true; + pc->length = 80; +} + +static void print_driver(struct PrintContext *restrict pc, LispVal *val) { + switch (TYPE_OF(val)) { + case TYPE_FIXNUM: + case TYPE_FLOAT: + case TYPE_CONS: + case TYPE_STRING: + case TYPE_SYMBOL: + case TYPE_VECTOR: + case TYPE_HASH_TABLE: + case TYPE_FUNCTION: + break; + default: + abort(); + } +} + +DEFUN(princ, "princ", (LispVal * val), "(val)", "") { + struct PrintContext pc; + init_print_context(&pc); + print_driver(&pc, val); + return Qnil; +} + +DEFUN(prin1, "prin1", (LispVal * val), "(val)", "") { + struct PrintContext pc; + init_print_context(&pc); + print_driver(&pc, val); + return Qnil; +} + +void debug_print(FILE *file, LispVal *obj) { + switch (TYPE_OF(obj)) { + case TYPE_FIXNUM: + fprintf(file, "%jd", (intmax_t) XFIXNUM(obj)); + break; + case TYPE_FLOAT: + fprintf(file, "%f", (double) XLISP_FLOAT(obj)); + break; + case TYPE_STRING: { + LispString *s = obj; + fputc('"', file); + fwrite(s->data, 1, s->length, file); + fputc('"', file); + break; + } + case TYPE_SYMBOL: { + LispString *name = ((LispSymbol *) obj)->name; + fwrite(name->data, 1, name->length, file); + break; + } + case TYPE_HASH_TABLE: { + fprintf(file, "", + ((LispHashTable *) obj)->count, (uintmax_t) obj); + break; + } + case TYPE_FUNCTION: { + LispFunction *fobj = obj; + if (NILP(fobj->name)) { + fprintf(file, "", (uintmax_t) obj); + } else { + fprintf(file, "name); + fprintf(file, " at 0x%jx>", (uintmax_t) obj); + } + break; + } + case TYPE_CONS: { + fputc('(', file); + DOTAILS(tail, obj) { + if (CONSP(tail)) { + debug_print(file, XCAR(tail)); + if (!NILP(XCDR(tail))) { + fputc(' ', file); + } + } else { + fwrite(". ", 1, 2, file); + debug_print(file, tail); + } + } + fputc(')', file); + break; + } + case TYPE_VECTOR: { + LispVector *v = obj; + fputc('[', file); + for (size_t i = 0; i < v->length; ++i) { + debug_print(file, v->data[i]); + if (i < v->length - 1) { + fputc(' ', file); + } + } + fputc(']', file); + break; + } + default: + abort(); + } +} + +void debug_obj_info(FILE *file, LispVal *obj) { + fprintf(file, "%s -> ", LISP_TYPE_NAMES[TYPE_OF(obj)]); + debug_print(file, obj); + fputc('\n', file); +} diff --git a/src/print.h b/src/print.h new file mode 100644 index 0000000..36bfcc6 --- /dev/null +++ b/src/print.h @@ -0,0 +1,23 @@ +#ifndef INCLUDED_PRINT_H +#define INCLUDED_PRINT_H + +#include "base.h" + +#include + +DECLARE_VARIABLE(print_circular); +DECLARE_VARIABLE(print_length); +DECLARE_VARIABLE(print_level); + +// Pretty print +DECLARE_FUNCTION(princ, (LispVal * val)); +// Quoted print +DECLARE_FUNCTION(prin1, (LispVal * val)); + +__attribute__((no_sanitize("address"))) void debug_print(FILE *file, + LispVal *obj); + +__attribute__((no_sanitize("address"))) void debug_obj_info(FILE *file, + LispVal *obj); + +#endif diff --git a/src/stack.c b/src/stack.c index e94de05..e5b3335 100644 --- a/src/stack.c +++ b/src/stack.c @@ -131,10 +131,13 @@ static void store_local_reference_in_frame(StackFrame *restrict frame, } void add_local_reference_no_recurse(StackFrame *restrict frame, LispVal *obj) { + if (!OBJECTP(obj)) { + return; + } frame = frame->last_references; assert(frame->kind == STACK_FRAME_LOCAL_REFERENCES); StackFrame *current_frame = OBJECT_LOWEST_LOCAL_REFERENCE(obj); - if (OBJECTP(obj) && (!current_frame || current_frame > frame)) { + if (!current_frame || current_frame > frame) { store_local_reference_in_frame(frame, obj); } } @@ -173,7 +176,8 @@ add_local_refs_for_object_sub_vals(StackFrame *restrict frame, case TYPE_SYMBOL: { LispSymbol *sym = val; add_local_ref_if_not_seen_no_recurse(frame, seen_objs, sym->name); - add_local_ref_if_not_seen_no_recurse(frame, seen_objs, sym->value); + add_local_ref_if_not_seen_no_recurse(frame, seen_objs, + SYMBOL_VALUE(sym)); add_local_ref_if_not_seen_no_recurse(frame, seen_objs, sym->function); add_local_ref_if_not_seen_no_recurse(frame, seen_objs, sym->plist); break; @@ -216,6 +220,9 @@ add_local_refs_for_object_sub_vals(StackFrame *restrict frame, } void add_local_reference(StackFrame *restrict frame, LispVal *obj) { + if (!OBJECTP(obj)) { + return; + } frame = frame->last_references; assert(frame->kind == STACK_FRAME_LOCAL_REFERENCES); add_local_reference_no_recurse(frame, obj); @@ -231,20 +238,37 @@ void add_local_reference(StackFrame *restrict frame, LispVal *obj) { void push_dynamic_binding(LispVal *name, LispVal *new_value) { assert(SYMBOLP(name)); + LispVal *old_val = SYMBOL_VALUE(name); + SET_SYMBOL_VALUE(name, new_value); // will throw if name is const StackFrame *frame = PUSH_NEW_FRAME(STACK_FRAME_DYNAMIC_BINDING); frame->dynamic_binding.symbol = name; - if (name == Qlexical_environment) { - frame->dynamic_binding.old_value = Vlexical_environment; - Vlexical_environment = new_value; - } else { - frame->dynamic_binding.old_value = SYMBOL_VALUE(name); - SET_SYMBOL_VALUE(name, new_value); - } + frame->dynamic_binding.old_value = old_val; } void set_lexical_variable(LispVal *name, LispVal *value) { assert(SYMBOLP(name)); - Vlexical_environment = Fplist_put(Vlexical_environment, name, value); + if (CONST_VALUE_P(name)) { + // TODO throw + abort(); + } + if (DYNAMIC_SYMBOL_P(name)) { + SET_SYMBOL_VALUE(name, value); + } else { + Vlexical_environment = Fplist_put(Vlexical_environment, name, value); + } +} + +void new_lexical_variable(LispVal *name, LispVal *value) { + assert(SYMBOLP(name)); + if (CONST_VALUE_P(name)) { + // TODO throw + abort(); + } + if (DYNAMIC_SYMBOL_P(name)) { + SET_SYMBOL_VALUE(name, value); + } else { + Vlexical_environment = CONS(name, CONS(value, Vlexical_environment)); + } } void unwind_to(StackFrame *frame) { diff --git a/src/stack.h b/src/stack.h index 06a3e8d..797f9a0 100644 --- a/src/stack.h +++ b/src/stack.h @@ -142,9 +142,7 @@ static ALWAYS_INLINE void push_copy_lexenv(void) { void set_lexical_variable(LispVal *name, LispVal *value); // Just add a new lexical variable without any checking -static inline void new_lexical_variable(LispVal *name, LispVal *value) { - Vlexical_environment = CONS(name, CONS(value, Vlexical_environment)); -} +void new_lexical_variable(LispVal *name, LispVal *value); void unwind_to(StackFrame *frame); static ALWAYS_INLINE LispVal *UNWIND_AND_RETURN(StackFrame *frame,