adding (srfi 128)

lib/srfi/128.sld

@@ -0,0 +1,27 @@
+(define-library (srfi 128)
+  (import (scheme base) (scheme char)
+          (srfi 27) (srfi 33) (srfi 69) (srfi 95) (srfi 98)
+          (only (chibi) fixnum? er-macro-transformer))
+  (export
+   ;; Predicates:
+   comparator? comparator-ordered? comparator-hashable?
+   ;; Constructors:
+   make-comparator make-pair-comparator make-list-comparator
+   make-vector-comparator make-eq-comparator make-eqv-comparator
+   make-equal-comparator
+   ;; Standard hash functions:
+   boolean-hash char-hash char-ci-hash string-hash string-ci-hash
+   symbol-hash number-hash
+   ;; Bounds and salt:
+   hash-bound hash-salt
+   ;; Default comparators:
+   make-default-comparator default-hash comparator-register-default!
+   ;; Accessors and invokers:
+   comparator-type-test-predicate comparator-equality-predicate
+   comparator-ordering-predicate comparator-hash-function
+   comparator-test-type comparator-check-type comparator-hash
+   ;; Comparison predicates:
+   =? <? >? <=? >=?
+   ;;Syntax:
+   comparator-if<=>)
+  (include "128/comparators.scm"))

lib/srfi/128/comparators.scm

