Find all relevant shared objects. Handle NMV headers in vectors.

diff --git a/src/runtime/printer.scm b/src/runtime/printer.scm
index 90af02c6196f8ece00d7dfe584432a792976f70b..16c95026a5a3b5a1cf7ff6e8d42196d7f0524412 100644 (file)
--- a/src/runtime/printer.scm
+++ b/src/runtime/printer.scm
@@ -265,11 +265,29 @@ USA.
            ((pair? object)
             (if (mark! object)
                 (begin
-                  (walk (car object))
-                  (walk (cdr object)))))
+                  (walk (safe-car object))
+                  (walk (safe-cdr object)))))
            ((vector? object)
             (if (mark! object)
-                (vector-for-each walk object)))))
+                (let ((end (vector-length object)))
+                  (let loop ((i 0))
+                    (if (< i end)
+                        (if (nmv-header? object i)
+                            ;; An embedded non-marked vector: skip over and
+                            ;; continue.
+                            (loop (+ i 1 (nmv-header-length object i)))
+                            (begin
+                              (walk (safe-vector-ref object i))
+                              (loop (+ i 1)))))))))
+           ((promise? object)
+            (if (mark! object)
+                (if (promise-forced? object)
+                    (walk (promise-value object)))))
+           ((%tagged-object? object)
+            (if (mark! object)
+                (begin
+                  (walk (%tagged-object-tag object))
+                  (walk (%tagged-object-datum object)))))))
 
     (define (mark! object)
       (let ((value
@@ -410,6 +428,22 @@ USA.
   (*print-string "#@" context)
   (*print-hash object context))
 
+(define (safe-car pair)
+  (map-reference-trap (lambda () (car pair))))
+
+(define (safe-cdr pair)
+  (map-reference-trap (lambda () (cdr pair))))
+
+(define (nmv-header? vector index)
+  (fix:= (ucode-type manifest-nm-vector)
+        ((ucode-primitive primitive-type-ref 2) vector (fix:+ 1 index))))
+
+(define (nmv-header-length vector index)
+  ((ucode-primitive primitive-datum-ref 2) vector (fix:+ 1 index)))
+
+(define (safe-vector-ref vector index)
+  (map-reference-trap (lambda () (vector-ref vector index))))
+
 (define (allowed-char? char context)
   (char-in-set? char (context-char-set context)))
 
@@ -700,19 +734,16 @@ USA.
       (let ((end (vector-length vector)))
        (*general-print-items 0 context* print-object 0
          (lambda (index k)
-           (if (fix:< index end)
-               (k (safe-vector-ref vector index)
-                  (fix:+ index 1))))))
+           (if (< index end)
+               (if (nmv-header? vector index)
+                   ;; An embedded non-marked vector: skip over and continue.
+                   (let ((length (nmv-header-length vector index)))
+                     (k (symbol "#[non-marked section of length " length "]")
+                        (+ index 1 length)))
+                   (k (safe-vector-ref vector index)
+                      (+ index 1)))))))
       (*print-char #\) context*))))
 
-(define (safe-vector-ref vector index)
-  (if (with-absolutely-no-interrupts
-       (lambda ()
-         (object-type? (ucode-type manifest-nm-vector)
-                       (vector-ref vector index))))
-      (error "Attempt to print partially marked vector."))
-  (map-reference-trap (lambda () (vector-ref vector index))))
-
 (define (print-bytevector bytevector context)
   (limit-print-depth context
     (lambda (context*)
@@ -798,12 +829,6 @@ USA.
                          (*print-string " . " context*)
                          (print-object value context*))))))))
       (*print-char #\} context*))))
-
-(define (safe-car pair)
-  (map-reference-trap (lambda () (car pair))))
-
-(define (safe-cdr pair)
-  (map-reference-trap (lambda () (cdr pair))))
 \f
 ;;;; Procedures
 

diff --git a/tests/runtime/test-printer.scm b/tests/runtime/test-printer.scm
index 5e88557ddcfe125cbd836667e35cbac00bdc09ff..b7ab2393e5ddec39d15cfdd06fafde360f1c5f84 100644 (file)
--- a/tests/runtime/test-printer.scm
+++ b/tests/runtime/test-printer.scm
@@ -129,4 +129,24 @@ USA.
       (assert-prints-as '#u8(2 3 5 7 11 13 17 19)
                        "#u8(2 3 5 ...)")
       (assert-prints-as '(2 3 5 7 11 13 17 19 . foo)
-                       "(2 3 5 ...)"))))
\ No newline at end of file
+                       "(2 3 5 ...)"))))
+
+(define-primitives
+  primitive-type-set!)
+
+(define (insert-nmv! v i n)
+  (vector-set! v i n)
+  (primitive-type-set! v (+ i 1) (ucode-type manifest-nm-vector)))
+
+(define-test 'partially-marked-vector
+  (lambda ()
+    (let ((v (make-vector 10)))
+      (insert-nmv! v 2 5)
+      (assert-prints-as v "#(#f #f |#[non-marked section of length 5]| #f #f)"))
+    (let ((v (make-vector 10)))
+      (insert-nmv! v 0 5)
+      (assert-prints-as v "#(|#[non-marked section of length 5]| #f #f #f #f)"))
+    (let ((v (make-vector 10)))
+      (insert-nmv! v 4 5)
+      (assert-prints-as v "#(#f #f #f #f |#[non-marked section of length 5]|)"))
+    ))
\ No newline at end of file