Add immutable-hashtable for R6RS

This commit is contained in:
Lassi Kortela 2021-08-17 14:38:51 +03:00
parent 5793281d41
commit 2f1981e068
1 changed files with 173 additions and 0 deletions

173
immutable-hashtable.sls Normal file
View File

@ -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))))