From a68ddba589390f5158be5f77c82fca962a151b1d Mon Sep 17 00:00:00 2001 From: Alexander Rosenberg Date: Mon, 7 Sep 2026 10:53:21 -0700 Subject: [PATCH] Recursive reading and printing --- lisp/kernel.gl | 2 +- src/function.c | 1 + src/main.c | 1 + src/memory.h | 4 ++ src/print.c | 144 ++++++++++++++++++++++++++++++++++++++++++++++--- src/read.c | 121 ++++++++++++++++++++++++++++++++++++----- src/read.h | 3 ++ 7 files changed, 255 insertions(+), 21 deletions(-) diff --git a/lisp/kernel.gl b/lisp/kernel.gl index fcda2b6..9f731d5 100644 --- a/lisp/kernel.gl +++ b/lisp/kernel.gl @@ -23,4 +23,4 @@ (princ datum print-char-fun) (funcall (or print-char-fun 'write-byte) ?\n)) -(princln (list (symbolp 1) '1a '1aa)) +(princln '#1=(a '#2=(a #1# c) . #1#)) diff --git a/src/function.c b/src/function.c index c566406..21f39da 100644 --- a/src/function.c +++ b/src/function.c @@ -213,6 +213,7 @@ LispVal *make_builtin_function(LispVal *name, LispVal *(*cfunc)(void), ReadStream stream; read_stream_init_from_string(&stream, lisp_args, args_len); LispVal *args_form = read(&stream); + read_stream_cleanup(&stream); if (!args_form) { fprintf(stderr, "Builtin function lambda list had a syntax error\n"); fprintf(stderr, "Name: "); diff --git a/src/main.c b/src/main.c index 47031e4..4eae3cb 100644 --- a/src/main.c +++ b/src/main.c @@ -42,6 +42,7 @@ int main(int argc, const char **argv) { StackFrame *toplevel = LISP_STACK_REF(); ReadStream s; read_stream_init_from_string(&s, src, src_len); + push_unwind_protect_frame(read_stream_cleanup, &s, NULL); LispVal *r; push_handler_bind_frame(LIST(Qt), toplevel_error_handler, NULL, NULL); volatile bool had_toplevel_error = false; diff --git a/src/memory.h b/src/memory.h index 858748e..3f198c7 100644 --- a/src/memory.h +++ b/src/memory.h @@ -41,6 +41,10 @@ static ALWAYS_INLINE bool LITTLE_ENDIAN_P(void) { return ENDIANNESS() == ENDIAN_LITTLE; } +// ceil(# bytes in sizeof(t) / 3) +// This works because log10(2^n) is O(n) for k=3 +#define NUMBER_PRINTF_BUFFER_SIZE(t) (((sizeof(t) * 8) / 3) + 1) + // General float stuff #if SIZE_MAX == 0xffffffff # define LISP_WORD_BITS 32 diff --git a/src/print.c b/src/print.c index bba6b41..5be0a72 100644 --- a/src/print.c +++ b/src/print.c @@ -32,8 +32,9 @@ struct PrintOptions { struct PrintContext { struct PrintOptions opts; LispVal *print_char_fun; + size_t next_circular_num; LispHashTable *seen_objects; - LispVal *length_stack; + LispHashTable *printed_objects; }; static void check_print_base(fixnum_t base) { @@ -88,8 +89,14 @@ static void init_print_context(struct PrintContext *restrict pc, bool readable, } else { pc->print_char_fun = print_char_fun; } - pc->seen_objects = Fmake_hash_table(Qnil, Qnil); - pc->length_stack = Qnil; + if (pc->opts.circle) { + pc->seen_objects = Fmake_hash_table(Qnil, Qnil); + pc->printed_objects = Fmake_hash_table(Qnil, Qnil); + } else { + pc->seen_objects = Qnil; + pc->printed_objects = Qnil; + } + pc->next_circular_num = 0; } static void print_char(struct PrintContext *restrict pc, char c) { @@ -205,16 +212,95 @@ static void print_float(struct PrintContext *restrict pc, LispVal *val) { } } +static bool seen_object_p(struct PrintContext *restrict pc, LispVal *val) { + if (!pc->opts.circle) { + return false; + } + return !NILP(Fgethash(pc->seen_objects, val, Qnil)); +} + +static bool recursive_object_p(struct PrintContext *restrict pc, LispVal *val) { + if (!pc->opts.circle) { + return false; + } + return FIXNUMP(Fgethash(pc->seen_objects, val, Qnil)); +} + +static void mark_object_seen(struct PrintContext *restrict pc, LispVal *val) { + assert(pc->opts.circle); + Fputhash(pc->seen_objects, val, Qt); +} + +static fixnum_t seen_object_number(struct PrintContext *restrict pc, + LispVal *val) { + assert(pc->opts.circle); + LispVal *cur = Fgethash(pc->seen_objects, val, Qnil); + assert(!NILP(cur)); + if (FIXNUMP(cur)) { + return XFIXNUM(cur); + } + Fputhash(pc->seen_objects, val, MAKE_FIXNUM(pc->next_circular_num)); + return pc->next_circular_num++; +} + +static bool printed_seen_object_p(struct PrintContext *restrict pc, + LispVal *val) { + assert(pc->opts.circle); + return !NILP(Fgethash(pc->printed_objects, val, Qnil)); +} + +static void mark_object_printed(struct PrintContext *restrict pc, + LispVal *val) { + assert(pc->opts.circle); + Fputhash(pc->printed_objects, val, Qt); +} + +static void print_numbered_reference(struct PrintContext *restrict pc, + LispVal *val, char term) { + print_char(pc, '#'); + size_t fixnum_t_len = NUMBER_PRINTF_BUFFER_SIZE(fixnum_t); + char buf[fixnum_t_len + 1]; + fixnum_t n = seen_object_number(pc, val); + int l = snprintf(buf, fixnum_t_len + 1, "%" LISP_FIXNUM_PRINTF(d), n); + print_buffer(pc, buf, l); + print_char(pc, term); +} + static void print_cons(struct PrintContext *restrict pc, LispVal *val) { if (pc->opts.quoted && EQ(XCAR(val), Qquote) && list_length_eq(val, 2)) { + if (recursive_object_p(pc, val)) { + if (printed_seen_object_p(pc, val)) { + print_numbered_reference(pc, val, '#'); + return; + } + print_numbered_reference(pc, val, '='); + mark_object_printed(pc, val); + } print_char(pc, '\''); print_driver(pc, SECOND(val)); return; } - print_char(pc, '('); bool first = true; DOTAILS(rest, val) { - if (!first) { + if (recursive_object_p(pc, rest)) { + if (!first) { + PRINT_STATIC_BUFFER(pc, " . "); + } + if (printed_seen_object_p(pc, rest)) { + print_numbered_reference(pc, rest, '#'); + break; + } else { + print_numbered_reference(pc, rest, '='); + mark_object_printed(pc, rest); + if (!first) { + print_cons(pc, rest); + break; + } + } + } + if (first) { + print_char(pc, '('); + } else { print_char(pc, ' '); } first = false; @@ -298,6 +384,14 @@ static void print_pretty_symbol(struct PrintContext *restrict pc, } static void print_vector(struct PrintContext *restrict pc, LispVal *val) { + if (recursive_object_p(pc, val)) { + if (printed_seen_object_p(pc, val)) { + print_numbered_reference(pc, val, '#'); + return; + } + print_numbered_reference(pc, val, '='); + mark_object_printed(pc, val); + } LispVector *vec = val; print_char(pc, '['); bool first = true; @@ -315,7 +409,7 @@ static void print_hash_table(struct PrintContext *restrict pc, LispVal *val) { LispHashTable *ht = val; PRINT_STATIC_BUFFER(pc, "count); assert(written < sizeof(buffer)); print_buffer(pc, buffer, written); @@ -352,6 +446,36 @@ static void print_function(struct PrintContext *restrict pc, LispVal *val) { print_char(pc, '>'); } +static void scan_circular_objects(struct PrintContext *restrict pc, + LispVal *val) { + assert(HASH_TABLE_P(pc->seen_objects)); + if (CONSP(val)) { + DOTAILS(rest, val) { + if (!CONSP(rest)) { + scan_circular_objects(pc, rest); + break; + } + if (!seen_object_p(pc, rest)) { + mark_object_seen(pc, rest); + scan_circular_objects(pc, XCAR(rest)); + } else { + seen_object_number(pc, rest); + break; + } + } + } else if (VECTORP(val)) { + if (!seen_object_p(pc, val)) { + mark_object_seen(pc, val); + LispVector *vec = val; + for (size_t i = 0; i < vec->length; ++i) { + scan_circular_objects(pc, vec->data[i]); + } + } else { + seen_object_number(pc, val); + } + } +} + static void print_driver(struct PrintContext *restrict pc, LispVal *val) { switch (TYPE_OF(val)) { case TYPE_FIXNUM: @@ -391,11 +515,18 @@ static void print_driver(struct PrintContext *restrict pc, LispVal *val) { } } +static void prepare_for_print(struct PrintContext *restrict pc, LispVal *obj) { + if (pc->opts.circle) { + scan_circular_objects(pc, obj); + } +} + // Not readable DEFUN(princ, "princ", (LispVal * val, LispVal *print_char_fun), "(val &optional print-char-fun)", "") { struct PrintContext pc; init_print_context(&pc, false, print_char_fun); + prepare_for_print(&pc, val); print_driver(&pc, val); return Qnil; } @@ -405,6 +536,7 @@ DEFUN(prin1, "prin1", (LispVal * val, LispVal *print_char_fun), "(val &optional print-char-fun)", "") { struct PrintContext pc; init_print_context(&pc, true, print_char_fun); + prepare_for_print(&pc, val); print_driver(&pc, val); return Qnil; } diff --git a/src/read.c b/src/read.c index 72b2e73..64d23d1 100644 --- a/src/read.c +++ b/src/read.c @@ -1,6 +1,7 @@ #include "read.h" #include "function.h" +#include "hashtable.h" #include "io.h" #include "lisp_string.h" #include "list.h" @@ -21,6 +22,8 @@ void read_stream_init_from_string(ReadStream *restrict stream, stream->string.buffer = buffer; stream->string.len = length; stream->string.off = 0; + stream->named_objects = make_hash_table_no_gc(Qnil, Qnil); + stream->need_record_self = Qnil; stream->line = 1; stream->col = 0; stream->backquote_level = 0; @@ -31,11 +34,17 @@ void read_stream_init_from_func(ReadStream *restrict stream, stream->kind = READ_STREAM_FUNC; stream->func.func = read_char_func; stream->func.is_eof = false; + stream->named_objects = make_hash_table_no_gc(Qnil, Qnil); + stream->need_record_self = Qnil; stream->line = 1; stream->col = 0; stream->backquote_level = 0; } +void read_stream_cleanup(void *stream) { + release_hash_table_no_gc(((ReadStream *) stream)->named_objects); +} + static int peek_char(ReadStream *restrict stream); static ALWAYS_INLINE bool EOSP(ReadStream *restrict stream) { switch (stream->kind) { @@ -119,12 +128,14 @@ static void skip_whitespace(ReadStream *restrict stream) { FORMAT(2, 3) static noreturn void read_error(ReadStream *restrict stream, const char *restrict msg, ...) { + int c = pop_char(stream); va_list args; va_start(args, msg); LispVal *lmsg = lisp_vsprintf(msg, args); va_end(args); - lisp_signal(Qread_error, LIST(MAKE_FIXNUM(stream->line), - MAKE_FIXNUM(stream->col), lmsg)); + lisp_signal(Qread_error, + LIST(MAKE_FIXNUM(stream->line), MAKE_FIXNUM(stream->col), lmsg, + c == READ_EOS ? Qnil : MAKE_FIXNUM(c))); } static ALWAYS_INLINE bool DOT_SYMBOL_P(LispVal *val) { @@ -138,7 +149,10 @@ static ALWAYS_INLINE bool DOT_SYMBOL_P(LispVal *val) { LispVal *next_list(ReadStream *restrict stream) { pop_char(stream); // the ( skip_whitespace(stream); - LispVal *start = Qnil; + LispVal *start = CONS(Qnil, Qnil); + if (!NILP(stream->need_record_self)) { + Fputhash(stream->named_objects, stream->need_record_self, start); + } LispVal *end = NULL; bool dotted = false; while (peek_char(stream) != ')') { @@ -159,8 +173,8 @@ LispVal *next_list(ReadStream *restrict stream) { } if (dotted) { RPLACD(end, new_val); - } else if (NILP(start)) { - start = CONS(new_val, Qnil); + } else if (end == NULL) { + RPLACA(start, new_val); end = start; } else { RPLACD(end, CONS(new_val, Qnil)); @@ -171,18 +185,21 @@ LispVal *next_list(ReadStream *restrict stream) { if (pop_char(stream) == READ_EOS) { // the ) read_error(stream, "got EOF while reading list"); } - return start; + return end == NULL ? Qnil : start; } LispVal *next_vector(ReadStream *restrict stream) { pop_char(stream); // the [ skip_whitespace(stream); - LispVal **data = NULL; - size_t length = 0; + LispVal *vec = make_vector(NULL, 0, true); +#define data ((LispVector *) vec)->data +#define length ((LispVector *) vec)->length + if (!NILP(stream->need_record_self)) { + Fputhash(stream->named_objects, stream->need_record_self, vec); + } while (peek_char(stream) != ']') { LispVal *new_val = read(stream); if (!new_val) { - free(data); read_error(stream, "got EOF while reading vector"); } data = lisp_realloc(data, sizeof(LispVal *) * ++length); @@ -193,7 +210,9 @@ LispVal *next_vector(ReadStream *restrict stream) { free(data); read_error(stream, "got EOF while reading vector"); } - return make_vector(data, length, true); + return vec; +#undef data +#undef length } LispVal *next_string(ReadStream *restrict stream) { @@ -446,9 +465,7 @@ LispVal *next_number_or_symbol(ReadStream *restrict stream, int base) { size_t len = ss.nchars - number_start; if (has_decimal || exp_start) { // float - // ceil(# bytes in size_t / 3) - // This works because log10(2^n) is O(n) for k=3 - size_t size_t_len = ((sizeof(size_t) * 8) / 3) + 1; + size_t size_t_len = NUMBER_PRINTF_BUFFER_SIZE(size_t); char fmt_buf[3 + size_t_len + 1]; if (exp_start == ss.nchars) { goto change_to_symbol; @@ -480,7 +497,81 @@ change_to_symbol: next_symbol(ss.buffer, ss.nchars, stream)); } -LispVal *read(ReadStream *stream) { +static fixnum_t convert_object_number(ReadStream *restrict stream, + const char *buffer) { + char *endptr; + intmax_t number = strtoimax(buffer, &endptr, 10); + if (number < 0 || number > MOST_POSITIVE_FIXNUM) { + read_error(stream, "object number out of range: %jd", number); + } + return number; +} + +static LispVal *lookup_numbered_object(ReadStream *restrict stream, + fixnum_t n) { + LispVal *lisp_n = MAKE_FIXNUM(n); + LispVal *obj = Fgethash(stream->named_objects, lisp_n, Qunbound); + if (obj == Qunbound) { + read_error(stream, + "numbered object not defined: %" LISP_FIXNUM_PRINTF(d), n); + } + return obj; +} + +static LispVal *read_numbered(ReadStream *restrict stream, fixnum_t n) { + if (!NILP(Fgethash(stream->named_objects, MAKE_FIXNUM(n), Qnil))) { + read_error(stream, "duplicate named object: %" LISP_FIXNUM_PRINTF(d), + n); + } + LispVal *save = stream->need_record_self; + stream->need_record_self = MAKE_FIXNUM(n); + LispVal *obj = read(stream); + Fremhash(stream->named_objects, stream->need_record_self); + stream->need_record_self = save; + return obj; +} + +static LispVal *hash_dispatcher(ReadStream *restrict stream) { + pop_char(stream); // the # + StringStream ss; + string_stream_init(&ss); + StackFrame *stack_ref = LISP_STACK_REF(); + push_unwind_protect_frame(string_stream_free_as_cleanup, &ss, NULL); + int c; + while ((c = peek_char(stream)) != READ_EOS) { + switch (c) { + case '#': + pop_char(stream); + return UNWIND_AND_RETURN( + stack_ref, + lookup_numbered_object( + stream, convert_object_number(stream, ss.buffer))); + case '=': + pop_char(stream); + return UNWIND_AND_RETURN( + stack_ref, read_numbered(stream, convert_object_number( + stream, ss.buffer))); + case '0': + case '1': + case '2': + case '3': + case '4': + case '5': + case '6': + case '7': + case '8': + case '9': + pop_char(stream); + string_stream_putc(&ss, c); + break; + default: + read_error(stream, "expected digit, '#', or '="); + } + } + read_error(stream, "got EOF while reading object number"); +} + +LispVal *read(ReadStream *restrict stream) { skip_whitespace(stream); if (EOSP(stream)) { return NULL; @@ -548,6 +639,8 @@ LispVal *read(ReadStream *stream) { case '8': case '9': return next_number_or_symbol(stream, ANY_BASE); + case '#': + return hash_dispatcher(stream); default: return next_symbol(NULL, 0, stream); } diff --git a/src/read.h b/src/read.h index 481e972..0b73099 100644 --- a/src/read.h +++ b/src/read.h @@ -36,6 +36,8 @@ typedef struct { } func; }; + LispVal *need_record_self; // fixnum or null + LispVal *named_objects; // hashtable size_t line; size_t col; size_t backquote_level; @@ -44,6 +46,7 @@ typedef struct { void read_stream_init_from_string(ReadStream *stream, const char *buffer, size_t length); void read_stream_init_from_func(ReadStream *stream, LispVal *read_char_func); +void read_stream_cleanup(void *stream); // NULL on eof LispVal *read(ReadStream *stream);