Test suite and bug fixes

.github/workflows/chez.yaml

@@ -0,0 +1,21 @@
+on: [push]
+jobs:
+  test-chez:
+    runs-on: ubuntu-latest
+    container:
+      image: schemers/chezscheme:latest
+    steps:
+      - uses: actions/checkout@v5
+      - name: 'Install chez-srfi'
+        run: |
+          apt-get update
+          apt-get install -yy git
+          git clone https://github.com/arcfide/chez-srfi.git
+          cd chez-srfi
+          ./install.chezscheme.sps ~/chezlib
+      - name: 'Install (chibi test)'
+        run: |
+          git clone https://codeberg.org/dpk/chibi-lib.git ~/chezlib/chibi
+      - name: 'Run tests'
+        run: |
+          env CHEZSCHEMELIBDIRS="$HOME/chezlib:" scheme --program test-on-r6rs.sps

.github/workflows/chibi.yaml

@@ -0,0 +1,19 @@
+on: [push]
+jobs:
+  test-chibi:
+    runs-on: ubuntu-latest
+    container:
+      image: schemers/chibi:latest
+    steps:
+      - uses: actions/checkout@v5
+      - name: 'Grab newer version of (chibi test)'
+        run: |
+          apt-get update
+          apt-get install -yy wget
+          mkdir -p ~/chibilib/chibi
+          cd ~/chibilib/chibi
+          wget https://raw.githubusercontent.com/ashinn/chibi-scheme/3ca9e57d1e2a7199ea84c775296843ca5f08c024/lib/chibi/test.sld
+          wget https://raw.githubusercontent.com/ashinn/chibi-scheme/3ca9e57d1e2a7199ea84c775296843ca5f08c024/lib/chibi/test.scm
+      - name: 'Run tests'
+        run: |
+          env TEST_GROUP_REMOVE='Stress tests: building' chibi-scheme -I ~/chibilib -I . test-on-r7rs.scm

srfi/250.sld

