add test printing code

from https://stackoverflow.com/a/78169673/23626926

need to test recursive nature ok

Author: dragoncoder047

.vscode/settings.json

@@ -1,5 +1,6 @@
 {
     "cSpell.words": [
+        "eqcmp",
         "tinobsy"
     ],
     "files.associations": {

pickle.cpp

@@ -70,11 +70,11 @@ void pickle::step() {
 
 static bool is_primitive_type(object* x) {
     if (x == NULL) return true;
-    size_t i = 0; while (primitives[i] != NULL) { if (x->type == primitives[i]) break; }
+    size_t i = 0; while (primitives[i] != NULL) { if (x->type == primitives[i]) break; i++; }
     return primitives[i] != NULL;
 }
 
-int prim_cmp(object* a, object* b) {
+int eqcmp(object* a, object* b) {
     if (a == b) return 0;
     if (a == NULL) return -1;
     if (b == NULL) return 1;
@@ -88,15 +88,15 @@ int prim_cmp(object* a, object* b) {
 object* assoc(object* list, object* key) {
     for (; list; list = cdr(list)) {
         object* pair = car(list);
-        if (!prim_cmp(key, car(pair))) return pair;
+        if (!eqcmp(key, car(pair))) return pair;
     }
     return NULL;
 }
 
 object* delassoc(object** list, object* key) {
     for (; *list; list = &cdr(*list)) {
         object* pair = car(*list);
-        if (!prim_cmp(key, car(pair))) {
+        if (!eqcmp(key, car(pair))) {
             *list = cdr(*list);
             return pair;
         }
@@ -171,37 +171,90 @@ void splice_match(pickle* vm, object* args, object* env, object* cont, object* f
     // TODO(sm);
 }
 
-static void count_pointers() {
+static void make_refs_list(pickle* vm, object* obj, object** alist) {
+    again:
+    DBG();
+    if (obj == NULL || obj->type != &cons_type) return;
+    object* entry = assoc(*alist, obj);
+    if (entry) {
+        cdr(entry) = vm->make_integer(2);
+        return;
+    }
+    vm->push(vm->cons(obj, vm->make_integer(1)), *alist);
+    make_refs_list(vm, cdr(obj), alist);
+    obj = cdr(obj);
+    goto again;
+}
 
+// returns zero if the object doesn't need a #N# marker
+// otherwise returns N (negative if not first time)
+static int64_t reffed(pickle* vm, object* obj, object* alist, int64_t* counter) {
+    object* entry = assoc(alist, obj);
+    if (entry) {
+        int64_t value = vm->unwrap_integer(cdr(entry));
+        if (value < 0) {
+            // seen already
+            return value;
+        }
+        if (value == 2) {
+            // object with shared structure but no id yet
+            // assign id
+            int64_t my_id = *counter++;
+            // store entry
+            cdr(entry) = vm->make_integer(-my_id);
+            return my_id;
+        }
+    }
+    return 0;
 }
 
-void dump(object* x) {
-    if (x == NULL) printf("NULL");
-    else if (x->type == &cons_type) {
-        // Try to print a Scheme list
+static void print_with_refs(pickle* vm, object* obj, object* alist, int64_t* counter) {
+    if (obj == NULL) {
+        printf("NULL");
+        return;
+    }
+    #define PRINTTYPE(t, f, fmt) else if (obj->type == t) printf(fmt, obj->f)
+    PRINTTYPE(&string_type, as_chars, "\"%s\"");
+    PRINTTYPE(&symbol_type, as_chars, strchr(obj->as_chars, ' ') ? "#|%s|" : "%s");
+    PRINTTYPE(&integer_type, as_big_int, "%" PRId64);
+    PRINTTYPE(&float_type, as_double, "%lg");
+    PRINTTYPE(&c_function_type, as_ptr, "<function %p>");
+    PRINTTYPE(NULL, as_ptr, "<garbage %p>");
+    #undef PRINTTYPE
+    else if (obj->type != &cons_type) printf("<%s:%p>", obj->type->name, obj->as_ptr);
+    else {
+        // it's a cons
+        // test if it's in the table
+        int64_t ref = reffed(vm, obj, alist, counter);
+        if (ref < 0) {
+            printf("#%" PRId64 "#", -ref);
+            return;
+        }
+        if (ref) {
+            printf("#%" PRId64 "=", ref);
+        }
+        // now print the object
         putchar('(');
         for (;;) {
-            dump(car(x));
-            x = cdr(x);
-            if (x && x->type == &cons_type) putchar(' ');
+            print_with_refs(vm, car(obj), alist, counter);
+            obj = cdr(obj);
+            if (reffed(vm, obj, alist, counter)) break;
+            if (obj && obj->type == &cons_type) putchar(' ');
             else break;
         }
-        if (x) {
+        if (obj) {
             printf(" . ");
-            dump(x);
+            print_with_refs(vm, obj, alist, counter);
         }
         putchar(')');
     }
-    else {
-        #define PRINTTYPE(t, f, fmt) if (x->type == &t) printf(fmt, x->f)
-        PRINTTYPE(string_type, as_chars, "\"%s\"");
-        else PRINTTYPE(symbol_type, as_chars, strchr(x->as_chars, ' ') ? "#|%s|" : "%s");
-        else PRINTTYPE(integer_type, as_big_int, "%" PRId64);
-        else PRINTTYPE(float_type, as_double, "%lg");
-        else PRINTTYPE(c_function_type, as_ptr, "<function %p>");
-        else printf("<%s:%p>", x->type->name, x->as_ptr);
-        #undef PRINTTYPE
-    }
+}
+
+void pickle::dump(object* obj) {
+    object* alist = NULL;
+    int64_t counter = 0;
+    make_refs_list(this, obj, &alist);
+    print_with_refs(this, obj, alist, &counter);
 }
 
 }

pickle.hpp

@@ -21,17 +21,12 @@ class pickle;
 
 typedef object* (*func_ptr)(pickle* vm);
 
-extern const object_type metadata_type;
 extern const object_type cons_type;
-extern const object_type partial_type;
 extern const object_type c_function_type;
 extern const object_type string_type;
 extern const object_type symbol_type;
-extern const object_type stream_type;
-extern const object_type error_type;
 extern const object_type integer_type;
 extern const object_type float_type;
-extern const object_type list_type;
 
 class pickle : public tinobsy::vm {
     public:
@@ -91,17 +86,28 @@ class pickle : public tinobsy::vm {
         o->as_big_int = x;
         return o;
     }
+    inline int64_t unwrap_integer(object* x) {
+        ASSERT(x != NULL && x->type == &integer_type);
+        return x->as_big_int;
+    }
     inline object* make_float(double x) {
         INTERN(this, int64_t, &float_type, x);
         object* o = this->alloc(&float_type);
         o->as_double = x;
         return o;
     }
+    inline double unwrap_double(object* x) {
+        ASSERT(x != NULL && x->type == &float_type);
+        return x->as_double;
+    }
 
 
     void step();
 
 
+    void dump(object*);
+
+
     private:
     void mark_globals();
 };
@@ -110,7 +116,7 @@ class pickle : public tinobsy::vm {
 // Helper functions.
 
 // Returns 0 if equal, or nonzero if not equal. Doesn't work on compound or user types
-int prim_cmp(object*, object*);
+int eqcmp(object*, object*);
 // Returns the pair in the assoc list that has the same key, or NULL if not found.
 object* assoc(object*, object*);
 // Removes the key/value pair from the list and returns it, or returns NULL if the pair never existed.
@@ -121,7 +127,6 @@ void eval(pickle* vm, object* args, object* env, object* cont, object* fail_cont
 void splice_match(pickle* vm, object* args, object* env, object* cont, object* fail_cont);
 
 // Chokes on self-referential objects -- you have been warned
-void dump(object*);
 
 
 }

pickle_test.cpp

@@ -21,15 +21,13 @@ void start_catch_segfault() {
 int main() {
     start_catch_segfault();
     pickle::pickle vm;
-    for (size_t i = 0; i < 100; i++) {
-        vm.push_instruction(vm.make_symbol("foo"));
-        vm.push_instruction(vm.make_symbol("bar"), vm.make_symbol("error"));
-        vm.push_instruction(vm.make_symbol("baz"));
-        vm.push_instruction(vm.make_symbol("baz"), vm.make_symbol("test long symbol with spaces"));
-        vm.push_instruction(vm.make_symbol("baz"));
-        vm.push_instruction(vm.make_symbol("baz"));
-    }
-    pickle::dump(vm.instruction_stack);
+    vm.push_instruction(vm.make_symbol("foo"));
+    vm.push_instruction(vm.make_symbol("bar"), vm.make_symbol("error"));
+    vm.push_instruction(vm.make_symbol("baz"));
+    vm.push_instruction(vm.make_symbol("baz"), vm.make_symbol("test long symbol with spaces"));
+    vm.push_instruction(vm.make_symbol("baz"));
+    vm.push_instruction(vm.make_symbol("baz"));
+    vm.dump(vm.instruction_stack);
     putchar('\n');
     vm.gc();
     printf("all done -- cleaning up\n");