summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--module/ice-9/vlist.scm73
1 files changed, 35 insertions, 38 deletions
diff --git a/module/ice-9/vlist.scm b/module/ice-9/vlist.scm
index dd62661af..0c9297654 100644
--- a/module/ice-9/vlist.scm
+++ b/module/ice-9/vlist.scm
@@ -73,7 +73,7 @@
(define-syntax name
(syntax-rules ()
((_ formals ...)
- body ...))))))
+ (begin body ...)))))))
(define-inline (make-block base offset size hash-tab?)
;; Return a block (and block descriptor) of SIZE elements pointing to BASE
@@ -408,55 +408,52 @@ with @var{value}. Use @var{hash} to compute @var{key}'s hash."
(define vhash-consq (cut vhash-cons <> <> <> hashq))
(define vhash-consv (cut vhash-cons <> <> <> hashv))
-(define-syntax make-vhash-assoc
- ;; This hack to make sure `vhash-assq' gets to use the `eq?' instruction
- ;; instead of calling the `eq?' subr.
- (syntax-rules ()
- ((_ key vhash equal? hash)
- (begin
- (define khash
- (let ((size (block-size (vlist-base vhash))))
- (and (> size 0) (hash key size))))
-
- (let loop ((base (vlist-base vhash))
- (khash khash)
- (offset (and khash
- (block-hash-table-ref (vlist-base vhash)
- khash)))
- (max-offset (vlist-offset vhash)))
- (let ((answer (and offset (block-ref base offset))))
- (cond ((and (pair? answer)
- (<= offset max-offset)
- (let ((answer-key (caar answer)))
- (equal? key answer-key)))
- (car answer))
- ((and (pair? answer) (cdr answer))
- =>
- (lambda (next-offset)
- (loop base khash next-offset max-offset)))
- (else
- (let ((next-base (block-base base)))
- (and next-base
- (> (block-size next-base) 0)
- (let* ((khash (hash key (block-size next-base)))
- (offset (block-hash-table-ref next-base khash)))
- (loop next-base khash offset
- (block-offset base)))))))))))))
+;; This hack to make sure `vhash-assq' gets to use the `eq?' instruction instead
+;; of calling the `eq?' subr.
+(define-inline (%vhash-assoc key vhash equal? hash)
+ (define khash
+ (let ((size (block-size (vlist-base vhash))))
+ (and (> size 0) (hash key size))))
+
+ (let loop ((base (vlist-base vhash))
+ (khash khash)
+ (offset (and khash
+ (block-hash-table-ref (vlist-base vhash)
+ khash)))
+ (max-offset (vlist-offset vhash)))
+ (let ((answer (and offset (block-ref base offset))))
+ (cond ((and (pair? answer)
+ (<= offset max-offset)
+ (let ((answer-key (caar answer)))
+ (equal? key answer-key)))
+ (car answer))
+ ((and (pair? answer) (cdr answer))
+ =>
+ (lambda (next-offset)
+ (loop base khash next-offset max-offset)))
+ (else
+ (let ((next-base (block-base base)))
+ (and next-base
+ (> (block-size next-base) 0)
+ (let* ((khash (hash key (block-size next-base)))
+ (offset (block-hash-table-ref next-base khash)))
+ (loop next-base khash offset
+ (block-offset base))))))))))
(define* (vhash-assoc key vhash #:optional (equal? equal?) (hash hash))
"Return the first key/value pair from @var{vhash} whose key is equal to
@var{key} according to the @var{equal?} equality predicate."
- (make-vhash-assoc key vhash equal? hash))
+ (%vhash-assoc key vhash equal? hash))
(define (vhash-assq key vhash)
"Return the first key/value pair from @var{vhash} whose key is @code{eq?} to
@var{key}."
- (make-vhash-assoc key vhash eq? hashq))
+ (%vhash-assoc key vhash eq? hashq))
(define (vhash-assv key vhash)
"Return the first key/value pair from @var{vhash} whose key is @code{eqv?} to
@var{key}."
- (make-vhash-assoc key vhash eqv? hashv))
+ (%vhash-assoc key vhash eqv? hashv))
(define* (vhash-delete key vhash #:optional (equal? equal?) (hash hash))
"Remove all associations from @var{vhash} with @var{key}, comparing keys