From 232fcdbbc034c00fbe5978abd5bd93a9630563c6 Mon Sep 17 00:00:00 2001 From: Chongkai Zhu Date: Sat, 12 Nov 2005 21:09:12 +0000 Subject: [PATCH] SRFI 69 hash table svn: r1299 --- collects/srfi/69.ss | 10 ++ collects/srfi/69/hash.ss | 227 +++++++++++++++++++++++++++++++++++++++ collects/srfi/doc.txt | 25 ++--- 3 files changed, 246 insertions(+), 16 deletions(-) create mode 100644 collects/srfi/69.ss create mode 100644 collects/srfi/69/hash.ss diff --git a/collects/srfi/69.ss b/collects/srfi/69.ss new file mode 100644 index 0000000000..7cd9cf07b2 --- /dev/null +++ b/collects/srfi/69.ss @@ -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))) diff --git a/collects/srfi/69/hash.ss b/collects/srfi/69/hash.ss new file mode 100644 index 0000000000..0d04ba4377 --- /dev/null +++ b/collects/srfi/69/hash.ss @@ -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)) '())) + + ) + \ No newline at end of file diff --git a/collects/srfi/doc.txt b/collects/srfi/doc.txt index 6c51c860f3..1aaebd1673 100644 --- a/collects/srfi/doc.txt +++ b/collects/srfi/doc.txt @@ -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: ,--------------------