@@ -78,7 +78,7 @@
 
     (define-record-type Hash-Table
       (%make-hash-table type-test-function hash-function same?-function
-                        size next-entry compact-index
+                        size next-entry compact-index compact-index-max-fill
                         keys-vector values-vector mutable?)
       hash-table?
       (type-test-function hash-table-type-test-function)

srfi/250/hash-tables.scm

@@ -1,5 +1,6 @@
 ;; -*- eldoc-documentation-function: eldoc-documentation-default -*-
 ;; scheme-complete eldoc is bizarrely slow in this buffer
+(begin ; meze only supports one expression per file
 
 (define *nice-n-buckets*
   '#(2 2 3 5 5 7 7 11 11 13 13 17 17 19 19 23 23 23 23 29 29 31 31 31 31
@@ -162,8 +163,7 @@
     (let loop ((from-idx 0)
                (to-idx 0))
       ;;(display from-idx) (newline) (display to-idx) (newline) (newline)
-      (cond ((or (>= from-idx (hash-table-next-entry ht))
-                 (unfilled? (vector-ref (hash-table-keys-vector ht) from-idx)))
+      (cond ((>= from-idx (hash-table-next-entry ht))
              (vector-fill! (hash-table-keys-vector ht)
                            *unfilled*
                            (hash-table-size ht)
@@ -175,8 +175,35 @@
              (hash-table-next-entry-set! ht (hash-table-size ht)))
             ((deletion? (vector-ref (hash-table-keys-vector ht) from-idx))
              (unless fast?
-               (compact-array-delete! (hash-table-compact-index ht)
-                                      (vector-ref (hash-table-values-vector ht) from-idx)))
+               (let ((deleted-bucket (vector-ref (hash-table-values-vector ht) from-idx)))
+                 (compact-array-delete! (hash-table-compact-index ht)
+                                        deleted-bucket)
+                 (let loop ((deleted-bucket deleted-bucket)
+                            (examine-bucket (+ deleted-bucket 1)))
+                   (let ((examine-bucket
+                          (modulo examine-bucket
+                                  (compact-array-length
+                                   (hash-table-compact-index ht)))))
+                     (let ((collision-idx
+                            (compact-array-ref (hash-table-compact-index ht)
+                                               examine-bucket)))
+                       (when collision-idx
+                         (let* ((key (vector-ref (hash-table-keys-vector ht)
+                                                 collision-idx))
+                                (new-bucket
+                                 (if (deletion? key)
+                                     (vector-ref (hash-table-values-vector ht)
+                                                 collision-idx)
+                                     (hash-table-bucket-for-key ht key))))
+                           (if (eqv? new-bucket deleted-bucket)
+                               (begin
+                                 (compact-array-set! (hash-table-compact-index ht)
+                                                     deleted-bucket
+                                                     collision-idx)
+                                 (compact-array-delete! (hash-table-compact-index ht)
+                                                        examine-bucket)
+                                 (loop examine-bucket (+ examine-bucket 1)))
+                               (loop deleted-bucket (+ examine-bucket 1))))))))))
              (loop (+ from-idx 1) to-idx))
             ((eqv? from-idx to-idx) (loop (+ from-idx 1) (+ to-idx 1)))
             (else
@@ -233,9 +260,13 @@
 
 ;; add to the entries arrays, setting the bucket in the compact index
 (define (hash-table-add-entry! ht bucket key value)
-  (if (>= (hash-table-next-entry ht)
-          (vector-length (hash-table-keys-vector ht)))
-      (hash-table-grow-entries! ht))
+  (when (>= (hash-table-next-entry ht)
+            (vector-length (hash-table-keys-vector ht)))
+    (if (eqv? (hash-table-size ht) (hash-table-next-entry ht))
+        (hash-table-grow-entries! ht)
+        (begin
+          (hash-table-grow-entries! ht)
+          (set! bucket (hash-table-bucket-for-key ht key)))))
   (when (hash-table-compact-index-must-grow? ht)
     (hash-table-grow-compact-index! ht)
     (set! bucket (hash-table-bucket-for-key ht key)))
@@ -416,7 +447,7 @@
 
 (define (hash-table-pop! ht)
   (unless (hash-table-mutable? ht)
-    (assertion-violation 'hash-table-delete!
+    (assertion-violation 'hash-table-pop!
                          "hash table is immutable"
                          ht))
   (when (hash-table-empty? ht)
@@ -425,11 +456,12 @@
                          ht))
   (let* ((idx (- (hash-table-next-entry ht) 1))
          (key (vector-ref (hash-table-keys-vector ht) idx))
-         (value (vector-ref (hash-table-values-vector ht) idx)))
-    (vector-set! (hash-table-keys-vector ht) idx *unfilled*)
-    (vector-set! (hash-table-values-vector ht) idx *unfilled*)
+         (value (vector-ref (hash-table-values-vector ht) idx))
+         (bucket (hash-table-bucket-for-key ht key)))
+    (vector-set! (hash-table-keys-vector ht) idx *deletion*)
+    (vector-set! (hash-table-values-vector ht) idx bucket)
     (hash-table-size-set! ht (- (hash-table-size ht) 1))
-    (hash-table-next-entry-set! ht idx)
+    (hash-table-prune-dead-entries-at-end! ht)
     (values key value)))
 
 (define (hash-table-clear! ht)
@@ -635,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?)
@@ -679,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)
 
@@ -771,3 +805,5 @@
                          "hash table is immutable"
                          ht))
   (hash-table-set! ht key (updater (hash-table-ref/default ht key default))))
+
+)

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

@@ -1,12 +1,12 @@
 (define (make-compact-array size)
-  (cond ((< size #xFF) (make-bytevector size #xFF))
+  (cond ((< size #xFF) (make-u8vector size #xFF))
         ((< size #xFFFF) (make-u16vector size #xFFFF))
         ((< size #xFFFFFFFF) (make-u32vector size #xFFFFFFFF))
         (else (make-u64vector size #xFFFFFFFFFFFFFFFF))))
 
 (define (compact-array-ref sa idx)
   (define (max-to n) (lambda (x) (if (eqv? x n) #f x)))
-  (cond ((and (bytevector? sa) (bytevector-u8-ref sa idx))
+  (cond ((and (u8vector? sa) (u8vector-ref sa idx))
          => (max-to #xFF))
         ((and (u16vector? sa) (u16vector-ref sa idx))
          => (max-to #xFFFF))
@@ -19,14 +19,14 @@
   (not (not (compact-array-ref sa idx))))
 
 (define (compact-array-set! sa idx val)
-  (cond ((bytevector? sa) (bytevector-u8-set! sa idx val))
+  (cond ((u8vector? sa)   (u8vector-set! sa idx val))
         ((u16vector? sa)  (u16vector-set! sa idx val))
         ((u32vector? sa)  (u32vector-set! sa idx val))
         ((u64vector? sa)  (u64vector-set! sa idx val))))
 
 (define (compact-array-delete! sa idx)
-  (cond ((bytevector? sa)
-         (bytevector-u8-set! sa idx #xFF))
+  (cond ((u8vector? sa)
+         (u8vector-set! sa idx #xFF))
         ((u16vector? sa)
          (u16vector-set! sa idx #xFFFF))
         ((u32vector? sa)
@@ -36,10 +36,10 @@
 
 (define (compact-array-clear! sa)
   (define len (compact-array-length sa))
-  (cond ((bytevector? sa)
+  (cond ((u8vector? sa)
          (let loop ((idx 0))
            (when (< idx len)
-             (bytevector-u8-set! sa idx #xFF)
+             (u8vector-set! sa idx #xFF)
              (loop (+ idx 1)))))
         ((u16vector? sa)
          (let loop ((idx 0))
@@ -59,26 +59,38 @@
 
 (define (compact-array-copy sa)
   (define len (compact-array-length sa))
-  (cond ((bytevector? sa) (bytevector-copy sa))
+  (cond ((u8vector? sa)
+         (let ((out (make-u8vector len)))
+           (let loop ((idx 0))
+             (when (< idx len)
+               (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 ((bytevector? sa)
-         (bytevector-length sa))
+  (cond ((u8vector? sa)
+         (u8vector-length sa))
         ((u16vector? sa)
          (u16vector-length sa))
         ((u32vector? sa)

srfi/:250/hash-tables.sls

@@ -93,8 +93,8 @@
     (syntax-rules ()
       ((_ name pred)
        (begin
-         (define-record-type the-sentinel-type)
-         (define name (make-the-sentinel-type))
+         (define-record-type the-sentinel-type (fields sentinel-name))
+         (define name (make-the-sentinel-type 'name))
          (define (pred obj) (eq? obj name))))))
   (define-sentinel *unfilled* unfilled?)
   (define-sentinel *deletion* deletion?)

srfi/srfi-250.scm

@@ -11,6 +11,7 @@
   #:use-module ((guile) #:select (include
                                   procedure-name))
   #:use-module (ice-9 format)
+  #:use-module (srfi srfi-4)
   #:use-module ((srfi srfi-9 gnu) #:select (set-record-type-printer!))
   #:use-module (srfi srfi-128) ; https://codeberg.org/pukkamustard/guile-srfi-128
   #:duplicates (last)
@@ -113,7 +114,7 @@
 (define (hash-table-immutablize! ht)
   (hash-table-mutable?-set! ht #f))
 
-(include "250/internal/r6rs-compact-arrays.scm")
+(include "250/internal/srfi-compact-arrays.scm")
 (include "250/hash-tables.scm")
 
 (set-record-type-printer! (record-type-descriptor hash-table)

test-on-guile.scm

@@ -0,0 +1,17 @@
+(import (rnrs)
+        (rnrs r5rs)
+        (chibi test)
+        (only (srfi :1) list-tabulate)
+        (srfi :6)
+        (srfi :27)
+        (srfi :128)
+        (srfi :250)
+        (only (guile) include))
+
+(define (exact-integer? x)
+  (and (integer? x) (exact? x)))
+
+(test-begin "SRFI 250")
+(include "test-srfi-250.scm")
+(test-end "SRFI 250")
+(test-exit)

test-on-r6rs.sps

@@ -0,0 +1,17 @@
+(import (rnrs)
+        (rnrs r5rs)
+        (chibi test)
+        (only (srfi :1) list-tabulate)
+        (srfi :6)
+        (srfi :27)
+        (srfi :128)
+        (srfi :250)
+        (srfi :250 internal include))
+
+(define (exact-integer? x)
+  (and (integer? x) (exact? x)))
+
+(test-begin "SRFI 250")
+(include "test-srfi-250.scm")
+(test-end "SRFI 250")
+(test-exit)

test-on-r7rs.scm

@@ -0,0 +1,21 @@
+(import (scheme base)
+        (scheme char)
+        (scheme write)
+        (chibi test)
+        (only (srfi 1) list-tabulate)
+        (srfi 27)
+        (srfi 250)
+        (rename (srfi 128)
+                (default-hash equal-hash)))
+
+(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")
+(include "test-srfi-250.scm")
+(test-end "SRFI 250")
+(test-exit)