mirror of
https://github.com/ashinn/chibi-scheme.git
synced 2025-05-18 21:29:19 +02:00
adding (srfi 125)
This commit is contained in:
Alex Shinn
parent
f37429d510
commit
37178eacd5
6 changed files with 921 additions and 5 deletions
|
|
@ -330,6 +330,14 @@ sexp sexp_immutablep_op (sexp ctx, sexp self, sexp_sint_t n, sexp x) {
|
|||
return sexp_pointerp(x) ? sexp_make_boolean(sexp_immutablep(x)) : SEXP_TRUE;
|
||||
}
|
||||
|
||||
sexp sexp_make_immutable_op (sexp ctx, sexp self, sexp_sint_t n, sexp x) {
|
||||
if (sexp_pointerp(x)) {
|
||||
sexp_immutablep(x) = 1;
|
||||
return SEXP_TRUE;
|
||||
}
|
||||
return SEXP_FALSE;
|
||||
}
|
||||
|
||||
sexp sexp_integer_to_immediate (sexp ctx, sexp self, sexp_sint_t n, sexp i, sexp dflt) {
|
||||
sexp x = (sexp)sexp_unbox_fixnum(i);
|
||||
sexp_assert_type(ctx, sexp_fixnump, SEXP_FIXNUM, i);
|
||||
|
|
@ -699,6 +707,7 @@ sexp sexp_init_library (sexp ctx, sexp self, sexp_sint_t n, sexp env, const char
|
|||
sexp_define_foreign(ctx, env, "core-code", 1, sexp_core_code_op);
|
||||
sexp_define_foreign(ctx, env, "object-size", 1, sexp_object_size);
|
||||
sexp_define_foreign(ctx, env, "immutable?", 1, sexp_immutablep_op);
|
||||
sexp_define_foreign(ctx, env, "make-immutable!", 1, sexp_make_immutable_op);
|
||||
sexp_define_foreign_opt(ctx, env, "integer->immediate", 2, sexp_integer_to_immediate, SEXP_FALSE);
|
||||
sexp_define_foreign_opt(ctx, env, "object->integer", 1, sexp_object_to_integer, SEXP_FALSE);
|
||||
sexp_define_foreign(ctx, env, "gc", 0, sexp_gc_op);
|
||||
|
|
|
|||
|
|
@ -39,7 +39,7 @@
|
|||
atomically thread-list abort
|
||||
string-contains string-cursor-copy! errno integer->error-string
|
||||
flatten-dot update-free-vars! setenv unsetenv safe-setenv
|
||||
immutable?)
|
||||
immutable? make-immutable!)
|
||||
(import (chibi))
|
||||
(include-shared "ast")
|
||||
(include "ast.scm"))
|
||||
|
|
|
|||
38
lib/srfi/125.sld
Normal file
38
lib/srfi/125.sld
Normal file
|
|
@ -0,0 +1,38 @@
|
|||
(define-library (srfi 125)
|
||||
(import (scheme base)
|
||||
(srfi 128)
|
||||
(rename (srfi 69)
|
||||
(make-hash-table %make-hash-table)
|
||||
(alist->hash-table %alist->hash-table)
|
||||
(hash-table-copy %hash-table-copy)
|
||||
(hash-table-set! %hash-table-set!)
|
||||
(hash-table-delete! %hash-table-delete!)
|
||||
(hash-table-fold %hash-table-fold))
|
||||
(only (chibi ast) immutable? make-immutable!))
|
||||
(export
|
||||
;; Constructors:
|
||||
make-hash-table hash-table hash-table-unfold alist->hash-table
|
||||
;; Predicates:
|
||||
hash-table? hash-table-contains? hash-table-exists?
|
||||
hash-table-empty? hash-table=? hash-table-mutable?
|
||||
;; Accessors:
|
||||
hash-table-ref hash-table-ref/default
|
||||
;; Mutators:
|
||||
hash-table-set! hash-table-delete! hash-table-intern!
|
||||
hash-table-update! hash-table-update!/default hash-table-pop!
|
||||
hash-table-clear!
|
||||
;; The whole hash table:
|
||||
hash-table-size hash-table-keys hash-table-values
|
||||
hash-table-entries hash-table-find hash-table-count
|
||||
;; Mapping and folding:
|
||||
hash-table-map hash-table-for-each hash-table-walk
|
||||
hash-table-map! hash-table-map->list hash-table-fold hash-table-prune!
|
||||
;; Copying and conversion:
|
||||
hash-table-copy hash-table-empty-copy hash-table->alist
|
||||
;; Hash tables as sets:
|
||||
hash-table-union! hash-table-merge!
|
||||
hash-table-intersection! hash-table-difference! hash-table-xor!
|
||||
;; Hash functions and reflectivity:
|
||||
hash string-hash string-ci-hash hash-by-identity
|
||||
hash-table-equivalence-function hash-table-hash-function)
|
||||
(include "125/hash.scm"))
|
||||
178
lib/srfi/125/hash.scm
Normal file
178
lib/srfi/125/hash.scm
Normal file
|
|
@ -0,0 +1,178 @@
|
|||
|
||||
(define (opt-hash eq-fn o)
|
||||
(if (pair? o)
|
||||
(car o)
|
||||
(if (eq? eq? eq-fn) hash-by-identity hash)))
|
||||
|
||||
(define (make-hash-table x . o)
|
||||
(if (comparator? x)
|
||||
(%make-hash-table (comparator-equality-predicate x)
|
||||
(comparator-hash-function x))
|
||||
(%make-hash-table x (opt-hash x o))))
|
||||
|
||||
(define (hash-table comparator . o)
|
||||
(let ((ht (make-hash-table comparator)))
|
||||
(let lp ((ls o))
|
||||
(when (pair? ls)
|
||||
(hash-table-set! ht (car ls) (cadr ls))
|
||||
(lp (cddr ls))))
|
||||
ht))
|
||||
|
||||
(define (hash-table-copy ht . o)
|
||||
(cond
|
||||
((and (pair? o) (car o))
|
||||
(%hash-table-copy ht))
|
||||
((hash-table-mutable? ht)
|
||||
(let ((res (%hash-table-copy ht)))
|
||||
(make-immutable! res)
|
||||
res))
|
||||
(else
|
||||
ht)))
|
||||
|
||||
(define (hash-table-set! ht . o)
|
||||
(let lp ((ls o))
|
||||
(when (pair? ls)
|
||||
(%hash-table-set! ht (car ls) (cadr ls))
|
||||
(lp (cddr ls)))))
|
||||
|
||||
(define (hash-table-fold a b c)
|
||||
(if (hash-table? a)
|
||||
(%hash-table-fold a b c)
|
||||
(%hash-table-fold c a b)))
|
||||
|
||||
(define (hash-table-unfold stop? mapper successor seed comparator . o)
|
||||
(let ((ht (make-hash-table comparator)))
|
||||
(let lp ((acc seed))
|
||||
(if (stop? acc)
|
||||
ht
|
||||
(call-with-values (lambda () (mapper acc))
|
||||
(lambda (key value)
|
||||
(hash-table-set! ht key value)
|
||||
(lp (successor acc))))))))
|
||||
|
||||
(define (alist->hash-table alist x . o)
|
||||
(if (comparator? x)
|
||||
(%alist->hash-table alist
|
||||
(comparator-equality-predicate x)
|
||||
(comparator-hash-function x))
|
||||
(%alist->hash-table alist x (opt-hash x o))))
|
||||
|
||||
(define hash-table-contains? hash-table-exists?)
|
||||
|
||||
(define (hash-table-empty? ht)
|
||||
(zero? (hash-table-size ht)))
|
||||
|
||||
(define (hash-table-mutable? ht)
|
||||
(not (immutable? ht)))
|
||||
|
||||
(define missing-key (list 'missing-key))
|
||||
|
||||
(define (hash-table=? value-cmp ht1 ht2)
|
||||
(and (= (hash-table-size ht1)
|
||||
(hash-table-size ht2))
|
||||
(let lp ((ls (hash-table-keys ht1)))
|
||||
(or (null? ls)
|
||||
(let ((v1 (hash-table-ref/default ht1 (car ls) missing-key))
|
||||
(v2 (hash-table-ref/default ht2 (car ls) missing-key)))
|
||||
(and (not (eq? missing-key v1))
|
||||
(not (eq? missing-key v2))
|
||||
((comparator-equality-predicate value-cmp) v1 v2)
|
||||
(lp (cdr ls))))))))
|
||||
|
||||
(define (hash-table-intern! ht key failure)
|
||||
(hash-table-ref ht key (lambda ()
|
||||
(let ((res (failure)))
|
||||
(hash-table-set! ht key res)
|
||||
res))))
|
||||
|
||||
(define (hash-table-delete! ht . keys)
|
||||
(for-each (lambda (key) (%hash-table-delete! ht key)) keys))
|
||||
|
||||
(define (hash-table-pop! ht)
|
||||
(let* ((key (car (hash-table-keys ht)))
|
||||
(value (hash-table-ref ht key)))
|
||||
(hash-table-delete! ht key)
|
||||
(values key value)))
|
||||
|
||||
(define (hash-table-clear! ht)
|
||||
(for-each
|
||||
(lambda (key) (hash-table-delete! ht key))
|
||||
(hash-table-keys ht)))
|
||||
|
||||
(define (hash-table-entries ht)
|
||||
(values (hash-table-keys ht) (hash-table-values ht)))
|
||||
|
||||
(define (hash-table-find proc ht failure)
|
||||
(call-with-current-continuation
|
||||
(lambda (return)
|
||||
(hash-table-for-each
|
||||
(lambda (key value)
|
||||
(let ((res (proc key value)))
|
||||
(if res (return res))))
|
||||
ht)
|
||||
(failure))))
|
||||
|
||||
(define (hash-table-count proc ht)
|
||||
(let ((count 0))
|
||||
(hash-table-for-each
|
||||
(lambda (key value)
|
||||
(if (proc key value)
|
||||
(set! count (+ count 1))))
|
||||
ht)
|
||||
count))
|
||||
|
||||
(define (hash-table-map proc cmp ht)
|
||||
(let ((ht2 (make-hash-table cmp)))
|
||||
(hash-table-for-each
|
||||
(lambda (key value) (hash-table-set! ht2 key (proc value)))
|
||||
ht)
|
||||
ht2))
|
||||
|
||||
(define (hash-table-map! proc ht)
|
||||
(for-each
|
||||
(lambda (key value) (hash-table-set! ht key (proc key value)))
|
||||
(hash-table-keys ht)
|
||||
(hash-table-values ht)))
|
||||
|
||||
(define (hash-table-for-each proc ht)
|
||||
(hash-table-walk ht proc))
|
||||
|
||||
(define (hash-table-map->list proc ht)
|
||||
(map (lambda (cell) (proc (car cell) (cdr cell))) (hash-table->alist ht)))
|
||||
|
||||
(define (hash-table-prune! proc ht)
|
||||
(for-each
|
||||
(lambda (key value)
|
||||
(if (proc key value)
|
||||
(hash-table-delete! ht key)))
|
||||
(hash-table-keys ht)
|
||||
(hash-table-values ht)))
|
||||
|
||||
(define (hash-table-empty-copy ht)
|
||||
(make-hash-table (hash-table-equivalence-function ht)
|
||||
(hash-table-hash-function ht)))
|
||||
|
||||
(define hash-table-union! hash-table-merge!)
|
||||
|
||||
(define (hash-table-intersection! ht1 ht2)
|
||||
(for-each
|
||||
(lambda (key)
|
||||
(if (not (hash-table-contains? ht2 key))
|
||||
(hash-table-delete! ht1 key)))
|
||||
(hash-table-keys ht1))
|
||||
ht1)
|
||||
|
||||
(define (hash-table-difference! ht1 ht2)
|
||||
(for-each
|
||||
(lambda (key)
|
||||
(if (hash-table-contains? ht2 key)
|
||||
(hash-table-delete! ht1 key)))
|
||||
(hash-table-keys ht1))
|
||||
ht1)
|
||||
|
||||
(define (hash-table-xor! ht1 ht2)
|
||||
(let* ((tmp (hash-table-copy ht1 #t))
|
||||
(intersection (hash-table-intersection! tmp ht2)))
|
||||
(hash-table-difference! (hash-table-union! ht1 ht2)
|
||||
intersection)
|
||||
ht1))
|
||||
685
lib/srfi/125/test.sld
Normal file
685
lib/srfi/125/test.sld
Normal file
|
|
@ -0,0 +1,685 @@
|
|||
(define-library (srfi 125 test)
|
||||
(export run-tests)
|
||||
(import (scheme base) (scheme char) (scheme write)
|
||||
(srfi 125) (srfi 128) (srfi 132)
|
||||
(chibi test))
|
||||
(begin
|
||||
(define (run-tests)
|
||||
(define default-comparator (make-default-comparator))
|
||||
(define number-comparator
|
||||
(make-comparator real? = < (lambda (x . o) (exact (abs (round x))))))
|
||||
(define string-comparator
|
||||
(make-comparator string? string=? string<? string-hash))
|
||||
(define string-ci-comparator
|
||||
(make-comparator string? string-ci=? string-ci<? string-ci-hash))
|
||||
(define eq-comparator (make-eq-comparator))
|
||||
(define eqv-comparator (make-eqv-comparator))
|
||||
(define ht-default (make-hash-table default-comparator))
|
||||
(define ht-eq (make-hash-table eq-comparator 'random-argument "another"))
|
||||
(define ht-eqv (make-hash-table eqv-comparator))
|
||||
(define ht-eq2 (make-hash-table eq?))
|
||||
(define ht-eqv2 (make-hash-table eqv?))
|
||||
(define ht-equal (make-hash-table equal?))
|
||||
(define ht-string (make-hash-table string=?))
|
||||
(define ht-string-ci (make-hash-table string-ci=?))
|
||||
(define ht-symbol (make-hash-table symbol=?)) ; FIXME: glass-box
|
||||
(define ht-fixnum (make-hash-table = (lambda (x . o) (abs x))))
|
||||
(define ht-default2
|
||||
(hash-table default-comparator 'foo 'bar 101.3 "fever" '(x y z) '#()))
|
||||
(define ht-fixnum2
|
||||
(let ((ht (make-hash-table number-comparator)))
|
||||
(do ((i 0 (+ i 1)))
|
||||
((= i 10) (hash-table-copy ht))
|
||||
(hash-table-set! ht (* i i) i))))
|
||||
(define ht-string2
|
||||
(hash-table-unfold (lambda (s) (= 0 (string-length s)))
|
||||
(lambda (s) (values s (string-length s)))
|
||||
(lambda (s) (substring s 0 (- (string-length s) 1)))
|
||||
"prefixes"
|
||||
string-comparator
|
||||
'ignored1 'ignored2 "ignored3" '#(ignored 4 5)))
|
||||
(define ht-string-ci2
|
||||
(alist->hash-table '(("" . 0) ("Mary" . 4) ("Paul" . 4) ("Peter" . 5))
|
||||
string-ci-comparator
|
||||
"ignored1" 'ignored2))
|
||||
(define ht-symbol2
|
||||
(alist->hash-table '((mary . travers) (noel . stookey) (peter .yarrow))
|
||||
eq?))
|
||||
(define ht-equal2
|
||||
(alist->hash-table '(((edward) . abbey)
|
||||
((dashiell) . hammett)
|
||||
((edward) . teach)
|
||||
((mark) . twain))
|
||||
equal?
|
||||
(comparator-hash-function default-comparator)))
|
||||
(define test-tables
|
||||
(list ht-default ht-default2 ; initial keys: foo, 101.3, (x y z)
|
||||
ht-eq ht-eq2 ; initially empty
|
||||
ht-eqv ht-eqv2 ; initially empty
|
||||
ht-equal ht-equal2 ; initial keys: (edward), (dashiell), (mark)
|
||||
ht-string ht-string2 ; initial keys: "p, "pr", ..., "prefixes"
|
||||
ht-string-ci ht-string-ci2 ; initial keys: "", "Mary", "Paul", "Peter"
|
||||
ht-symbol ht-symbol2 ; initial keys: mary, noel, peter
|
||||
ht-fixnum ht-fixnum2)) ; initial keys: 0, 1, 4, 9, ..., 81
|
||||
|
||||
(test-begin "srfi 125: intermediate hash tables")
|
||||
|
||||
;; Predicates
|
||||
|
||||
(test (append '(#f #f) (map (lambda (x) #t) test-tables))
|
||||
(map hash-table?
|
||||
(cons '#()
|
||||
(cons default-comparator
|
||||
test-tables))))
|
||||
|
||||
(test '(#f #t #f #f #f #f #f #t #f #t #f #t #f #t #f #t)
|
||||
(map hash-table-contains?
|
||||
test-tables
|
||||
'(foo 101.3
|
||||
x "y"
|
||||
(14 15) #\newline
|
||||
(edward) (mark)
|
||||
"p" "pref"
|
||||
"mike" "PAUL"
|
||||
jane noel
|
||||
0 4)))
|
||||
|
||||
(test (map (lambda (x) #f) test-tables)
|
||||
(map hash-table-contains?
|
||||
test-tables
|
||||
'(#u8() 47.9
|
||||
'#() '()
|
||||
foo bar
|
||||
19 (henry)
|
||||
"p" "perp"
|
||||
"mike" "Noel"
|
||||
jane paul
|
||||
0 5)))
|
||||
|
||||
(test '(#t #f #t #t #t #t #t #f #t #f #t #f #t #f #t #f)
|
||||
(map hash-table-empty? test-tables))
|
||||
|
||||
;; (test (map (lambda (x) #t) test-tables)
|
||||
;; (map (lambda (ht1 ht2) (hash-table=? default-comparator ht1 ht2))
|
||||
;; test-tables
|
||||
;; test-tables))
|
||||
|
||||
;; (test '(#f #f #t #t #t #t #f #f #f #f #f #f #f #f #f #f)
|
||||
;; (map (lambda (ht1 ht2) (hash-table=? default-comparator ht1 ht2))
|
||||
;; test-tables
|
||||
;; (do ((tables (reverse test-tables) (cddr tables))
|
||||
;; (rev '() (cons (car tables) (cons (cadr tables) rev))))
|
||||
;; ((null? tables)
|
||||
;; rev))))
|
||||
|
||||
(test '(#t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #f)
|
||||
(map hash-table-mutable? test-tables))
|
||||
|
||||
;; FIXME: glass-box
|
||||
;; (test (map hash-table-mutable? (map hash-table-copy test-tables))
|
||||
;; (map (lambda (x) #f) test-tables))
|
||||
|
||||
(test #t
|
||||
(hash-table-mutable? (hash-table-copy ht-fixnum2 #t)))
|
||||
|
||||
;; Accessors.
|
||||
|
||||
;; FIXME: glass-box (implementations not required to raise an exception here)
|
||||
;; (test (map (lambda (ht)
|
||||
;; (guard (exn
|
||||
;; (else 'err))
|
||||
;; (hash-table-ref ht 'not-a-key)))
|
||||
;; test-tables)
|
||||
;; (map (lambda (ht) 'err) test-tables))
|
||||
|
||||
;; FIXME: glass-box (implementations not required to raise an exception here)
|
||||
;; (test (map (lambda (ht)
|
||||
;; (guard (exn
|
||||
;; (else 'err))
|
||||
;; (hash-table-ref ht 'not-a-key (lambda () 'err))))
|
||||
;; test-tables)
|
||||
;; (map (lambda (ht) 'err) test-tables))
|
||||
|
||||
;; FIXME: glass-box (implementations not required to raise an exception here)
|
||||
;; (test (map (lambda (ht)
|
||||
;; (guard (exn
|
||||
;; (else 'err))
|
||||
;; (hash-table-ref ht 'not-a-key (lambda () 'err) values)))
|
||||
;; test-tables)
|
||||
;; (map (lambda (ht) 'err) test-tables))
|
||||
|
||||
(test '(err "fever" err err err err err twain err 4 err 4 err stookey err 2)
|
||||
(map (lambda (ht key)
|
||||
(guard (exn
|
||||
(else 'err))
|
||||
(hash-table-ref ht key)))
|
||||
test-tables
|
||||
'(foo 101.3
|
||||
x "y"
|
||||
(14 15) #\newline
|
||||
(edward) (mark)
|
||||
"p" "pref"
|
||||
"mike" "PAUL"
|
||||
jane noel
|
||||
0 4)))
|
||||
|
||||
(test '(eh "fever" eh eh eh eh eh twain eh 4 eh 4 eh stookey eh 2)
|
||||
(map (lambda (ht key)
|
||||
(guard (exn
|
||||
(else 'err))
|
||||
(hash-table-ref ht key (lambda () 'eh))))
|
||||
test-tables
|
||||
'(foo 101.3
|
||||
x "y"
|
||||
(14 15) #\newline
|
||||
(edward) (mark)
|
||||
"p" "pref"
|
||||
"mike" "PAUL"
|
||||
jane noel
|
||||
0 4)))
|
||||
|
||||
(test '(eh ("fever") eh eh eh eh eh (twain) eh (4) eh (4) eh (stookey) eh (2))
|
||||
(map (lambda (ht key)
|
||||
(guard (exn
|
||||
(else 'err))
|
||||
(hash-table-ref ht key (lambda () 'eh) list)))
|
||||
test-tables
|
||||
'(foo 101.3
|
||||
x "y"
|
||||
(14 15) #\newline
|
||||
(edward) (mark)
|
||||
"p" "pref"
|
||||
"mike" "PAUL"
|
||||
jane noel
|
||||
0 4)))
|
||||
|
||||
;; FIXME: glass-box (implementations not required to raise an exception here)
|
||||
;; (test (map (lambda (ht)
|
||||
;; (guard (exn
|
||||
;; (else 'eh))
|
||||
;; (hash-table-ref/default ht 'not-a-key 'eh)))
|
||||
;; test-tables)
|
||||
;; (map (lambda (ht) 'eh) test-tables))
|
||||
|
||||
(test '(eh "fever" eh eh eh eh eh twain eh 4 eh 4 eh stookey eh 2)
|
||||
(map (lambda (ht key)
|
||||
(guard (exn
|
||||
(else 'err))
|
||||
(hash-table-ref/default ht key 'eh)))
|
||||
test-tables
|
||||
'(foo 101.3
|
||||
x "y"
|
||||
(14 15) #\newline
|
||||
(edward) (mark)
|
||||
"p" "pref"
|
||||
"mike" "PAUL"
|
||||
jane noel
|
||||
0 4)))
|
||||
|
||||
(test '()
|
||||
(begin (hash-table-set! ht-fixnum)
|
||||
(list-sort < (hash-table-keys ht-fixnum))))
|
||||
|
||||
(test '(121 144 169)
|
||||
(begin (hash-table-set! ht-fixnum 121 11 144 12 169 13)
|
||||
(list-sort < (hash-table-keys ht-fixnum))))
|
||||
|
||||
(test '(0 1 4 9 16 25 36 49 64 81 121 144 169)
|
||||
(begin (hash-table-set! ht-fixnum
|
||||
0 0 1 1 4 2 9 3 16 4 25 5 36 6 49 7 64 8 81 9)
|
||||
(list-sort < (hash-table-keys ht-fixnum))))
|
||||
|
||||
(test '(13 12 11 0 1 2 3 4 5 6 7 8 9)
|
||||
(map (lambda (i) (hash-table-ref/default ht-fixnum i 'error))
|
||||
'(169 144 121 0 1 4 9 16 25 36 49 64 81)))
|
||||
|
||||
(test '(13 12 11 0 1 2 3 4 5 6 7 8 9)
|
||||
(begin (hash-table-delete! ht-fixnum)
|
||||
(map (lambda (i) (hash-table-ref/default ht-fixnum i 'error))
|
||||
'(169 144 121 0 1 4 9 16 25 36 49 64 81))))
|
||||
|
||||
(test '(-1 12 -1 0 -1 2 -1 4 -1 6 -1 8 -1)
|
||||
(begin (hash-table-delete! ht-fixnum 1 9 25 49 81 200 121 169 81 1)
|
||||
(map (lambda (i) (hash-table-ref/default ht-fixnum i -1))
|
||||
'(169 144 121 0 1 4 9 16 25 36 49 64 81))))
|
||||
|
||||
(test '(-1 12 -1 -1 -1 2 -1 4 -1 -1 -1 8 -1)
|
||||
(begin (hash-table-delete! ht-fixnum 200 100 0 81 36)
|
||||
(map (lambda (i) (hash-table-ref/default ht-fixnum i -1))
|
||||
'(169 144 121 0 1 4 9 16 25 36 49 64 81))))
|
||||
|
||||
(test '(13 12 11 0 1 2 -1 4 -1 -1 -1 8 -1)
|
||||
(begin (hash-table-intern! ht-fixnum 169 (lambda () 13))
|
||||
(hash-table-intern! ht-fixnum 121 (lambda () 11))
|
||||
(hash-table-intern! ht-fixnum 0 (lambda () 0))
|
||||
(hash-table-intern! ht-fixnum 1 (lambda () 1))
|
||||
(hash-table-intern! ht-fixnum 1 (lambda () 99))
|
||||
(hash-table-intern! ht-fixnum 121 (lambda () 66))
|
||||
(map (lambda (i) (hash-table-ref/default ht-fixnum i -1))
|
||||
'(169 144 121 0 1 4 9 16 25 36 49 64 81))))
|
||||
|
||||
(test '(#(0 0) #(1 1) #(4 2) #(16 4) #(64 8) #(121 11) #(144 12) #(169 13))
|
||||
(list-sort (lambda (v1 v2) (< (vector-ref v1 0) (vector-ref v2 0)))
|
||||
(hash-table-map->list vector ht-fixnum)))
|
||||
|
||||
(test (begin (hash-table-intern! ht-fixnum 169 (lambda () 13))
|
||||
(hash-table-intern! ht-fixnum 144 (lambda () 9999))
|
||||
(hash-table-intern! ht-fixnum 121 (lambda () 11))
|
||||
(list-sort (lambda (l1 l2)
|
||||
(< (car l1) (car l2)))
|
||||
(hash-table-map->list list ht-fixnum)))
|
||||
'((0 0) (1 1) (4 2) (16 4) (64 8) (121 11) (144 12) (169 13)))
|
||||
|
||||
(test (begin (hash-table-update! ht-fixnum 9 length (lambda () '(a b c)))
|
||||
(map (lambda (i) (hash-table-ref/default ht-fixnum i -1))
|
||||
'(169 144 121 0 1 4 9 16 25 36 49 64 81)))
|
||||
'(13 12 11 0 1 2 3 4 -1 -1 -1 8 -1))
|
||||
|
||||
(test (begin (hash-table-update! ht-fixnum 16 -)
|
||||
(map (lambda (i) (hash-table-ref/default ht-fixnum i -1))
|
||||
'(169 144 121 0 1 4 9 16 25 36 49 64 81)))
|
||||
'(13 12 11 0 1 2 3 -4 -1 -1 -1 8 -1))
|
||||
|
||||
(test (begin (hash-table-update! ht-fixnum 16 - abs)
|
||||
(map (lambda (i) (hash-table-ref/default ht-fixnum i -1))
|
||||
'(169 144 121 0 1 4 9 16 25 36 49 64 81)))
|
||||
'(13 12 11 0 1 2 3 4 -1 -1 -1 8 -1))
|
||||
|
||||
(test (begin (hash-table-update!/default ht-fixnum 25 - 5)
|
||||
(map (lambda (i) (hash-table-ref/default ht-fixnum i -1))
|
||||
'(169 144 121 0 1 4 9 16 25 36 49 64 81)))
|
||||
'(13 12 11 0 1 2 3 4 -5 -1 -1 8 -1))
|
||||
|
||||
(test (begin (hash-table-update!/default ht-fixnum 25 - 999)
|
||||
(map (lambda (i) (hash-table-ref/default ht-fixnum i -1))
|
||||
'(169 144 121 0 1 4 9 16 25 36 49 64 81)))
|
||||
'(13 12 11 0 1 2 3 4 5 -1 -1 8 -1))
|
||||
|
||||
(test '(#t #t)
|
||||
(let* ((n0 (hash-table-size ht-fixnum))
|
||||
(ht (hash-table-copy ht-fixnum #t)))
|
||||
(call-with-values
|
||||
(lambda () (hash-table-pop! ht))
|
||||
(lambda (key val)
|
||||
(list (= key (* val val))
|
||||
(= (- n0 1) (hash-table-size ht)))))))
|
||||
|
||||
(test '(13 12 11 0 1 2 3 4 5 -1 -1 8 -1 -1)
|
||||
(begin (hash-table-delete! ht-fixnum 75)
|
||||
(map (lambda (i) (hash-table-ref/default ht-fixnum i -1))
|
||||
'(169 144 121 0 1 4 9 16 25 36 49 64 75 81))))
|
||||
|
||||
(test '(13 12 11 0 1 2 3 4 5 -1 -1 8 -1)
|
||||
(map (lambda (i) (hash-table-ref/default ht-fixnum i -1))
|
||||
'(169 144 121 0 1 4 9 16 25 36 49 64 81)))
|
||||
|
||||
(test '(13 12 11 0 1 2 3 4 5 6 -1 8 9)
|
||||
(begin (hash-table-set! ht-fixnum 36 6)
|
||||
(hash-table-set! ht-fixnum 81 9)
|
||||
(map (lambda (i) (hash-table-ref/default ht-fixnum i -1))
|
||||
'(169 144 121 0 1 4 9 16 25 36 49 64 81))))
|
||||
|
||||
(test 0
|
||||
(begin (hash-table-clear! ht-eq)
|
||||
(hash-table-size ht-eq)))
|
||||
|
||||
;; The whole hash table.
|
||||
|
||||
(test 3
|
||||
(begin (hash-table-set! ht-eq 'foo 13 'bar 14 'baz 18)
|
||||
(hash-table-size ht-eq)))
|
||||
|
||||
(test '(0 3 #t)
|
||||
(let* ((ht (hash-table-empty-copy ht-eq))
|
||||
(n0 (hash-table-size ht))
|
||||
(ignored (hash-table-set! ht 'foo 13 'bar 14 'baz 18))
|
||||
(n1 (hash-table-size ht)))
|
||||
(list n0 n1 (hash-table=? default-comparator ht ht-eq))))
|
||||
|
||||
(test 0
|
||||
(begin (hash-table-clear! ht-eq)
|
||||
(hash-table-size ht-eq)))
|
||||
|
||||
(test '(144 12)
|
||||
(hash-table-find (lambda (key val)
|
||||
(if (= 144 key (* val val))
|
||||
(list key val)
|
||||
#f))
|
||||
ht-fixnum
|
||||
(lambda () 99)))
|
||||
|
||||
(test 99
|
||||
(hash-table-find (lambda (key val)
|
||||
(if (= 144 key val)
|
||||
(list key val)
|
||||
#f))
|
||||
ht-fixnum
|
||||
(lambda () 99)))
|
||||
|
||||
(test 2
|
||||
(hash-table-count <= ht-fixnum))
|
||||
|
||||
;; Mapping and folding.
|
||||
|
||||
(test '(0 1 2 3 4 5 6 -1 8 9 -1 11 12 13 -1)
|
||||
(map (lambda (i) (hash-table-ref/default ht-fixnum i -1))
|
||||
'(0 1 4 9 16 25 36 49 64 81 100 121 144 169 196)))
|
||||
|
||||
(test '(0 1 4 9 16 25 36 -1 64 81 -1 121 144 169 -1)
|
||||
(let ((ht (hash-table-map (lambda (val) (* val val))
|
||||
eqv-comparator
|
||||
ht-fixnum)))
|
||||
(map (lambda (i) (hash-table-ref/default ht i -1))
|
||||
'(0 1 4 9 16 25 36 49 64 81 100 121 144 169 196))))
|
||||
|
||||
(test '(#(0 1 4 9 16 25 36 -1 64 81 -1 121 144 169 -1)
|
||||
#(0 1 2 3 4 5 6 -1 8 9 -1 11 12 13 -1))
|
||||
(let ((keys (make-vector 15 -1))
|
||||
(vals (make-vector 15 -1)))
|
||||
(hash-table-for-each (lambda (key val)
|
||||
(vector-set! keys val key)
|
||||
(vector-set! vals val val))
|
||||
ht-fixnum)
|
||||
(list keys vals)))
|
||||
|
||||
(test '(0 1 2 3 -4 -5 -6 -1 -8 -9 -1 -11 -12 -13 -1)
|
||||
(begin (hash-table-map! (lambda (key val)
|
||||
(if (<= 10 key)
|
||||
(- val)
|
||||
val))
|
||||
ht-fixnum)
|
||||
(map (lambda (i) (hash-table-ref/default ht-fixnum i -1))
|
||||
'(0 1 4 9 16 25 36 49 64 81 100 121 144 169 196))))
|
||||
|
||||
(test 13
|
||||
(hash-table-fold (lambda (key val acc)
|
||||
(+ val acc))
|
||||
0
|
||||
ht-string-ci2))
|
||||
|
||||
(test '(0 1 4 9 16 25 36 64 81 121 144 169)
|
||||
(list-sort < (hash-table-fold (lambda (key val acc)
|
||||
(cons key acc))
|
||||
'()
|
||||
ht-fixnum)))
|
||||
|
||||
;; Copying and conversion.
|
||||
|
||||
(test #t
|
||||
(hash-table=? number-comparator ht-fixnum (hash-table-copy ht-fixnum)))
|
||||
|
||||
(test #t
|
||||
(hash-table=? number-comparator ht-fixnum (hash-table-copy ht-fixnum #f)))
|
||||
|
||||
(test #t
|
||||
(hash-table=? number-comparator ht-fixnum (hash-table-copy ht-fixnum #t)))
|
||||
|
||||
(test #f
|
||||
(hash-table-mutable? (hash-table-copy ht-fixnum)))
|
||||
|
||||
(test #f
|
||||
(hash-table-mutable? (hash-table-copy ht-fixnum #f)))
|
||||
|
||||
(test #t
|
||||
(hash-table-mutable? (hash-table-copy ht-fixnum #t)))
|
||||
|
||||
(test '()
|
||||
(hash-table->alist ht-eq))
|
||||
|
||||
(test '((0 . 0)
|
||||
(1 . 1)
|
||||
(4 . 2)
|
||||
(9 . 3)
|
||||
(16 . -4)
|
||||
(25 . -5)
|
||||
(36 . -6)
|
||||
(64 . -8)
|
||||
(81 . -9)
|
||||
(121 . -11)
|
||||
(144 . -12)
|
||||
(169 . -13))
|
||||
(list-sort (lambda (x y) (< (car x) (car y)))
|
||||
(hash-table->alist ht-fixnum)))
|
||||
|
||||
;; Hash tables as sets.
|
||||
|
||||
(test '((0 . 0)
|
||||
(1 . 1)
|
||||
(4 . 2)
|
||||
(9 . 3)
|
||||
(16 . -4)
|
||||
(25 . -5)
|
||||
(36 . -6)
|
||||
(49 . 7)
|
||||
(64 . -8)
|
||||
(81 . -9)
|
||||
(121 . -11)
|
||||
(144 . -12)
|
||||
(169 . -13))
|
||||
(begin (hash-table-union! ht-fixnum ht-fixnum2)
|
||||
(list-sort (lambda (x y) (< (car x) (car y)))
|
||||
(hash-table->alist ht-fixnum))))
|
||||
|
||||
(test '((0 . 0)
|
||||
(1 . 1)
|
||||
(4 . 2)
|
||||
(9 . 3)
|
||||
(16 . 4)
|
||||
(25 . 5)
|
||||
(36 . 6)
|
||||
(49 . 7)
|
||||
(64 . 8)
|
||||
(81 . 9)
|
||||
(121 . -11)
|
||||
(144 . -12)
|
||||
(169 . -13))
|
||||
(let ((ht (hash-table-copy ht-fixnum2 #t)))
|
||||
(hash-table-union! ht ht-fixnum)
|
||||
(list-sort (lambda (x y) (< (car x) (car y)))
|
||||
(hash-table->alist ht))))
|
||||
|
||||
(test #t
|
||||
(begin (hash-table-union! ht-eqv2 ht-fixnum)
|
||||
(hash-table=? default-comparator ht-eqv2 ht-fixnum)))
|
||||
|
||||
(test #t
|
||||
(begin (hash-table-intersection! ht-eqv2 ht-fixnum)
|
||||
(hash-table=? default-comparator ht-eqv2 ht-fixnum)))
|
||||
|
||||
(test #t
|
||||
(begin (hash-table-intersection! ht-eqv2 ht-eqv)
|
||||
(hash-table-empty? ht-eqv2)))
|
||||
|
||||
(test '((0 . 0)
|
||||
(1 . 1)
|
||||
(4 . 2)
|
||||
(9 . 3)
|
||||
(16 . -4)
|
||||
(25 . -5)
|
||||
(36 . -6)
|
||||
(49 . 7)
|
||||
(64 . -8)
|
||||
(81 . -9))
|
||||
(begin (hash-table-intersection! ht-fixnum ht-fixnum2)
|
||||
(list-sort (lambda (x y) (< (car x) (car y)))
|
||||
(hash-table->alist ht-fixnum))))
|
||||
|
||||
(test '((4 . 2)
|
||||
(25 . -5))
|
||||
(begin (hash-table-intersection!
|
||||
ht-fixnum
|
||||
(alist->hash-table '((-1 . -1) (4 . 202) (25 . 205) (100 . 10))
|
||||
number-comparator))
|
||||
(list-sort (lambda (x y) (< (car x) (car y)))
|
||||
(hash-table->alist ht-fixnum))))
|
||||
|
||||
(test '((0 . 0)
|
||||
(1 . 1)
|
||||
(9 . 3)
|
||||
(16 . 4)
|
||||
(36 . 6)
|
||||
(49 . 7)
|
||||
(64 . 8)
|
||||
(81 . 9))
|
||||
(let ((ht (hash-table-copy ht-fixnum2 #t)))
|
||||
(hash-table-difference!
|
||||
ht
|
||||
(alist->hash-table '((-1 . -1) (4 . 202) (25 . 205) (100 . 10))
|
||||
number-comparator))
|
||||
(list-sort (lambda (x y) (< (car x) (car y)))
|
||||
(hash-table->alist ht))))
|
||||
|
||||
(test '((-1 . -1)
|
||||
(0 . 0)
|
||||
(1 . 1)
|
||||
(9 . 3)
|
||||
(16 . 4)
|
||||
(36 . 6)
|
||||
(49 . 7)
|
||||
(64 . 8)
|
||||
(81 . 9)
|
||||
(100 . 10))
|
||||
(let ((ht (hash-table-copy ht-fixnum2 #t)))
|
||||
(hash-table-xor!
|
||||
ht
|
||||
(alist->hash-table '((-1 . -1) (4 . 202) (25 . 205) (100 . 10))
|
||||
number-comparator))
|
||||
(list-sort (lambda (x y) (< (car x) (car y)))
|
||||
(hash-table->alist ht))))
|
||||
|
||||
(test 'key-not-found
|
||||
(guard (exn
|
||||
(else 'key-not-found))
|
||||
(hash-table-ref ht-default "this key won't be present")))
|
||||
|
||||
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;;
|
||||
;; Desultory tests of deprecated procedures and usages.
|
||||
;; Deprecated usage of make-hash-table and alist->hash-table
|
||||
;; has already been tested above.
|
||||
;;
|
||||
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(test '(#t #t #t)
|
||||
(let* ((x (list 1 2 3))
|
||||
(y (cons 1 (cdr x)))
|
||||
(h1 (hash x))
|
||||
(h2 (hash y)))
|
||||
(list (exact-integer? h1)
|
||||
(exact-integer? h2)
|
||||
(= h1 h2))))
|
||||
|
||||
(test '(#t #t #t)
|
||||
(let* ((x "abcd")
|
||||
(y (string-append "ab" "cd"))
|
||||
(h1 (string-hash x))
|
||||
(h2 (string-hash y)))
|
||||
(list (exact-integer? h1)
|
||||
(exact-integer? h2)
|
||||
(= h1 h2))))
|
||||
|
||||
(test '(#t #t #t)
|
||||
(let* ((x "Hello There!")
|
||||
(y "hello THERE!")
|
||||
(h1 (string-ci-hash x))
|
||||
(h2 (string-ci-hash y)))
|
||||
(list (exact-integer? h1)
|
||||
(exact-integer? h2)
|
||||
(= h1 h2))))
|
||||
|
||||
(test '(#t #t #t)
|
||||
(let* ((x '#(a "bcD" #\c (d 2.718) -42 #u8() #() #u8(19 20)))
|
||||
(y x)
|
||||
(h1 (hash-by-identity x))
|
||||
(h2 (hash-by-identity y)))
|
||||
(list (exact-integer? h1)
|
||||
(exact-integer? h2)
|
||||
(= h1 h2))))
|
||||
|
||||
(test '(#t #t #t)
|
||||
(let* ((x (list 1 2 3))
|
||||
(y (cons 1 (cdr x)))
|
||||
(h1 (hash x 60))
|
||||
(h2 (hash y 60)))
|
||||
(list (exact-integer? h1)
|
||||
(exact-integer? h2)
|
||||
(= h1 h2))))
|
||||
|
||||
(test '(#t #t #t)
|
||||
(let* ((x "abcd")
|
||||
(y (string-append "ab" "cd"))
|
||||
(h1 (string-hash x 97))
|
||||
(h2 (string-hash y 97)))
|
||||
(list (exact-integer? h1)
|
||||
(exact-integer? h2)
|
||||
(= h1 h2))))
|
||||
|
||||
(test '(#t #t #t)
|
||||
(let* ((x "Hello There!")
|
||||
(y "hello THERE!")
|
||||
(h1 (string-ci-hash x 101))
|
||||
(h2 (string-ci-hash y 101)))
|
||||
(list (exact-integer? h1)
|
||||
(exact-integer? h2)
|
||||
(= h1 h2))))
|
||||
|
||||
(test '(#t #t #t)
|
||||
(let* ((x '#(a "bcD" #\c (d 2.718) -42 #u8() #() #u8(19 20)))
|
||||
(y x)
|
||||
(h1 (hash-by-identity x 102))
|
||||
(h2 (hash-by-identity y 102)))
|
||||
(list (exact-integer? h1)
|
||||
(exact-integer? h2)
|
||||
(= h1 h2))))
|
||||
|
||||
(test #t
|
||||
(let ((f (hash-table-equivalence-function ht-fixnum)))
|
||||
(if (procedure? f)
|
||||
(f 34 34)
|
||||
#t)))
|
||||
|
||||
(test #t
|
||||
(let ((f (hash-table-hash-function ht-fixnum)))
|
||||
(if (procedure? f)
|
||||
(= (f 34) (f 34))
|
||||
#t)))
|
||||
|
||||
(test '(#t #t #f #f #t #f #f #f #f #t #f)
|
||||
(map (lambda (key) (hash-table-exists? ht-fixnum2 key))
|
||||
'(0 1 2 3 4 5 6 7 8 9 10)))
|
||||
|
||||
(test (apply +
|
||||
(map (lambda (x) (* x x))
|
||||
'(0 1 2 3 4 5 6 7 8 9)))
|
||||
(let ((n 0))
|
||||
(hash-table-walk ht-fixnum2
|
||||
(lambda (key val) (set! n (+ n key))))
|
||||
n))
|
||||
|
||||
(test '(0 1 4 9 16 25 36 49 64 81)
|
||||
(list-sort < (hash-table-fold ht-fixnum2
|
||||
(lambda (key val acc)
|
||||
(cons key acc))
|
||||
'())))
|
||||
|
||||
(test '((0 . 0)
|
||||
(.25 . .5)
|
||||
(1 . 1)
|
||||
(4 . 2)
|
||||
(9 . 3)
|
||||
(16 . 4)
|
||||
(25 . 5)
|
||||
(36 . 6)
|
||||
(49 . 7)
|
||||
(64 . 8)
|
||||
(81 . 9)
|
||||
(121 . -11)
|
||||
(144 . -12))
|
||||
(let ((ht (hash-table-copy ht-fixnum2 #t))
|
||||
(ht2 (hash-table number-comparator
|
||||
.25 .5 64 9999 81 9998 121 -11 144 -12)))
|
||||
(hash-table-merge! ht ht2)
|
||||
(list-sort (lambda (x y) (< (car x) (car y)))
|
||||
(hash-table->alist ht))))
|
||||
|
||||
(test-end))))
|
||||
|
|
@ -1,5 +1,5 @@
|
|||
;; interface.scm -- hash-table interface
|
||||
;; Copyright (c) 2009-2011 Alex Shinn. All rights reserved.
|
||||
;; Copyright (c) 2009-2017 Alex Shinn. All rights reserved.
|
||||
;; BSD-style license: http://synthcode.com/license.txt
|
||||
|
||||
;; the non-exported hash-table-cell is the heart of the implemenation
|
||||
|
|
@ -38,7 +38,9 @@
|
|||
(define (hash-table-ref table key . o)
|
||||
(assert-hash-table "hash-table-ref" table)
|
||||
(let ((cell (hash-table-cell table key #f)))
|
||||
(cond (cell (cdr cell))
|
||||
(cond (cell (if (and (pair? o) (pair? (cdr o)))
|
||||
((cadr o) (cdr cell))
|
||||
(cdr cell)))
|
||||
((pair? o) ((car o)))
|
||||
(else (error "hash-table-ref: key not found" key)))))
|
||||
|
||||
|
|
@ -65,7 +67,9 @@
|
|||
(if (pair? o)
|
||||
(func ((car o)))
|
||||
(error "hash-table-update!: key not found" key))
|
||||
(func (cdr cell))))))))
|
||||
(func (if (and (pair? o) (pair? (cdr o)))
|
||||
((cadr o) (cdr cell))
|
||||
(cdr cell)))))))))
|
||||
|
||||
(define hash-table-update!/default
|
||||
(let ((not-found (cons 'not-found '())))
|
||||
|
|
@ -106,7 +110,9 @@
|
|||
res))
|
||||
|
||||
(define (hash-table-merge! a b)
|
||||
(hash-table-walk b (lambda (k v) (hash-table-set! a k v)))
|
||||
(hash-table-walk b (lambda (k v)
|
||||
(if (not (hash-table-exists? a k))
|
||||
(hash-table-set! a k v))))
|
||||
a)
|
||||
|
||||
(define (hash-table-copy table)
|
||||
|
|
|
|||
Loading…
Add table
Reference in a new issue