@@ -0,0 +1,229 @@
+
+(define-record-type Comparator
+  (make-comparator type-test equality ordering hash)
+  comparator?
+  (type-test comparator-type-test-predicate)
+  (equality comparator-equality-predicate)
+  (ordering comparator-ordering-predicate)
+  (hash comparator-hash-function))
+
+(define-syntax hash-bound
+  (er-macro-transformer
+   (lambda (expr rename compare)
+     (if (fixnum? (- (expt 2 62) 1))
+         (- (expt 2 62) 1)
+         (- (expt 2 30) 1)))))
+
+(define-syntax hash-salt
+  (er-macro-transformer
+   (let ((salt (or (string->number
+                    (or (get-environment-variable "CHIBI_HASH_SALT") ""))
+                   (random-integer (hash-bound)))))
+     (lambda (expr rename compare)
+       salt))))
+
+(define-syntax comparator-if<=>
+  (syntax-rules ()
+    ((comparator-if<=> comparator obj1 obj2 less equal greater)
+     (let ((cmp comparator)
+           (o1 obj1)
+           (o2 obj2))
+       (cond
+        (((comparator-equality-predicate cmp) o1 o2) equal)
+        (((comparator-ordering-predicate cmp) o1 o2) less)
+        (else greater))))
+    ((comparator-if<=> obj1 obj2 less equal greater)
+     (comparator-if<=> (make-default-comparator) obj1 obj2 less equal greater))))
+
+(define (comparator-ordered? comparator)
+  (and (comparator-ordering-predicate comparator) #t))
+
+(define (comparator-hashable? comparator)
+  (and (comparator-hash-function comparator) #t))
+
+(define (comparator-test-type comparator obj)
+  ((comparator-type-test-predicate comparator) obj))
+
+(define (comparator-check-type comparator obj)
+  (or (comparator-test-type comparator obj)
+      (error "not an object of the comparator type" comparator obj)))
+
+(define (comparator-hash comparator obj)
+  ((comparator-hash-function comparator) obj))
+
+(define default-comparators
+  (make-parameter '()))
+
+(define (comparator-register-default! comparator)
+  (default-comparators (cons comparator (default-comparators))))
+
+(define (make-pair-comparator car-comparator cdr-comparator)
+  (make-comparator
+   (lambda (x)
+     (and (pair? x)
+          ((comparator-type-test-predicate car-comparator) (car x))
+          ((comparator-type-test-predicate cdr-comparator) (cdr x))))
+   (lambda (x y)
+     (and ((comparator-equality-predicate car-comparator) (car x) (car y))
+          ((comparator-equality-predicate cdr-comparator) (cdr x) (cdr y))))
+   (lambda (x y)
+     (if ((comparator-equality-predicate car-comparator) (car x) (car y))
+         ((comparator-ordering-predicate cdr-comparator) (cdr x) (cdr y))
+         ((comparator-ordering-predicate car-comparator) (car x) (car y))))
+   (lambda (x)
+     (bitwise-xor ((comparator-hash-function car-comparator) (car x))
+                  ((comparator-hash-function cdr-comparator) (cdr x))))))
+
+(define (make-list-comparator element-comparator type-test empty? head tail)
+  (make-comparator
+   (lambda (x)
+     (and (type-test x)
+          (let lp ((ls x))
+            (or (empty? ls)
+                (and ((comparator-type-test-predicate element-comparator) (head ls))
+                     (lp (tail ls)))))))
+   (lambda (x y)
+     (let lp ((ls1 x) (ls2 y))
+       (cond
+        ((empty? ls1) (empty? ls2))
+        ((empty? ls2) #f)
+        (else
+         (and ((comparator-equality-predicate element-comparator) (head ls1) (head ls2))
+              (lp (tail ls1) (tail ls2)))))))
+   (lambda (x y)
+     (let lp ((ls1 x) (ls2 y))
+       (cond
+        ((empty? ls1) (not (empty? ls2)))
+        ((empty? ls2) #f)
+        (else
+         (let ((a (head ls1)) (b (head ls2)))
+           (if ((comparator-equality-predicate element-comparator) a b)
+               (lp (tail ls1) (tail ls2))
+               ((comparator-ordering-predicate element-comparator) a b)))))))
+   (lambda (x)
+     (let lp ((ls x) (acc 0))
+       (if (empty? ls)
+           acc
+           (lp (tail ls)
+               (bitwise-xor ((comparator-hash-function element-comparator) (head ls))
+                            acc)))))
+   ))
+
+(define (make-vector-comparator element-comparator type-test length ref)
+  (make-comparator
+   (lambda (x)
+     (and (type-test x)
+          (let ((len (length x)))
+            (let lp ((i 0))
+              (or (>= i len)
+                  (and ((comparator-type-test-predicate element-comparator) (ref x i))
+                       (lp (+ i 1))))))))
+   (lambda (x y)
+     (let ((lenx (length x)) (leny (length y)))
+       (and
+        (= lenx leny)
+        (let lp ((i 0))
+          (or (>= i lenx)
+              (let ((a (ref x i)) (b (ref y i)))
+                (and ((comparator-equality-predicate element-comparator) a b)
+                     (lp (+ i 1)))))))))
+   (lambda (x y)
+     (let ((lenx (length x)) (leny (length y)))
+       (cond
+        ((< lenx leny) #t)
+        ((> lenx leny) #f)
+        (else
+         (let lp ((i 0))
+           (and (< i lenx)
+                (let ((a (ref x i)) (b (ref y i)))
+                  (if ((comparator-equality-predicate element-comparator) a b)
+                      (lp (+ i 1))
+                      ((comparator-ordering-predicate element-comparator) a b)))))))))
+   (lambda (x)
+     (let ((len (length x)))
+       (let lp ((i 0) (acc 0))
+         (if (>= i len)
+             acc
+             (lp (+ i 1)
+                 (bitwise-xor ((comparator-hash-function element-comparator) (ref x i))
+                              acc))))))
+   ))
+
+(define (make-eq-comparator)
+  (make-comparator (lambda (x) #t) eq? object-cmp hash-by-identity))
+
+(define (make-eqv-comparator)
+  (make-comparator (lambda (x) #t) eqv? object-cmp hash))
+
+(define (make-equal-comparator)
+  (make-comparator (lambda (x) #t) equal? object-cmp hash))
+
+(define boolean-hash hash)
+
+(define char-hash hash)
+
+(define (char-ci-hash ch)
+  (hash (char-foldcase ch)))
+
+(define symbol-hash hash)
+
+(define number-hash hash)
+
+(define (default-hash x . o)
+  (if (string? x) (string-hash x) (hash x)))
+
+(define default-comparator
+  (make-comparator
+   (lambda (x) #t)
+   (lambda (x y)
+     (let lp ((ls (default-comparators)))
+       (cond ((null? ls)
+              (equal? x y))
+             ((and (comparator-test-type (car ls) x)
+                   (comparator-test-type (car ls) y))
+              ((comparator-equality-predicate (car ls)) x y))
+             (else
+              (lp (cdr ls))))))
+   (lambda (x y)
+     (let lp ((ls (default-comparators)))
+       (cond ((null? ls)
+              (negative? (object-cmp x y)))
+             ((and (comparator-test-type (car ls) x)
+                   (comparator-test-type (car ls) y))
+              ((comparator-ordering-predicate (car ls)) x y))
+             (else
+              (lp (cdr ls))))))
+   default-hash))
+
+(define (make-default-comparator)
+  default-comparator)
+
+(define (=? comparator o1 o2 . o)
+  (let ((eq (comparator-equality-predicate comparator)))
+    (and (eq o1 o2)
+         (let lp ((ls o))
+           (or (null? ls)
+               (and (eq o1 (car ls))
+                    (lp (cdr ls))))))))
+
+(define (<? comparator o1 o2 . o)
+  (let ((less (comparator-ordering-predicate comparator)))
+    (and (less o1 o2)
+         (let lp ((prev o2) (ls o))
+           (or (null? ls)
+               (and (less prev (car ls))
+                    (lp (car ls) (cdr ls))))))))
+
+(define (<=? comparator o1 o2 . o)
+  (let ((less (comparator-ordering-predicate comparator)))
+    (and (not (less o2 o1))
+         (let lp ((prev o2) (ls o))
+           (or (null? ls)
+               (and (not (less (car ls) prev))
+                    (lp (car ls) (cdr ls))))))))
+
+(define (>? comparator . o)
+  (apply <? comparator (reverse o)))
+
+(define (>=? comparator . o)
+  (apply <=? comparator (reverse o)))

lib/srfi/128/test.sld

@@ -0,0 +1,281 @@
+(define-library (srfi 128 test)
+  (export run-tests)
+  (import (scheme base) (srfi 128) (chibi test))
+  (begin
+    (define default-comparator (make-default-comparator))
+    (define real-comparator (make-comparator real? = < number-hash))
+    (define degenerate-comparator (make-comparator (lambda (x) #t) equal? #f #f))
+    (define boolean-comparator
+      (make-comparator boolean? eq? (lambda (x y) (and (not x) y)) boolean-hash))
+    (define bool-pair-comparator
+      (make-pair-comparator boolean-comparator boolean-comparator))
+    (define num-list-comparator
+      (make-list-comparator real-comparator list? null? car cdr))
+    (define num-vector-comparator
+      (make-vector-comparator real-comparator vector? vector-length vector-ref))
+    (define (vector-cdr vec)
+      (let* ((len (vector-length vec))
+             (result (make-vector (- len 1))))
+        (let loop ((n 1))
+          (cond
+           ((= n len) result)
+           (else (vector-set! result (- n 1) (vector-ref vec n))
+                 (loop (+ n 1)))))))
+    (define vector-qua-list-comparator
+      (make-list-comparator
+       real-comparator
+       vector?
+       (lambda (vec) (= 0 (vector-length vec)))
+       (lambda (vec) (vector-ref vec 0))
+       vector-cdr))
+    (define list-qua-vector-comparator
+      (make-vector-comparator default-comparator list? length list-ref))
+    (define eq-comparator (make-eq-comparator))
+    (define eqv-comparator (make-eqv-comparator))
+    (define equal-comparator (make-equal-comparator))
+    (define symbol-comparator
+      (make-comparator
+       symbol?
+       eq?
+       (lambda (a b) (string<? (symbol->string a) (symbol->string b)))
+       symbol-hash))
+    (define (run-tests)
+      (test-group "comparators"
+        (test '#(2 3 4) (vector-cdr '#(1 2 3 4)))
+        (test '#() (vector-cdr '#(1)))
+
+        (test-group "comparators/predicates"
+          (test-assert (comparator? real-comparator))
+          (test-assert (not (comparator? =)))
+          (test-assert (comparator-ordered? real-comparator))
+          (test-assert (comparator-hashable? real-comparator))
+          (test-assert (not (comparator-ordered? degenerate-comparator)))
+          (test-assert (not (comparator-hashable? degenerate-comparator)))
+          )                              ; end comparators/predicates
+
+        (test-group "comparators/constructors"
+          (test-assert (=? boolean-comparator #t #t))
+          (test-assert (not (=? boolean-comparator #t #f)))
+          (test-assert (<? boolean-comparator #f #t))
+          (test-assert (not (<? boolean-comparator #t #t)))
+          (test-assert (not (<? boolean-comparator #t #f)))
+
+          (test-assert (comparator-test-type bool-pair-comparator '(#t . #f)))
+          (test-assert (not (comparator-test-type bool-pair-comparator 32)))
+          (test-assert (not (comparator-test-type bool-pair-comparator '(32 . #f))))
+          (test-assert (not (comparator-test-type bool-pair-comparator '(#t . 32))))
+          (test-assert (not (comparator-test-type bool-pair-comparator '(32 . 34))))
+          (test-assert (=? bool-pair-comparator '(#t . #t) '(#t . #t)))
+          (test-assert (not (=? bool-pair-comparator '(#t . #t) '(#f . #t))))
+          (test-assert (not (=? bool-pair-comparator '(#t . #t) '(#t . #f))))
+          (test-assert (<? bool-pair-comparator '(#f . #t) '(#t . #t)))
+          (test-assert (<? bool-pair-comparator '(#t . #f) '(#t . #t)))
+          (test-assert (not (<? bool-pair-comparator '(#t . #t) '(#t . #t))))
+          (test-assert (not (<? bool-pair-comparator '(#t . #t) '(#f . #t))))
+          (test-assert (not (<? bool-pair-comparator '(#f . #t) '(#f . #f))))
+
+          (test-assert (comparator-test-type num-vector-comparator '#(1 2 3)))
+          (test-assert (comparator-test-type num-vector-comparator '#()))
+          (test-assert (not (comparator-test-type num-vector-comparator 1)))
+          (test-assert (not (comparator-test-type num-vector-comparator '#(a 2 3))))
+          (test-assert (not (comparator-test-type num-vector-comparator '#(1 b 3))))
+          (test-assert (not (comparator-test-type num-vector-comparator '#(1 2 c))))
+          (test-assert (=? num-vector-comparator '#(1 2 3) '#(1 2 3)))
+          (test-assert (not (=? num-vector-comparator '#(1 2 3) '#(4 5 6))))
+          (test-assert (not (=? num-vector-comparator '#(1 2 3) '#(1 5 6))))
+          (test-assert (not (=? num-vector-comparator '#(1 2 3) '#(1 2 6))))
+          (test-assert (<? num-vector-comparator '#(1 2) '#(1 2 3)))
+          (test-assert (<? num-vector-comparator '#(1 2 3) '#(2 3 4)))
+          (test-assert (<? num-vector-comparator '#(1 2 3) '#(1 3 4)))
+          (test-assert (<? num-vector-comparator '#(1 2 3) '#(1 2 4)))
+          (test-assert (<? num-vector-comparator '#(3 4) '#(1 2 3)))
+          (test-assert (not (<? num-vector-comparator '#(1 2 3) '#(1 2 3))))
+          (test-assert (not (<? num-vector-comparator '#(1 2 3) '#(1 2))))
+          (test-assert (not (<? num-vector-comparator '#(1 2 3) '#(0 2 3))))
+          (test-assert (not (<? num-vector-comparator '#(1 2 3) '#(1 1 3))))
+
+          (test-assert (not (<? vector-qua-list-comparator '#(3 4) '#(1 2 3))))
+          (test-assert (<? list-qua-vector-comparator '(3 4) '(1 2 3)))
+
+          (let ((bool-pair (cons #t #f))
+                (bool-pair-2 (cons #t #f))
+                (reverse-bool-pair (cons #f #t)))
+            (test-assert (=? eq-comparator #t #t))
+            (test-assert (not (=? eq-comparator #f #t)))
+            (test-assert (=? eqv-comparator bool-pair bool-pair))
+            (test-assert (not (=? eqv-comparator bool-pair bool-pair-2)))
+            (test-assert (=? equal-comparator bool-pair bool-pair-2))
+            (test-assert (not (=? equal-comparator bool-pair reverse-bool-pair))))
+          )                              ; end comparators/constructors
+
+        (test-group "comparators/hash"
+          (test-assert (exact-integer? (boolean-hash #f)))
+          (test-assert (not (negative? (boolean-hash #t))))
+          (test-assert (exact-integer? (char-hash #\a)))
+          (test-assert (not (negative? (char-hash #\b))))
+          (test-assert (exact-integer? (char-ci-hash #\a)))
+          (test-assert (not (negative? (char-ci-hash #\b))))
+          (test-assert (= (char-ci-hash #\a) (char-ci-hash #\A)))
+          (test-assert (exact-integer? (string-hash "f")))
+          (test-assert (not (negative? (string-hash "g"))))
+          (test-assert (exact-integer? (string-ci-hash "f")))
+          (test-assert (not (negative? (string-ci-hash "g"))))
+          (test-assert (= (string-ci-hash "f") (string-ci-hash "F")))
+          (test-assert (exact-integer? (symbol-hash 'f)))
+          (test-assert (not (negative? (symbol-hash 't))))
+          (test-assert (exact-integer? (number-hash 3)))
+          (test-assert (not (negative? (number-hash 3))))
+          (test-assert (exact-integer? (number-hash -3)))
+          (test-assert (not (negative? (number-hash -3))))
+          (test-assert (exact-integer? (number-hash 3.0)))
+          (test-assert (not (negative? (number-hash 3.0))))
+          (test-assert (exact-integer? (number-hash 3.47)))
+          (test-assert (not (negative? (number-hash 3.47))))
+          (test-assert (exact-integer? (default-hash '())))
+          (test-assert (not (negative? (default-hash '()))))
+          (test-assert (exact-integer? (default-hash '(a "b" #\c #(dee) 2.718))))
+          (test-assert (not (negative? (default-hash '(a "b" #\c #(dee) 2.718)))))
+          (test-assert (exact-integer? (default-hash '#u8())))
+          (test-assert (not (negative? (default-hash '#u8()))))
+          (test-assert (exact-integer? (default-hash '#u8(8 6 3))))
+          (test-assert (not (negative? (default-hash '#u8(8 6 3)))))
+          (test-assert (exact-integer? (default-hash '#())))
+          (test-assert (not (negative? (default-hash '#()))))
+          (test-assert (exact-integer? (default-hash '#(a "b" #\c #(dee) 2.718))))
+          (test-assert (not (negative? (default-hash '#(a "b" #\c #(dee) 2.718)))))
+
+          )                              ; end comparators/hash
+
+        (test-group "comparators/default"
+          (test-assert (<? default-comparator '() '(a)))
+          (test-assert (not (=? default-comparator '() '(a))))
+          (test-assert (=? default-comparator #t #t))
+          (test-assert (not (=? default-comparator #t #f)))
+          (test-assert (<? default-comparator #f #t))
+          (test-assert (not (<? default-comparator #t #t)))
+          (test-assert (=? default-comparator #\a #\a))
+          (test-assert (<? default-comparator #\a #\b))
+
+          (test-assert (comparator-test-type default-comparator '()))
+          (test-assert (comparator-test-type default-comparator #t))
+          (test-assert (comparator-test-type default-comparator #\t))
+          (test-assert (comparator-test-type default-comparator '(a)))
+          (test-assert (comparator-test-type default-comparator 'a))
+          (test-assert (comparator-test-type default-comparator (make-bytevector 10)))
+          (test-assert (comparator-test-type default-comparator 10))
+          (test-assert (comparator-test-type default-comparator 10.0))
+          (test-assert (comparator-test-type default-comparator "10.0"))
+          (test-assert (comparator-test-type default-comparator '#(10)))
+
+          (test-assert (=? default-comparator '(#t . #t) '(#t . #t)))
+          (test-assert (not (=? default-comparator '(#t . #t) '(#f . #t))))
+          (test-assert (not (=? default-comparator '(#t . #t) '(#t . #f))))
+          (test-assert (<? default-comparator '(#f . #t) '(#t . #t)))
+          (test-assert (<? default-comparator '(#t . #f) '(#t . #t)))
+          (test-assert (not (<? default-comparator '(#t . #t) '(#t . #t))))
+          (test-assert (not (<? default-comparator '(#t . #t) '(#f . #t))))
+          (test-assert (not (<? default-comparator '#(#f #t) '#(#f #f))))
+
+          (test-assert (=? default-comparator '#(#t #t) '#(#t #t)))
+          (test-assert (not (=? default-comparator '#(#t #t) '#(#f #t))))
+          (test-assert (not (=? default-comparator '#(#t #t) '#(#t #f))))
+          (test-assert (<? default-comparator '#(#f #t) '#(#t #t)))
+          (test-assert (<? default-comparator '#(#t #f) '#(#t #t)))
+          (test-assert (not (<? default-comparator '#(#t #t) '#(#t #t))))
+          (test-assert (not (<? default-comparator '#(#t #t) '#(#f #t))))
+          (test-assert (not (<? default-comparator '#(#f #t) '#(#f #f))))
+
+          (test-assert (= (comparator-hash default-comparator #t) (boolean-hash #t)))
+          (test-assert (= (comparator-hash default-comparator #\t) (char-hash #\t)))
+          (test-assert (= (comparator-hash default-comparator "t") (string-hash "t")))
+          (test-assert (= (comparator-hash default-comparator 't) (symbol-hash 't)))
+          (test-assert (= (comparator-hash default-comparator 10) (number-hash 10)))
+          (test-assert (= (comparator-hash default-comparator 10.0) (number-hash 10.0)))
+
+          (comparator-register-default!
+           (make-comparator procedure? (lambda (a b) #t) (lambda (a b) #f) (lambda (obj) 200)))
+          (test-assert (=? default-comparator (lambda () #t) (lambda () #f)))
+          (test-assert (not (<? default-comparator (lambda () #t) (lambda () #f))))
+          ;;(test 200 (comparator-hash default-comparator (lambda () #t)))
+
+          )                              ; end comparators/default
+
+        ;; SRFI 128 does not actually require a comparator's four procedures
+        ;; to be eq? to the procedures originally passed to make-comparator.
+        ;; For interoperability/interchangeability between the comparators
+        ;; of SRFI 114 and SRFI 128, some of the procedures passed to
+        ;; make-comparator may need to be wrapped inside another lambda
+        ;; expression before they're returned by the corresponding accessor.
+        ;;
+        ;; So this next group of tests is incorrect, hence commented out
+        ;; and replaced by a slightly less naive group of tests.
+
+        #;
+        (test-group "comparators/accessors"
+        (define ttp (lambda (x) #t))
+        (define eqp (lambda (x y) #t))
+        (define orp (lambda (x y) #t))
+        (define hf (lambda (x) 0))
+        (define comp (make-comparator ttp eqp orp hf))
+        (test ttp (comparator-type-test-predicate comp))
+        (test eqp (comparator-equality-predicate comp))
+        (test orp (comparator-ordering-predicate comp))
+        (test hf (comparator-hash-function comp))
+        )                                ; end comparators/accessors
+
+        (test-group "comparators/accessors"
+          (define x1 0)
+          (define x2 0)
+          (define x3 0)
+          (define x4 0)
+          (define ttp (lambda (x) (set! x1 111) #t))
+          (define eqp (lambda (x y) (set! x2 222) #t))
+          (define orp (lambda (x y) (set! x3 333) #t))
+          (define hf (lambda (x) (set! x4 444) 0))
+          (define comp (make-comparator ttp eqp orp hf))
+          (test #t (and ((comparator-type-test-predicate comp) x1)   (= x1 111)))
+          (test #t (and ((comparator-equality-predicate comp) x1 x2) (= x2 222)))
+          (test #t (and ((comparator-ordering-predicate comp) x1 x3) (= x3 333)))
+          (test #t (and (zero? ((comparator-hash-function comp) x1)) (= x4 444)))
+          )                              ; end comparators/accessors
+
+        (test-group "comparators/invokers"
+          (test-assert (comparator-test-type real-comparator 3))
+          (test-assert (comparator-test-type real-comparator 3.0))
+          (test-assert (not (comparator-test-type real-comparator "3.0")))
+          (test-assert (comparator-check-type boolean-comparator #t))
+          (test-error (comparator-check-type boolean-comparator 't))
+          )                              ; end comparators/invokers
+
+        (test-group "comparators/comparison"
+          (test-assert (=? real-comparator 2 2.0 2))
+          (test-assert (<? real-comparator 2 3.0 4))
+          (test-assert (>? real-comparator 4.0 3.0 2))
+          (test-assert (<=? real-comparator 2.0 2 3.0))
+          (test-assert (>=? real-comparator 3 3.0 2))
+          (test-assert (not (=? real-comparator 1 2 3)))
+          (test-assert (not (<? real-comparator 3 1 2)))
+          (test-assert (not (>? real-comparator 1 2 3)))
+          (test-assert (not (<=? real-comparator 4 3 3)))
+          (test-assert (not (>=? real-comparator 3 4 4.0)))
+
+          )                              ; end comparators/comparison
+
+        (test-group "comparators/syntax"
+          (test 'less (comparator-if<=> real-comparator 1 2 'less 'equal 'greater))
+          (test 'equal (comparator-if<=> real-comparator 1 1 'less 'equal 'greater))
+          (test 'greater (comparator-if<=> real-comparator 2 1 'less 'equal 'greater))
+          (test 'less (comparator-if<=> "1" "2" 'less 'equal 'greater))
+          (test 'equal (comparator-if<=> "1" "1" 'less 'equal 'greater))
+          (test 'greater (comparator-if<=> "2" "1" 'less 'equal 'greater))
+
+          )                              ; end comparators/syntax
+
+        (test-group "comparators/bound-salt"
+          (test-assert (exact-integer? (hash-bound)))
+          (test-assert (exact-integer? (hash-salt)))
+          (test-assert (< (hash-salt) (hash-bound)))
+          #;  (test (hash-salt) (fake-salt-hash #t))  ; no such thing as fake-salt-hash
+          )                              ; end comparators/bound-salt
+
+        ))))                             ; end comparators

lib/srfi/95/qsort.c

@@ -22,6 +22,8 @@ namespace {
 
 #define swap(tmp_var, a, b) (tmp_var=a, a=b, b=tmp_var)
 
+#define COMPARE_DEPTH 5
+
 static sexp sexp_vector_copy_to_list (sexp ctx, sexp vec, sexp seq) {
   sexp_sint_t i;
   sexp ls, *data=sexp_vector_data(vec);
@@ -80,13 +82,16 @@ static int sexp_isymbol_compare (sexp ctx, sexp a, sexp b) {
 #define sexp_non_immediate_ordered_numberp(x) 0
 #endif
 
-static int sexp_object_compare (sexp ctx, sexp a, sexp b) {
+static int sexp_object_compare (sexp ctx, sexp a, sexp b, int depth) {
-  int res;
+  sexp ls1, ls2;
+  int i, res, len;
   if (a == b)
     return 0;
   if (sexp_pointerp(a)) {
     if (sexp_pointerp(b)) {
       if (sexp_pointer_tag(a) == sexp_pointer_tag(b)) {
+        if (depth <= 0)
+          return 0;
         switch (sexp_pointer_tag(a)) {
 #if SEXP_USE_FLONUMS
         case SEXP_FLONUM:
@@ -106,8 +111,8 @@ static int sexp_object_compare (sexp ctx, sexp a, sexp b) {
 #endif
 #if SEXP_USE_COMPLEX
         case SEXP_COMPLEX:
-          res = sexp_object_compare(ctx, sexp_complex_real(a), sexp_complex_real(b));
+          res = sexp_object_compare(ctx, sexp_complex_real(a), sexp_complex_real(b), depth-1);
-          if (res==0) res = sexp_object_compare(ctx, sexp_complex_imag(a), sexp_complex_imag(b));
+          if (res==0) res = sexp_object_compare(ctx, sexp_complex_imag(a), sexp_complex_imag(b), depth-1);
           break;
 #endif
         case SEXP_STRING:
@@ -116,12 +121,24 @@ static int sexp_object_compare (sexp ctx, sexp a, sexp b) {
         case SEXP_SYMBOL:
           res = strcmp(sexp_lsymbol_data(a), sexp_lsymbol_data(b));
           break;
-        /* TODO: consider recursively traversing containers.  requires */
+        case SEXP_PAIR:
-        /* cycle detection. */
+          for (res=0, ls1=a, ls2=sexp_cdr(a); res == 0 && ls1 != ls2 && sexp_pairp(ls1) && sexp_pairp(b) && sexp_pairp(b); ls1=sexp_cdr(ls1), ls2=((sexp_pairp(ls2)&&sexp_pairp(sexp_cdr(ls2)))?sexp_cdr(ls2):SEXP_NULL), b=sexp_cdr(b))
-        /* case SEXP_PAIR: */
+            res = sexp_object_compare(ctx, sexp_car(ls1), sexp_car(b), depth-1);
-        /*   res = sexp_object_compare(ctx, sexp_car(a), sexp_car(b)); */
+          if (sexp_pairp(ls2) && !sexp_pairp(b))
-        /*   if (res==0) res = sexp_object_compare(ctx, sexp_cdr(a), sexp_cdr(b)); */
+            res = 1;
-        /*   break; */
+          else if (sexp_pairp(b) && !sexp_pairp(ls2))
+            res = -1;
+          else if (ls1==SEXP_NULL && b==SEXP_NULL)
+            res = 0;
+          else if (res == 0)
+            res = sexp_object_compare(ctx, ls1, b, depth-1);
+          break;
+        case SEXP_VECTOR:
+          len = sexp_vector_length(a);
+          res = len - sexp_vector_length(b);
+          for (i=0; res == 0 && i < len; ++i)
+            res = sexp_object_compare(ctx, sexp_vector_ref(a, sexp_make_fixnum(i)), sexp_vector_ref(b, sexp_make_fixnum(i)), depth-1);
+          break;
         default:
           res = 0;
           break;
@@ -169,7 +186,7 @@ static int sexp_object_compare (sexp ctx, sexp a, sexp b) {
 }
 
 sexp sexp_object_compare_op (sexp ctx, sexp self, sexp_sint_t n, sexp a, sexp b) {
-  return sexp_make_fixnum(sexp_object_compare(ctx, a, b));
+  return sexp_make_fixnum(sexp_object_compare(ctx, a, b, COMPARE_DEPTH));
 }
 
 /* fast path when using general object-cmp comparator with no key */
@@ -182,14 +199,14 @@ static void sexp_merge_sort (sexp ctx, sexp *vec, sexp *scratch, sexp_sint_t lo,
     scratch[lo] = vec[lo];
     break;
   case 2:
-    if (sexp_object_compare(ctx, vec[hi], vec[hi-1]) < 0)
+    if (sexp_object_compare(ctx, vec[hi], vec[hi-1], COMPARE_DEPTH) < 0)
       swap(tmp, vec[hi], vec[hi-1]);
     /* ... FALLTHROUGH ... */
   case 1:
-    if (sexp_object_compare(ctx, vec[lo+1], vec[lo]) < 0) {
+    if (sexp_object_compare(ctx, vec[lo+1], vec[lo], COMPARE_DEPTH) < 0) {
       swap(tmp, vec[lo+1], vec[lo]);
       if (hi - lo > 1) {
-        if (sexp_object_compare(ctx, vec[lo+2], vec[lo+1]) < 0)
+        if (sexp_object_compare(ctx, vec[lo+2], vec[lo+1], COMPARE_DEPTH) < 0)
           swap(tmp, vec[lo+2], vec[lo+1]);
       }
     }
@@ -204,7 +221,7 @@ static void sexp_merge_sort (sexp ctx, sexp *vec, sexp *scratch, sexp_sint_t lo,
       } else if (j > hi) {
         scratch[k] = vec[i++];
       } else {
-        if (sexp_object_compare(ctx, vec[j], vec[i]) < 0) {
+        if (sexp_object_compare(ctx, vec[j], vec[i], COMPARE_DEPTH) < 0) {
           scratch[k] = vec[j++];
         } else {
           scratch[k] = vec[i++];