>From 8ab17c4a4411e535cbd20bcb1cf47a2e6d2b6812 Mon Sep 17 00:00:00 2001
From: Peter Bex <address@hidden>
Date: Fri, 17 Jan 2014 21:26:51 +0100
Subject: [PATCH] Fix crashes in resize-vector when sizing down (detected by
 DEBUGBUILD)

---
 NEWS                    |    1 +
 library.scm             |   33 +++++++++++++++++----------------
 tests/library-tests.scm |   13 +++++++++++++
 3 files changed, 31 insertions(+), 16 deletions(-)

diff --git a/NEWS b/NEWS
index 4e89a4e..ed114c6 100644
--- a/NEWS
+++ b/NEWS
@@ -26,6 +26,7 @@
   - Nonblocking behaviour on sockets has been fixed on Windows.
   - Possible race condition while handling TCP errors has been fixed.
   - The posix unit will no longer hang upon any error in Windows.
+  - resize-vector no longer crashes when reducing the size of the vector.
 
 - Platform support
   - CHICKEN can now be built on AIX (contributed by Erik Falor)
diff --git a/library.scm b/library.scm
index 107e884..bf8a194 100644
--- a/library.scm
+++ b/library.scm
@@ -30,7 +30,7 @@
   (uses build-version)
   (disable-interrupts)
   (hide ##sys#dynamic-unwind
-	##sys#grow-vector ##sys#default-parameter-vector 
+	##sys#vector-resize ##sys#default-parameter-vector 
 	current-print-length setter-tag read-marks
 	##sys#print-exit
 	##sys#format-here-doc-warning
@@ -1418,15 +1418,14 @@ EOF
 (define (vector-resize v n #!optional init)
   (##sys#check-vector v 'vector-resize)
   (##sys#check-exact n 'vector-resize)
-  (##sys#grow-vector v n init) )
+  (##sys#vector-resize v n init) )
 
-(define (##sys#grow-vector v n init)
-  (let ([v2 (##sys#make-vector n init)]
-	[len (##sys#size v)] )
-    (do ([i 0 (fx+ i 1)])
+(define (##sys#vector-resize v n init)
+  (let ((v2 (##sys#make-vector n init))
+	(len (min (##sys#size v) n)) )
+    (do ((i 0 (fx+ i 1)))
 	((fx>= i len) v2)
       (##sys#setslot v2 i (##sys#slot v i)) ) ) )
-	
 
 ;;; Characters:
 
@@ -2321,7 +2320,7 @@ EOF
 	(set! count (fx+ count 1))
 	(when (fx>= i (##sys#size ##sys#default-parameter-vector))
 	  (set! ##sys#default-parameter-vector 
-	    (##sys#grow-vector
+	    (##sys#vector-resize
 	     ##sys#default-parameter-vector
 	     (fx+ i 1)
 	     (##core#undefined)) ) )
@@ -2330,7 +2329,7 @@ EOF
 	       (lambda (val n mode)
 		 (when (fx>= i n)
 		   (set! ##sys#current-parameter-vector
-		     (##sys#grow-vector
+		     (##sys#vector-resize
 		      ##sys#current-parameter-vector
 		      (fx+ i 1)
 		      ##sys#snafu) ) )
@@ -3172,11 +3171,11 @@ EOF
   (##sys#make-structure 
    'read-table
    (let ((t1 (##sys#slot rt 1)))
-     (and t1 (##sys#grow-vector t1 (##sys#size t1) #f) ) )
+     (and t1 (##sys#vector-resize t1 (##sys#size t1) #f) ) )
    (let ((t2 (##sys#slot rt 2)))
-     (and t2 (##sys#grow-vector t2 (##sys#size t2) #f) ) )
+     (and t2 (##sys#vector-resize t2 (##sys#size t2) #f) ) )
    (let ((t3 (##sys#slot rt 3)))
-     (and t3 (##sys#grow-vector t3 (##sys#size t3) #f) ) ) ))
+     (and t3 (##sys#vector-resize t3 (##sys#size t3) #f) ) ) ))
 
 
 ;;; Output:
@@ -4488,7 +4487,8 @@ EOF
     ##sys#standard-output
     ##sys#standard-error
     ##sys#default-exception-handler
-    (##sys#grow-vector ##sys#current-parameter-vector (##sys#size ##sys#current-parameter-vector) #f) )
+    (##sys#vector-resize ##sys#current-parameter-vector
+			 (##sys#size ##sys#current-parameter-vector) #f) )
    name					; #6 name
    (##core#undefined)			; #7 end-exception
    '()					; #8 owned mutexes
@@ -4737,9 +4737,10 @@ EOF
     (lambda (x y)
       (when (fx>= (##sys#fudge 26) _max_pending_finalizers)
 	(cond ((##core#inline "C_resize_pending_finalizers" (fx* 2 _max_pending_finalizers))
-	       (set! ##sys#pending-finalizers (##sys#grow-vector ##sys#pending-finalizers
-								 (fx+ (fx* 2 _max_pending_finalizers) 1)
-								 (##core#undefined)))
+	       (set! ##sys#pending-finalizers
+		 (##sys#vector-resize ##sys#pending-finalizers
+				      (fx+ (fx* 2 _max_pending_finalizers) 1)
+				      (##core#undefined)))
 	       (when (##sys#fudge 13)
 		 (##sys#print 
 		  (string-append
diff --git a/tests/library-tests.scm b/tests/library-tests.scm
index ba75076..5418fbb 100644
--- a/tests/library-tests.scm
+++ b/tests/library-tests.scm
@@ -513,6 +513,19 @@ A
 (assert-fail (make-blob -1))
 (assert-fail (make-vector -1))
 
+;;; Resizing of vectors works to both sides
+(let ((original (vector 1 2 3 4 5 6)))
+  (assert (equal? (vector-resize original 6 -1) original))
+  (assert (not (eq? (vector-resize original 6 -1) original))))
+
+(let ((original (vector 1 2 3 4 5 6))
+      (smaller (vector 1 2 3)))
+  (assert (equal? (vector-resize original 3 -1) smaller)))
+
+(let ((original (vector 1 2 3))
+      (larger (vector 1 2 3 -1 -1 -1)))
+  (assert (equal? (vector-resize original 6 -1) larger)))
+
 ;;; eval return values
 
 (assert (= 1 (eval 1)))
-- 
1.7.10.4