Add immutable-hashtable for R6RS
This commit is contained in:
parent
5793281d41
commit
2f1981e068
|
|
@ -0,0 +1,173 @@
|
|||
(library (lassik immutable-hashtable)
|
||||
(export make-eq-hashtable
|
||||
make-eqv-hashtable
|
||||
make-hashtable
|
||||
|
||||
hashtable-contains?
|
||||
hashtable-entries
|
||||
hashtable-equivalence-function
|
||||
hashtable-hash-function
|
||||
hashtable-keys
|
||||
hashtable-mutable?
|
||||
hashtable-ref
|
||||
hashtable-size
|
||||
hashtable?
|
||||
immutable-hashtable?
|
||||
|
||||
equal-hash
|
||||
string-ci-hash
|
||||
string-hash
|
||||
symbol-hash
|
||||
|
||||
hashtable-delete
|
||||
hashtable-set
|
||||
hashtable-update)
|
||||
(import (rnrs base)
|
||||
(rename (except (rnrs hashtables)
|
||||
make-hashtable
|
||||
make-eq-hashtable
|
||||
make-eqv-hashtable)
|
||||
(hashtable?
|
||||
rnrs-hashtable?)
|
||||
(hashtable-mutable?
|
||||
rnrs-hashtable-mutable?)
|
||||
(hashtable-size
|
||||
rnrs-hashtable-size)
|
||||
(hashtable-contains?
|
||||
rnrs-hashtable-contains?)
|
||||
(hashtable-entries
|
||||
rnrs-hashtable-entries)
|
||||
(hashtable-equivalence-function
|
||||
rnrs-hashtable-equivalence-function)
|
||||
(hashtable-hash-function
|
||||
rnrs-hashtable-hash-function)
|
||||
(hashtable-keys
|
||||
rnrs-hashtable-keys)
|
||||
(hashtable-ref
|
||||
rnrs-hashtable-ref)))
|
||||
(begin
|
||||
|
||||
;; From SRFI 1.
|
||||
(define (append-reverse list1 list2)
|
||||
(append (reverse list1) list2))
|
||||
|
||||
;; From R7RS.
|
||||
(define (assoc key alist equivalent?)
|
||||
(cond ((null? alist) #f)
|
||||
((equivalent? key (caar alist)) (car alist))
|
||||
(else (assoc key (cdr alist) equivalent?))))
|
||||
|
||||
;;
|
||||
|
||||
(define (immutable-hashtable? obj)
|
||||
(and (vector? obj) (eq? 'immutable-hashtable (vector-ref obj 0))))
|
||||
|
||||
(define (hashtable? obj)
|
||||
(or (rnrs-hashtable? obj)
|
||||
(immutable-hashtable? obj)))
|
||||
|
||||
(define (hashtable-mutable? table)
|
||||
(if (rnrs-hashtable? table)
|
||||
(rnrs-hashtable-mutable? table)
|
||||
#f))
|
||||
|
||||
;;
|
||||
|
||||
(define (make-hashtable* hash equivalent? alist)
|
||||
(vector 'immutable-hashtable hash equivalent? alist))
|
||||
|
||||
(define (make-hashtable hash equivalent?)
|
||||
(make-hashtable* hash equivalent? '()))
|
||||
|
||||
(define (make-eq-hashtable)
|
||||
(make-hashtable #f eq?))
|
||||
|
||||
(define (make-eqv-hashtable)
|
||||
(make-hashtable #f eqv?))
|
||||
|
||||
;;
|
||||
|
||||
(define (hashtable-hash-function table)
|
||||
(if (rnrs-hashtable? table)
|
||||
(rnrs-hashtable-hash-function table)
|
||||
(vector-ref table 1)))
|
||||
|
||||
(define (hashtable-equivalence-function table)
|
||||
(if (rnrs-hashtable? table)
|
||||
(rnrs-hashtable-equivalence-function table)
|
||||
(vector-ref table 2)))
|
||||
|
||||
(define (hashtable-alist table)
|
||||
(vector-ref table 3))
|
||||
|
||||
(define (hashtable-assoc table key)
|
||||
(assoc key
|
||||
(hashtable-alist table)
|
||||
(hashtable-equivalence-function table)))
|
||||
|
||||
;;
|
||||
|
||||
(define (hashtable-contains? table key)
|
||||
(if (rnrs-hashtable? table)
|
||||
(rnrs-hashtable-contains? table key)
|
||||
(not (not (hashtable-assoc table key)))))
|
||||
|
||||
(define (hashtable-keys table)
|
||||
(if (rnrs-hashtable? table)
|
||||
(rnrs-hashtable-keys table)
|
||||
(list->vector (map car (hashtable-alist table)))))
|
||||
|
||||
(define (hashtable-entries table)
|
||||
(if (rnrs-hashtable? table)
|
||||
(rnrs-hashtable-entries table)
|
||||
(values (list->vector (map car (hashtable-alist table)))
|
||||
(list->vector (map cdr (hashtable-alist table))))))
|
||||
|
||||
(define (hashtable-ref table key default)
|
||||
(if (rnrs-hashtable? table)
|
||||
(rnrs-hashtable-ref table key default)
|
||||
(let ((entry (hashtable-assoc table key)))
|
||||
(if entry (cdr entry) default))))
|
||||
|
||||
(define (hashtable-size table)
|
||||
(if (rnrs-hashtable? table)
|
||||
(rnrs-hashtable-size table)
|
||||
(length (hashtable-alist table))))
|
||||
|
||||
;;
|
||||
|
||||
(define (hashtable-delete table key)
|
||||
(let ((equivalent? (hashtable-equivalence-function table)))
|
||||
(make-hashtable*
|
||||
(hashtable-hash-function table)
|
||||
equivalent?
|
||||
(let loop ((old-alist (hashtable-alist table))
|
||||
(new-alist '()))
|
||||
(if (null? old-alist) (reverse new-alist)
|
||||
(loop (cdr old-alist)
|
||||
(if (equivalent? key (caar old-alist))
|
||||
new-alist
|
||||
(cons (car old-alist) new-alist))))))))
|
||||
|
||||
(define (hashtable-update table key update default)
|
||||
(let ((equivalent? (hashtable-equivalence-function table)))
|
||||
(make-hashtable*
|
||||
(hashtable-hash-function table)
|
||||
equivalent?
|
||||
(let loop ((old-alist (hashtable-alist table))
|
||||
(new-alist '()))
|
||||
(cond ((null? old-alist)
|
||||
(reverse (cons (cons key (update default))
|
||||
new-alist)))
|
||||
((equivalent? key (caar old-alist))
|
||||
(append-reverse (cons (cons (caar old-alist)
|
||||
(update (cdar old-alist)))
|
||||
new-alist)
|
||||
(cdr old-alist)))
|
||||
(else
|
||||
(loop (cdr old-alist)
|
||||
(cons (car old-alist)
|
||||
new-alist))))))))
|
||||
|
||||
(define (hashtable-set table key value)
|
||||
(hashtable-update table key (lambda (_) value) #f))))
|
||||
Loading…
Reference in New Issue