mirror of
https://github.com/ashinn/chibi-scheme.git
synced 2025-05-19 21:59:17 +02:00
116 lines
4.2 KiB
Scheme
116 lines
4.2 KiB
Scheme
;; interface.scm -- hash-table interface
|
|
;; Copyright (c) 2009-2011 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
|
|
|
|
(define (make-hash-table . o)
|
|
(let* ((eq-fn (if (pair? o) (car o) equal?))
|
|
(hash-fn (if (and (pair? o) (pair? (cdr o)))
|
|
(car (cdr o))
|
|
(if (eq? eq? eq-fn) hash-by-identity hash))))
|
|
(cond
|
|
((not (procedure? eq-fn))
|
|
(error "make-hash-table: bad equivalence function" eq-fn))
|
|
((not (procedure? hash-fn))
|
|
(error "make-hash-table: bad hash function" hash-fn))
|
|
(else
|
|
(%make-hash-table
|
|
(make-vector 23 '())
|
|
0
|
|
(if (eq? hash-fn hash-by-identity) 1 (if (eq? hash-fn hash) 2 hash-fn))
|
|
(if (eq? eq-fn eq?) 1 (if (eq? eq-fn equal?) 2 eq-fn)))))))
|
|
|
|
(define (hash-table-hash-function table)
|
|
(let ((f (%hash-table-hash-function table)))
|
|
(case f ((1) hash-by-identity) ((2) hash) (else f))))
|
|
|
|
(define (hash-table-equivalence-function table)
|
|
(let ((f (%hash-table-equivalence-function table)))
|
|
(case f ((1) eq?) ((2) equal?) (else f))))
|
|
|
|
(define-syntax assert-hash-table
|
|
(syntax-rules ()
|
|
((assert-hash-table from obj)
|
|
(if (not (hash-table? obj))
|
|
(error (string-append from ": not a Hash-Table") obj)))))
|
|
|
|
(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))
|
|
((pair? o) ((car o)))
|
|
(else (error "hash-table-ref: key not found" key)))))
|
|
|
|
(define (hash-table-ref/default table key default)
|
|
(assert-hash-table "hash-table-ref/default" table)
|
|
(let ((cell (hash-table-cell table key #f)))
|
|
(if cell (cdr cell) default)))
|
|
|
|
(define (hash-table-set! table key value)
|
|
(assert-hash-table "hash-table-set!" table)
|
|
(let ((cell (hash-table-cell table key #t)))
|
|
(set-cdr! cell value)))
|
|
|
|
(define (hash-table-exists? table key)
|
|
(assert-hash-table "hash-table-exists?" table)
|
|
(and (hash-table-cell table key #f) #t))
|
|
|
|
(define hash-table-update!
|
|
(let ((not-found (cons 'not-found '())))
|
|
(lambda (table key func . o)
|
|
(assert-hash-table "hash-table-update!" table)
|
|
(let ((cell (hash-table-cell table key not-found)))
|
|
(set-cdr! cell (if (eq? not-found (cdr cell))
|
|
(if (pair? o)
|
|
(func ((car o)))
|
|
(error "hash-table-update!: key not found" key))
|
|
(func (cdr cell))))))))
|
|
|
|
(define hash-table-update!/default
|
|
(let ((not-found (cons 'not-found '())))
|
|
(lambda (table key func default)
|
|
(assert-hash-table "hash-table-update!/default" table)
|
|
(let ((cell (hash-table-cell table key not-found)))
|
|
(set-cdr! cell (func (if (eq? not-found (cdr cell)) default (cdr cell))))))))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(define (hash-table-fold table kons knil)
|
|
(assert-hash-table "hash-table-fold" table)
|
|
(let ((vec (hash-table-buckets table)))
|
|
(let lp1 ((i (- (vector-length vec) 1)) (acc knil))
|
|
(if (< i 0)
|
|
acc
|
|
(let lp2 ((ls (vector-ref vec i)) (acc acc))
|
|
(if (null? ls)
|
|
(lp1 (- i 1) acc)
|
|
(lp2 (cdr ls) (kons (car (car ls)) (cdr (car ls)) acc))))))))
|
|
|
|
(define (hash-table-walk table proc)
|
|
(hash-table-fold table (lambda (k v a) (proc k v)) #f)
|
|
(if #f #f))
|
|
|
|
(define (hash-table->alist table)
|
|
(hash-table-fold table (lambda (k v a) (cons (cons k v) a)) '()))
|
|
|
|
(define (hash-table-keys table)
|
|
(hash-table-fold table (lambda (k v a) (cons k a)) '()))
|
|
|
|
(define (hash-table-values table)
|
|
(hash-table-fold table (lambda (k v a) (cons v a)) '()))
|
|
|
|
(define (alist->hash-table ls . o)
|
|
(let ((res (apply make-hash-table o)))
|
|
(for-each (lambda (x) (hash-table-set! res (car x) (cdr x))) ls)
|
|
res))
|
|
|
|
(define (hash-table-merge! a b)
|
|
(hash-table-walk b (lambda (k v) (hash-table-set! a k v)))
|
|
a)
|
|
|
|
(define (hash-table-copy table)
|
|
(assert-hash-table "hash-table-copy" table)
|
|
(let ((res (make-hash-table (hash-table-equivalence-function table))))
|
|
(hash-table-merge! res table)
|
|
res))
|