From: Chris Hanson <org/chris-hanson/cph>
Date: Sat, 12 Jan 2019 07:41:17 +0000 (-0800)
Subject: Find all relevant shared objects.  Handle NMV headers in vectors.
X-Git-Tag: mit-scheme-pucked-10.1.10~6^2~34
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=bfbca91cc077527cffa8ec35e09ed84835780e25;p=mit-scheme.git

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

diff --git a/src/runtime/printer.scm b/src/runtime/printer.scm
index 90af02c61..16c95026a 100644
--- 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))))
 
 ;;;; Procedures
 
diff --git a/tests/runtime/test-printer.scm b/tests/runtime/test-printer.scm
index 5e88557dd..b7ab2393e 100644
--- 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