in the generation of the written representation for many objects
(@pxref{Custom Output}).
-All of these procedures accept an optional argument called @var{table};
-this table contains the object-integer associations. If given, this
-argument must be an object-hash table as constructed by
-@code{hash-table/make} (see below). If not given, a default table is
-used.
+All of these procedures accept an optional argument called
+@var{hasher} which contains the object-integer associations. If
+given, this argument must be an object hasher as constructed by
+@code{make-object-hasher} (see below). If not given, a default table
+is used.
-@deffn procedure hash object [table]
+@deffn procedure hash-object object [hasher]
@findex eq?
-@code{hash} associates an exact non-negative integer with @var{object}
-and returns that integer. If @code{hash} was previously called with
-@var{object} as its argument, the integer returned is the same as was
-returned by the previous call. @code{hash} guarantees that distinct
-objects (in the sense of @code{eq?}) are associated with distinct
-integers.
-@end deffn
-
-@deffn procedure unhash k [table]
-@code{unhash} takes an exact non-negative integer @var{k} and returns
-the object associated with that integer. If there is no object
-associated with @var{k}, or if the object previously associated with
-@var{k} has been reclaimed by the garbage collector, an error of type
-@code{condition-type:bad-range-argument} is signalled. In other words,
-if @code{hash} previously returned @var{k} for some object, and that
-object has not been reclaimed, it is the value of the call to
-@code{unhash}.
+@code{hash-object} associates an exact non-negative integer with
+@var{object} and returns that integer. If @code{hash-object} was
+previously called with @var{object} as its argument, the integer
+returned is the same as was returned by the previous call.
+@code{hash-object} guarantees that distinct objects (in the sense of
+@code{eqv?}) are associated with distinct integers.
+@end deffn
+
+@deffn procedure unhash-object k [hasher]
+@code{unhash-object} takes an exact non-negative integer @var{k} and
+returns the object associated with that integer. If there is no
+object associated with @var{k}, or if the object previously associated
+with @var{k} has been reclaimed by the garbage collector, an error of
+type @code{condition-type:bad-range-argument} is signalled. In other
+words, if @code{hash-object} previously returned @var{k} for some
+object, and that object has not been reclaimed, it is the value of the
+call to @code{unhash-object}.
@findex condition-type:bad-range-argument
@end deffn
@example
@group
(define x (cons 0 0)) @result{} @r{unspecified}
-(hash x) @result{} 77
-(eqv? (hash x) (hash x)) @result{} #t
+(hash-object x) @result{} 77
+(eqv? (hash-object x)
+ (hash-object x)) @result{} #t
(define x 0) @result{} @r{unspecified}
(gc-flip) @r{;force a garbage collection}
-(unhash 77) @error{}
+(unhash-object 77) @error{}
@end group
@end example
-@deffn procedure object-hashed? object [table]
-This predicate is true if @var{object} has an associated hash number.
-Otherwise it is false.
+@deffn procedure object-hashed? object [hasher]
+This predicate is true iff @var{object} has an associated hash number.
@end deffn
-@deffn procedure valid-hash-number? k [table]
-This predicate is true if @var{k} is the hash number associated with
-some object. Otherwise it is false.
+@deffn procedure valid-object-hash? k [hasher]
+This predicate is true iff @var{k} is the hash number associated with
+some object.
@end deffn
-The following two procedures provide a lower-level interface to the
-object-hashing mechanism.
+Finally, this procedure makes new object hashers:
-@deffn procedure object-hash object [table [insert?]]
-@findex eq?
-@code{object-hash} is like @code{hash}, except that it accepts an
-additional optional argument, @var{insert?}. If @var{insert?}@: is
-supplied and is @code{#f}, @code{object-hash} will return an integer for
-@var{object} only if there is already an association in the table;
-otherwise, it will return @code{#f}. If @var{insert?} is not supplied,
-or is not @code{#f}, @code{object-hash} always returns an integer,
-creating an association in the table if necessary.
-
-@code{object-hash} additionally treats @code{#f} differently than does
-@code{hash}. Calling @code{object-hash} with @code{#f} as its argument
-will return an integer that, when passed to @code{unhash}, will signal
-an error rather than returning @code{#f}. Likewise,
-@code{valid-hash-number?} will return @code{#f} for this integer.
-@end deffn
-
-@deffn procedure object-unhash k [table]
-@code{object-unhash} is like @code{unhash}, except that when @var{k} is
-not associated with any object or was previously associated with an
-object that has been reclaimed, @code{object-unhash} returns @code{#f}.
-This means that there is an ambiguity in the value returned by
-@code{object-unhash}: if @code{#f} is returned, there is no way to
-tell if @var{k} is associated with @code{#f} or is not associated with
-any object at all.
-@end deffn
-
-Finally, this procedure makes new object-hash tables:
-
-@deffn procedure hash-table/make
-This procedure creates and returns a new, empty object-hash table that
-is suitable for use as the optional @var{table} argument to the above
-procedures. The returned table contains no associations.
+@deffn procedure make-object-hasher
+This procedure creates and returns a new, empty object hasher that
+is suitable for use as the optional @var{hasher} argument to the above
+procedures. The returned hasher contains no associations.
@end deffn
@node Red-Black Trees, Weight-Balanced Trees, Object Hashing, Associations
(define (->tagged-vector object)
(let ((object
(if (exact-nonnegative-integer? object)
- (unhash object)
+ (unhash-object object)
object)))
(and (or (tagged-vector? object)
(named-structure? object))
(cond ((integer? object) (inexact->exact object))
((symbol? object) (symbol-hash object))
((string? object) (string-hash object))
- (else (hash object))))))
+ (else (hash-object object))))))
(let ((hash (loop expression)))
(receiver (modulo hash (rcse-ht-size))
(write-string "; multiple blocks")))
(bblock
(write-string "; block ")
- (write (unhash bblock)))
+ (write (unhash-object bblock)))
(else
(write-string "; no block!"))))))))))
(not (number? value)))
(string-append
" "
- (write-to-string (object-hash value)))
+ (write-to-string (hash-object value)))
"")
": ")))
'())
(define (make-buffer-position mark buffer)
- (cons buffer-position-tag (cons mark (hash buffer))))
+ (cons buffer-position-tag (cons mark (hash-object buffer))))
(define (buffer-position? object)
(and (pair? object)
(cadr position))
(define-integrable (buffer-position-buffer position)
- (unhash (cddr position)))
\ No newline at end of file
+ (unhash-object (cddr position)))
\ No newline at end of file
(declare (usual-integrations))
\f
-(define hash-of-false (object-hash #f))
+(define hash-of-false (hash-object #f))
(define match-group hash-of-false)
(define (re-match-start i)
(re-match-end-index i)))
(define (re-match-group)
- (let ((group (object-unhash match-group)))
+ (let ((group (unhash-object match-group)))
(if (not group)
(error "No match group"))
group))
(define (re-match-data)
- (let ((group (object-unhash match-group)))
+ (let ((group (unhash-object match-group)))
(cons group
(if group
(let ((v (make-vector 20)))
(define (group-hash-number group)
(or (group-%hash-number group)
- (let ((n (object-hash group)))
+ (let ((n (hash-object group)))
(set-group-%hash-number! group n)
n)))
\f
(if (get-param:unparse-with-maximum-readability?)
(begin
(write-string "#@" port)
- (write (object-hash object) port))
+ (write (hash-object object) port))
(procedure object port))))))
(define (bracketed-unparser-method procedure)
name)
port)
(write-char #\space port)
- (write (object-hash object) port)
+ (write (hash-object object) port)
(if procedure (procedure object port)))))
(define (simple-unparser-method name get-parts)
;;;; Object Hashing
;;; package: (runtime hash)
-(declare (usual-integrations))
-\f
-;;;; Object hashing
-
;;; How this works:
-;;; There are two tables, the hash table and the unhash table:
+;;; There are two tables:
-;;; - The hash table associates objects to their hash numbers. The
-;;; entries are keyed according to the address (datum) of the object.
+;;; * The hash table associates objects (as compared by eqv?) to their hash
+;;; numbers.
-;;; - The unhash table associates the hash numbers with the
-;;; corresponding objects. It is keyed according to the numbers
-;;; themselves.
+;;; * The unhash table associates the hash numbers back to the hashed objects.
-;;; Both tables hold the objects weakly. Thus the hash table holds
-;;; its keys weakly, and the unhash table holds its values weakly.
-\f
-(define default/hash-table-size 313)
-(define default-hash-table)
-
-(define (initialize-package!)
- (set! make-datum-weak-eq-hash-table
- (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
- (conc-name hash-table/)
- (constructor %hash-table/make))
- (mutex)
- (next-number)
- (hash-table)
- (unhash-table))
-
-(define make-datum-weak-eq-hash-table)
-
-(define (hash-table/make #!optional size)
- (let ((size (if (default-object? size)
- default/hash-table-size
- size)))
- (%hash-table/make
- (make-thread-mutex)
- 1
- (make-key-weak-eq-hash-table size)
- (make-datum-weak-eq-hash-table size))))
-
-(define (hash x #!optional table)
- (if (eq? x #f)
- 0
- (object-hash x
- (if (default-object? table) default-hash-table table)
- #t)))
-
-(define (unhash n #!optional table)
- (if (= n 0)
- #f
- (let ((object
- (object-unhash n
- (if (default-object? table)
- default-hash-table
- table))))
- (if (not object)
- (error:bad-range-argument n 'unhash))
- object)))
-
-(define (valid-hash-number? n #!optional table)
- (or (= n 0)
- (object-unhash n (if (default-object? table) default-hash-table table))))
-
-(define (object-hashed? x #!optional table)
- (or (eq? x #f)
- (object-hash x
- (if (default-object? table) default-hash-table table)
- #f)))
+;;; Both tables hold the objects weakly; the hash table holds its keys weakly,
+;;; and the unhash table holds its values weakly.
+
+(declare (usual-integrations))
\f
-(define (object-hash object #!optional table insert?)
- (let ((table
- (if (default-object? table)
- default-hash-table
- (begin
- (if (not (hash-table? table))
- (error:wrong-type-argument table
- "object-hash table"
- 'object-hash))
- table)))
- (insert? (or (default-object? insert?) insert?)))
- (with-thread-mutex-lock (hash-table/mutex table)
- (lambda ()
- (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-set! unhashtb next object)
- (hash-table-set! hashtb object next)
- next)
- number)
- number))))))
-
-(define (object-unhash number #!optional table)
- (let ((table
- (if (default-object? table)
- default-hash-table
- (begin
- (if (not (hash-table? table))
- (error:wrong-type-argument table
- "object-hash table"
- 'object-unhash))
- table))))
- (with-thread-mutex-lock (hash-table/mutex table)
- (lambda ()
- (hash-table-ref/default (hash-table/unhash-table table) number #f)))))
\ No newline at end of file
+(define (hash-object object #!optional hasher)
+ ((get-operation hasher 'hash-object) object))
+
+(define (object-hashed? object #!optional hasher)
+ ((get-operation hasher 'object-hashed?) object))
+
+(define (unhash-object hash #!optional hasher)
+ ((get-operation hasher 'unhash-object) hash))
+
+(define (valid-object-hash? hash #!optional hasher)
+ ((get-operation hasher 'valid-object-hash?) hash))
+
+(define (get-operation hasher operator)
+ ((if (default-object? hasher)
+ default-object-hasher
+ hasher)
+ operator))
+
+(define-deferred default-object-hasher
+ (make-object-hasher 313))
+
+(define (make-object-hasher #!optional initial-size)
+ (let ((mutex (make-thread-mutex))
+ (next-hash 1)
+ (hash-table (make-key-weak-eqv-hash-table initial-size))
+ (unhash-table (make-datum-weak-eqv-hash-table initial-size)))
+
+ (define (hash-object object)
+ (if (eq? object #f)
+ 0
+ (with-thread-mutex-lock mutex
+ (lambda ()
+ (hash-table-intern! hash-table object
+ (lambda ()
+ (let ((hash next-hash))
+ (set! next-hash (+ next-hash 1))
+ (hash-table-set! unhash-table hash object)
+ hash)))))))
+
+ (define (object-hashed? object)
+ (or (eq? object #f)
+ (with-thread-mutex-lock mutex
+ (lambda ()
+ (hash-table-exists? hash-table object)))))
+
+ (define (unhash-object hash)
+ (guarantee exact-nonnegative-integer? hash 'unhash-object)
+ (if (= hash 0)
+ #f
+ (with-thread-mutex-lock mutex
+ (lambda ()
+ (hash-table-ref unhash-table hash)))))
+
+ (define (valid-object-hash? hash)
+ (guarantee exact-nonnegative-integer? hash 'valid-object-hash?)
+ (or (= hash 0)
+ (with-thread-mutex-lock mutex
+ (lambda ()
+ (hash-table-exists? unhash-table hash)))))
+
+ (lambda (operator)
+ (case operator
+ ((hash-object) hash-object)
+ ((object-hashed?) object-hashed?)
+ ((unhash-object) unhash-object)
+ ((valid-object-hash?) valid-object-hash?)
+ (else (error "Unknown operator:" operator))))))
\ No newline at end of file
(error:illegal-unhash object))
(if (eq? object 0)
#f
- (or (object-unhash object)
+ (or (unhash-object object)
(error:undefined-hash object))))
\f
(define (handler:quote db ctx char)
(define system-properties)
(define (2d-put! x y value)
- (let ((x-hash (object-hash x))
- (y-hash (object-hash y)))
+ (let ((x-hash (hash-object x))
+ (y-hash (hash-object y)))
(let ((bucket (assq x-hash system-properties)))
(if bucket
(let ((entry (assq y-hash (cdr bucket))))
system-properties))))))
(define (2d-get x y)
- (let ((bucket (assq (object-hash x) system-properties)))
+ (let ((bucket (assq (hash-object x) system-properties)))
(and bucket
- (let ((entry (assq (object-hash y) (cdr bucket))))
+ (let ((entry (assq (hash-object y) (cdr bucket))))
(and entry
(cdr entry))))))
;;; Removes the bucket if the entry removed was the only entry.
(define (2d-remove! x y)
- (let ((bucket (assq (object-hash x) system-properties)))
+ (let ((bucket (assq (hash-object x) system-properties)))
(and bucket
(begin (set-cdr! bucket
- (del-assq! (object-hash y)
+ (del-assq! (hash-object y)
(cdr bucket)))
(if (null? (cdr bucket))
(set! system-properties
- (del-assq! (object-hash x)
+ (del-assq! (hash-object x)
system-properties)))
true))))
\f
(set! system-properties (delete-invalid-hash-numbers! system-properties)))
(define (filter-bucket! bucket)
- (or (not (valid-hash-number? (car bucket)))
+ (or (not (valid-object-hash? (car bucket)))
(begin (set-cdr! bucket (delete-invalid-y! (cdr bucket)))
(null? (cdr bucket)))))
(define (filter-entry! entry)
- (not (valid-hash-number? (car entry))))
+ (not (valid-object-hash? (car entry))))
(define delete-invalid-hash-numbers!)
(define delete-invalid-y!)
(define (2d-get-alist-x x)
- (let ((bucket (assq (object-hash x) system-properties)))
+ (let ((bucket (assq (hash-object x) system-properties)))
(if bucket
(let loop ((rest (cdr bucket)))
(cond ((null? rest) '())
- ((valid-hash-number? (caar rest))
- (cons (cons (object-unhash (caar rest))
+ ((valid-object-hash? (caar rest))
+ (cons (cons (unhash-object (caar rest))
(cdar rest))
(loop (cdr rest))))
(else (loop (cdr rest)))))
'())))
(define (2d-get-alist-y y)
- (let ((y-hash (object-hash y)))
+ (let ((y-hash (hash-object y)))
(let loop ((rest system-properties))
(cond ((null? rest) '())
- ((valid-hash-number? (caar rest))
+ ((valid-object-hash? (caar rest))
(let ((entry (assq y-hash (cdar rest))))
(if entry
- (cons (cons (object-unhash (caar rest))
+ (cons (cons (unhash-object (caar rest))
(cdr entry))
(loop (cdr rest)))
(loop (cdr rest)))))
(object-pointer? object)
(not (interned-symbol? object))
(not (number? object))
- (object-hash object))
+ (hash-object object))
environment))
(define (repl-eval/write s-expression #!optional environment repl)
(define-package (runtime hash)
(files "hash")
(parent (runtime))
- (export ()
- hash
- hash-table/make
- object-hash
+ (export () deprecated:hash
+ (hash hash-object)
+ (hash-table/make make-object-hasher)
+ (object-hash hash-object)
+ (object-unhash unhash-object)
+ (unhash unhash-object)
+ (valid-hash-number? valid-object-hash?))
+ (export ()
+ hash-object
+ make-object-hasher
object-hashed?
- object-unhash
- unhash
- valid-hash-number?)
- (initialization (initialize-package!)))
+ unhash-object
+ valid-object-hash?))
(define-package (runtime hash-table)
(files "hash-table")
(get-current-environment))
((string-prefix? anonymous-package-prefix pstring)
(let ((object
- (object-unhash
+ (unhash-object
(string->number (string-tail pstring
(string-length
anonymous-package-prefix))
(let ((package (environment->package env)))
(if package
(write-to-string (package/name package))
- (string anonymous-package-prefix (object-hash env)))))
+ (string anonymous-package-prefix (hash-object env)))))
(define anonymous-package-prefix
"environment-")
(let ((value (repl-eval sexp socket)))
(call-with-output-string
(lambda (port)
- (port/write-result port sexp value (object-hash value) (buffer-env))
+ (port/write-result port sexp value (hash-object value) (buffer-env))
(if nl? (newline port))))))
(define (for-each-sexp procedure string)
(*unparse-string (number->string number 16) context))
(define-integrable (*unparse-hash object context)
- (*unparse-string (number->string (hash object)) context))
+ (*unparse-string (number->string (hash-object object)) context))
(define (*unparse-readable-hash object context)
(*unparse-string "#@" context)
'()))
flags))
(newline port)))
- (sort (map (lambda (t) (cons (hash t) t)) (threads-list))
+ (sort (map (lambda (t) (cons (hash-object t) t)) (threads-list))
(lambda (a b) (< (car a) (car b))))))
(define (write-state thread port)
(if object
(begin
(write-char #\space port)
- (write (hash object) port)))
+ (write (hash-object object) port)))
(if thunk
(thunk))
(write-char #\] port))
(hash-table-intern! *rdf-bnode-registry* name %make-rdf-bnode))))
(define (rdf-bnode-name bnode)
- (string-append "B" (number->string (hash bnode))))
+ (string-append "B" (number->string (hash-object bnode))))
(define (%decode-bnode-uri uri)
(let ((v
((symbol? uri) (*parse-symbol parse-bnode uri))
(else #f))))
(and v
- (unhash (vector-ref v 0)))))
+ (unhash-object (vector-ref v 0)))))
(define parse-bnode
(let ((digits (ascii-range->char-set #x30 #x3A)))
projects / mit-scheme.git / commitdiff