From 6b6ae47140647b9c33dbd7082c075d42759c2164 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 8 Apr 2008 21:42:38 +0000 Subject: [PATCH] new hash function names and ops (3.99.0.23) svn: r9209 original commit: 021d4d7527f39cc01b6b8952f4a90e61e55e8956 --- collects/mzlib/cm.ss | 8 ++-- collects/mzlib/for.ss | 8 ++-- collects/mzlib/foreign.ss | 16 +++---- .../mzlib/private/contract-arr-obj-helpers.ss | 6 +-- collects/mzlib/private/contract-object.ss | 2 +- collects/net/dns-unit.ss | 6 +-- collects/scheme/private/old-procs.ss | 48 ++++++++++++++++++- collects/tests/mzscheme/pconvert.ss | 24 +++++----- 8 files changed, 81 insertions(+), 37 deletions(-) diff --git a/collects/mzlib/cm.ss b/collects/mzlib/cm.ss index bc8030e..7566306 100644 --- a/collects/mzlib/cm.ss +++ b/collects/mzlib/cm.ss @@ -217,7 +217,7 @@ (define (compile-root mode path up-to-date read-src-syntax) (let ([path (simplify-path (cleanse-path path))]) (let ((stamp (and up-to-date - (hash-table-get up-to-date path #f)))) + (hash-ref up-to-date path #f)))) (cond (stamp stamp) (else @@ -272,21 +272,21 @@ (cdr deps))) (compile-zo mode path read-src-syntax)))))) (let ((stamp (get-compiled-time mode path #t))) - (hash-table-put! up-to-date path stamp) + (hash-set! up-to-date path stamp) stamp))))))))) (define (managed-compile-zo zo [read-src-syntax read-syntax]) ((make-caching-managed-compile-zo read-src-syntax) zo)) (define (make-caching-managed-compile-zo [read-src-syntax read-syntax]) - (let ([cache (make-hash-table 'equal)]) + (let ([cache (make-hash)]) (lambda (zo) (parameterize ([current-load/use-compiled (make-compilation-manager-load/use-compiled-handler/table cache)]) (compile-root (car (use-compiled-file-paths)) (path->complete-path zo) cache read-src-syntax) (void))))) (define (make-compilation-manager-load/use-compiled-handler) - (make-compilation-manager-load/use-compiled-handler/table (make-hash-table 'equal))) + (make-compilation-manager-load/use-compiled-handler/table (make-hash))) (define (make-compilation-manager-load/use-compiled-handler/table cache) (let ([orig-eval (current-eval)] diff --git a/collects/mzlib/for.ss b/collects/mzlib/for.ss index ecf229a..a44225d 100644 --- a/collects/mzlib/for.ss +++ b/collects/mzlib/for.ss @@ -18,10 +18,10 @@ in-bytes in-input-port-bytes in-input-port-chars - in-hash-table - in-hash-table-keys - in-hash-table-values - in-hash-table-pairs + (rename-out [in-hash in-hash-table] + [in-hash-keys in-hash-table-keys] + [in-hash-values in-hash-table-values] + [in-hash-pairs in-hash-table-pairs]) in-parallel stop-before diff --git a/collects/mzlib/foreign.ss b/collects/mzlib/foreign.ss index b4efa6b..6750ab5 100644 --- a/collects/mzlib/foreign.ss +++ b/collects/mzlib/foreign.ss @@ -200,7 +200,7 @@ (ptr-ref ffi-obj type)) (define (ffi-set! ffi-obj type new) (let-values ([(new type) (get-lowlevel-object new type)]) - (hash-table-put! ffi-objects-ref-table ffi-obj new) + (hash-set! ffi-objects-ref-table ffi-obj new) (ptr-set! ffi-obj type new))) ;; This is better handled with `make-c-parameter' @@ -282,7 +282,7 @@ ;; This table keeps references to values that are set in foreign libraries, to ;; avoid them being GCed. See set-ffi-obj! above. -(define ffi-objects-ref-table (make-hash-table)) +(define ffi-objects-ref-table (make-hasheq)) ;; ---------------------------------------------------------------------------- ;; Compile-time support for fun-expanders @@ -709,14 +709,14 @@ ;; `string/eof' type: converts an output #f (NULL) to an eof-object. (define string-type->string/eof-type - (let ([table (make-hash-table)]) + (let ([table (make-hasheq)]) (lambda (string-type) - (hash-table-get table string-type + (hash-ref table string-type (lambda () (let ([new-type (make-ctype string-type (lambda (x) (and (not (eof-object? x)) x)) (lambda (x) (or x eof)))]) - (hash-table-put! table string-type new-type) + (hash-set! table string-type new-type) new-type)))))) (provide _string/eof _bytes/eof) (define _bytes/eof @@ -1457,12 +1457,12 @@ ;; helper for the above: keep runtime information on structs (define cstruct-info - (let ([table (make-hash-table 'weak)]) + (let ([table (make-weak-hasheq)]) (lambda (cstruct msg/fail-thunk . args) (cond [(eq? 'set! msg/fail-thunk) - (hash-table-put! table cstruct (make-ephemeron cstruct args))] + (hash-set! table cstruct (make-ephemeron cstruct args))] [(and cstruct ; might get a #f if there were no slots - (hash-table-get table cstruct (lambda () #f))) + (hash-ref table cstruct (lambda () #f))) => (lambda (xs) (let ([v (ephemeron-value xs)]) (if v diff --git a/collects/mzlib/private/contract-arr-obj-helpers.ss b/collects/mzlib/private/contract-arr-obj-helpers.ss index 74576c6..175fc9f 100644 --- a/collects/mzlib/private/contract-arr-obj-helpers.ss +++ b/collects/mzlib/private/contract-arr-obj-helpers.ss @@ -271,15 +271,15 @@ ;; ensure-no-duplicates : syntax (listof syntax[identifier]) -> void (define (ensure-no-duplicates stx form-name names) - (let ([ht (make-hash-table)]) + (let ([ht (make-hasheq)]) (for-each (lambda (name) (let ([key (syntax-e name)]) - (when (hash-table-get ht key (lambda () #f)) + (when (hash-ref ht key (lambda () #f)) (raise-syntax-error form-name "duplicate method name" stx name)) - (hash-table-put! ht key #t))) + (hash-set! ht key #t))) names))) ;; method-specifier? : syntax -> boolean diff --git a/collects/mzlib/private/contract-object.ss b/collects/mzlib/private/contract-object.ss index 8d48438..fee9323 100644 --- a/collects/mzlib/private/contract-object.ss +++ b/collects/mzlib/private/contract-object.ss @@ -367,7 +367,7 @@ [method-ht (extract-method-ht val)]) (make-object cls val - (method/app-var (vector-ref vtable (hash-table-get method-ht 'method-name))) ... + (method/app-var (vector-ref vtable (hash-ref method-ht 'method-name))) ... (field/app-var (get-field field-name val)) ... )))))) #f)))))))])))) diff --git a/collects/net/dns-unit.ss b/collects/net/dns-unit.ss index 667c56f..ab7536d 100644 --- a/collects/net/dns-unit.ss +++ b/collects/net/dns-unit.ss @@ -211,14 +211,14 @@ (values (positive? (bitwise-and #x4 v0)) qds ans nss ars reply))))))) - (define cache (make-hash-table)) + (define cache (make-hasheq)) (define (dns-query/cache nameserver addr type class) (let ([key (string->symbol (format "~a;~a;~a;~a" nameserver addr type class))]) - (let ([v (hash-table-get cache key (lambda () #f))]) + (let ([v (hash-ref cache key (lambda () #f))]) (if v (apply values v) (let-values ([(auth? qds ans nss ars reply) (dns-query nameserver addr type class)]) - (hash-table-put! cache key (list auth? qds ans nss ars reply)) + (hash-set! cache key (list auth? qds ans nss ars reply)) (values auth? qds ans nss ars reply)))))) (define (ip->string s) diff --git a/collects/scheme/private/old-procs.ss b/collects/scheme/private/old-procs.ss index 03db7ad..94aa5d1 100644 --- a/collects/scheme/private/old-procs.ss +++ b/collects/scheme/private/old-procs.ss @@ -10,7 +10,10 @@ free-identifier=?* namespace-transformer-require transcript-on - transcript-off) + transcript-off + make-hash-table + make-immutable-hash-table + hash-table?) (define reflect-var #f) @@ -40,4 +43,45 @@ (define (transcript-on filename) (error 'transcript-on "unsupported")) (define (transcript-off) - (error 'transcript-off "unsupported"))) + (error 'transcript-off "unsupported")) + + (define make-hash-table + (case-lambda + [() (make-hasheq)] + [(a) (if (eq? a 'equal) + (make-hash) + (if (eq? a 'weak) + (make-weak-hasheq) + (raise-mismatch-error "make-hash-table: bad argument: " a)))] + [(a b) (if (or (and (eq? a 'equal) + (eq? b 'weak)) + (and (eq? a 'weak) + (eq? b 'equal))) + (make-weak-hash) + (raise-mismatch-error "make-hash-table: bad arguments: " (list a b)))])) + + (define make-immutable-hash-table + (case-lambda + [(l) (make-immutable-hasheq l)] + [(l a) (if (eq? a 'equal) + (make-immutable-hash l) + (raise-mismatch-error "make-immutable-hash-table: bad argument: " a))])) + + (define hash-table? + (case-lambda + [(v) (hash? v)] + [(v a) (if (eq? a 'equal) + (and (hash? v) + (not (hash-eq? v))) + (if (eq? a 'weak) + (and (hash? v) + (hash-weak? v)) + (raise-mismatch-error "hash-table?: bad argument: " a)))] + [(v a b) (if (or (and (eq? a 'equal) + (eq? b 'weak)) + (and (eq? a 'weak) + (eq? b 'equal))) + (and (hash? v) + (not (hash-eq? v)) + (hash-weak? v)) + (raise-mismatch-error "hash-table?: bad arguments: " (list a b)))]))) diff --git a/collects/tests/mzscheme/pconvert.ss b/collects/tests/mzscheme/pconvert.ss index 9c0b718..f447419 100644 --- a/collects/tests/mzscheme/pconvert.ss +++ b/collects/tests/mzscheme/pconvert.ss @@ -200,18 +200,18 @@ '(case-lambda [() ...] [args ...])) (make-same-test (case-lambda [() 'a] [(x y z) 'a] [x 'a]) '(case-lambda [() ...] [(a1 a2 a3) ...] [args ...])) - (make-same-test (make-hash-table) - '(hash-table)) - (make-same-test (make-hash-table 'weak) - '(hash-table 'weak)) - (make-same-test (make-hash-table 'equal) - '(hash-table 'equal)) - (make-same-test (make-hash-table 'equal 'weak) - '(hash-table 'equal 'weak)) - (make-same-test (let ([ht (make-hash-table)]) - (hash-table-put! ht 'x 1) + (make-same-test (make-hasheq) + '(hasheq)) + (make-same-test (make-weak-hasheq) + '(weak-hasheq)) + (make-same-test (make-hash) + '(hash)) + (make-same-test (make-weak-hash) + '(weak-hash)) + (make-same-test (let ([ht (make-hash)]) + (hash-set! ht 'x 1) ht) - '(hash-table ('x 1))) + '(hash ('x 1))) (make-pctest (list 'a (box (list '())) (cons 1 '())) '(list (quote a) (box (list empty)) (list 1)) '(list (quote a) (box (list empty)) (list 1)) @@ -354,7 +354,7 @@ (test-shared (vector 1 2 3) '(vector 1 2 3)) (let () (define-struct a () #:inspector (make-inspector)) (test-shared (make-a) '(make-a))) (test-shared (box 1) '(box 1)) - (test-shared (make-hash-table) '(hash-table))) + (test-shared (make-hash) '(hash))) (arity-test print-convert 1 2) (arity-test build-share 1 1)