/usr/share/scheme48-1.9/r6rs/hashtable.scm is in scheme48 1.9-5.
This file is owned by root:root, with mode 0o644.
The actual contents of the file can be viewed below.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 | ; Part of Scheme 48 1.9. See file COPYING for notices and license.
; Authors: Harald Glab-Plhak, Marcus Crestani
;; R6RS hashtable functions:
;; default size of a hashtable
(define *hashtable-default-init-size* 20)
;; constructors
(define make-eq-hashtable
(opt-lambda ((size *hashtable-default-init-size*))
(make-eq-tlc-table size)))
(define make-eqv-hashtable
(opt-lambda ((size *hashtable-default-init-size*))
(make-eqv-tlc-table size)))
(define make-hashtable
(opt-lambda (hash-function equiv (size *hashtable-default-init-size*))
(make-non-default-tlc-table hash-function equiv size #f)))
;; predicate
(define (hashtable? hashtable)
(tlc-table? hashtable))
;; size
(define (hashtable-size hashtable)
(tlc-table-size hashtable))
;; getter
(define (hashtable-ref hashtable key default)
(tlc-table-ref hashtable key default))
;; setter
(define (hashtable-set! hashtable key obj)
(assert-key-equiv/hash-fun hashtable key)
(tlc-table-set! hashtable key obj))
;; delete
(define (hashtable-delete! hashtable key)
(tlc-table-delete! hashtable key #f))
;; contains
(define (hashtable-contains? hashtable key)
(tlc-table-contains? hashtable key))
;; update
(define (hashtable-update! hashtable key proc default)
(assert-key-equiv/hash-fun hashtable key)
(tlc-table-update! hashtable key proc default))
;; copy
(define hashtable-copy
(opt-lambda (hashtable (mutable? #f))
(tlc-table-copy hashtable mutable?)))
;; clear
(define hashtable-clear!
(opt-lambda (hashtable (k #f))
(tlc-table-clear! hashtable)
(if k
(tlc-table-resize! hashtable k))))
;; inspection
(define (hashtable-keys hashtable)
(tlc-table-keys hashtable))
(define (hashtable-entries hashtable)
(tlc-table-entries hashtable))
;; hash functions
(define (hashtable-equivalence-function hashtable)
(tlc-table-equivalence-function hashtable))
(define (hashtable-hash-function hashtable)
(tlc-table-hash-function hashtable))
(define (hashtable-mutable? hashtable)
(not (immutable? hashtable)))
;; check restrictions on hash-function and equiv
(define (key-equiv/hash-fun-checker hashtable key)
(let* ((equiv (hashtable-equivalence-function hashtable))
(hash-fun (hashtable-hash-function hashtable)))
(values (eq? (hash-fun key) (hash-fun ((lambda (e) e) key)))
(cond ((string? key) (equiv key ((lambda(k) k) key)))
((pair? key) (equiv key key))
((list? key) (equiv key key))
((symbol? key) (equiv 'test 'test))
((number? key) (equiv 8.8 8.8))
(else #t))
hash-fun equiv)))
;; assert restrictions
(define (assert-key-equiv/hash-fun hashtable key)
(call-with-values
(lambda () (key-equiv/hash-fun-checker hashtable key))
(lambda (valid-to-hashfun valid-to-equiv hash-fun equiv)
(if (not valid-to-hashfun)
(assertion-violation 'assert-key-equiv/hash-fun
"key does not work correctly with hash-fun"
key hash-fun))
(if (not valid-to-equiv)
(assertion-violation 'assert-key-equiv/hash-fun
"key does not work correctly with equiv"
key equiv)))))
|