From: Matt Birkholz <puck@birchwood-abbey.net>
Date: Sat, 26 Apr 2014 15:00:13 +0000 (-0700)
Subject: Fix string-head! to hide the unused (non-marked) words.
X-Git-Tag: release-9.2.0~17
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=8e653625fb56a1810174fba407d90000c5ec43de;p=mit-scheme.git

Fix string-head! to hide the unused (non-marked) words.

This quiets 3 of the 17 complaints from verify_heap during `make
check'.  The remaining 14 appear to be caused by SIGFPE recovery.
---

diff --git a/src/runtime/string.scm b/src/runtime/string.scm
index f7279c8fe..04b2d5f9e 100644
--- a/src/runtime/string.scm
+++ b/src/runtime/string.scm
@@ -173,19 +173,31 @@ USA.
 
 (define %string-head!
   (let ((reuse
-	 (lambda (string end)
+	 (named-lambda (%string-head! string end)
 	   (declare (no-type-checks) (no-range-checks))
 	   (let ((mask (set-interrupt-enables! interrupt-mask/none)))
 	     (if (fix:< end (string-length string))
 		 (begin
 		   (string-set! string end #\nul)
 		   (set-string-length! string end)))
-	     ((ucode-primitive primitive-object-set! 3)
-	      string
-	      0
-	      ((ucode-primitive primitive-object-set-type 2)
-	       (ucode-type manifest-nm-vector)
-	       (fix:+ 2 (fix:lsh end %octets->words-shift))))
+	     (string-set! string end #\nul)
+	     (set-string-length! string end)
+	     (let ((new-gc-length (fix:+ 2 (fix:lsh end %octets->words-shift)))
+		   (old-gc-length (system-vector-length string)))
+	       (let ((delta (fix:- old-gc-length new-gc-length)))
+		 (cond ((fix:= delta 1)
+			(system-vector-set! string new-gc-length #f))
+		       ((fix:> delta 1)
+			(system-vector-set!
+			 string new-gc-length
+			 ((ucode-primitive primitive-object-set-type 2)
+			  (ucode-type manifest-nm-vector) (fix:-1+ delta)))))
+		 (if (fix:> delta 0)
+		     ((ucode-primitive primitive-object-set! 3)
+		      string
+		      0
+		      ((ucode-primitive primitive-object-set-type 2)
+		       (ucode-type manifest-nm-vector) new-gc-length)))))
 	     (set-interrupt-enables! mask)
 	     string))))
     (if (compiled-procedure? reuse)