suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

SRFI 69 hash table

Browse Source 
svn: r1299
This commit is contained in:
Chongkai Zhu 2005-11-12 21:09:12 +00:00
parent 010001efba
commit 232fcdbbc0
3 changed files with 246 additions and 16 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

10
collects/srfi/69.ss Normal file
View File

@ -0,0 +1,10 @@
;; module loader for SRFI-69
(module |69| mzscheme
(require (lib "hash.ss" "srfi" "69"))
(provide (all-from-except (lib "hash.ss" "srfi" "69")
s:make-hash-table
s:hash-table?
s:hash-table-copy)
(rename s:make-hash-table make-hash-table)
(rename s:hash-table? hash-table?)
(rename s:hash-table-copy hash-table-copy)))

227
collects/srfi/69/hash.ss Normal file
View File

@ -0,0 +1,227 @@
; SRFI 69
; Chongkai Zhu mrmathematica@yahoo.com
; 01-Nov-2005
(module hash mzscheme
(require (lib "etc.ss"))
(provide (rename my-make-hash-table s:make-hash-table)
(rename my-hash-table? s:hash-table?)
alist->hash-table
(rename my-hash-table-equivalence-function hash-table-equivalence-function)
(rename my-hash-table-hash-function hash-table-hash-function)
hash-table-ref
hash-table-ref/default
hash-table-set!
hash-table-delete!
hash-table-exists?
hash-table-update!
hash-table-update!/default
(rename my-hash-table-size hash-table-size)
hash-table-keys
hash-table-values
hash-table-walk
hash-table-fold
hash-table->alist
(rename my-hash-table-copy s:hash-table-copy)
hash-table-merge!
hash
string-hash
string-ci-hash
hash-by-identity)
(define hash
(case-lambda
((obj) (equal-hash-code obj))
((obj bound) (modulo (equal-hash-code obj) bound))))
(define (string-hash . args)
(unless (string? (car args))
(raise-type-error 'string-hash "string" 1 args))
(apply hash args))
(define (string-ci-hash s . maybe-bound)
(unless (string? s)
(raise-type-error 'string-hash "string" s))
(apply hash (string-downcase s) maybe-bound))
(define hash-by-identity
(case-lambda
((obj) (eq-hash-code obj))
((obj bound) (modulo (eq-hash-code obj) bound))))
(define-struct my-hash-table (size hash-function equivalence-function association-function entries))
(define *default-table-size* 64)
(define (appropriate-hash-function-for comparison)
(cond ((eq? comparison eq?) hash-by-identity)
((eq? comparison string=?) string-hash)
((eq? comparison string-ci=?) string-ci-hash)
(else hash)))
(define my-make-hash-table
(opt-lambda ([comparison equal?]
[hash (appropriate-hash-function-for comparison)]
[size *default-table-size*]
[association (cond ((eq? comparison eq?) assq)
((eq? comparison eqv?) assv)
((eq? comparison equal?) assoc)
(else (letrec ((associate
(lambda (val alist)
(cond ((null? alist) #f)
((comparison val (caar alist)) (car alist))
(else (associate val (cdr alist)))))))
associate)))])
(make-my-hash-table 0 hash comparison association (make-vector size '()))))
(define (%hash-table-hash hash-table key)
((my-hash-table-hash-function hash-table)
key (vector-length (my-hash-table-entries hash-table))))
(define (%hash-table-find entries associate hash key)
(associate key (vector-ref entries hash)))
(define (%hash-table-add! entries hash key value)
(vector-set! entries hash
(cons (cons key value)
(vector-ref entries hash))))
(define (%hash-table-delete! entries compare hash key)
(let ((entrylist (vector-ref entries hash)))
(cond ((null? entrylist) #f)
((compare key (caar entrylist))
(vector-set! entries hash (cdr entrylist)) #t)
(else
(let loop ((current (cdr entrylist)) (previous entrylist))
(cond ((null? current) #f)
((compare key (caar current))
(set-cdr! previous (cdr current)) #t)
(else (loop (cdr current) current))))))))
(define (%hash-table-walk proc entries)
(do ((index (- (vector-length entries) 1) (- index 1)))
((< index 0)) (for-each proc (vector-ref entries index))))
(define (%hash-table-maybe-resize! hash-table)
(let* ((old-entries (my-hash-table-entries hash-table))
(hash-length (vector-length old-entries)))
(if (> (my-hash-table-size hash-table) hash-length)
(let* ((new-length (* 2 hash-length))
(new-entries (make-vector new-length '()))
(hash (my-hash-table-hash-function hash-table)))
(%hash-table-walk
(lambda (node)
(%hash-table-add! new-entries
(hash (car node) new-length)
(car node) (cdr node)))
old-entries)
(set-my-hash-table-entries! hash-table new-entries)))))
(define (hash-table-ref hash-table key . maybe-default)
(cond ((%hash-table-find (my-hash-table-entries hash-table)
(my-hash-table-association-function hash-table)
(%hash-table-hash hash-table key) key)
=> cdr)
((null? maybe-default)
(raise-mismatch-error 'hash-table-ref "no value associated with " key))
(else ((car maybe-default)))))
(define-syntax hash-table-ref/default
(syntax-rules ()
((_ hash-table key default)
(hash-table-ref hash-table key (lambda () default)))))
(define (hash-table-set! hash-table key value)
(let ((hash (%hash-table-hash hash-table key))
(entries (my-hash-table-entries hash-table)))
(cond ((%hash-table-find entries
(my-hash-table-association-function hash-table)
hash key)
=> (lambda (node) (set-cdr! node value)))
(else (%hash-table-add! entries hash key value)
(set-my-hash-table-size! hash-table
(+ 1 (my-hash-table-size hash-table)))
(%hash-table-maybe-resize! hash-table)))))
(define (hash-table-update! hash-table key function . maybe-default)
(let ((hash (%hash-table-hash hash-table key))
(entries (my-hash-table-entries hash-table)))
(cond ((%hash-table-find entries
(my-hash-table-association-function hash-table)
hash key)
=> (lambda (node)
(set-cdr! node (function (cdr node)))))
((null? maybe-default)
(raise-mismatch-error 'hash-table-update "no value exists for key " key))
(else (%hash-table-add! entries hash key
(function ((car maybe-default))))
(set-my-hash-table-size! hash-table
(+ 1 (my-hash-table-size hash-table)))
(%hash-table-maybe-resize! hash-table)))))
(define-syntax hash-table-update!/default
(syntax-rules ()
((_ hash-table key function default)
(hash-table-update! hash-table key function (lambda () default)))))
(define (hash-table-delete! hash-table key)
(if (%hash-table-delete! (my-hash-table-entries hash-table)
(my-hash-table-equivalence-function hash-table)
(%hash-table-hash hash-table key) key)
(set-my-hash-table-size! hash-table (- (my-hash-table-size hash-table) 1))))
(define (hash-table-exists? hash-table key)
(and (%hash-table-find (my-hash-table-entries hash-table)
(my-hash-table-association-function hash-table)
(%hash-table-hash hash-table key) key) #t))
(define (hash-table-walk hash-table proc)
(%hash-table-walk
(lambda (node) (proc (car node) (cdr node)))
(my-hash-table-entries hash-table)))
(define (hash-table-fold hash-table f acc)
(hash-table-walk hash-table
(lambda (key value) (set! acc (f key value acc))))
acc)
(define alist->hash-table
(opt-lambda (alist
[comparison equal?]
[hash (appropriate-hash-function-for comparison)]
[size (max *default-table-size* (* 2 (length alist)))]
[hash-table (my-make-hash-table comparison hash size)])
(for-each (lambda (elem)
(hash-table-set! hash-table (car elem) (cdr elem)))
alist)
hash-table))
(define (hash-table->alist hash-table)
(hash-table-fold hash-table
(lambda (key val acc) (cons (cons key val) acc)) '()))
(define (my-hash-table-copy hash-table)
(let ((new (my-make-hash-table (my-hash-table-equivalence-function hash-table)
(my-hash-table-hash-function hash-table)
(max *default-table-size*
(* 2 (my-hash-table-size hash-table))))))
(hash-table-walk hash-table
(lambda (key value) (hash-table-set! new key value)))
new))
(define (hash-table-merge! hash-table1 hash-table2)
(hash-table-walk hash-table2
(lambda (key value)
(hash-table-set! hash-table1 key value)))
hash-table1)
(define (hash-table-keys hash-table)
(hash-table-fold hash-table (lambda (key val acc) (cons key acc)) '()))
(define (hash-table-values hash-table)
(hash-table-fold hash-table (lambda (key val acc) (cons val acc)) '()))
)

25
collects/srfi/doc.txt
View File

@ -11,8 +11,8 @@ If you need more information on SRFI, please visit:
Loading
-------
To load a SRFI with name conflicts (currently SRFI's 1, 19, 43 and 45)
in a module, please see the note below.
To load a SRFI with name conflicts (currently SRFIs 1, 19, 43, 45,
48 and 69) in a module, please see the note below.
To load a SRFI, use the following form:
@ -28,19 +28,19 @@ if you know the `informative name' of the SRFI.
N, is a number corresponding to the sub-collection that holds a
particular SRFI, and NAME is a more descriptive name we assigned to
the main file in which the SRFI is defined. For instance, to load
SRFI-13 you have to do either one of:
SRFI-34 you have to do either one of:
(require (lib "13.ss" "srfi"))
(require (lib "34.ss" "srfi"))
or,
(require (lib "string.ss" "srfi" "13"))
(require (lib "exception.ss" "srfi" "34"))
NOTE on SRFIs with name conflicts
---------------------------------
Certain SRFIs (currently SRFIs 1, 13, 19, 43, 45, and 48) provide names
which conflict with names provided by the 'mzscheme' language.
Certain SRFIs (currently SRFIs 1, 13, 19, 43, 45, 48 and 69) provide
names which conflict with names provided by the 'mzscheme' language.
Attempting to require one of these SRFIs in a module written in the
'mzscheme' language will result in an error.
@ -64,15 +64,6 @@ which supplies the colliding names with a prefix of 'srfi:'
(e.g. "srfi:date?", "srfi:date-second") and is therefore suitable for
requires in a module.
For SRFI 13, this library is called string.ss, and should be required
like this:
(require (lib "string.ss" "srfi" "13"))
which supplies the colliding names with a prefix of 's:'
(that is, s:string-upcase, s:string-downcase, and s:string-titlecase)
and is therefore suitable for requires in a module.
Supported SRFIs
---------------
@ -113,8 +104,10 @@ number of the already ported SRFIs:
SRFI-43 vector-lib.ss 43
SRFI-45(*3) lazy.ss 45
SRFI-48 format.ss 48
SRFI-57 records.ss 57
SRFI-59 vicinity.ss 59
SRFI-60 60.ss 60
SRFI-69 hash.ss 69
Notes:
,--------------------