Finish test suite, with corrections for bugs discovered

Author: dpk

srfi/250/hash-tables.scm

@@ -667,23 +667,25 @@
    ht))
 
 (define (hash-table-prune! proc ht)
+  (define original-size (hash-table-size ht))
   (unless (hash-table-mutable? ht)
     (assertion-violation 'hash-table-prune!
                          "hash table is immutable"
                          ht))
   (let loop ((cur (hash-table-cursor-first ht)) (n-deleted 0))
     (if (hash-table-cursor-at-end? ht cur)
         (begin
-          (hash-table-size-set! ht (- (hash-table-size ht) n-deleted))
           (hash-table-prune-dead-entries-at-end! ht)
-          (when (> (- (hash-table-next-entry ht) (hash-table-size ht))
+          (when (> (- (hash-table-next-entry ht) original-size)
                    (* 1/3 (hash-table-size ht)))
             (hash-table-prune-dead-entries! ht #f))
           n-deleted)
         (let-values (((k v) (hash-table-cursor-key+value ht cur)))
           (if (and (proc k v)
                    (hash-table-delete-one! ht k))
-              (loop (hash-table-cursor-next ht cur) (+ n-deleted 1))
+              (begin
+                (hash-table-size-set! ht (- (hash-table-size ht) 1))
+                (loop (hash-table-cursor-next ht cur) (+ n-deleted 1)))
               (loop (hash-table-cursor-next ht cur) n-deleted))))))
 
 (define (hash-table-copy ht mutable?)
@@ -711,7 +713,7 @@
   (hash-table-for-each
    (lambda (k v)
      (unless (hash-table-contains? ht_1 k)
-       (hash-table-set! ht_2 k v)))
+       (hash-table-set! ht_1 k v)))
    ht_2)
   ht_1)
 

srfi/250/internal/srfi-compact-arrays.scm

@@ -63,22 +63,30 @@
          (let ((out (make-u8vector len)))
            (let loop ((idx 0))
              (when (< idx len)
-               (u8vector-set! out idx (u8vector-ref sa idx))))))
+               (u8vector-set! out idx (u8vector-ref sa idx))
+               (loop (+ idx 1))))
+           out))
         ((u16vector? sa)
          (let ((out (make-u16vector len)))
            (let loop ((idx 0))
              (when (< idx len)
-               (u16vector-set! out idx (u16vector-ref sa idx))))))
+               (u16vector-set! out idx (u16vector-ref sa idx))
+               (loop (+ idx 1))))
+           out))
         ((u32vector? sa)
          (let ((out (make-u32vector len)))
            (let loop ((idx 0))
              (when (< idx len)
-               (u32vector-set! out idx (u32vector-ref sa idx))))))
+               (u32vector-set! out idx (u32vector-ref sa idx))
+               (loop (+ idx 1))))
+           out))
         ((u64vector? sa)
          (let ((out (make-u64vector len)))
            (let loop ((idx 0))
              (when (< idx len)
-               (u64vector-set! out idx (u64vector-ref sa idx))))))))
+               (u64vector-set! out idx (u64vector-ref sa idx))
+               (loop (+ idx 1))))
+           out))))
 
 (define (compact-array-length sa)
   (cond ((u8vector? sa)

test-on-guile.scm

@@ -2,6 +2,7 @@
         (rnrs r5rs)
         (chibi test)
         (only (srfi :1) list-tabulate)
+        (srfi :6)
         (srfi :27)
         (srfi :128)
         (srfi :250)

test-on-r6rs.sps

@@ -2,6 +2,7 @@
         (rnrs r5rs)
         (chibi test)
         (only (srfi :1) list-tabulate)
+        (srfi :6)
         (srfi :27)
         (srfi :128)
         (srfi :250)

test-on-r7rs.scm

@@ -1,5 +1,6 @@
 (import (scheme base)
         (scheme char)
+        (scheme write)
         (chibi test)
         (only (srfi 1) list-tabulate)
         (srfi 27)
@@ -10,6 +11,8 @@
 (define-syntax assert
   (syntax-rules ()
     ((_ what) (unless what (error "assertion failed")))))
+(define (assertion-violation who msg . rest)
+  (apply error msg rest))
 (define assertion-violation? error-object?)
 
 (test-begin "SRFI 250")