new hash function names and ops (3.99.0.23)

svn: r9209

original commit: 021d4d7527f39cc01b6b8952f4a90e61e55e8956

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)]

collects/mzlib/for.ss

@@ -18,10 +18,10 @@
            in-bytes
            in-input-port-bytes
            in-input-port-chars
-           in-hash-table
+           (rename-out [in-hash in-hash-table]
-           in-hash-table-keys
+                       [in-hash-keys in-hash-table-keys]
-           in-hash-table-values
+                       [in-hash-values in-hash-table-values]
-           in-hash-table-pairs
+                       [in-hash-pairs in-hash-table-pairs])
            
            in-parallel
            stop-before

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 

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

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)))))))]))))

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)

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)))])))

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)
+     (make-same-test (make-hasheq)
-                     '(hash-table))
+                     '(hasheq))
-     (make-same-test (make-hash-table 'weak)
+     (make-same-test (make-weak-hasheq)
-                     '(hash-table 'weak))
+                     '(weak-hasheq))
-     (make-same-test (make-hash-table 'equal)
+     (make-same-test (make-hash)
-                     '(hash-table 'equal))
+                     '(hash))
-     (make-same-test (make-hash-table 'equal 'weak)
+     (make-same-test (make-weak-hash)
-                     '(hash-table 'equal 'weak))
+                     '(weak-hash))
-     (make-same-test (let ([ht (make-hash-table)])
+     (make-same-test (let ([ht (make-hash)])
-                       (hash-table-put! ht 'x 1)
+                       (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)