(declare (usual-integrations))
\f
(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)))
(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
(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)))
(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)
(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!)
(%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))
(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
;;
(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!)
(%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))
(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.
(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))
\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
(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))
(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!)
(%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))
(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!)
(%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))
(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.
(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))))
(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)
(receiver pseudo))))
\f
(define (define-expression-method name method)
- (hash-table/put! expression-methods name method)
+ (hash-table-set! expression-methods name method)
name)
(define expression-methods
(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
(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))))))))
(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)
(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))))
(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))
(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))
-
\f
(define (cse/assign statement)
(expression-replace! rtl:assign-expression rtl:set-assign-expression!
(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
(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!)
(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*)))))
(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?))))
\f
;; 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*)
(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)
(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)
(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*))
;;;; 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))))))
;; 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)))))
;; 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))
(declare (usual-integrations))
\f
-(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
(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*)
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))
(loop next (element-next-value next)))))))
element))
\f
-(define (hash-table-delete! hash element)
+(define (rcse-ht-delete! hash element)
(if element
(begin
;; **** Mark this element as removed. [ref crock-1]
(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)))))))
\f
-(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)))
(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)))
(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)))
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
(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))
(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))))
(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
(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)))
(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
(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
(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
(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)))
(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)
(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)
(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)))
'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))))))
(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))
(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)
(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
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))
\f
(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
(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?)
;;;; 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)))))))
\f
;;;; NNTP Commands
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?)
(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)
(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)
'())))
\f
(define (news-group:headers group numbers ignore?)
(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
(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)
((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)))))
\f
;;;; Header Database
(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)
(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))
(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 ()
(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
'())
result)))
headers))))))
- (hash-table/put! table header result)
+ (hash-table-set! table header result)
result))
((PENDING)
;;(error "Cycle detected in header graph:" header)
(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)))
(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))
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)
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:<)))
(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)
(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
(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
(receiver pass-phrase)))))))
(define (delete-stored-pass-phrase key)
- (hash-table/remove! stored-pass-phrases key))
+ (hash-table-delete! stored-pass-phrases key))
\f
(define (set-up-pass-phrase-timer! entry key retention-time)
;; A race condition can occur when the timer event is re-registered.
(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))
(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)
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)))
#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))))
(cond ((null? entries)
result)
((< (cdar entries) t)
- (hash-table/remove! table
+ (hash-table-delete! table
(caar entries))
(loop (cdr entries) result))
(else
(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))
(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))))
(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)
(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))
(loop (cdr elements) satisfied (cons (car elements) unsatisfied)))
(values satisfied unsatisfied))))
\f
-(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))
(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
(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))
\f
;;;; Events
WM_TRANSIENT_FOR))
\f
(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
(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)))))
\f
;;;; Properties
(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)))
(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
;;; 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)
(let ((modifier (slot-modifier <url> '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
(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))
(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?
(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)
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
(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))
(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)))
(< (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)
(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)))))
(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)))
(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)
(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
(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)
(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)))
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
name)
\f
(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)
(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)
(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?)
(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)
(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)))
\f
-(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.
(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))
\f
-(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
(< 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
((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)
(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))
(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.
(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)
(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))
;; 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 ()
(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?
(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)
(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=?
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)))
\f
;;;; 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
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))
(equal-hash key)
(equal-hash-mod key modulus)))
\f
-(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)
(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)))
\f
;;;; Miscellany
(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
(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
(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))))))
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
(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
(%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)))))))
(if dedup?
(delete-duplicates list elt=)
list)))
- (hash-table/intern! table
+ (hash-table-intern! table
(get-key list)
(lambda () (get-datum list))))))))))
(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!)
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?
(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)
(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
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
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
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")
(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)
(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 <mime-type>
(%%make-mime-type top-level subtype)
(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)))))
(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)
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)
((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)
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)
\f
(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
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)))
(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!)
finalized)))))
(lambda (rename)
- (or (hash-table/get safe-set rename #f)
+ (or (hash-table-ref/default safe-set rename #f)
(finalize-renamed-identifier rename)))))
\f
;;;; Compute substitution
(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)))
(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))
(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))
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))))
(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))))))
(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)))
#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)
(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)))
(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 <object>)))
(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? <boolean>)
(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)
(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))))
(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))
(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
(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
(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))
(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)))
(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
(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
(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))
(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)))
(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
(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)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(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)))
(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
;; 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.
(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))
WM_TRANSIENT_FOR))
\f
(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
(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)
(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))))))
\f
;;;; Properties
(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)))
(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
;;; 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)
(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))
(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))))
(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
(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))
(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))
(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)))
\f
;;;; 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)))
(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)))
(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)))
(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)))
"\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))
;;;; 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)
(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))
;;;; 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)
(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)
(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))
(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
(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 <xd:when> condition:" condition)))
(content-selector-source elt))
(html:div (xdoc-attributes elt)
(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))
(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
(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
(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)
(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))))
(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))
(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)
(%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))))
(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)))))
(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))))
(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
(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))
(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)))))
(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))
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 '())))
(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))))
(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)))
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)))))))
((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
(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))
\f
;;; 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
projects / mit-scheme.git / commitdiff