From 8d66b76a32561d34e06bd0c72396b8a0918bb598 Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Sun, 22 Apr 2018 23:34:31 -0700 Subject: [PATCH] Standardize hash tables on SRFI-69 names and deprecate others. Change make-hash-table to be smarter about choosing the appropriate hash function for a given equality predicate. Also work around name collisions in rtlopt/rcse*.scm, and tweak the hash-table implementation to favor SRFI-69. Some work remains: the code around building hash-table types needs to be re-thought: it's a little clunky and could usefully take advantage of keyword arguments. (These keyword arguments should also be supported by make-hash-table.) The hash function should be optional and use the equality-predicate default. The older %make-hash-table should be renamed and exported as it's the right interface when using types. --- src/compiler/back/symtab.scm | 8 +- src/compiler/back/syntax.scm | 4 +- src/compiler/base/infnew.scm | 9 +- src/compiler/machines/C/decls.scm | 4 +- src/compiler/machines/C/stackify.scm | 4 +- src/compiler/machines/i386/decls.scm | 4 +- src/compiler/machines/i386/lapopt.scm | 9 +- .../machines/svm/assembler-runtime.scm | 22 +- src/compiler/machines/svm/decls.scm | 4 +- src/compiler/machines/x86-64/decls.scm | 4 +- src/compiler/machines/x86-64/lapopt.scm | 9 +- src/compiler/rtlbase/rtlcon.scm | 6 +- src/compiler/rtlbase/rtlobj.scm | 8 +- src/compiler/rtlgen/opncod.scm | 8 +- src/compiler/rtlopt/rcse1.scm | 19 +- src/compiler/rtlopt/rcse2.scm | 32 +-- src/compiler/rtlopt/rcseht.scm | 32 +-- src/compiler/rtlopt/rerite.scm | 22 +- src/edwin/abbrev.scm | 20 +- src/edwin/comman.scm | 4 +- src/edwin/curren.scm | 14 +- src/edwin/edtstr.scm | 2 +- src/edwin/eystep.scm | 14 +- src/edwin/nntp.scm | 69 ++--- src/edwin/prompt.scm | 14 +- src/edwin/rcsparse.scm | 8 +- src/edwin/snr.scm | 16 +- src/edwin/utils.scm | 6 - src/edwin/win32.scm | 4 +- src/edwin/xterm.scm | 29 +- src/imail/imail-core.scm | 31 ++- src/imail/imail-file.scm | 6 +- src/imail/imail-imap.scm | 11 +- src/imail/imail-mime.scm | 10 +- src/imail/imail-top.scm | 8 +- src/runtime/hash-table.scm | 260 +++++++++--------- src/runtime/hash.scm | 16 +- src/runtime/host-adapter.scm | 6 + src/runtime/memoizer.scm | 6 +- src/runtime/runtime.pkg | 106 +++---- src/runtime/sfile.scm | 10 +- src/runtime/stack-sample.scm | 4 +- src/runtime/string.scm | 2 +- src/runtime/swank.scm | 7 +- src/runtime/syntax-rename.scm | 6 +- src/runtime/unxprm.scm | 16 +- src/runtime/url.scm | 8 +- src/sos/class.scm | 6 +- src/ssp/mod-lisp.scm | 10 +- src/ssp/xhtml-expander.scm | 4 +- src/ssp/xmlrpc.scm | 4 +- src/star-parser/matcher.scm | 8 +- src/star-parser/parser.scm | 8 +- src/star-parser/shared.scm | 8 +- src/win32/win_ffi.scm | 15 +- src/x11-screen/x11-screen.scm | 29 +- src/xdoc/validate-xdoc.scm | 4 +- src/xdoc/xdoc.scm | 58 ++-- src/xml/rdf-struct.scm | 10 +- src/xml/turtle.scm | 4 +- src/xml/xhtml-entities.scm | 4 +- src/xml/xhtml.scm | 8 +- src/xml/xml-names.scm | 4 +- tests/runtime/test-boyer-moore.scm | 4 +- tests/runtime/test-hash-table.scm | 134 +++++---- 65 files changed, 643 insertions(+), 600 deletions(-) diff --git a/src/compiler/back/symtab.scm b/src/compiler/back/symtab.scm index d8ef13c24..3078510bd 100644 --- a/src/compiler/back/symtab.scm +++ b/src/compiler/back/symtab.scm @@ -30,18 +30,18 @@ USA. (declare (usual-integrations)) (define make-symbol-table - (strong-hash-table/constructor eq-hash-mod eq? #t)) + (hash-table-constructor strong-eq-hash-table-type)) (define (symbol-table-define! table key value) - (let ((binding (hash-table/get table key #f))) + (let ((binding (hash-table-ref/default table key #f))) (if binding (begin (error "Redefining symbol:" key) (set-binding-value! binding value)) - (hash-table/put! table key (make-binding value))))) + (hash-table-set! table key (make-binding value))))) (define (symbol-table-value table key) - (let ((binding (hash-table/get table key #f))) + (let ((binding (hash-table-ref/default table key #f))) (if (not binding) (error "Undefined key:" key)) (let ((value (binding-value binding))) diff --git a/src/compiler/back/syntax.scm b/src/compiler/back/syntax.scm index 3b2bf2821..faa3bd80d 100644 --- a/src/compiler/back/syntax.scm +++ b/src/compiler/back/syntax.scm @@ -69,13 +69,13 @@ USA. (match-result)))) (define (instruction-lookup instruction) - (let ((pattern (hash-table/get instructions (car instruction) #f))) + (let ((pattern (hash-table-ref/default instructions (car instruction) #f))) (if pattern (pattern-lookup pattern (cdr instruction)) (error "INSTRUCTION-LOOKUP: Unknown keyword" (car instruction))))) (define (add-instruction! keyword lookup) - (hash-table/put! instructions keyword lookup) + (hash-table-set! instructions keyword lookup) keyword) (define instructions diff --git a/src/compiler/base/infnew.scm b/src/compiler/base/infnew.scm index ef3ec68cb..303a0d3ef 100644 --- a/src/compiler/base/infnew.scm +++ b/src/compiler/base/infnew.scm @@ -262,10 +262,11 @@ USA. (for-each (lambda (label-binding) (for-each (lambda (key) (let ((datum - (hash-table/get labels key no-datum))) + (hash-table-ref/default labels key + no-datum))) (if (not (eq? datum no-datum)) (error "Redefining label:" key datum))) - (hash-table/put! labels + (hash-table-set! labels key (cdr label-binding))) (car label-binding))) @@ -273,13 +274,13 @@ USA. (let ((map-label/fail (lambda (label) (let ((key (symbol->string label))) - (let ((datum (hash-table/get labels key no-datum))) + (let ((datum (hash-table-ref/default labels key no-datum))) (if (eq? datum no-datum) (error "Missing label:" key)) datum)))) (map-label/false (lambda (label) - (hash-table/get labels (symbol->string label) #f)))) + (hash-table-ref/default labels (symbol->string label) #f)))) (for-each (lambda (label) (set-dbg-label/external?! (map-label/fail label) true)) external-labels) diff --git a/src/compiler/machines/C/decls.scm b/src/compiler/machines/C/decls.scm index c4db0038d..adfe04c5e 100644 --- a/src/compiler/machines/C/decls.scm +++ b/src/compiler/machines/C/decls.scm @@ -65,7 +65,7 @@ USA. (set! source-nodes (map (lambda (filename) (let ((node (make/source-node filename))) - (hash-table/put! source-hash filename node) + (hash-table-set! source-hash filename node) node)) source-filenames)) (initialize/syntax-dependencies!) @@ -101,7 +101,7 @@ USA. (%make/source-node filename (->pathname filename))) (define (filename->source-node filename) - (let ((node (hash-table/get source-hash filename #f))) + (let ((node (hash-table-ref/default source-hash filename #f))) (if (not node) (error "Unknown source file:" filename)) node)) diff --git a/src/compiler/machines/C/stackify.scm b/src/compiler/machines/C/stackify.scm index dc29a7698..07619df1e 100644 --- a/src/compiler/machines/C/stackify.scm +++ b/src/compiler/machines/C/stackify.scm @@ -73,10 +73,10 @@ USA. (make-strong-eq-hash-table)) (define-integrable (stackify/table/lookup key) - (hash-table/get *stackify/table* key #f)) + (hash-table-ref/default *stackify/table* key #f)) (define-integrable (stackify/table/associate! key val) - (hash-table/put! *stackify/table* key val)) + (hash-table-set! *stackify/table* key val)) ;; An value in the table looks like ;; diff --git a/src/compiler/machines/i386/decls.scm b/src/compiler/machines/i386/decls.scm index 42dbd9c47..d2af7217e 100644 --- a/src/compiler/machines/i386/decls.scm +++ b/src/compiler/machines/i386/decls.scm @@ -65,7 +65,7 @@ USA. (set! source-nodes (map (lambda (filename) (let ((node (make/source-node filename))) - (hash-table/put! source-hash filename node) + (hash-table-set! source-hash filename node) node)) source-filenames)) (initialize/syntax-dependencies!) @@ -101,7 +101,7 @@ USA. (%make/source-node filename (->pathname filename))) (define (filename->source-node filename) - (let ((node (hash-table/get source-hash filename #f))) + (let ((node (hash-table-ref/default source-hash filename #f))) (if (not node) (error "Unknown source file:" filename)) node)) diff --git a/src/compiler/machines/i386/lapopt.scm b/src/compiler/machines/i386/lapopt.scm index 0de99c9a6..87f449f6a 100644 --- a/src/compiler/machines/i386/lapopt.scm +++ b/src/compiler/machines/i386/lapopt.scm @@ -102,13 +102,14 @@ USA. (error "Illegal LAPOPT pattern - must end with opcode" (reverse pattern))) (let ((key (caar pattern))) - (hash-table/put! *rules* key - (cons rule (hash-table/get *rules* key '())))))) + (hash-table-set! *rules* key + (cons rule + (hash-table-ref/default *rules* key '())))))) name) (define (find-rules instruction) - (hash-table/get *rules* (car instruction) '())) - + (hash-table-ref/default *rules* (car instruction) '())) + ;; Rules are tried in the reverse order in which they are defined. ;; ;; Rules are matched against the LAP from the bottom up. diff --git a/src/compiler/machines/svm/assembler-runtime.scm b/src/compiler/machines/svm/assembler-runtime.scm index 43703e262..4a0816541 100644 --- a/src/compiler/machines/svm/assembler-runtime.scm +++ b/src/compiler/machines/svm/assembler-runtime.scm @@ -115,27 +115,29 @@ USA. (make-strong-eq-hash-table)) (define (define-symbol name type value symbol-table) - (hash-table/get symbol-table name (make-symbol-binding name type value))) + (hash-table-ref/default symbol-table + name + (make-symbol-binding name type value))) (define (lookup-symbol name symbol-table) - (hash-table/get symbol-table name #f)) + (hash-table-ref/default symbol-table name #f)) ;;;; Top level ;;(define-import instructions (compiler lap-syntaxer)) (define (add-instruction! keyword assemblers) - (hash-table/put! instructions keyword assemblers) + (hash-table-set! instructions keyword assemblers) keyword) (define (add-instruction-assembler! keyword assembler) - (let ((assemblers (hash-table/get instructions keyword #f))) + (let ((assemblers (hash-table-ref/default instructions keyword #f))) (if assemblers - (hash-table/put! instructions keyword (cons assembler assemblers)) - (hash-table/put! instructions keyword (list assembler))))) + (hash-table-set! instructions keyword (cons assembler assemblers)) + (hash-table-set! instructions keyword (list assembler))))) (define (clear-instructions!) - (hash-table/clear! instructions)) + (hash-table-clear! instructions)) (define (init-assembler-instructions!) ;; Initialize the assembler's instruction database using the @@ -595,16 +597,16 @@ USA. (decoder pvt-decoder)) (define (lookup-pvar-type keyword) - (hash-table/get pvar-type-table keyword #f)) + (hash-table-ref/default pvar-type-table keyword #f)) (define (pvar-types) - (hash-table/datum-list pvar-type-table)) + (hash-table-values pvar-type-table)) (define pvar-type-table (make-strong-eq-hash-table)) (define (define-pvt name abbreviation sb-type predicate encoder decoder) - (hash-table/put! pvar-type-table + (hash-table-set! pvar-type-table name (make-pvt name abbreviation sb-type predicate encoder decoder)) diff --git a/src/compiler/machines/svm/decls.scm b/src/compiler/machines/svm/decls.scm index 161baf847..d54167e40 100644 --- a/src/compiler/machines/svm/decls.scm +++ b/src/compiler/machines/svm/decls.scm @@ -75,7 +75,7 @@ USA. (set! source-nodes (map (lambda (filename) (let ((node (make/source-node filename (env filename)))) - (hash-table/put! source-hash filename node) + (hash-table-set! source-hash filename node) node)) (all-filenames))) (initialize/integration-dependencies!) @@ -109,7 +109,7 @@ USA. (%make/source-node filename (->pathname filename) syntax-table)) (define (filename->source-node filename) - (let ((node (hash-table/get source-hash filename #f))) + (let ((node (hash-table-ref/default source-hash filename #f))) (if (not node) (error "Unknown source file:" filename)) node)) diff --git a/src/compiler/machines/x86-64/decls.scm b/src/compiler/machines/x86-64/decls.scm index d568abb94..ad8a4bb34 100644 --- a/src/compiler/machines/x86-64/decls.scm +++ b/src/compiler/machines/x86-64/decls.scm @@ -65,7 +65,7 @@ USA. (set! source-nodes (map (lambda (filename) (let ((node (make/source-node filename))) - (hash-table/put! source-hash filename node) + (hash-table-set! source-hash filename node) node)) source-filenames)) (initialize/syntax-dependencies!) @@ -101,7 +101,7 @@ USA. (%make/source-node filename (->pathname filename))) (define (filename->source-node filename) - (let ((node (hash-table/get source-hash filename #f))) + (let ((node (hash-table-ref/default source-hash filename #f))) (if (not node) (error "Unknown source file:" filename)) node)) diff --git a/src/compiler/machines/x86-64/lapopt.scm b/src/compiler/machines/x86-64/lapopt.scm index 14cfcbf74..4cf1173dd 100644 --- a/src/compiler/machines/x86-64/lapopt.scm +++ b/src/compiler/machines/x86-64/lapopt.scm @@ -106,13 +106,14 @@ USA. (error "Illegal LAPOPT pattern - must end with opcode" (reverse pattern))) (let ((key (caar pattern))) - (hash-table/put! *rules* key - (cons rule (hash-table/get *rules* key '())))))) + (hash-table-set! *rules* key + (cons rule + (hash-table-ref/default *rules* key '())))))) name) (define (find-rules instruction) - (hash-table/get *rules* (car instruction) '())) - + (hash-table-ref/default *rules* (car instruction) '())) + ;; Rules are tried in the reverse order in which they are defined. ;; ;; Rules are matched against the LAP from the bottom up. diff --git a/src/compiler/rtlbase/rtlcon.scm b/src/compiler/rtlbase/rtlcon.scm index e63b94c73..139b22c2c 100644 --- a/src/compiler/rtlbase/rtlcon.scm +++ b/src/compiler/rtlbase/rtlcon.scm @@ -226,7 +226,7 @@ USA. (expression-simplify expression scfg*pcfg->pcfg! receiver)) (define-export (expression-simplify-for-pseudo-assignment expression receiver) - (let ((entry (hash-table/get expression-methods (car expression) #f))) + (let ((entry (hash-table-ref/default expression-methods (car expression) #f))) (if entry (apply entry receiver scfg*scfg->scfg! (cdr expression)) (receiver expression)))) @@ -234,7 +234,7 @@ USA. (define (expression-simplify expression scfg-append! receiver) (if (rtl:register? expression) (receiver expression) - (let ((entry (hash-table/get expression-methods (car expression) #f))) + (let ((entry (hash-table-ref/default expression-methods (car expression) #f))) (if entry (apply entry (lambda (expression) @@ -409,7 +409,7 @@ USA. (receiver pseudo)))) (define (define-expression-method name method) - (hash-table/put! expression-methods name method) + (hash-table-set! expression-methods name method) name) (define expression-methods diff --git a/src/compiler/rtlbase/rtlobj.scm b/src/compiler/rtlbase/rtlobj.scm index 4b53b6d74..1de11688b 100644 --- a/src/compiler/rtlbase/rtlobj.scm +++ b/src/compiler/rtlbase/rtlobj.scm @@ -106,21 +106,21 @@ USA. (length procedures) (length continuations))))) (if expression - (hash-table/put! hash-table + (hash-table-set! hash-table (rtl-expr/label expression) expression)) (for-each (lambda (procedure) - (hash-table/put! hash-table + (hash-table-set! hash-table (rtl-procedure/label procedure) procedure)) procedures) (for-each (lambda (continuation) - (hash-table/put! hash-table + (hash-table-set! hash-table (rtl-continuation/label continuation) continuation)) continuations) (lambda (label) - (let ((datum (hash-table/get hash-table label #f))) + (let ((datum (hash-table-ref/default hash-table label #f))) (if (not datum) (error "Undefined label:" label)) datum)))) \ No newline at end of file diff --git a/src/compiler/rtlgen/opncod.scm b/src/compiler/rtlgen/opncod.scm index 55f9b8730..1f4139ee4 100644 --- a/src/compiler/rtlgen/opncod.scm +++ b/src/compiler/rtlgen/opncod.scm @@ -67,9 +67,9 @@ USA. (let ((value (constant-value callee))) (and (scode/primitive-procedure? value) (let ((entry - (hash-table/get name->open-coders - (primitive-procedure-name value) - #f))) + (hash-table-ref/default name->open-coders + (primitive-procedure-name value) + #f))) (and entry (try-handler combination value entry)))))))) @@ -211,7 +211,7 @@ USA. (lambda (name handler) (if (available-primitive? name) (let ((item (vector handler ->effect ->predicate ->value))) - (hash-table/put! name->open-coders name item)))))) + (hash-table-set! name->open-coders name item)))))) (lambda (name handler) (if (list? name) (for-each (lambda (name) diff --git a/src/compiler/rtlopt/rcse1.scm b/src/compiler/rtlopt/rcse1.scm index 7bc0d5135..f06acb134 100644 --- a/src/compiler/rtlopt/rcse1.scm +++ b/src/compiler/rtlopt/rcse1.scm @@ -74,14 +74,14 @@ USA. (define (state/reset!) (register-tables/reset! *register-tables*) - (set! *hash-table* (make-hash-table)) + (set! *hash-table* (make-rcse-ht)) (set! *stack-offset* 0) (set! *stack-reference-quantities* '()) unspecific) (define (state/get) (make-state (register-tables/copy *register-tables*) - (hash-table-copy *hash-table*) + (rcse-ht-copy *hash-table*) *stack-offset* (map (lambda (entry) (cons (car entry) (quantity-copy (cdr entry)))) @@ -92,7 +92,10 @@ USA. (let ((rtl (rinst-rtl rinst))) ((if (eq? (rtl:expression-type rtl) 'ASSIGN) cse/assign - (let ((method (hash-table/get cse-methods (rtl:expression-type rtl) #f))) + (let ((method + (hash-table-ref/default cse-methods + (rtl:expression-type rtl) + #f))) (if (not method) (error "Missing CSE method" (rtl:expression-type rtl))) method)) @@ -131,11 +134,10 @@ USA. (walk-bblock bblock)) (define (define-cse-method type method) - (hash-table/put! cse-methods type method) + (hash-table-set! cse-methods type method) type) (define cse-methods (make-strong-eq-hash-table)) - (define (cse/assign statement) (expression-replace! rtl:assign-expression rtl:set-assign-expression! @@ -202,7 +204,7 @@ USA. (let ((hash (expression-hash address))) (let ((memory-invalidate! (lambda () - (hash-table-delete! hash (hash-table-lookup hash address))))) + (rcse-ht-delete! hash (rcse-ht-lookup hash address))))) (if volatile? (memory-invalidate!) (assignment-memory-insertion address @@ -227,11 +229,10 @@ USA. (rtl:address-register address)))) ((expression-address-varies? address) (lambda () - (hash-table-delete-class! element-in-memory?))) + (rcse-ht-delete-class! element-in-memory?))) (else (lambda () - (hash-table-delete! hash - (hash-table-lookup hash address)) + (rcse-ht-delete! hash (rcse-ht-lookup hash address)) (varying-address-invalidate!)))))) (if (or volatile? volatile?*) (memory-invalidate!) diff --git a/src/compiler/rtlopt/rcse2.scm b/src/compiler/rtlopt/rcse2.scm index e601e6a47..b2a3e0c41 100644 --- a/src/compiler/rtlopt/rcse2.scm +++ b/src/compiler/rtlopt/rcse2.scm @@ -66,7 +66,7 @@ USA. (set-register-expression! (rtl:register-number expression) expression) (mention-registers! expression)) - (let ((element* (hash-table-insert! hash expression false))) + (let ((element* (rcse-ht-insert! hash expression false))) (set-element-in-memory?! element* in-memory?) (element-first-value element*))))) @@ -132,7 +132,7 @@ USA. (else (hash object)))))) (let ((hash (loop expression))) - (receiver (modulo hash (hash-table-size)) + (receiver (modulo hash (rcse-ht-size)) do-not-record? hash-arg-in-memory?)))) @@ -150,7 +150,7 @@ USA. ;; Returns false if no such element exists or if EXPRESSION is ;; VOLATILE?. (and (not volatile?) - (let ((element (hash-table-lookup hash expression))) + (let ((element (rcse-ht-lookup hash expression))) (and element (let ((element* (element-first-value element))) (if (eq? element element*) @@ -202,18 +202,18 @@ USA. (set-register-next-equivalent! last register) (set-register-previous-equivalent! register last)))) (set-quantity-last-register! quantity register))))) - (set-element-in-memory?! (hash-table-insert! (expression-hash expression) - expression - (element->class element)) + (set-element-in-memory?! (rcse-ht-insert! (expression-hash expression) + expression + (element->class element)) false)) (define (insert-stack-destination! expression element) (let ((quantity (get-element-quantity element))) (if quantity (set-stack-reference-quantity! expression quantity))) - (set-element-in-memory?! (hash-table-insert! (expression-hash expression) - expression - (element->class element)) + (set-element-in-memory?! (rcse-ht-insert! (expression-hash expression) + expression + (element->class element)) false)) (define (get-element-quantity element) @@ -230,11 +230,11 @@ USA. (define (insert-memory-destination! expression element hash) (let ((class (element->class element))) (mention-registers! expression) - ;; Optimization: if class and hash are both false, hash-table-insert! + ;; Optimization: if class and hash are both false, rcse-ht-insert! ;; makes an element which is not connected to the rest of the table. ;; In that case, there is no need to make an element at all. (if (or class hash) - (set-element-in-memory?! (hash-table-insert! hash expression class) + (set-element-in-memory?! (rcse-ht-insert! hash expression class) true)))) (define (mention-registers! expression) @@ -251,7 +251,7 @@ USA. (and (not (negative? in-table)) (not (= in-table (register-tick register))))) (let ((expression (register-expression register))) - (hash-table-delete-class! + (rcse-ht-delete-class! (lambda (element) (let ((expression* (element-expression element))) (and (not (rtl:register? expression*)) @@ -261,12 +261,12 @@ USA. ;;;; Invalidation (define (non-object-invalidate!) - (hash-table-delete-class! + (rcse-ht-delete-class! (lambda (element) (not (rtl:object-valued-expression? (element-expression element)))))) (define (varying-address-invalidate!) - (hash-table-delete-class! + (rcse-ht-delete-class! (lambda (element) (and (element-in-memory? element) (expression-address-varies? (element-expression element)))))) @@ -276,7 +276,7 @@ USA. ;; expression. (if (rtl:register? expression) (register-expression-invalidate! expression) - (hash-table-delete-class! + (rcse-ht-delete-class! (lambda (element) (expression-refers-to? (element-expression element) expression))))) @@ -291,7 +291,7 @@ USA. ;; immediately. (if (interpreter-stack-pointer? expression) (mention-registers! expression) - (hash-table-delete! hash (hash-table-lookup hash expression))))) + (rcse-ht-delete! hash (rcse-ht-lookup hash expression))))) (define (register-invalidate! register) (let ((next (register-next-equivalent register)) diff --git a/src/compiler/rtlopt/rcseht.scm b/src/compiler/rtlopt/rcseht.scm index e71e80090..a578b6eb7 100644 --- a/src/compiler/rtlopt/rcseht.scm +++ b/src/compiler/rtlopt/rcseht.scm @@ -30,18 +30,18 @@ USA. (declare (usual-integrations)) -(define (make-hash-table) +(define (make-rcse-ht) (make-vector 31 false)) (define *hash-table*) -(define-integrable (hash-table-size) +(define-integrable (rcse-ht-size) (vector-length *hash-table*)) -(define-integrable (hash-table-ref hash) +(define-integrable (rcse-ht-ref hash) (vector-ref *hash-table* hash)) -(define-integrable (hash-table-set! hash element) +(define-integrable (rcse-ht-set! hash element) (vector-set! *hash-table* hash element)) (define-structure (element @@ -57,8 +57,8 @@ USA. (previous-value false) (first-value false)) -(define (hash-table-lookup hash expression) - (let loop ((element (hash-table-ref hash))) +(define (rcse-ht-lookup hash expression) + (let loop ((element (rcse-ht-ref hash))) (and element (if (let ((expression* (element-expression element))) (or (eq? expression expression*) @@ -66,16 +66,16 @@ USA. element (loop (element-next-hash element)))))) -(define (hash-table-insert! hash expression class) +(define (rcse-ht-insert! hash expression class) (let ((element (make-element expression)) (cost (rtl:expression-cost expression))) (set-element-cost! element cost) (if hash (begin - (let ((next (hash-table-ref hash))) + (let ((next (rcse-ht-ref hash))) (set-element-next-hash! element next) (if next (set-element-previous-hash! next element))) - (hash-table-set! hash element))) + (rcse-ht-set! hash element))) (cond ((not class) (set-element-first-value! element element)) ((or (< cost (element-cost class)) @@ -109,7 +109,7 @@ USA. (loop next (element-next-value next))))))) element)) -(define (hash-table-delete! hash element) +(define (rcse-ht-delete! hash element) (if element (begin ;; **** Mark this element as removed. [ref crock-1] @@ -129,19 +129,19 @@ USA. (if next (set-element-previous-hash! next previous)) (if previous (set-element-next-hash! previous next) - (hash-table-set! hash next)))))) + (rcse-ht-set! hash next)))))) -(define (hash-table-delete-class! predicate) +(define (rcse-ht-delete-class! predicate) (let table-loop ((i 0)) - (if (< i (hash-table-size)) - (let bucket-loop ((element (hash-table-ref i))) + (if (< i (rcse-ht-size)) + (let bucket-loop ((element (rcse-ht-ref i))) (if element (begin - (if (predicate element) (hash-table-delete! i element)) + (if (predicate element) (rcse-ht-delete! i element)) (bucket-loop (element-next-hash element))) (table-loop (1+ i))))))) -(define (hash-table-copy table) +(define (rcse-ht-copy table) ;; During this procedure, the `element-cost' slots of `table' are ;; reused as "broken hearts". (let ((elements (vector->list table))) diff --git a/src/compiler/rtlopt/rerite.scm b/src/compiler/rtlopt/rerite.scm index 1a616d3c8..f053abfcf 100644 --- a/src/compiler/rtlopt/rerite.scm +++ b/src/compiler/rtlopt/rerite.scm @@ -105,8 +105,9 @@ USA. (or (if (rtl:assign? rtl) (pattern-lookup (rewriting-rules/assignment rules) rtl) (let ((entries - (hash-table/get (rewriting-rules/statement rules) - (rtl:expression-type rtl) #f))) + (hash-table-ref/default (rewriting-rules/statement rules) + (rtl:expression-type rtl) + #f))) (and entries (pattern-lookup entries rtl)))) (pattern-lookup (rewriting-rules/generic rules) rtl))) @@ -115,8 +116,9 @@ USA. (or (if (rtl:register? expression) (pattern-lookup (rewriting-rules/register rules) expression) (let ((entries - (hash-table/get (rewriting-rules/expression rules) - (rtl:expression-type expression) #f))) + (hash-table-ref/default (rewriting-rules/expression rules) + (rtl:expression-type expression) + #f))) (and entries (pattern-lookup entries expression)))) (pattern-lookup (rewriting-rules/generic rules) expression))) @@ -133,12 +135,16 @@ USA. rules (cons matcher (rewriting-rules/register rules)))) ((memq keyword rtl:expression-types) - (hash-table/modify! (rewriting-rules/expression rules) keyword '() - (lambda (rules) (cons matcher rules)))) + (hash-table-update!/default (rewriting-rules/expression rules) + keyword + (lambda (rules) (cons matcher rules)) + '())) ((or (memq keyword rtl:statement-types) (memq keyword rtl:predicate-types)) - (hash-table/modify! (rewriting-rules/statement rules) keyword '() - (lambda (rules) (cons matcher rules)))) + (hash-table-update!/default (rewriting-rules/statement rules) + keyword + (lambda (rules) (cons matcher rules)) + '())) (else (error "illegal RTL type" keyword)))) (set-rewriting-rules/generic! rules diff --git a/src/edwin/abbrev.scm b/src/edwin/abbrev.scm index 38b26d3ab..2b708735c 100644 --- a/src/edwin/abbrev.scm +++ b/src/edwin/abbrev.scm @@ -44,7 +44,7 @@ USA. (define (clear-abbrev-table table) (set! abbrevs-changed? #t) - (hash-table/clear! table)) + (hash-table-clear! table)) (define (define-abbrev table abbrev expansion #!optional hook count) (let ((hook (if (default-object? hook) #f hook)) @@ -55,7 +55,7 @@ USA. (if hook (guarantee symbol? hook 'DEFINE-ABBREV)) (guarantee exact-nonnegative-integer? count 'DEFINE-ABBREV) (set! abbrevs-changed? #t) - (hash-table/put! table + (hash-table-set! table (string-downcase abbrev) (make-abbrev-entry expansion hook count)))) @@ -72,7 +72,7 @@ USA. (guarantee-abbrev-table table 'UNDEFINE-ABBREV) (guarantee-string abbrev 'UNDEFINE-ABBREV) (set! abbrevs-changed? #t) - (hash-table/remove! table (string-downcase abbrev))) + (hash-table-delete! table (string-downcase abbrev))) (define (abbrev-entry abbrev where) (let ((abbrev @@ -83,14 +83,14 @@ USA. (error:wrong-type-argument abbrev "string" 'ABBREV-EXPANSION)))))) (if (abbrev-table? where) - (hash-table/get where abbrev #f) + (hash-table-ref/default where abbrev #f) (let ((buffer (if (not where) (selected-buffer) where))) (or (let ((table (ref-variable local-abbrev-table buffer))) (and table - (hash-table/get table abbrev #f))) - (hash-table/get (ref-variable global-abbrev-table #f) - abbrev - #f)))))) + (hash-table-ref/default table abbrev #f))) + (hash-table-ref/default (ref-variable global-abbrev-table #f) + abbrev + #f)))))) (define (abbrev-expansion abbrev where) (let ((entry (abbrev-entry abbrev where))) @@ -474,7 +474,7 @@ Mark is set after the inserted text." (insert-string "(" mark) (insert-string (symbol->string name) mark) (insert-string ")\n\n" mark) - (hash-table/for-each table + (hash-table-walk table (lambda (abbrev entry) (if (abbrev-entry-expansion entry) (begin @@ -601,7 +601,7 @@ The argument FILENAME is the file name to write." (write name port) (write-string " '(" port) (newline port) - (hash-table/for-each table + (hash-table-walk table (lambda (abbrev entry) (if (abbrev-entry-expansion entry) (begin diff --git a/src/edwin/comman.scm b/src/edwin/comman.scm index 11a69d735..70b1bcb63 100644 --- a/src/edwin/comman.scm +++ b/src/edwin/comman.scm @@ -197,10 +197,10 @@ USA. (name->variable object))) (define (variable-permanent-local! variable) - (hash-table/put! permanent-local-variables variable #t)) + (hash-table-set! permanent-local-variables variable #t)) (define (variable-permanent-local? variable) - (hash-table/get permanent-local-variables variable #f)) + (hash-table-ref/default permanent-local-variables variable #f)) (define permanent-local-variables (make-weak-eq-hash-table)) \ No newline at end of file diff --git a/src/edwin/curren.scm b/src/edwin/curren.scm index 37d6302a6..6fdc004cd 100644 --- a/src/edwin/curren.scm +++ b/src/edwin/curren.scm @@ -557,14 +557,14 @@ The buffer is guaranteed to be selected at that time." (define (maybe-select-buffer-layout-1 window buffer) (let ((screen (window-screen window))) - (let ((l1 (hash-table/get screen-buffer-layouts screen #f)) + (let ((l1 (hash-table-ref/default screen-buffer-layouts screen #f)) (l2 (buffer-get buffer buffer-layout-key #f))) (and (or (not (eq? l1 l2)) (and l1 (buffer-layout-visible? l1 screen))) (begin (if l1 (begin - (hash-table/remove! screen-buffer-layouts screen) + (hash-table-delete! screen-buffer-layouts screen) (delete-other-windows window))) (and l2 (if (let loop ((buffers (cdr l2))) @@ -575,7 +575,7 @@ The buffer is guaranteed to be selected at that time." (loop (weak-cdr buffers))))) (begin (delete-other-windows window) - (hash-table/put! screen-buffer-layouts screen l2) + (hash-table-set! screen-buffer-layouts screen l2) l2) (begin (delete-buffer-layout-1 l2) @@ -584,9 +584,9 @@ The buffer is guaranteed to be selected at that time." (define (maybe-deselect-buffer-layout screen) (without-interrupts (lambda () - (if (hash-table/get screen-buffer-layouts screen #f) + (if (hash-table-ref/default screen-buffer-layouts screen #f) (begin - (hash-table/remove! screen-buffer-layouts screen) + (hash-table-delete! screen-buffer-layouts screen) (delete-other-windows (screen-selected-window screen))))))) (define (delete-buffer-layout buffer) @@ -596,10 +596,10 @@ The buffer is guaranteed to be selected at that time." (delete-buffer-layout-1 layout)))) (define (delete-buffer-layout-1 layout) - (hash-table/for-each screen-buffer-layouts + (hash-table-walk screen-buffer-layouts (lambda (screen layout*) (if (eq? layout layout*) - (hash-table/remove! screen-buffer-layouts screen)))) + (hash-table-delete! screen-buffer-layouts screen)))) (do ((buffers (cdr layout) (weak-cdr buffers))) ((not (weak-pair? buffers))) (let ((buffer (weak-car buffers))) diff --git a/src/edwin/edtstr.scm b/src/edwin/edtstr.scm index 58a8c6458..7f9e9588f 100644 --- a/src/edwin/edtstr.scm +++ b/src/edwin/edtstr.scm @@ -111,7 +111,7 @@ USA. 'BUTTON- number (if down? '-DOWN '-UP)))) - (hash-table/intern! buttons-table name + (hash-table-intern! buttons-table name (lambda () (%%make-button number bits down? name)))))) diff --git a/src/edwin/eystep.scm b/src/edwin/eystep.scm index fde80d695..90a8ee6c1 100644 --- a/src/edwin/eystep.scm +++ b/src/edwin/eystep.scm @@ -152,7 +152,7 @@ c contract the step under the cursor") (let ((buffer (new-buffer "*Stepper*"))) (add-kill-buffer-hook buffer kill-stepper-buffer) (buffer-put! buffer 'STEPPER-STATE state) - (hash-table/put! stepper-buffers state buffer) + (hash-table-set! stepper-buffers state buffer) (set-buffer-read-only! buffer) (set-buffer-major-mode! buffer (ref-mode-object stepper)) buffer)) @@ -160,7 +160,7 @@ c contract the step under the cursor") (define (kill-stepper-buffer buffer) (let ((state (buffer-get buffer 'STEPPER-STATE))) (if state - (hash-table/remove! stepper-buffers state))) + (hash-table-delete! stepper-buffers state))) (buffer-remove! buffer 'STEPPER-STATE)) (define (buffer->stepper-state buffer) @@ -168,7 +168,7 @@ c contract the step under the cursor") (error:bad-range-argument buffer 'BUFFER->STEPPER-STATE))) (define (stepper-state->buffer state) - (or (hash-table/get stepper-buffers state #f) + (or (hash-table-ref/default stepper-buffers state #f) (get-stepper-buffer state))) (define stepper-buffers @@ -198,14 +198,14 @@ c contract the step under the cursor") table))) (define (clear-ynode-regions! regions) - (for-each mark-temporary! (hash-table/datum-list regions)) - (hash-table/clear! regions)) + (for-each mark-temporary! (hash-table-values regions)) + (hash-table-clear! regions)) (define (ynode-start-mark regions node) - (hash-table/get regions node #f)) + (hash-table-ref/default regions node #f)) (define (save-ynode-region! regions node start end) - (hash-table/put! regions node (mark-temporary-copy start)) + (hash-table-set! regions node (mark-temporary-copy start)) (add-text-property (mark-group start) (mark-index start) (mark-index end) 'STEPPER-NODE node)) diff --git a/src/edwin/nntp.scm b/src/edwin/nntp.scm index acdf50286..747ba6b0c 100644 --- a/src/edwin/nntp.scm +++ b/src/edwin/nntp.scm @@ -127,7 +127,7 @@ USA. (let* ((table (make-string-hash-table)) (add-line (lambda (line) - (hash-table/put! table (string-first-token line) line)))) + (hash-table-set! table (string-first-token line) line)))) (for-each-vector-element lines add-line) (for-each-vector-element new-lines add-line) (write-init-file-atomically @@ -138,7 +138,7 @@ USA. (for-each (lambda (line) (write-string line port) (newline port)) - (hash-table/datum-list table))))) + (hash-table-values table))))) (convert-groups-list new-lines))))) (define (nntp-connection:active-groups-vector connection re-read?) @@ -185,18 +185,18 @@ USA. ;;;; Group Cache (define (find-news-group connection name) - (hash-table/get (nntp-connection:group-table connection) name #f)) + (hash-table-ref/default (nntp-connection:group-table connection) name #f)) (define (nntp-connection:remember-group! connection name group) - (hash-table/put! (nntp-connection:group-table connection) name group)) + (hash-table-set! (nntp-connection:group-table connection) name group)) (define (nntp-connection:purge-group-cache connection predicate) (let ((table (nntp-connection:group-table connection))) (if table - (hash-table/for-each table + (hash-table-walk table (lambda (name group) (if (predicate group) - (hash-table/remove! table name))))))) + (hash-table-delete! table name))))))) ;;;; NNTP Commands @@ -547,14 +547,15 @@ USA. table))) (define make-header-hash-table - (strong-hash-table/constructor remainder = #f)) + (hash-table-constructor + (make-hash-table-type remainder = #f hash-table-entry-type:strong))) (define (news-group:header group number) (let ((table (news-group:header-table group))) - (or (hash-table/get table number #f) + (or (hash-table-ref/default table number #f) (let ((header (parse-header group (get-header group number)))) (if (news-header? header) - (hash-table/put! table number header)) + (hash-table-set! table number header)) header)))) (define (news-group:id->header group id allow-server-probes?) @@ -566,9 +567,9 @@ USA. (and (news-header? header) (let ((table (news-group:header-table group)) (number (news-header:number header))) - (or (hash-table/get table number #f) + (or (hash-table-ref/default table number #f) (begin - (hash-table/put! table number header) + (hash-table-set! table number header) header))))))))) (define (news-group:id->pre-read-header group id) @@ -580,28 +581,28 @@ USA. (define (news-group:cached-header group number) (and (news-group:%header-table group) - (hash-table/get (news-group:%header-table group) number #f))) + (hash-table-ref/default (news-group:%header-table group) number #f))) (define (news-group:purge-header-cache group predicate) (let ((table (news-group:%header-table group))) (if table (if (eq? 'ALL predicate) - (hash-table/clear! table) - (hash-table/for-each table + (hash-table-clear! table) + (hash-table-walk table (lambda (number header) (if (and (news-header? header) (predicate header #f)) - (hash-table/remove! table number)))))))) + (hash-table-delete! table number)))))))) (define (news-group:discard-cached-header! header) (let ((group (news-header:group header))) (if (news-group:%header-table group) - (hash-table/remove! (news-group:%header-table group) + (hash-table-delete! (news-group:%header-table group) (news-header:number header))))) (define (news-group:cached-headers group) (let ((table (news-group:%header-table group))) (if table - (hash-table/datum-list table) + (hash-table-values table) '()))) (define (news-group:headers group numbers ignore?) @@ -620,7 +621,7 @@ USA. (let loop ((numbers numbers) (headers '()) (numbers* '())) (if (null? numbers) (values headers (reverse! numbers*)) - (let ((header (hash-table/get table (car numbers) #f))) + (let ((header (hash-table-ref/default table (car numbers) #f))) (if (not header) (loop (cdr numbers) headers @@ -628,7 +629,7 @@ USA. (loop (cdr numbers) (cons (if (ignore? header) (begin - (hash-table/remove! table (car numbers)) + (hash-table-delete! table (car numbers)) (cons 'IGNORED-ARTICLE (car numbers))) header) headers) @@ -680,7 +681,7 @@ USA. ((ignore? header) headers) (else - (hash-table/put! (news-group:header-table group) number header) + (hash-table-set! (news-group:header-table group) number header) (cons header headers))))) ;;;; Header Database @@ -1326,7 +1327,7 @@ USA. (set-news-header:followup-to! header (news-header:reference-list header)) (set-news-header:followups! header '()) (set-news-header:thread! header #f) - (hash-table/put! id-table (news-header:message-id header) header)) + (hash-table-set! id-table (news-header:message-id header) header)) (for-each init-header headers) (for-each (lambda (header) (enqueue!/unsafe queue header)) headers) @@ -1338,14 +1339,15 @@ USA. (remove-duplicates (map (lambda (id) - (or (hash-table/get id-table id #f) + (or (hash-table-ref/default id-table id #f) (and show-context? (let ((header (news-group:id->header group id allow-server-probes?))) (and (news-header? header) (begin - (if (eq? (hash-table/get id-table id #t) + (if (eq? (hash-table-ref/default id-table id + #t) #t) (begin (set! headers (cons header headers)) @@ -1412,7 +1414,8 @@ USA. (let ((tables (cons (make-strong-eq-hash-table) (make-strong-eq-hash-table)))) (for-each (lambda (header) - (if (eq? (hash-table/get (car tables) header 'NONE) 'NONE) + (if (eq? (hash-table-ref/default (car tables) header 'NONE) + 'NONE) (eliminate-redundant-relatives tables header))) headers) (let loop () @@ -1495,10 +1498,10 @@ USA. (define (compute-header-relatives step table header) (let loop ((header header)) - (let ((cache (hash-table/get table header 'NONE))) + (let ((cache (hash-table-ref/default table header 'NONE))) (case cache ((NONE) - (hash-table/put! table header 'PENDING) + (hash-table-set! table header 'PENDING) (let ((result (reduce unionq @@ -1515,7 +1518,7 @@ USA. '()) result))) headers)))))) - (hash-table/put! table header result) + (hash-table-set! table header result) result)) ((PENDING) ;;(error "Cycle detected in header graph:" header) @@ -1525,8 +1528,8 @@ USA. (define (reset-caches! tables header) (let ((do-header (lambda (header) - (hash-table/remove! (car tables) header) - (hash-table/remove! (cdr tables) header)))) + (hash-table-delete! (car tables) header) + (hash-table-delete! (cdr tables) header)))) (let loop ((header header)) (do-header header) (for-each loop (news-header:followup-to header))) @@ -1726,7 +1729,7 @@ USA. (define (build-equivalence-classes threads subject-alist) (let ((equivalences (make-strong-eq-hash-table))) (for-each (lambda (thread) - (hash-table/put! equivalences + (hash-table-set! equivalences thread (let ((t (list thread))) (set-cdr! t (list t)) @@ -1734,8 +1737,8 @@ USA. threads) (let ((equivalence! (lambda (x y) - (let ((x (hash-table/get equivalences x #f)) - (y (hash-table/get equivalences y #f))) + (let ((x (hash-table-ref/default equivalences x #f)) + (y (hash-table-ref/default equivalences y #f))) (if (not (eq? (cdr x) (cdr y))) (let ((k (lambda (x y) @@ -1751,7 +1754,7 @@ USA. subject-alist)) (map (lambda (class) (map car class)) (remove-duplicates - (map cdr (hash-table/datum-list equivalences)))))) + (map cdr (hash-table-values equivalences)))))) (define (make-threads-equivalent! threads) (let ((threads (sort threads news-thread:<))) diff --git a/src/edwin/prompt.scm b/src/edwin/prompt.scm index 96fcb5ca7..d935f3b3a 100644 --- a/src/edwin/prompt.scm +++ b/src/edwin/prompt.scm @@ -453,9 +453,9 @@ USA. (if (not (or (not name) (symbol? name))) (error:wrong-type-argument name "symbol" 'NAME->HISTORY)) (let ((name (or name 'MINIBUFFER-DEFAULT))) - (or (hash-table/get prompt-histories name #f) + (or (hash-table-ref/default prompt-histories name #f) (let ((history (list 'PROMPT-HISTORY))) - (hash-table/put! prompt-histories name history) + (hash-table-set! prompt-histories name history) history)))) (define (prompt-history-strings name) @@ -1060,7 +1060,7 @@ Set this to zero if you don't want pass-phrase retention." (define (call-with-stored-pass-phrase key receiver) (let ((retention-time (ref-variable pass-phrase-retention-time #f))) - (let ((entry (hash-table/get stored-pass-phrases key #f))) + (let ((entry (hash-table-ref/default stored-pass-phrases key #f))) (if entry (begin (without-interrupts @@ -1072,7 +1072,7 @@ Set this to zero if you don't want pass-phrase retention." (string-append "Pass phrase for " key) (lambda (pass-phrase) (if (> retention-time 0) - (hash-table/put! + (hash-table-set! stored-pass-phrases key (let ((entry @@ -1082,7 +1082,7 @@ Set this to zero if you don't want pass-phrase retention." (receiver pass-phrase))))))) (define (delete-stored-pass-phrase key) - (hash-table/remove! stored-pass-phrases key)) + (hash-table-delete! stored-pass-phrases key)) (define (set-up-pass-phrase-timer! entry key retention-time) ;; A race condition can occur when the timer event is re-registered. @@ -1097,9 +1097,9 @@ Set this to zero if you don't want pass-phrase retention." (lambda () (without-interrupts (lambda () - (let ((entry (hash-table/get stored-pass-phrases key #f))) + (let ((entry (hash-table-ref/default stored-pass-phrases key #f))) (if (and entry (eq? (vector-ref entry 2) id)) - (hash-table/remove! stored-pass-phrases key)))))))))) + (hash-table-delete! stored-pass-phrases key)))))))))) (define stored-pass-phrases (make-string-hash-table)) diff --git a/src/edwin/rcsparse.scm b/src/edwin/rcsparse.scm index 00b59cd9a..99ad65c55 100644 --- a/src/edwin/rcsparse.scm +++ b/src/edwin/rcsparse.scm @@ -102,10 +102,10 @@ USA. (let ((table (make-string-hash-table))) (for-each (lambda (delta) (let ((key (vector-ref delta 0))) - (let ((entry (hash-table/get table key #f))) + (let ((entry (hash-table-ref/default table key #f))) (if entry (error "duplicate delta entry" delta entry))) - (hash-table/put! table key + (hash-table-set! table key (make-rcs-delta key (vector-ref delta 1) (vector-ref delta 2) @@ -115,11 +115,11 @@ USA. deltas) (let ((num->delta (lambda (key) - (let ((delta (hash-table/get table key #f))) + (let ((delta (hash-table-ref/default table key #f))) (if (not delta) (error "unknown delta number" key)) delta)))) - (hash-table/for-each table + (hash-table-walk table (lambda (key delta) key (do ((branches (rcs-delta/branches delta) (cdr branches))) diff --git a/src/edwin/snr.scm b/src/edwin/snr.scm index a7d90bcaa..6da40f3f0 100644 --- a/src/edwin/snr.scm +++ b/src/edwin/snr.scm @@ -3366,7 +3366,7 @@ C-c C-q mail-fill-yanked-message (fill what was yanked)." #f (let ((table (make-string-hash-table (length entries)))) (for-each (lambda (entry) - (hash-table/put! table (car entry) (cadr entry))) + (hash-table-set! table (car entry) (cadr entry))) entries) table)))) @@ -3394,7 +3394,7 @@ C-c C-q mail-fill-yanked-message (fill what was yanked)." (cond ((null? entries) result) ((< (cdar entries) t) - (hash-table/remove! table + (hash-table-delete! table (caar entries)) (loop (cdr entries) result)) (else @@ -4499,9 +4499,9 @@ With prefix arg, replaces the file with the list information." (define (news-header:ignore?! header table t) (let ((subject (canonicalize-subject (news-header:subject header)))) (and (not (fix:= 0 (string-length subject))) - (hash-table/get table subject #f) + (hash-table-ref/default table subject #f) (let ((group (news-header:group header))) - (hash-table/put! table subject t) + (hash-table-set! table subject t) (news-group:ignored-subjects-modified! group) (news-group:process-cross-posts header (ignore-subject-marker subject t)) @@ -4513,7 +4513,7 @@ With prefix arg, replaces the file with the list information." (and table (let ((subject (canonicalize-subject (news-header:subject header)))) (and (not (fix:= 0 (string-length subject))) - (hash-table/get table subject #f)))))) + (hash-table-ref/default table subject #f)))))) (define (news-group:article-ignored! header buffer) (let ((subject (canonicalize-subject (news-header:subject header)))) @@ -4527,7 +4527,7 @@ With prefix arg, replaces the file with the list information." (define ((ignore-subject-marker subject t) group number) number - (hash-table/put! (news-group:get-ignored-subjects group #t) subject t) + (hash-table-set! (news-group:get-ignored-subjects group #t) subject t) (news-group:ignored-subjects-modified! group)) (define (news-group:article-not-ignored! header buffer) @@ -4538,9 +4538,9 @@ With prefix arg, replaces the file with the list information." (lambda (group number) number (let ((table (news-group:get-ignored-subjects group #f))) - (if (and table (hash-table/get table subject #f)) + (if (and table (hash-table-ref/default table subject #f)) (begin - (hash-table/remove! table subject) + (hash-table-delete! table subject) (news-group:ignored-subjects-modified! group))))))) (process-header (news-header:group header) (news-header:number header)) diff --git a/src/edwin/utils.scm b/src/edwin/utils.scm index b66a04ffd..6492c525c 100644 --- a/src/edwin/utils.scm +++ b/src/edwin/utils.scm @@ -271,12 +271,6 @@ USA. (loop (cdr elements) satisfied (cons (car elements) unsatisfied))) (values satisfied unsatisfied)))) -(define make-strong-eq-hash-table - (strong-hash-table/constructor eq-hash-mod eq? #t)) - -(define make-weak-equal-hash-table - (weak-hash-table/constructor equal-hash-mod equal? #t)) - (define (weak-assq item alist) (let loop ((alist alist)) (and (not (null? alist)) diff --git a/src/edwin/win32.scm b/src/edwin/win32.scm index 8cf5ddce0..47a662aa3 100644 --- a/src/edwin/win32.scm +++ b/src/edwin/win32.scm @@ -422,7 +422,7 @@ USA. (else (error "Illegal change event:" event)))) (define (process-special-event event) - (let ((handler (hash-table/get event-handlers (event-type event) #f)) + (let ((handler (hash-table-ref/default event-handlers (event-type event) #f)) (screen (handle->win32-screen (event-handle event)))) (and handler screen @@ -432,7 +432,7 @@ USA. (make-strong-eqv-hash-table)) (define (define-event-handler event-type handler) - (hash-table/put! event-handlers event-type handler)) + (hash-table-set! event-handlers event-type handler)) ;;;; Events diff --git a/src/edwin/xterm.scm b/src/edwin/xterm.scm index cdba200d8..83b059f10 100644 --- a/src/edwin/xterm.scm +++ b/src/edwin/xterm.scm @@ -898,28 +898,28 @@ USA. WM_TRANSIENT_FOR)) (define (symbol->x-atom display name soft?) - (or (hash-table/get built-in-atoms-table name #f) + (or (hash-table-ref/default built-in-atoms-table name #f) (let ((table (car (display/cached-atoms-tables display)))) - (or (hash-table/get table name #f) + (or (hash-table-ref/default table name #f) (let ((atom (x-intern-atom display (string-upcase (symbol->string name)) soft?))) (if (not (= atom 0)) - (hash-table/put! table name atom)) + (hash-table-set! table name atom)) atom))))) (define (x-atom->symbol display atom) (if (< atom (vector-length built-in-atoms)) (vector-ref built-in-atoms atom) (let ((table (cdr (display/cached-atoms-tables display)))) - (or (hash-table/get table atom #f) + (or (hash-table-ref/default table atom #f) (let ((symbol (let ((string (x-get-atom-name display atom))) (if (not (string? string)) (error "X error (XGetAtomName):" string atom)) (intern string)))) - (hash-table/put! table atom symbol) + (hash-table-set! table atom symbol) symbol))))) (define built-in-atoms-table @@ -927,17 +927,17 @@ USA. (let ((table (make-strong-eq-hash-table n))) (do ((i 0 (fix:+ i 1))) ((fix:= i n)) - (hash-table/put! table (vector-ref built-in-atoms i) i)) + (hash-table-set! table (vector-ref built-in-atoms i) i)) table))) (define display/cached-atoms-tables (let ((table (make-weak-eq-hash-table))) (lambda (display) - (or (hash-table/get table display #f) + (or (hash-table-ref/default table display #f) (let ((result (cons (make-strong-eq-hash-table) (make-strong-eqv-hash-table)))) - (hash-table/put! table display result) + (hash-table-set! table display result) result))))) ;;;; Properties @@ -1105,7 +1105,7 @@ In either case, it is copied to the primary selection." (x-set-selection-owner display selection window time) (x-get-selection-owner display selection))) (begin - (hash-table/put! (display/selection-records display) + (hash-table-set! (display/selection-records display) selection (make-selection-record window time value)) #t))) @@ -1113,9 +1113,9 @@ In either case, it is copied to the primary selection." (define display/selection-records (let ((table (make-weak-eq-hash-table))) (lambda (display) - (or (hash-table/get table display #f) + (or (hash-table-ref/default table display #f) (let ((result (make-strong-eq-hash-table))) - (hash-table/put! table display result) + (hash-table-set! table display result) result))))) ;;; In the next two procedures, we must allow TIME to be 0, even @@ -1123,17 +1123,18 @@ In either case, it is copied to the primary selection." ;;; value. An example of a broken client is GTK+ version 1.2.6. (define (display/selection-record display name time) - (let ((record (hash-table/get (display/selection-records display) name #f))) + (let ((record + (hash-table-ref/default (display/selection-records display) name #f))) (and record (or (= 0 time) (<= (selection-record/time record) time)) record))) (define (display/delete-selection-record! display name time) (let ((records (display/selection-records display))) - (if (let ((record (hash-table/get records name #f))) + (if (let ((record (hash-table-ref/default records name #f))) (and record (or (= 0 time) (<= (selection-record/time record) time)))) - (hash-table/remove! records name)))) + (hash-table-delete! records name)))) (define-structure (selection-record (conc-name selection-record/)) (window #f read-only #t) diff --git a/src/imail/imail-core.scm b/src/imail/imail-core.scm index fc7af2f92..75d174ab8 100644 --- a/src/imail/imail-core.scm +++ b/src/imail/imail-core.scm @@ -136,19 +136,19 @@ USA. (let ((modifier (slot-modifier 'CONTAINER))) (lambda (url compute-container) (let ((string (url->string url))) - (or (hash-table/get interned-urls string #f) + (or (hash-table-ref/default interned-urls string #f) (begin (let ((finished? #f)) (dynamic-wind (lambda () - (hash-table/put! interned-urls string url)) + (hash-table-set! interned-urls string url)) (lambda () (modifier url (compute-container url)) (set! finished? #t) unspecific) (lambda () (if (not finished?) - (hash-table/remove! interned-urls string))))) + (hash-table-delete! interned-urls string))))) url)))))) (define interned-urls @@ -156,10 +156,10 @@ USA. (define (define-url-protocol name class) (define-method url-protocol ((url class)) url name) - (hash-table/put! url-protocols (string-downcase name) class)) + (hash-table-set! url-protocols (string-downcase name) class)) (define (url-protocol-name? name) - (hash-table/get url-protocols (string-downcase name) #f)) + (hash-table-ref/default url-protocols (string-downcase name) #f)) (define url-protocols (make-string-hash-table)) @@ -369,7 +369,7 @@ USA. (memoize-resource (constructor url)))) (define (get-memoized-resource url #!optional error?) - (or (let ((resource (hash-table/get memoized-resources url #f))) + (or (let ((resource (hash-table-ref/default memoized-resources url #f))) (and resource (let ((resource (weak-car resource))) ;; Delete memoization _only_ if URL-EXISTS? @@ -378,13 +378,13 @@ USA. (if (and resource (ignore-errors (lambda () (url-exists? url)))) resource (begin - (hash-table/remove! memoized-resources url) + (hash-table-delete! memoized-resources url) #f))))) (and (if (default-object? error?) #f error?) (error "URL has no associated resource:" url)))) (define (memoize-resource resource) - (hash-table/put! memoized-resources + (hash-table-set! memoized-resources (resource-locator resource) (weak-cons resource (lambda (resource) @@ -392,7 +392,7 @@ USA. resource) (define (unmemoize-resource url) - (let ((r.c (hash-table/get memoized-resources url #f))) + (let ((r.c (hash-table-ref/default memoized-resources url #f))) (if r.c (let ((resource (weak-car r.c))) (if resource @@ -400,10 +400,10 @@ USA. (let ((close (weak-cdr r.c))) (if close (close resource))) - (hash-table/remove! memoized-resources url))))))) + (hash-table-delete! memoized-resources url))))))) (define (%unmemoize-resource url) - (hash-table/remove! memoized-resources url)) + (hash-table-delete! memoized-resources url)) (define memoized-resources (make-weak-eq-hash-table)) @@ -751,7 +751,7 @@ USA. (define (reset-folder-order! order) (set-folder-order-tree! order #f) (let ((cache (folder-order-cache order))) - (if cache (hash-table/clear! cache)))) + (if cache (hash-table-clear! cache)))) (define (map-folder-index folder index) (let ((order (folder-order folder))) @@ -783,14 +783,15 @@ USA. (< (cdr a) (cdr b)))))))) (define make-integer-hash-table - (strong-hash-table/constructor int:remainder int:=)) + (hash-table-constructor + (make-hash-table-type int:remainder int:= #f hash-table-entry-type:strong))) (define (%message-order-key message order index) (let ((compute-key (lambda () (cons ((folder-order-selector order) message) index))) (cache (folder-order-cache order))) (if cache - (hash-table/intern! cache index compute-key) + (hash-table-intern! cache index compute-key) (compute-key)))) (define (index-order-key folder order index) @@ -830,7 +831,7 @@ USA. (let ((compute-key (if cache (lambda (message index) - (hash-table/intern! cache index + (hash-table-intern! cache index (lambda () (cons (selector message) index)))) (lambda (message index) (cons (selector message) index))))) diff --git a/src/imail/imail-file.scm b/src/imail/imail-file.scm index 95b337fd2..5f7cfc6b9 100644 --- a/src/imail/imail-file.scm +++ b/src/imail/imail-file.scm @@ -35,7 +35,7 @@ USA. (predicate define accessor)) (define (define-file-folder-type class name predicate) - (hash-table/put! file-folder-types + (hash-table-set! file-folder-types class ((instance-constructor class '(NAME PREDICATE)) name predicate))) @@ -48,14 +48,14 @@ USA. (string-append "File type for " (url->string url)) (map (lambda (type) (cons (file-folder-type-name type) type)) - (hash-table/datum-list file-folder-types)))) + (hash-table-values file-folder-types)))) (define (url-file-folder-type url) (or (file-folder-type (pathname-url-pathname url)) (error "Unknown folder type:" url))) (define (file-folder-type pathname) - (let loop ((types (hash-table/datum-list file-folder-types))) + (let loop ((types (hash-table-values file-folder-types))) (and (pair? types) (if ((file-folder-type-predicate (car types)) pathname) (car types) diff --git a/src/imail/imail-imap.scm b/src/imail/imail-imap.scm index d8acca172..cd45eca9b 100644 --- a/src/imail/imail-imap.scm +++ b/src/imail/imail-imap.scm @@ -444,7 +444,7 @@ USA. (let* ((slash (string-find-next-char mailbox #\/)) (root (if slash (string-head mailbox slash) mailbox)) (key (make-imap-url-string url root))) - (hash-table/intern! imap-delimiters-table key + (hash-table-intern! imap-delimiters-table key (lambda () (let ((delimiter (imap:response:list-delimiter @@ -1328,7 +1328,7 @@ USA. (count 0)) ((imail-ui:message-wrapper "Reading message data") (lambda () - (hash-table/for-each message-sets + (hash-table-walk message-sets (lambda (keywords messages) (imap:command:fetch-set/for-each (lambda (response) @@ -1384,8 +1384,11 @@ USA. (let ((keywords (select-uncached-keywords message keywords))) (if (pair? keywords) (begin - (hash-table/modify! message-sets keywords '() - (lambda (messages) (cons message messages))) + (hash-table-update!/default message-sets + keywords + (lambda (messages) + (cons message messages)) + '()) (set! count (+ count 1))))))))))) (values message-sets count))) diff --git a/src/imail/imail-mime.scm b/src/imail/imail-mime.scm index ab119c69f..1857cbefe 100644 --- a/src/imail/imail-mime.scm +++ b/src/imail/imail-mime.scm @@ -776,7 +776,7 @@ USA. encode:initialize encode:finalize encode:update decode:initialize decode:finalize decode:update call-with-port) - (hash-table/put! + (hash-table-set! mime-encodings name (%make-mime-encoding name #f @@ -786,7 +786,7 @@ USA. name) (define (define-identity-mime-encoding name) - (hash-table/put! mime-encodings + (hash-table-set! mime-encodings name (%make-mime-encoding name #t (lambda (port text?) text? port) @@ -800,13 +800,13 @@ USA. (generator port))))) (define (known-mime-encoding? name) - (and (hash-table/get mime-encodings name #f) + (and (hash-table-ref/default mime-encodings name #f) #t)) (define (named-mime-encoding name) - (or (hash-table/get mime-encodings name #f) + (or (hash-table-ref/default mime-encodings name #f) (let ((encoding (make-unknown-mime-encoding name))) - (hash-table/put! mime-encodings name encoding) + (hash-table-set! mime-encodings name encoding) encoding))) (define (make-unknown-mime-encoding name) diff --git a/src/imail/imail-top.scm b/src/imail/imail-top.scm index b7433c480..6c332804e 100644 --- a/src/imail/imail-top.scm +++ b/src/imail/imail-top.scm @@ -2693,7 +2693,7 @@ WARNING: With a prefix argument, this command may take a very long (key (cons (mime-info-entity info) (mime-info-selector info))) (inline? (mime-info-inline? info))) (if expansions - (hash-table/get expansions key inline?) + (hash-table-ref/default expansions key inline?) inline?))) (define (set-mime-info-expanded?! info mark expanded?) @@ -2702,10 +2702,10 @@ WARNING: With a prefix argument, this command may take a very long (if (if (mime-info-inline? info) expanded? (not expanded?)) (cond ((buffer-get buffer 'IMAIL-MIME-EXPANSIONS #f) => (lambda (expansions) - (hash-table/remove! expansions key) - (if (zero? (hash-table/count expansions)) + (hash-table-delete! expansions key) + (if (zero? (hash-table-size expansions)) (buffer-remove! buffer 'IMAIL-MIME-EXPANSIONS))))) - (hash-table/put! + (hash-table-set! (or (buffer-get buffer 'IMAIL-MIME-EXPANSIONS #f) (let ((expansions (make-equal-hash-table))) (buffer-put! buffer 'IMAIL-MIME-EXPANSIONS expansions) diff --git a/src/runtime/hash-table.scm b/src/runtime/hash-table.scm index b50161857..7bc04bae9 100644 --- a/src/runtime/hash-table.scm +++ b/src/runtime/hash-table.scm @@ -128,53 +128,68 @@ USA. (lambda (table) (set-table-needs-rehash?! table #t)))) -(define (hash-table/type table) - (guarantee hash-table? table 'hash-table/type) +(define (hash-table-type table) + (guarantee hash-table? table 'hash-table-type) (table-type table)) -(define (hash-table/key-hash table) - (guarantee hash-table? table 'hash-table/key-hash) +(define (hash-table-hash-function table) + (guarantee hash-table? table 'hash-table-hash-function) (table-type-key-hash (table-type table))) -(define (hash-table/key=? table) - (guarantee hash-table? table 'hash-table/key=?) +(define (hash-table-equivalence-function table) + (guarantee hash-table? table 'hash-table-equivalence-function) (table-type-key=? (table-type table))) -(define (hash-table/get table key default) - (guarantee hash-table? table 'hash-table/get) - ((table-type-method:get (table-type table)) table key default)) +(define (hash-table-exists? table key) + (not (eq? (hash-table-ref/default table key default-marker) default-marker))) -(define (hash-table/lookup table key if-found if-not-found) - (let ((datum (hash-table/get table key default-marker))) - (if (eq? datum default-marker) - (if-not-found) - (if-found datum)))) +(define (hash-table-ref table key #!optional get-default) + (guarantee hash-table? table 'hash-table-ref) + ((table-type-method:get (table-type table)) + table + key + (if (default-object? get-default) + (lambda () (error:bad-range-argument key 'hash-table-ref)) + get-default))) + +(define (hash-table-ref/default table key default) + (hash-table-ref table key (lambda () default))) -(define (hash-table/put! table key datum) - (guarantee hash-table? table 'hash-table/put!) +(define (hash-table-set! table key datum) + (guarantee hash-table? table 'hash-table-set!) ((table-type-method:put! (table-type table)) table key datum)) -(define (hash-table/modify! table key default procedure) +(define (hash-table-update! table key procedure #!optional get-default) (guarantee hash-table? table 'hash-table/modify!) - ((table-type-method:modify! (table-type table)) table key default procedure)) + ((table-type-method:modify! (table-type table)) + table + key + (if (default-object? get-default) + (lambda () (error:bad-range-argument key 'hash-table-update!)) + get-default) + procedure)) + +(define (hash-table-update!/default table key procedure default) + (hash-table-update! table key procedure (lambda () default))) -(define (hash-table/intern! table key generator) - (hash-table/modify! table key default-marker +(define (hash-table-intern! table key generator) + (hash-table-update!/default table key (lambda (datum) - (if (eq? datum default-marker) (generator) datum)))) + (if (eq? datum default-marker) (generator) datum)) + default-marker)) -(define (hash-table/remove! table key) - (guarantee hash-table? table 'hash-table/remove!) +(define (hash-table-delete! table key) + (guarantee hash-table? table 'hash-table-delete!) ((table-type-method:remove! (table-type table)) table key)) -(define (hash-table/clean! table) - (guarantee hash-table? table 'hash-table/clean!) +(define (hash-table-clean! table) + (guarantee hash-table? table 'hash-table-clean!) (without-interruption (lambda () ((table-type-method:clean! (table-type table)) table) (maybe-shrink-table! table)))) -(define (hash-table/for-each table procedure) +(define (hash-table-walk table procedure) ;; It's difficult to make this more efficient because PROCEDURE is ;; allowed to delete the entry from the table, and if the table is ;; resized while being examined we'll lose our place. @@ -183,31 +198,36 @@ USA. (define (hash-table->alist table) (guarantee hash-table? table 'hash-table->alist) - (%hash-table-fold table - (lambda (key datum alist) (cons (cons key datum) alist)) - '())) - -(define (hash-table/key-list table) - (guarantee hash-table? table 'hash-table/key-list) - (%hash-table-fold table - (lambda (key datum alist) datum (cons key alist)) - '())) - -(define (hash-table/datum-list table) - (guarantee hash-table? table 'hash-table/datum-list) - (%hash-table-fold table - (lambda (key datum alist) key (cons datum alist)) - '())) - -(define (%hash-table-fold table procedure initial-value) + (hash-table-fold table + (lambda (key datum alist) + (cons (cons key datum) alist)) + '())) + +(define (hash-table-keys table) + (guarantee hash-table? table 'hash-table-keys) + (hash-table-fold table + (lambda (key datum keys) + (declare (ignore datum)) + (cons key keys)) + '())) + +(define (hash-table-values table) + (guarantee hash-table? table 'hash-table-values) + (hash-table-fold table + (lambda (key datum values) + (declare (ignore key)) + (cons datum values)) + '())) + +(define (hash-table-fold table procedure initial-value) ((table-type-method:fold (table-type table)) table procedure initial-value)) -(define (hash-table/rehash-threshold table) - (guarantee hash-table? table 'hash-table/rehash-threshold) +(define (hash-table-rehash-threshold table) + (guarantee hash-table? table 'hash-table-rehash-threshold) (table-rehash-threshold table)) -(define (set-hash-table/rehash-threshold! table threshold) - (guarantee hash-table? table 'set-hash-table/rehash-threshold!) +(define (set-hash-table-rehash-threshold! table threshold) + (guarantee hash-table? table 'set-hash-table-rehash-threshold!) (let ((threshold (check-arg threshold default-rehash-threshold @@ -216,18 +236,18 @@ USA. (< 0 x) (<= x 1))) "real number between 0 (exclusive) and 1 (inclusive)" - 'set-hash-table/rehash-threshold!))) + 'set-hash-table-rehash-threshold!))) (without-interruption (lambda () (set-table-rehash-threshold! table threshold) (new-size! table (table-grow-size table)))))) -(define (hash-table/rehash-size table) - (guarantee hash-table? table 'hash-table/rehash-size) +(define (hash-table-rehash-size table) + (guarantee hash-table? table 'hash-table-rehash-size) (table-rehash-size table)) -(define (set-hash-table/rehash-size! table size) - (guarantee hash-table? table 'set-hash-table/rehash-size!) +(define (set-hash-table-rehash-size! table size) + (guarantee hash-table? table 'set-hash-table-rehash-size!) (let ((size (check-arg size default-rehash-size @@ -236,15 +256,15 @@ USA. ((real? x) (< 1 x)) (else #f))) "real number > 1 or exact integer >= 1" - 'set-hash-table/rehash-size!))) + 'set-hash-table-rehash-size!))) (without-interruption (lambda () (set-table-rehash-size! table size) (reset-shrink-size! table) (maybe-shrink-table! table))))) -(define (hash-table/count table) - (guarantee hash-table? table 'hash-table/count) +(define (hash-table-size table) + (guarantee hash-table? table 'hash-table-size) (let loop () (let ((count (table-count table))) (if (table-needs-rehash? table) @@ -253,12 +273,16 @@ USA. (loop)) count)))) -(define (hash-table/size table) - (guarantee hash-table? table 'hash-table/size) +(define (hash-table-grow-size table) + (guarantee hash-table? table 'hash-table-grow-size) (table-grow-size table)) -(define (hash-table/clear! table) - (guarantee hash-table? table 'hash-table/clear!) +(define (hash-table-shrink-size table) + (guarantee hash-table? table 'hash-table-shrink-size) + (table-shrink-size table)) + +(define (hash-table-clear! table) + (guarantee hash-table? table 'hash-table-clear!) (without-interruption (lambda () (if (not (table-initial-size-in-effect? table)) @@ -616,7 +640,7 @@ USA. (define (make-method:get compute-hash! key=? entry-type) (declare (integrate-operator compute-hash! key=? entry-type)) - (define (method:get table key default) + (define (method:get table key get-default) (let ((hash (compute-hash! table key))) ;; Call COMPUTE-HASH! before TABLE-BUCKETS, because computing the ;; hash might trigger rehashing which replaces the bucket vector. @@ -627,7 +651,7 @@ USA. (declare (integrate key* datum) (ignore barrier)) (if (key=? key* key) datum (loop (cdr p)))) (lambda () (loop (cdr p)))) - default)))) + (get-default))))) method:get) (define (make-method:put! compute-hash! key=? entry-type) @@ -659,7 +683,7 @@ USA. (define (make-method:modify! compute-hash! key=? entry-type) (declare (integrate-operator compute-hash! key=? entry-type)) - (define (method:modify! table key default procedure) + (define (method:modify! table key get-default procedure) (let restart ((has-value? #f) (value #f)) (let ((hash (compute-hash! table key))) (let loop ((p (vector-ref (table-buckets table) hash)) (q #f)) @@ -682,7 +706,7 @@ USA. ;; loop, and if there's still no entry, we can then safely add the ;; previously computed value. (if (not has-value?) - (restart #t (procedure default)) + (restart #t (procedure (get-default))) (begin (without-interruption (lambda () @@ -1076,19 +1100,18 @@ USA. (define (make-hash-table* key-hash key=? rehash-after-gc? entry-type #!optional initial-size) - ((hash-table/constructor key-hash key=? rehash-after-gc? entry-type) + ((hash-table-constructor + (make-hash-table-type key-hash key=? rehash-after-gc? entry-type)) initial-size)) -(define (hash-table/constructor key-hash key=? rehash-after-gc? entry-type) - (hash-table-constructor - (make-hash-table-type key-hash key=? rehash-after-gc? entry-type))) - (define (make-hash-table-type key-hash key=? rehash-after-gc? entry-type) - (hash-table/intern! (follow-memo-crap key-hash key=? rehash-after-gc?) + (hash-table-intern! (follow-memo-crap key-hash key=? rehash-after-gc?) entry-type (lambda () (let ((constructor - (hash-table/get hash-table-type-constructors entry-type #f))) + (hash-table-ref/default hash-table-type-constructors + entry-type + #f))) (if constructor (constructor key-hash key=? rehash-after-gc?) (%make-hash-table-type key-hash key=? rehash-after-gc? @@ -1097,10 +1120,10 @@ USA. (define (memoize-hash-table-type! key-hash key=? rehash-after-gc? entry-type type) (let ((crap (follow-memo-crap key-hash key=? rehash-after-gc?))) - (cond ((hash-table/get crap entry-type #f) + (cond ((hash-table-ref/default crap entry-type #f) => (lambda (type*) (warn "Replacing memoized hash table type:" type type*)))) - (hash-table/put! crap entry-type type))) + (hash-table-set! crap entry-type type))) (define (follow-memo-crap key-hash key=? rehash-after-gc?) (define (intern-car! pair generator) @@ -1108,8 +1131,8 @@ USA. (define (intern-cdr! pair generator) (or (cdr pair) (let ((v (generator))) (set-cdr! pair v) v))) ((if rehash-after-gc? intern-car! intern-cdr!) - (hash-table/intern! - (hash-table/intern! memoized-hash-table-types + (hash-table-intern! + (hash-table-intern! memoized-hash-table-types key-hash make-key-ephemeral-eq-hash-table) key=? @@ -1167,7 +1190,7 @@ USA. entry-type)))) (define-integrableish (open-type-constructor! entry-type) - (hash-table/put! hash-table-type-constructors + (hash-table-set! hash-table-type-constructors entry-type (open-type-constructor entry-type))) @@ -1271,6 +1294,10 @@ USA. ;;;; Compatibility with SRFI 69 and older MIT Scheme +(define (hash-table/constructor key-hash key=? rehash-after-gc? entry-type) + (hash-table-constructor + (make-hash-table-type key-hash key=? rehash-after-gc? entry-type))) + (define (strong-hash-table/constructor key-hash key=? #!optional rehash-after-gc?) (hash-table/constructor key-hash @@ -1289,29 +1316,29 @@ USA. rehash-after-gc?) hash-table-entry-type:key-weak)) -(define (make-hash-table #!optional key=? key-hash initial-size) - (%make-hash-table (custom-table-type - (if (default-object? key=?) equal? key=?) - (if (default-object? key-hash) equal-hash-mod key-hash)) - initial-size)) +(define (make-hash-table #!optional key=? key-hash . args) + (declare (ignore args)) + (%make-hash-table + (custom-table-type (if (default-object? key=?) equal? key=?) + key-hash) + (default-object))) (define (custom-table-type key=? key-hash) - (make-hash-table-type key-hash + (make-hash-table-type (if (default-object? key-hash) + (equality-predicate-hasher key=?) + key-hash) key=? - (if (and (or (eq? key=? string=?) - (eq? key=? string-ci=?)) - (or (eq? key-hash string-hash) - (eq? key-hash string-hash-ci) - (eq? key-hash hash))) + (if (or (eq? key=? string=?) + (eq? key=? string-ci=?)) #f ;No rehash needed after GC #t) ;Rehash needed after GC hash-table-entry-type:strong)) -(define (alist->hash-table alist #!optional key=? key-hash) +(define (alist->hash-table alist #!optional key=? key-hash . args) (guarantee alist? alist 'alist->hash-table) - (let ((table (make-hash-table key=? key-hash))) + (let ((table (apply make-hash-table key=? key-hash args))) (for-each (lambda (p) - (hash-table/put! table (car p) (cdr p))) + (hash-table-set! table (car p) (cdr p))) alist) table)) @@ -1330,32 +1357,14 @@ USA. (equal-hash key) (equal-hash-mod key modulus))) -(define (hash-table-exists? table key) - (not (eq? (hash-table/get table key default-marker) default-marker))) - -(define (hash-table-ref table key #!optional get-default) - (let ((datum (hash-table/get table key default-marker))) +(define (hash-table/lookup table key if-found if-not-found) + (let ((datum (hash-table-ref/default table key default-marker))) (if (eq? datum default-marker) - (begin - (if (default-object? get-default) - (error:bad-range-argument key 'hash-table-ref)) - (get-default)) - datum))) - -(define (hash-table-update! table key procedure #!optional get-default) - (hash-table-set! - table - key - (procedure - (hash-table-ref table - key - (if (default-object? get-default) - (lambda () - (error:bad-range-argument key 'hash-table-update!)) - get-default))))) + (if-not-found) + (if-found datum)))) -(define (hash-table-update!/default table key procedure default) - (hash-table-update! table key procedure (lambda () default))) +(define (hash-table/modify! table key default procedure) + (hash-table-update!/default table key procedure default)) (define (hash-table-copy table) (guarantee hash-table? table 'hash-table-copy) @@ -1374,17 +1383,12 @@ USA. (guarantee hash-table? table1 'hash-table-merge!) (guarantee hash-table? table2 'hash-table-merge!) (if (not (eq? table2 table1)) - (%hash-table-fold table2 - (lambda (key datum ignore) - ignore - (hash-table/put! table1 key datum)) - unspecific)) + (hash-table-fold table2 + (lambda (key datum ignore) + ignore + (hash-table-set! table1 key datum)) + unspecific)) table1) - -(define (hash-table-fold table procedure initial-value) - (fold (lambda (p v) (procedure (car p) (cdr p) v)) - initial-value - (hash-table->alist table))) ;;;; Miscellany @@ -1399,20 +1403,22 @@ USA. (list 'default-marker)) (define equality-predicate?) -(define maybe-get-equality-predicate-hasher) +(define get-equality-predicate-hasher) (define %set-equality-predicate-hasher!) (add-boot-init! (lambda () (let ((table (make-hashed-metadata-table))) (set! equality-predicate? (table 'has?)) - (set! maybe-get-equality-predicate-hasher (table 'get-if-available)) + (set! get-equality-predicate-hasher (table 'get)) (set! %set-equality-predicate-hasher! (table 'put!))) (set-equality-predicate-hasher! eq? hash-by-identity) (set-equality-predicate-hasher! eqv? hash-by-eqv) - (set-equality-predicate-hasher! equal? hash-by-equal))) + (set-equality-predicate-hasher! equal? hash-by-equal) + (set-equality-predicate-hasher! string=? string-hash) + (set-equality-predicate-hasher! string-ci=? string-ci-hash))) (define (equality-predicate-hasher equality-predicate) - (let ((hasher (maybe-get-equality-predicate-hasher equality-predicate #f))) + (let ((hasher (get-equality-predicate-hasher equality-predicate #f))) (if (not hasher) (error:not-a equality-predicate? equality-predicate diff --git a/src/runtime/hash.scm b/src/runtime/hash.scm index 77969b6b5..ed0967372 100644 --- a/src/runtime/hash.scm +++ b/src/runtime/hash.scm @@ -50,8 +50,9 @@ USA. (define (initialize-package!) (set! make-datum-weak-eq-hash-table - (hash-table/constructor eq-hash-mod eq? #f - hash-table-entry-type:datum-weak)) + (hash-table-constructor + (make-hash-table-type eq-hash-mod eq? #f + hash-table-entry-type:datum-weak))) (set! default-hash-table (hash-table/make))) (define-structure (hash-table @@ -116,15 +117,18 @@ USA. (insert? (or (default-object? insert?) insert?))) (with-thread-mutex-lock (hash-table/mutex table) (lambda () - (let ((number (hash-table/get (hash-table/hash-table table) object #f))) + (let ((number + (hash-table-ref/default (hash-table/hash-table table) + object + #f))) (if (not number) (if insert? (let ((hashtb (hash-table/hash-table table)) (unhashtb (hash-table/unhash-table table)) (next (hash-table/next-number table))) (set-hash-table/next-number! table (1+ next)) - (hash-table/put! unhashtb next object) - (hash-table/put! hashtb object next) + (hash-table-set! unhashtb next object) + (hash-table-set! hashtb object next) next) number) number)))))) @@ -141,4 +145,4 @@ USA. table)))) (with-thread-mutex-lock (hash-table/mutex table) (lambda () - (hash-table/get (hash-table/unhash-table table) number #f))))) \ No newline at end of file + (hash-table-ref/default (hash-table/unhash-table table) number #f))))) \ No newline at end of file diff --git a/src/runtime/host-adapter.scm b/src/runtime/host-adapter.scm index 73066297d..8e70e3025 100644 --- a/src/runtime/host-adapter.scm +++ b/src/runtime/host-adapter.scm @@ -74,6 +74,12 @@ USA. (provide-rename env 'lambda-tag:let 'scode-lambda-name:let) (provide-rename env 'lambda-tag:fluid-let 'scode-lambda-name:fluid-let) + (if (unbound? env 'hash-table-constructor) + (link-variables env + 'hash-table-constructor + (->environment '(runtime hash-table)) + 'hash-table-constructor)) + (for-each (lambda (old-name) (provide-rename env old-name (symbol 'scode- old-name))) '(access-environment diff --git a/src/runtime/memoizer.scm b/src/runtime/memoizer.scm index 032edceeb..fa2a15311 100644 --- a/src/runtime/memoizer.scm +++ b/src/runtime/memoizer.scm @@ -54,14 +54,14 @@ USA. (%memoizer-metadata-procedure (apply-hook-extra memoizer))) (define (clear-memoizer! memoizer) - (hash-table/clear! (memoizer-table memoizer))) + (hash-table-clear! (memoizer-table memoizer))) (define (weak-eqv-memoizer get-key get-datum) (let ((table (make-key-weak-eqv-hash-table))) (make-memoizer table get-datum (lambda args - (hash-table/intern! table + (hash-table-intern! table (apply get-key args) (lambda () (apply get-datum args))))))) @@ -88,7 +88,7 @@ USA. (if dedup? (delete-duplicates list elt=) list))) - (hash-table/intern! table + (hash-table-intern! table (get-key list) (lambda () (get-datum list)))))))))) diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg index 3cd936ae7..7927be55b 100644 --- a/src/runtime/runtime.pkg +++ b/src/runtime/runtime.pkg @@ -989,7 +989,7 @@ USA. (files "string") (parent (runtime)) (export () deprecated:string - (string-ci-hash string-hash-ci) + (string-hash-ci string-ci-hash) (string-hash-mod string-hash) (substring->list string->list) (substring-move-left! substring-move!) @@ -1064,8 +1064,8 @@ USA. string-foldcase string-for-each string-for-primitive ;export to (runtime) after 9.3 - string-hash - string-hash-ci + string-hash ;SRFI-69 + string-ci-hash ;SRFI-69 string-head string-immutable? string-in-nfc? @@ -2372,20 +2372,32 @@ USA. (parent (runtime)) (import (runtime population) add-to-population!/unsafe) + (export () deprecated:hash-table + (hash-table/clear! hash-table-clear!) + (hash-table/clean! hash-table-clean!) + (hash-table/count hash-table-size) + (hash-table/datum-list hash-table-values) + (hash-table/for-each hash-table-walk) + (hash-table/get hash-table-ref/default) + (hash-table/intern! hash-table-intern!) + (hash-table/key-hash hash-table-hash-function) + (hash-table/key-list hash-table-keys) + (hash-table/key=? hash-table-equivalence-function) + (hash-table/put! hash-table-set!) + (hash-table/rehash-size hash-table-rehash-size) + (hash-table/rehash-threshold hash-table-rehash-threshold) + (hash-table/remove! hash-table-delete!) + (hash-table/size! hash-table-grow-size) + (hash-table/type hash-table-type) + (set-hash-table/rehash-size! set-hash-table-rehash-size!) + (set-hash-table/rehash-threshold! set-hash-table-rehash-threshold!) + hash-table/constructor + hash-table/modify! + strong-hash-table/constructor + weak-hash-table/constructor) (export () (eq-hash-table-type key-weak-eq-hash-table-type) (eqv-hash-table-type key-weak-eqv-hash-table-type) - (hash-table-clear! hash-table/clear!) - (hash-table-delete! hash-table/remove!) - (hash-table-equivalence-function hash-table/key=?) - (hash-table-hash-function hash-table/key-hash) - (hash-table-intern! hash-table/intern!) - (hash-table-keys hash-table/key-list) - (hash-table-ref/default hash-table/get) - (hash-table-set! hash-table/put!) - (hash-table-size hash-table/count) - (hash-table-values hash-table/datum-list) - (hash-table-walk hash-table/for-each) (make-eq-hash-table make-key-weak-eq-hash-table) (make-eqv-hash-table make-key-weak-eqv-hash-table) (make-object-hash-table make-key-weak-eqv-hash-table) @@ -2394,7 +2406,7 @@ USA. (make-weak-eqv-hash-table make-key-weak-eqv-hash-table) (weak-eq-hash-table-type key-weak-eq-hash-table-type) (weak-eqv-hash-table-type key-weak-eqv-hash-table-type) - alist->hash-table + alist->hash-table ;SRFI-69 eq-hash eq-hash-mod equal-hash @@ -2404,9 +2416,13 @@ USA. equality-predicate? eqv-hash eqv-hash-mod - hash-by-identity - hash-table->alist - hash-table-copy + hash-by-identity ;SRFI-69 + hash-table->alist ;SRFI-69 + hash-table-clean! + hash-table-clear! ;SRFI-69 + hash-table-constructor + hash-table-copy ;SRFI-69 + hash-table-delete! ;SRFI-69 hash-table-entry-type:datum-ephemeral hash-table-entry-type:datum-weak hash-table-entry-type:key&datum-ephemeral @@ -2414,33 +2430,29 @@ USA. hash-table-entry-type:key-weak hash-table-entry-type:key/datum-weak hash-table-entry-type:strong - hash-table-exists? - hash-table-fold - hash-table-merge! - hash-table-ref + hash-table-equivalence-function ;SRFI-69 + hash-table-exists? ;SRFI-69 + hash-table-fold ;SRFI-69 + hash-table-grow-size + hash-table-hash-function ;SRFI-69 + hash-table-intern! + hash-table-keys ;SRFI-69 + hash-table-merge! ;SRFI-69 + hash-table-ref ;SRFI-69 + hash-table-ref/default ;SRFI-69 + hash-table-rehash-size + hash-table-rehash-threshold + hash-table-set! ;SRFI-69 + hash-table-shrink-size + hash-table-size ;SRFI-69 + hash-table-type hash-table-type? - hash-table-update! - hash-table-update!/default - hash-table/clean! - hash-table/clear! - hash-table/constructor - hash-table/count - hash-table/datum-list - hash-table/for-each - hash-table/get - hash-table/intern! - hash-table/key-hash - hash-table/key-list - hash-table/key=? + hash-table-update! ;SRFI-69 + hash-table-update!/default ;SRFI-69 + hash-table-values ;SRFI-69 + hash-table-walk ;SRFI-69 hash-table/lookup - hash-table/modify! - hash-table/put! - hash-table/rehash-size - hash-table/rehash-threshold - hash-table/remove! - hash-table/size - hash-table/type - hash-table? + hash-table? ;SRFI-69 key-ephemeral-eq-hash-table-type key-ephemeral-eqv-hash-table-type key-weak-eq-hash-table-type @@ -2459,13 +2471,11 @@ USA. make-strong-eqv-hash-table non-pointer-hash-table-type set-equality-predicate-hasher! - set-hash-table/rehash-size! - set-hash-table/rehash-threshold! + set-hash-table-rehash-size! + set-hash-table-rehash-threshold! string-hash-table-type strong-eq-hash-table-type - strong-eqv-hash-table-type - strong-hash-table/constructor - weak-hash-table/constructor)) + strong-eqv-hash-table-type)) (define-package (runtime memoizer) (files "memoizer") diff --git a/src/runtime/sfile.scm b/src/runtime/sfile.scm index d8dd5f74d..60e8618e4 100644 --- a/src/runtime/sfile.scm +++ b/src/runtime/sfile.scm @@ -282,7 +282,7 @@ USA. (define (pathname-type->mime-type type) (and (string? type) - (let ((mime-type (hash-table/get local-type-map type #f))) + (let ((mime-type (hash-table-ref/default local-type-map type #f))) (if mime-type (and (mime-type? mime-type) mime-type) @@ -293,11 +293,11 @@ USA. (define (associate-pathname-type-with-mime-type type mime-type) (guarantee string? type 'associate-pathname-type-with-mime-type) (guarantee mime-type? mime-type 'associate-pathname-type-with-mime-type) - (hash-table/put! local-type-map type mime-type)) + (hash-table-set! local-type-map type mime-type)) (define (disassociate-pathname-type-from-mime-type type) (guarantee string? type 'disassociate-pathname-type-from-mime-type) - (hash-table/put! local-type-map type 'disassociated)) + (hash-table-set! local-type-map type 'disassociated)) (define-record-type (%%make-mime-type top-level subtype) @@ -316,11 +316,11 @@ USA. (let loop ((i 0)) (if (fix:< i e) (if (eq? (vector-ref top-level-mime-types i) top-level) - (hash-table/intern! (vector-ref interned-mime-types i) + (hash-table-intern! (vector-ref interned-mime-types i) subtype new) (loop (fix:+ i 1))) - (hash-table/intern! unusual-interned-mime-types + (hash-table-intern! unusual-interned-mime-types (cons top-level subtype) new))))) diff --git a/src/runtime/stack-sample.scm b/src/runtime/stack-sample.scm index 73f497521..e14898c1d 100644 --- a/src/runtime/stack-sample.scm +++ b/src/runtime/stack-sample.scm @@ -260,7 +260,7 @@ (if (compiled-closure? return-address) (compiled-closure->entry return-address) return-address))) - (hash-table/intern! (profile.entries profile) return-address + (hash-table-intern! (profile.entries profile) return-address (lambda () (receive (expression environment subexpression) (stack-frame/debugging-info stack-frame) @@ -287,7 +287,7 @@ value)) (define (display-profile profile output-port) - (let ((entries (hash-table/datum-list (profile.entries profile)))) + (let ((entries (hash-table-values (profile.entries profile)))) (define (sortem entry.count) (sort (remove (lambda (e) (zero? (entry.count e))) entries) diff --git a/src/runtime/string.scm b/src/runtime/string.scm index e8be16c38..ba1916cce 100644 --- a/src/runtime/string.scm +++ b/src/runtime/string.scm @@ -2050,7 +2050,7 @@ USA. ((ucode-primitive string-hash) string*) ((ucode-primitive string-hash-mod) string* modulus)))) -(define (string-hash-ci string #!optional modulus) +(define (string-ci-hash string #!optional modulus) (string-hash (string-foldcase string) modulus)) (define (8-bit-string? object) diff --git a/src/runtime/swank.scm b/src/runtime/swank.scm index 37f44c712..45dc1c87a 100644 --- a/src/runtime/swank.scm +++ b/src/runtime/swank.scm @@ -932,8 +932,8 @@ swank:xref 0 500))) (define (assign-index o parts) - (let ((i (hash-table/count parts))) - (hash-table/put! parts i o) + (let ((i (hash-table-size parts))) + (hash-table-set! parts i o) i)) (define (prepare-range parts content from to) @@ -961,7 +961,8 @@ swank:xref (define (swank:inspect-nth-part socket index) socket - (inspect-object (hash-table/get (istate-parts istate) index 'no-such-part))) + (inspect-object + (hash-table-ref/default (istate-parts istate) index 'no-such-part))) (define (swank:quit-inspector socket) socket diff --git a/src/runtime/syntax-rename.scm b/src/runtime/syntax-rename.scm index 0ba38203b..db08a188d 100644 --- a/src/runtime/syntax-rename.scm +++ b/src/runtime/syntax-rename.scm @@ -95,7 +95,7 @@ USA. n)) (define (lookup-rename rename) - (hash-table/get unmapping-table rename #f)) + (hash-table-ref/default unmapping-table rename #f)) (make-rename-db identifier-renamer lookup-rename))) @@ -111,7 +111,7 @@ USA. (let ((safe-set (make-strong-eq-hash-table))) (compute-substitution expression (lambda (rename original) - (hash-table/put! safe-set rename original))) + (hash-table-set! safe-set rename original))) (alpha-substitute (make-final-substitution safe-set) expression))) (define (mark-local-bindings bound body mark-safe!) @@ -161,7 +161,7 @@ USA. finalized))))) (lambda (rename) - (or (hash-table/get safe-set rename #f) + (or (hash-table-ref/default safe-set rename #f) (finalize-renamed-identifier rename))))) ;;;; Compute substitution diff --git a/src/runtime/unxprm.scm b/src/runtime/unxprm.scm index ec76207de..4844b0b7d 100644 --- a/src/runtime/unxprm.scm +++ b/src/runtime/unxprm.scm @@ -164,12 +164,12 @@ USA. (define (get-environment-variable name) (guarantee string? name 'get-environment-variable) - (let ((value (hash-table/get environment-variables name 'none))) + (let ((value (hash-table-ref/default environment-variables name 'none))) (if (eq? value 'none) (let ((value ((ucode-primitive get-environment-variable 1) (string-for-primitive name)))) - (hash-table/put! environment-variables name value) + (hash-table-set! environment-variables name value) value) value))) @@ -177,14 +177,14 @@ USA. (guarantee string? name 'set-environment-variable!) (if value (guarantee string? value 'set-environment-variable!)) - (hash-table/put! environment-variables name value)) + (hash-table-set! environment-variables name value)) (define (delete-environment-variable! name) (guarantee string? name 'delete-environment-variable!) - (hash-table/remove! environment-variables name)) + (hash-table-delete! environment-variables name)) (define (reset-environment-variables!) - (hash-table/clear! environment-variables)) + (hash-table-clear! environment-variables)) (define (initialize-system-primitives!) (set! environment-variables (make-string-hash-table)) @@ -194,7 +194,7 @@ USA. (define (os/suffix-mime-type suffix) (import-mime-types) - (hash-table/get mime-types suffix #f)) + (hash-table-ref/default mime-types suffix #f)) (define (initialize-mime-types!) (set! mime-types (make-string-hash-table)) @@ -217,13 +217,13 @@ USA. changed?)) (with-thread-events-blocked (lambda () - (hash-table/clear! mime-types) + (hash-table-clear! mime-types) (for-each-vector-element mime.types-files (lambda (p) (for-each (lambda (entry) (let ((type (car entry))) (for-each (lambda (suffix) - (hash-table/put! mime-types + (hash-table-set! mime-types suffix type)) (cdr entry)))) diff --git a/src/runtime/url.scm b/src/runtime/url.scm index 3a2ca8b89..de9207574 100644 --- a/src/runtime/url.scm +++ b/src/runtime/url.scm @@ -55,7 +55,7 @@ USA. (call-with-output-string (lambda (port) (%write-uri scheme authority path query fragment port))))) - (hash-table/intern! interned-uris string + (hash-table-intern! interned-uris string (lambda () (%make-uri scheme authority path query fragment string)))))) @@ -128,7 +128,7 @@ USA. (if userinfo (guarantee uri-userinfo? userinfo 'make-uri-authority)) (guarantee uri-host? host 'make-uri-authority) (if port (guarantee uri-port? port 'make-uri-authority)) - (hash-table/intern! interned-uri-authorities + (hash-table-intern! interned-uri-authorities (call-with-output-string (lambda (output) (%write-authority userinfo host port output))) @@ -307,7 +307,7 @@ USA. #f))))) (do-string (lambda (string) - (or (hash-table/get interned-uris string #f) + (or (hash-table-ref/default interned-uris string #f) (do-parse string))))) (cond ((uri? object) (if (predicate object) @@ -336,7 +336,7 @@ USA. (or (and (string? string) (default-object? start) (default-object? end) - (hash-table/get interned-uris string #f)) + (hash-table-ref/default interned-uris string #f)) (let ((v (*parse-string parser string start end))) (and v (vector-ref v 0))) diff --git a/src/sos/class.scm b/src/sos/class.scm index 52ae781dd..76cbd1179 100644 --- a/src/sos/class.scm +++ b/src/sos/class.scm @@ -348,10 +348,10 @@ USA. (define (dispatch-tag->class tag) (cond ((class-tag? tag) (dispatch-tag-extra-ref tag 0)) - ((hash-table/get built-in-class-table tag #f)) + ((hash-table-ref/default built-in-class-table tag #f)) ((record-type? tag) (let ((class (make-record-type-class tag))) - (hash-table/put! built-in-class-table tag class) + (hash-table-set! built-in-class-table tag class) class)) (else ))) @@ -381,7 +381,7 @@ USA. (let ((assign-type (lambda (predicate class) - (hash-table/put! built-in-class-table + (hash-table-set! built-in-class-table (predicate->dispatch-tag predicate) class)))) (assign-type boolean? ) diff --git a/src/ssp/mod-lisp.scm b/src/ssp/mod-lisp.scm index ccce2e8a9..059793ab0 100644 --- a/src/ssp/mod-lisp.scm +++ b/src/ssp/mod-lisp.scm @@ -634,7 +634,7 @@ USA. (define (file-content-type pathname) (or (let ((extension (pathname-type pathname))) (and (string? extension) - (hash-table/get mime-extensions extension #f))) + (hash-table-ref/default mime-extensions extension #f))) (let ((t (pathname-mime-type pathname))) (and t (symbol (mime-type/top-level t) @@ -642,17 +642,17 @@ USA. (mime-type/subtype t)))))) (define (get-mime-handler type) - (hash-table/get mime-handlers type #f)) + (hash-table-ref/default mime-handlers type #f)) (define (define-mime-handler type handle-request) (cond ((symbol? type) - (hash-table/put! mime-handlers type handle-request)) + (hash-table-set! mime-handlers type handle-request)) ((and (pair? type) (symbol? (car type)) (every string? (cdr type))) - (hash-table/put! mime-handlers (car type) handle-request) + (hash-table-set! mime-handlers (car type) handle-request) (for-each (lambda (extension) - (hash-table/put! mime-extensions extension (car type))) + (hash-table-set! mime-extensions extension (car type))) (cdr type))) (else (error:wrong-type-argument type "MIME type" 'DEFINE-MIME-HANDLER)))) diff --git a/src/ssp/xhtml-expander.scm b/src/ssp/xhtml-expander.scm index b63a821d5..5d5820c18 100644 --- a/src/ssp/xhtml-expander.scm +++ b/src/ssp/xhtml-expander.scm @@ -115,10 +115,10 @@ USA. (get-sabbr (intern (string-trim text)))) (define (define-sabbr name expansion) - (hash-table/put! *sabbr-table* name (flatten expansion))) + (hash-table-set! *sabbr-table* name (flatten expansion))) (define (get-sabbr name) - (let ((expansion (hash-table/get *sabbr-table* name 'NO-EXPANSION))) + (let ((expansion (hash-table-ref/default *sabbr-table* name 'NO-EXPANSION))) (if (eq? expansion 'NO-EXPANSION) (error "Invalid sabbr name:" name)) expansion)) diff --git a/src/ssp/xmlrpc.scm b/src/ssp/xmlrpc.scm index cd3f02189..d2ff0b4d9 100644 --- a/src/ssp/xmlrpc.scm +++ b/src/ssp/xmlrpc.scm @@ -62,8 +62,8 @@ USA. (let ((environment (make-expansion-environment pathname))) (environment-define environment 'define-xmlrpc-method (lambda (name handler) - (hash-table/put! methods name handler))) + (hash-table-set! methods name handler))) (parameterize* (list (cons param:suppress-loading-message? #t)) (lambda () (load pathname environment)))) - (hash-table/get methods name #f))) \ No newline at end of file + (hash-table-ref/default methods name #f))) \ No newline at end of file diff --git a/src/star-parser/matcher.scm b/src/star-parser/matcher.scm index e1e05266e..01122a42f 100644 --- a/src/star-parser/matcher.scm +++ b/src/star-parser/matcher.scm @@ -78,7 +78,7 @@ USA. (if (pair? name) (for-each (lambda (name) (define-matcher-preprocessor name procedure)) name) - (hash-table/put! matcher-preprocessors name procedure)) + (hash-table-set! matcher-preprocessors name procedure)) name) (define-syntax define-*matcher-macro @@ -108,7 +108,7 @@ USA. (define (matcher-preprocessor name) (or (lookup-matcher-macro name) - (hash-table/get matcher-preprocessors name #f))) + (hash-table-ref/default matcher-preprocessors name #f))) (define matcher-preprocessors (make-strong-eq-hash-table)) @@ -245,7 +245,7 @@ USA. (cond ((and (pair? expression) (symbol? (car expression)) (list? (cdr expression)) - (hash-table/get matcher-compilers (car expression) #f)) + (hash-table-ref/default matcher-compilers (car expression) #f)) => (lambda (entry) (let ((arity (car entry)) (compiler (cdr entry))) @@ -285,7 +285,7 @@ USA. (ill-formed-syntax form))))) (define (define-matcher-compiler keyword arity compiler) - (hash-table/put! matcher-compilers keyword (cons arity compiler)) + (hash-table-set! matcher-compilers keyword (cons arity compiler)) keyword) (define matcher-compilers diff --git a/src/star-parser/parser.scm b/src/star-parser/parser.scm index 13f9d61f2..278b9876c 100644 --- a/src/star-parser/parser.scm +++ b/src/star-parser/parser.scm @@ -75,7 +75,7 @@ USA. (if (pair? name) (for-each (lambda (name) (define-parser-preprocessor name procedure)) name) - (hash-table/put! parser-preprocessors name procedure)) + (hash-table-set! parser-preprocessors name procedure)) name) (define-syntax define-*parser-macro @@ -105,7 +105,7 @@ USA. (define (parser-preprocessor name) (or (lookup-parser-macro name) - (hash-table/get parser-preprocessors name #f))) + (hash-table-ref/default parser-preprocessors name #f))) (define parser-preprocessors (make-strong-eq-hash-table)) @@ -227,7 +227,7 @@ USA. (cond ((and (pair? expression) (symbol? (car expression)) (list? (cdr expression)) - (hash-table/get parser-compilers (car expression) #f)) + (hash-table-ref/default parser-compilers (car expression) #f)) => (lambda (entry) (let ((arity (car entry)) (compiler (cdr entry))) @@ -269,7 +269,7 @@ USA. (ill-formed-syntax form))))) (define (define-parser-compiler keyword arity compiler) - (hash-table/put! parser-compilers keyword (cons arity compiler)) + (hash-table-set! parser-compilers keyword (cons arity compiler)) keyword) (define parser-compilers diff --git a/src/star-parser/shared.scm b/src/star-parser/shared.scm index 719e5dd22..090141904 100644 --- a/src/star-parser/shared.scm +++ b/src/star-parser/shared.scm @@ -167,21 +167,21 @@ USA. (make-strong-eq-hash-table))) (define (define-matcher-macro name expander) - (hash-table/put! (matcher-macros-table *parser-macros*) name expander)) + (hash-table-set! (matcher-macros-table *parser-macros*) name expander)) (define (lookup-matcher-macro name) (let loop ((environment *parser-macros*)) (and environment - (or (hash-table/get (matcher-macros-table environment) name #f) + (or (hash-table-ref/default (matcher-macros-table environment) name #f) (loop (parent-macros environment)))))) (define (define-parser-macro name expander) - (hash-table/put! (parser-macros-table *parser-macros*) name expander)) + (hash-table-set! (parser-macros-table *parser-macros*) name expander)) (define (lookup-parser-macro name) (let loop ((environment *parser-macros*)) (and environment - (or (hash-table/get (parser-macros-table environment) name #f) + (or (hash-table-ref/default (parser-macros-table environment) name #f) (loop (parent-macros environment)))))) (define (with-current-parser-macros macros thunk) diff --git a/src/win32/win_ffi.scm b/src/win32/win_ffi.scm index e648880f1..e403e2ce0 100644 --- a/src/win32/win_ffi.scm +++ b/src/win32/win_ffi.scm @@ -146,7 +146,8 @@ USA. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (define make-integer-hash-table - (strong-hash-table/constructor modulo int:= #f)) + (hash-table-constructor + (make-hash-table-type modulo int:= #f hash-table-entry-type:strong))) (define (initialize-wndproc-registry) (set! wndproc-registry (make-integer-hash-table))) @@ -162,10 +163,10 @@ USA. (cond (newproc => (lambda (theproc) (set! newproc #F) - (hash-table/put! wndproc-registry hwnd theproc) + (hash-table-set! wndproc-registry hwnd theproc) (set-interrupt-enables! mask) (theproc hwnd message wparam lparam))) - ((hash-table/get wndproc-registry hwnd #f) + ((hash-table-ref/default wndproc-registry hwnd #f) => (lambda (wndproc) (wndproc hwnd message wparam lparam))) (else @@ -191,11 +192,11 @@ USA. ;; As a temporary measure we check to see if the windows still exist every GC (define (wndproc-registry-cleaner) - (hash-table/for-each wndproc-registry + (hash-table-walk wndproc-registry (lambda (hwnd wndproc) wndproc ; ignored (if (not (is-window? hwnd)) - (hash-table/remove! wndproc-registry hwnd))))) + (hash-table-delete! wndproc-registry hwnd))))) ;; Applications should use DEFAULT-SCHEME-WNDPROC rather than DEF-WINDOW-PROC ;; so that we can hook in behaviour for all scheme windows. @@ -209,12 +210,12 @@ USA. (C-proc (get-window-long hwnd GWL_WNDPROC)) (scheme? (= C-proc scheme-wndproc)) (old-proc (if scheme? - (or (hash-table/get wndproc-registry hwnd #f) + (or (hash-table-ref/default wndproc-registry hwnd #f) default-scheme-wndproc) (lambda (hw m w l) (%call-foreign-function c-proc hw m w l))))) (set-window-long hwnd GWL_WNDPROC scheme-wndproc) - (hash-table/put! wndproc-registry hwnd (subclass-behaviour old-proc)) + (hash-table-set! wndproc-registry hwnd (subclass-behaviour old-proc)) unspecific)) diff --git a/src/x11-screen/x11-screen.scm b/src/x11-screen/x11-screen.scm index e2c36a66e..0794edd93 100644 --- a/src/x11-screen/x11-screen.scm +++ b/src/x11-screen/x11-screen.scm @@ -836,28 +836,28 @@ USA. WM_TRANSIENT_FOR)) (define (symbol->x-atom display name soft?) - (or (hash-table/get built-in-atoms-table name #f) + (or (hash-table-ref/default built-in-atoms-table name #f) (let ((table (car (display/cached-atoms-tables display)))) - (or (hash-table/get table name #f) + (or (hash-table-ref/default table name #f) (let ((atom (x-intern-atom display (string-upcase (symbol->string name)) soft?))) (if (not (= atom 0)) - (hash-table/put! table name atom)) + (hash-table-set! table name atom)) atom))))) (define (x-atom->symbol display atom) (if (< atom (vector-length built-in-atoms)) (vector-ref built-in-atoms atom) (let ((table (cdr (display/cached-atoms-tables display)))) - (or (hash-table/get table atom #f) + (or (hash-table-ref/default table atom #f) (let ((symbol (let ((string (x-get-atom-name display atom))) (if (not (string? string)) (error "X error (XGetAtomName):" string atom)) (intern string)))) - (hash-table/put! table atom symbol) + (hash-table-set! table atom symbol) symbol))))) (define built-in-atoms-table @@ -865,7 +865,7 @@ USA. (let ((table (make-strong-eq-hash-table n))) (do ((i 0 (fix:+ i 1))) ((fix:= i n)) - (hash-table/put! table (vector-ref built-in-atoms i) i)) + (hash-table-set! table (vector-ref built-in-atoms i) i)) table))) (define display/cached-atoms-tables @@ -873,10 +873,10 @@ USA. (let ((table (make-weak-eq-hash-table))) (lambda (display) (let ((key (intern (alien/address-string display)))) - (or (hash-table/get table key #f) + (or (hash-table-ref/default table key #f) (let ((result (cons (make-strong-eq-hash-table) (make-strong-eqv-hash-table)))) - (hash-table/put! table key result) + (hash-table-set! table key result) result)))))) ;;;; Properties @@ -1046,7 +1046,7 @@ In either case, it is copied to the primary selection." (x-set-selection-owner display selection window time) (x-get-selection-owner display selection))) (begin - (hash-table/put! (display/selection-records display) + (hash-table-set! (display/selection-records display) selection (make-selection-record window time value)) #t))) @@ -1056,9 +1056,9 @@ In either case, it is copied to the primary selection." (let ((table (make-weak-eq-hash-table))) (lambda (display) (let ((key (intern (alien/address-string display)))) - (or (hash-table/get table key #f) + (or (hash-table-ref/default table key #f) (let ((result (make-strong-eq-hash-table))) - (hash-table/put! table key result) + (hash-table-set! table key result) result)))))) ;;; In the next two procedures, we must allow TIME to be 0, even @@ -1066,17 +1066,18 @@ In either case, it is copied to the primary selection." ;;; value. An example of a broken client is GTK+ version 1.2.6. (define (display/selection-record display name time) - (let ((record (hash-table/get (display/selection-records display) name #f))) + (let ((record + (hash-table-ref/default (display/selection-records display) name #f))) (and record (or (= 0 time) (<= (selection-record/time record) time)) record))) (define (display/delete-selection-record! display name time) (let ((records (display/selection-records display))) - (if (let ((record (hash-table/get records name #f))) + (if (let ((record (hash-table-ref/default records name #f))) (and record (or (= 0 time) (<= (selection-record/time record) time)))) - (hash-table/remove! records name)))) + (hash-table-delete! records name)))) (define-structure (selection-record (conc-name selection-record/)) (window #f read-only #t) diff --git a/src/xdoc/validate-xdoc.scm b/src/xdoc/validate-xdoc.scm index 5f24d2798..db878f244 100644 --- a/src/xdoc/validate-xdoc.scm +++ b/src/xdoc/validate-xdoc.scm @@ -43,7 +43,7 @@ USA. (check-element root 'xdoc))))) (define (check-element elt local) - (let ((v (hash-table/get element-checkers local #f))) + (let ((v (hash-table-ref/default element-checkers local #f))) (if (not v) (error "Missing element definition:" local)) (let ((valid-attrs? (vector-ref v 0)) @@ -92,7 +92,7 @@ USA. (if (and (memq type '(element mixed)) (not valid-local?)) (error "Must supply a name predicate with this content type:" type)) - (hash-table/put! element-checkers + (hash-table-set! element-checkers local (vector valid-attrs? type valid-local? procedure)))) diff --git a/src/xdoc/xdoc.scm b/src/xdoc/xdoc.scm index 067ade24a..8ff5b368b 100644 --- a/src/xdoc/xdoc.scm +++ b/src/xdoc/xdoc.scm @@ -215,7 +215,7 @@ USA. (define (save-container-props elt containers prefix count offset) (let ((number (+ count offset))) (let ((db-id (string-append prefix (number->string number)))) - (hash-table/put! *xdoc-element-properties* elt + (hash-table-set! *xdoc-element-properties* elt (vector (string->symbol db-id) containers prefix @@ -225,20 +225,20 @@ USA. (string-append db-id ".")))) (define (save-element-props elt containers db-id) - (hash-table/put! *xdoc-element-properties* elt (vector db-id containers)) + (hash-table-set! *xdoc-element-properties* elt (vector db-id containers)) (save-xdoc-id elt) (cond ((xdoc-input? elt) - (hash-table/put! *xdoc-inputs* elt #f)) + (hash-table-set! *xdoc-inputs* elt #f)) ((xdoc-output? elt) - (hash-table/put! *xdoc-outputs* elt #f)))) + (hash-table-set! *xdoc-outputs* elt #f)))) (define (save-xdoc-id elt) (let ((id (id-attribute 'id elt #f))) (if id (begin - (if (hash-table/get *xdoc-id-map* id #f) + (if (hash-table-ref/default *xdoc-id-map* id #f) (error "ID attribute not unique:" id)) - (hash-table/put! *xdoc-id-map* id elt))))) + (hash-table-set! *xdoc-id-map* id elt))))) (define (xdoc-db-id elt) (vector-ref (%xdoc-element-properties elt) 0)) @@ -254,7 +254,7 @@ USA. (vector-ref v 4)))) (define (%xdoc-element-properties elt) - (let ((v (hash-table/get *xdoc-element-properties* elt #f))) + (let ((v (hash-table-ref/default *xdoc-element-properties* elt #f))) (if (not v) (error:wrong-type-argument elt "XDOC element" 'xdoc-element-properties)) @@ -267,15 +267,15 @@ USA. (car containers))) (define (named-element id) - (or (hash-table/get *xdoc-id-map* id #f) + (or (hash-table-ref/default *xdoc-id-map* id #f) (error:bad-range-argument id 'named-element))) ;;;; I/O memoization (define (memoize-xdoc-inputs) (for-each (lambda (elt) - (hash-table/put! *xdoc-inputs* elt (memoize-xdoc-input elt))) - (hash-table/key-list *xdoc-inputs*))) + (hash-table-set! *xdoc-inputs* elt (memoize-xdoc-input elt))) + (hash-table-keys *xdoc-inputs*))) (define (memoize-xdoc-input elt) (let ((id (xdoc-db-id elt))) @@ -292,9 +292,9 @@ USA. (define (memoize-xdoc-outputs) (for-each (lambda (elt) (receive (correctness submitter) (memoize-xdoc-output elt) - (hash-table/put! *xdoc-outputs* elt + (hash-table-set! *xdoc-outputs* elt (cons correctness submitter)))) - (hash-table/key-list *xdoc-outputs*))) + (hash-table-keys *xdoc-outputs*))) (define (memoize-xdoc-output elt) (let ((id (xdoc-db-id elt))) @@ -319,7 +319,7 @@ USA. (and (cdr (%current-input-status elt)) #t)) (define (%current-input-status elt) - (or (hash-table/get *xdoc-inputs* elt #f) + (or (hash-table-ref/default *xdoc-inputs* elt #f) (error:wrong-type-argument elt "XDOC input element" 'current-input-status))) @@ -345,7 +345,7 @@ USA. (and (cdr (%current-output-status elt)) #t)) (define (%current-output-status elt) - (or (hash-table/get *xdoc-outputs* elt #f) + (or (hash-table-ref/default *xdoc-outputs* elt #f) (error:wrong-type-argument elt "XDOC output element" 'current-output-status))) @@ -370,10 +370,10 @@ USA. "\n")) (define (define-html-generator name handler) - (hash-table/put! html-generators name handler)) + (hash-table-set! html-generators name handler)) (define (xdoc-html-generator item) - (hash-table/get html-generators (xdoc-element-name item) #f)) + (hash-table-ref/default html-generators (xdoc-element-name item) #f)) (define html-generators (make-strong-eq-hash-table)) @@ -707,7 +707,7 @@ USA. ;;;; Inputs (define (define-xdoc-input local canonicalizer generator) - (hash-table/put! xdoc-input-canonicalizers local canonicalizer) + (hash-table-set! xdoc-input-canonicalizers local canonicalizer) (define-html-generator local generator)) (define (xdoc-active-input-status elt) @@ -744,7 +744,7 @@ USA. (if (eq? local 'checkbox) (if (and (not value) request) "false" value) (and value - ((or (hash-table/get xdoc-input-canonicalizers local #f) + ((or (hash-table-ref/default xdoc-input-canonicalizers local #f) (error:wrong-type-argument elt "XDOC input element" 'canonicalize-xdoc-input-value)) @@ -841,7 +841,7 @@ USA. ;;;; Outputs (define (define-unary-xdoc-output local checkable? expected-value procedure) - (hash-table/put! xdoc-output-definitions local + (hash-table-set! xdoc-output-definitions local (vector checkable? expected-value (lambda (elt) @@ -858,7 +858,7 @@ USA. (find-child (nearest-container elt) #t xdoc-input?))) (define (define-n-ary-xdoc-output local checkable? expected-value procedure) - (hash-table/put! xdoc-output-definitions local + (hash-table-set! xdoc-output-definitions local (vector checkable? expected-value (lambda (elt) @@ -874,7 +874,7 @@ USA. (define-html-generator local (lambda (elt) elt '()))) (define (define-0-ary-xdoc-output local checkable? expected-value procedure) - (hash-table/put! xdoc-output-definitions local + (hash-table-set! xdoc-output-definitions local (vector checkable? expected-value procedure)) @@ -898,7 +898,9 @@ USA. (values correctness submitter))) (define (%xdoc-output-definition elt) - (or (hash-table/get xdoc-output-definitions (xdoc-element-name elt) #f) + (or (hash-table-ref/default xdoc-output-definitions + (xdoc-element-name elt) + #f) (error:bad-range-argument elt 'xdoc-output-definition))) (define xdoc-output-definitions @@ -1041,7 +1043,7 @@ USA. (define-html-generator 'when (lambda (elt) (and ((let ((condition (symbol-attribute 'condition elt #t))) - (or (hash-table/get when-conditions condition #f) + (or (hash-table-ref/default when-conditions condition #f) (error "Unknown condition:" condition))) (content-selector-source elt)) (html:div (xdoc-attributes elt) @@ -1050,7 +1052,7 @@ USA. (xml-element-contents elt)))))) (define (define-when-condition name procedure) - (hash-table/put! when-conditions name procedure)) + (hash-table-set! when-conditions name procedure)) (define when-conditions (make-strong-eq-hash-table)) @@ -1431,7 +1433,7 @@ USA. (define (xdoc-content-type elt) (let ((local (xdoc-element-name elt))) (and local - (or (hash-table/get xdoc-content-types local #f) + (or (hash-table-ref/default xdoc-content-types local #f) (error "Unknown XDOC element name:" local))))) (define xdoc-content-types @@ -1440,7 +1442,7 @@ USA. (define (xdoc-element-type elt) (let ((local (xdoc-element-name elt))) (and local - (or (hash-table/get xdoc-element-types local #f) + (or (hash-table-ref/default xdoc-element-types local #f) (error "Unknown XDOC element name:" local))))) (define xdoc-element-types @@ -1483,8 +1485,8 @@ USA. (LAMBDA (OBJECT) (AND (XML-ELEMENT? OBJECT) (XML-NAME=? (XML-ELEMENT-NAME OBJECT) NAME))))) - (HASH-TABLE/PUT! XDOC-CONTENT-TYPES ',local ',content-type) - (HASH-TABLE/PUT! XDOC-ELEMENT-TYPES ',local ',elt-type))))))) + (HASH-TABLE-SET! XDOC-CONTENT-TYPES ',local ',content-type) + (HASH-TABLE-SET! XDOC-ELEMENT-TYPES ',local ',elt-type))))))) (define-element xdoc mixed top-level-container) (define-element head mixed internal) diff --git a/src/xml/rdf-struct.scm b/src/xml/rdf-struct.scm index 70a656714..d31561b39 100644 --- a/src/xml/rdf-struct.scm +++ b/src/xml/rdf-struct.scm @@ -47,7 +47,7 @@ USA. (let ((subject (canonicalize-rdf-subject subject 'MAKE-RDF-TRIPLE)) (predicate (canonicalize-rdf-predicate predicate 'MAKE-RDF-TRIPLE)) (object (canonicalize-rdf-object object 'MAKE-RDF-TRIPLE))) - (hash-table/intern! rdf-triples (vector subject predicate object) + (hash-table-intern! rdf-triples (vector subject predicate object) (lambda () (let ((triple (%make-rdf-triple subject predicate object (next-index)))) @@ -56,7 +56,7 @@ USA. (define (for-each-rdf-triple procedure) (for-each procedure - (hash-table/datum-list rdf-triples))) + (hash-table-values rdf-triples))) (define next-index (let ((counter 0)) @@ -134,7 +134,7 @@ USA. (loop next this))))) (cdr head)) '()))) - (hash-table/intern! rdf-graphs triples + (hash-table-intern! rdf-graphs triples (lambda () (let ((graph (%make-rdf-graph triples))) (event-distributor/invoke! event:new-rdf-graph graph) @@ -162,7 +162,7 @@ USA. (%make-rdf-bnode) (begin (guarantee string? name 'MAKE-RDF-BNODE) - (hash-table/intern! *rdf-bnode-registry* name %make-rdf-bnode)))) + (hash-table-intern! *rdf-bnode-registry* name %make-rdf-bnode)))) (define (rdf-bnode-name bnode) (string-append "B" (number->string (hash bnode)))) @@ -208,7 +208,7 @@ USA. (language? type)) type (->absolute-uri type 'MAKE-RDF-LITERAL)))) - (hash-table/intern! rdf-literals (cons text type) + (hash-table-intern! rdf-literals (cons text type) (lambda () (%make-rdf-literal text type))))) diff --git a/src/xml/turtle.scm b/src/xml/turtle.scm index 2f734d43b..994d54cb4 100644 --- a/src/xml/turtle.scm +++ b/src/xml/turtle.scm @@ -602,8 +602,8 @@ USA. (cond ((uri? o) (receive (prefix expansion) (uri->rdf-prefix o (port/rdf-prefix-registry port) #f) - (if (and prefix (not (hash-table/get table prefix #f))) - (hash-table/put! table prefix expansion)))) + (if (and prefix (not (hash-table-ref/default table prefix #f))) + (hash-table-set! table prefix expansion)))) ((rdf-graph? o) (check-graph o)))) diff --git a/src/xml/xhtml-entities.scm b/src/xml/xhtml-entities.scm index 1abaff9b4..4644513cf 100644 --- a/src/xml/xhtml-entities.scm +++ b/src/xml/xhtml-entities.scm @@ -290,7 +290,7 @@ USA. (define html-char->name-map (let ((table (make-strong-eqv-hash-table))) - (for-each (lambda (b) (hash-table/put! table (cadr b) (car b))) + (for-each (lambda (b) (hash-table-set! table (cadr b) (car b))) html-entity-alist) (lambda (char) - (hash-table/get table char #f)))) \ No newline at end of file + (hash-table-ref/default table char #f)))) \ No newline at end of file diff --git a/src/xml/xhtml.scm b/src/xml/xhtml.scm index 02642d7d6..2fe23c077 100644 --- a/src/xml/xhtml.scm +++ b/src/xml/xhtml.scm @@ -147,21 +147,21 @@ USA. (ill-formed-syntax form))))) (define (define-html-element-context qname context) - (hash-table/put! element-context-map + (hash-table-set! element-context-map (make-xml-name qname html-uri) context) qname) (define (html-element-context elt) (guarantee-html-element elt 'HTML-ELEMENT-CONTEXT) - (hash-table/get element-context-map (xml-element-name elt) #f)) + (hash-table-ref/default element-context-map (xml-element-name elt) #f)) (define (html-element-name-context name) (guarantee-html-element-name name 'HTML-ELEMENT-NAME-CONTEXT) - (hash-table/get element-context-map name #f)) + (hash-table-ref/default element-context-map name #f)) (define (html-element-names) - (hash-table/key-list element-context-map)) + (hash-table-keys element-context-map)) (define element-context-map (make-strong-eq-hash-table)) diff --git a/src/xml/xml-names.scm b/src/xml/xml-names.scm index 732b365c2..af5df75c6 100644 --- a/src/xml/xml-names.scm +++ b/src/xml/xml-names.scm @@ -54,12 +54,12 @@ USA. (define (%make-xml-name qname uri) (let ((uname (let ((local (xml-qname-local qname))) - (hash-table/intern! (hash-table/intern! expanded-names uri + (hash-table-intern! (hash-table-intern! expanded-names uri make-strong-eq-hash-table) local (lambda () (make-expanded-name uri local (make-strong-eq-hash-table))))))) - (hash-table/intern! (expanded-name-combos uname) qname + (hash-table-intern! (expanded-name-combos uname) qname (lambda () (make-combo-name qname uname))))) diff --git a/tests/runtime/test-boyer-moore.scm b/tests/runtime/test-boyer-moore.scm index 392fd591d..93872ea39 100644 --- a/tests/runtime/test-boyer-moore.scm +++ b/tests/runtime/test-boyer-moore.scm @@ -55,9 +55,9 @@ USA. (table (make-string-hash-table))) (define (record! s die) (let ((entry - (or (hash-table/get table die #f) + (or (hash-table-ref/default table die #f) (let ((entry (list 'ENTRY))) - (hash-table/put! table die entry) + (hash-table-set! table die entry) entry)))) (set-cdr! entry (cons s (cdr entry))))) (let loop ((s 0)) diff --git a/tests/runtime/test-hash-table.scm b/tests/runtime/test-hash-table.scm index e6cb17ce8..2d1c35ed2 100644 --- a/tests/runtime/test-hash-table.scm +++ b/tests/runtime/test-hash-table.scm @@ -77,9 +77,9 @@ USA. s (loop (fix:+ n 1) (cons (cons (let ((x (random 1. state))) - (cond ((< x insert-fraction) 'INSERT) - ((< x delete-break) 'DELETE) - (else 'LOOKUP))) + (cond ((< x insert-fraction) 'insert) + ((< x delete-break) 'delete) + (else 'lookup))) (let ((key (random key-radix state))) (or (rb-tree/lookup tree key #f) (let ((pointer (cons key '()))) @@ -94,9 +94,9 @@ USA. (lookup (implementation/lookup implementation))) (do ((s s (cdr s))) ((null? s)) - (cond ((eq? 'INSERT (caar s)) + (cond ((eq? 'insert (caar s)) (insert! table (cdar s) #f)) - ((eq? 'DELETE (caar s)) + ((eq? 'delete (caar s)) (delete! table (cdar s))) (else (lookup table (cdar s) #f)))) @@ -116,7 +116,7 @@ USA. (lambda (table key default) table key default unspecific) (lambda (table) table '()))) -(load-option 'RB-TREE) +(load-option 'rb-tree) (define (make-pointer-tree) (make-rb-tree (lambda (x y) (fix:= (car x) (car y))) @@ -129,13 +129,13 @@ USA. rb-tree/lookup rb-tree->alist)) -(load-option 'HASH-TABLE) +(load-option 'hash-table) (define (make-hash-table-implementation constructor) (make-implementation constructor - hash-table/put! - hash-table/remove! - hash-table/get + hash-table-set! + hash-table-delete! + hash-table-ref/default (lambda (table) (sort (hash-table->alist table) (lambda (x y) (fix:< (caar x) (caar y))))))) @@ -150,10 +150,10 @@ USA. ((null? s)) (let ((operation (caar s)) (key (cdar s))) - (cond ((eq? 'INSERT operation) + (cond ((eq? 'insert operation) (rb-tree/insert! tree key #t) (insert! table key #t)) - ((eq? 'DELETE operation) + ((eq? 'delete operation) (rb-tree/delete! tree key) (delete! table key)) (else @@ -190,35 +190,36 @@ USA. (int:remainder (if (int:< integer 0) (int:- 0 integer) integer) modulus)) (let ((hash-parameters - (list (list 'EQ eq-hash-mod eq? #t) - (list 'EQV eqv-hash-mod eqv? #t) - (list 'EQUAL equal-hash-mod equal? #t) - (list 'INTEGER + (list (list 'eq eq-hash-mod eq? #t) + (list 'eqv eqv-hash-mod eqv? #t) + (list 'equal equal-hash-mod equal? #t) + (list 'integer (lambda (x modulus) (integer-hash-mod (car x) modulus)) (lambda (x y) (int:= (car x) (car y))) #f))) (entry-types - (list (list 'STRONG hash-table-entry-type:strong) - (list 'KEY-WEAK hash-table-entry-type:key-weak) - (list 'DATUM-WEAK hash-table-entry-type:datum-weak) - (list 'KEY/DATUM-WEAK hash-table-entry-type:key/datum-weak) - (list 'KEY-EPHEMERAL hash-table-entry-type:key-ephemeral) - (list 'DATUM-EPHEMERAL hash-table-entry-type:datum-ephemeral) - (list 'KEY&DATUM-EPHEMERAL + (list (list 'strong hash-table-entry-type:strong) + (list 'key-weak hash-table-entry-type:key-weak) + (list 'datum-weak hash-table-entry-type:datum-weak) + (list 'key/datum-weak hash-table-entry-type:key/datum-weak) + (list 'key-ephemeral hash-table-entry-type:key-ephemeral) + (list 'datum-ephemeral hash-table-entry-type:datum-ephemeral) + (list 'key&datum-ephemeral hash-table-entry-type:key&datum-ephemeral)))) (for-each (lambda (hash-parameters) (for-each (lambda (entry-type) (define-test - (symbol 'CORRECTNESS-VS-RB: + (symbol 'correctness-vs-rb: (car entry-type) '- (car hash-parameters)) (lambda () (check (make-hash-table-implementation - (apply hash-table/constructor - (append (cdr hash-parameters) - (cdr entry-type)))))))) + (hash-table-constructor + (apply make-hash-table-type + (append (cdr hash-parameters) + (cdr entry-type))))))))) entry-types)) hash-parameters)) @@ -229,72 +230,69 @@ USA. ;;; big, hairy, complicated statistical test that guarantees the ;;; desired behaviour with high probability. -(define-test 'REGRESSION:FALSE-KEY-OF-BROKEN-WEAK-ENTRY +(define (regression-make-table entry-type) + ((hash-table-constructor + (make-hash-table-type (lambda (k m) k m 0) eqv? #f entry-type)))) + +(define-test 'regression:false-key-of-broken-weak-entry (lambda () - (let ((hash-table - ((weak-hash-table/constructor (lambda (k m) k m 0) eqv?)))) - (hash-table/put! hash-table (cons 0 0) 'LOSE) + (let ((hash-table (regression-make-table hash-table-entry-type:key-weak))) + (hash-table-set! hash-table (cons 0 0) 'lose) (gc-flip) - (assert-eqv (hash-table/get hash-table #f 'WIN) 'WIN)))) + (assert-eqv (hash-table-ref/default hash-table #f 'win) 'win)))) -(define-test 'REGRESSION:MODIFICATION-DURING-SRFI-69-UPDATE +(define-test 'regression:modification-during-srfi-69-update (lambda () - (let ((hash-table - ((strong-hash-table/constructor (lambda (k m) k m 0) eqv?)))) - (hash-table/put! hash-table 0 'LOSE-0) + (let ((hash-table (regression-make-table hash-table-entry-type:strong))) + (hash-table-set! hash-table 0 'lose-0) (hash-table-update! hash-table 0 (lambda (datum) - datum ;ignore + (declare (ignore datum)) ;; Force consing a new entry. - (hash-table/remove! hash-table 0) - (hash-table/put! hash-table 0 'LOSE-1) - 'WIN)) - (assert-eqv (hash-table/get hash-table 0 'LOSE-2) 'WIN)))) + (hash-table-delete! hash-table 0) + (hash-table-set! hash-table 0 'lose-1) + 'win)) + (assert-eqv (hash-table-ref/default hash-table 0 'lose-2) 'win)))) -(define-test 'REGRESSION:MODIFICATION-DURING-SRFI-69-UPDATE/DEFAULT/0 +(define-test 'regression:modification-during-srfi-69-update/default/0 (lambda () - (let ((hash-table - ((strong-hash-table/constructor (lambda (k m) k m 0) eqv?)))) - (hash-table/put! hash-table 0 'LOSE-0) + (let ((hash-table (regression-make-table hash-table-entry-type:strong))) + (hash-table-set! hash-table 0 'lose-0) (hash-table-update!/default hash-table 0 (lambda (datum) - datum ;ignore + (declare (ignore datum)) ;; Force consing a new entry. - (hash-table/remove! hash-table 0) - (hash-table/put! hash-table 0 'LOSE-1) - 'WIN) - 'LOSE-2) - (assert-eqv (hash-table/get hash-table 0 'LOSE-3) 'WIN)))) + (hash-table-delete! hash-table 0) + (hash-table-set! hash-table 0 'lose-1) + 'win) + 'lose-2) + (assert-eqv (hash-table-ref/default hash-table 0 'lose-3) 'win)))) -(define-test 'REGRESSION:MODIFICATION-DURING-SRFI-69-UPDATE/DEFAULT/1 +(define-test 'regression:modification-during-srfi-69-update/default/1 (lambda () - (let ((hash-table - ((strong-hash-table/constructor (lambda (k m) k m 0) eqv?)))) + (let ((hash-table (regression-make-table hash-table-entry-type:strong))) (hash-table-update!/default hash-table 0 (lambda (datum) - datum ;ignore - (hash-table/put! hash-table 1 'WIN-1) - 'WIN-0) - 'LOSE-0A) - (assert-eqv (hash-table/get hash-table 0 'LOSE-0B) 'WIN-0) - (assert-eqv (hash-table/get hash-table 1 'LOSE-1) 'WIN-1)))) + (declare (ignore datum)) + (hash-table-set! hash-table 1 'win-1) + 'win-0) + 'lose-0a) + (assert-eqv (hash-table-ref/default hash-table 0 'lose-0b) 'win-0) + (assert-eqv (hash-table-ref/default hash-table 1 'lose-1) 'win-1)))) -(define-test 'REGRESSION:MODIFICATION-DURING-SRFI-69-FOLD +(define-test 'regression:modification-during-srfi-69-fold (lambda () (let* ((index 1) - (hash-table - ((strong-hash-table/constructor (lambda (k m) k m index) - eqv? - #t)))) - (hash-table/put! hash-table 0 0) - (hash-table/put! hash-table 1 1) + (hash-table (regression-make-table hash-table-entry-type:strong))) + (hash-table-set! hash-table 0 0) + (hash-table-set! hash-table 1 1) (assert-eqv (hash-table-fold hash-table (lambda (key datum count) key datum ;ignore (set! index 0) ;; Force a rehash. (gc-flip) - (hash-table/get hash-table 0 #f) + (hash-table-ref/default hash-table 0 #f) (+ count 1)) 0) 2)))) \ No newline at end of file -- 2.25.1