Recursive reading and printing

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#))

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: ");

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;

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

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);
+    if (pc->opts.circle) {
-    pc->length_stack = Qnil;
+        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, "<hash-table count=");
     // large enough for 32 or 64 bit word size
-    char buffer[32];
+    char buffer[NUMBER_PRINTF_BUFFER_SIZE(size_t)];
     int written = snprintf(buffer, sizeof(buffer), "%zu", ht->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;
 }

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),
+    lisp_signal(Qread_error,
-                                  MAKE_FIXNUM(stream->col), lmsg));
+                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)) {
+        } else if (end == NULL) {
-            start = CONS(new_val, Qnil);
+            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;
+    LispVal *vec = make_vector(NULL, 0, true);
-    size_t length = 0;
+#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)
+        size_t size_t_len = NUMBER_PRINTF_BUFFER_SIZE(size_t);
-        // This works because log10(2^n) is O(n) for k=3
-        size_t size_t_len = ((sizeof(size_t) * 8) / 3) + 1;
         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);
     }

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);