mirror of
https://github.com/ashinn/chibi-scheme.git
synced 2025-05-19 05:39:18 +02:00
adding (srfi 128)
This commit is contained in:
Alex Shinn
parent
04ed6e1388
commit
6ed3bd4cc3
4 changed files with 569 additions and 15 deletions
27
lib/srfi/128.sld
Normal file
27
lib/srfi/128.sld
Normal file
|
|
@ -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"))
|
||||
229
lib/srfi/128/comparators.scm
Normal file
229
lib/srfi/128/comparators.scm
Normal file
|
|
@ -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)))
|
||||
281
lib/srfi/128/test.sld
Normal file
281
lib/srfi/128/test.sld
Normal file
|
|
@ -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
|
||||
|
|
@ -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) {
|
||||
int res;
|
||||
static int sexp_object_compare (sexp ctx, sexp a, sexp b, int depth) {
|
||||
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));
|
||||
if (res==0) res = sexp_object_compare(ctx, sexp_complex_imag(a), sexp_complex_imag(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), 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 */
|
||||
/* cycle detection. */
|
||||
/* case SEXP_PAIR: */
|
||||
/* res = sexp_object_compare(ctx, sexp_car(a), sexp_car(b)); */
|
||||
/* if (res==0) res = sexp_object_compare(ctx, sexp_cdr(a), sexp_cdr(b)); */
|
||||
/* break; */
|
||||
case SEXP_PAIR:
|
||||
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))
|
||||
res = sexp_object_compare(ctx, sexp_car(ls1), sexp_car(b), depth-1);
|
||||
if (sexp_pairp(ls2) && !sexp_pairp(b))
|
||||
res = 1;
|
||||
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++];
|
||||
|
|
|
|||
Loading…
Add table
Reference in a new issue