scsh-conservatory
/
sunterlib
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

version 0.2 with some bug fixes and one new exported procedure TABLE->ALIST

This commit is contained in:
Taylor R. Campbell 2005-07-10 01:51:56 +00:00
parent b6af6f686f
commit 3fc8690f91
4 changed files with 87 additions and 70 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

9
s48/riatables/NEWS
View File

@ -1,3 +1,12 @@
version 0.2
* A number of bug fixes:
- Fixed variable name typo in POP-TABLE-ENTRY!.
- Overhauled previously completely broken WALK-TABLE.
- Corrected obscure bug that made the GC thrash when dumping
buckets while rehashing weak, GC-sensitive tables in a nearly
full heap.
* New procedure: (TABLE->ALIST table)
version 0.1 version 0.1
* Initial version. UPSTREAM: * Initial version. UPSTREAM:
http://www.bloodandcoffee.net/campbell/code/s48-riatables.tar.gz http://www.bloodandcoffee.net/campbell/code/s48-riatables.tar.gz

2
s48/riatables/pkg-def.scm
View File

@ -1,5 +1,5 @@
(define-package "riatables" (define-package "riatables"
(0 1) (0 2)
((install-lib-version (1 2 0))) ((install-lib-version (1 2 0)))
(write-to-load-script (write-to-load-script
`((config) `((config)

1
s48/riatables/scheme/packages.scm
View File

@ -32,6 +32,7 @@
modify-table-entry! modify-table-entry!
pop-table-entry! pop-table-entry!
walk-table walk-table
table->alist
table-template table-template

117
s48/riatables/scheme/riatable.scm
View File

@ -262,58 +262,59 @@
(bucket-index entry) (bucket-index entry)
(and entry (and entry
(begin (expunge-entry-from-table! table bucket-index entry) (begin (expunge-entry-from-table! table bucket-index entry)
(if (table-tail-weak? entry) (if (table-tail-weak? table)
(weak-entry-value entry) (weak-entry-value entry)
(entry-value entry))))) (entry-value entry)))))
(define (walk-table table proc) ;++ This should also clean out any of the table's broken weak entries.
(define (table->alist table)
(let* ((buckets (table-bucket-vector table)) (let* ((buckets (table-bucket-vector table))
(bcount (vector-length buckets))) (bcount (vector-length buckets))
(cons-entry
(let ((head-weak? (table-head-weak? table))
(tail-weak? (table-tail-weak? table)))
(cond ((and head-weak? tail-weak?)
(lambda (entry alist)
(cond ((weak-entry-key entry)
=> (lambda (k)
(cond ((weak-entry-value entry)
=> (lambda (v)
(cons (cons k v) alist)))
(else alist))))
(else alist))))
(head-weak?
(lambda (entry alist)
(cond ((weak-entry-key entry)
=> (lambda (k)
(cons (cons k (entry-value entry))
alist)))
(else alist))))
(tail-weak?
(lambda (entry alist)
(cond ((weak-entry-value entry)
=> (lambda (v)
(cons (cons (entry-key entry) v)
alist)))
(else alist))))
(else
(lambda (entry alist)
(cons (cons (entry-key entry) (entry-value entry))
alist)))))))
(let outer-loop ((alist '()) (let outer-loop ((alist '())
(i 0)) (i 0))
(if (= i bcount) (if (= i bcount)
(walk-table-alist alist proc alist
(table-head-weak? table)
(table-tail-weak? table))
(let inner-loop ((alist alist) (let inner-loop ((alist alist)
(bucket (vector-ref buckets i))) (bucket (vector-ref buckets i)))
(if (bucket-empty? bucket) (if (bucket-empty? bucket)
(outer-loop (+ i 1)) (outer-loop alist (+ i 1))
(inner-loop (cons (let ((entry (bucket-entry bucket))) (inner-loop (cons-entry (bucket-entry bucket) alist)
(cons (entry-key entry)
(entry-value entry)))
alist)
(bucket-next bucket)))))))) (bucket-next bucket))))))))
(define (walk-table-alist alist proc head-weak? tail-weak?) (define (walk-table table proc)
;++ Probably shouldn't break the weakness abstraction here. (Weak (for-each (lambda (k.v) (proc (car k.v) (cdr k.v)))
;++ pointers are supposed to be dealt with only by WEAK-ENTRY-VALUE (table->alist table)))
;++ &c.; they're meant to be invisible to all other code here.)
;++ Also, WALK-TABLE should expunge broken entries; it shouldn't be
;++ the job of this to filter them out when determining what to pass
;++ to PROC. Better yet, there would just be a TABLE->ALIST that
;++ does everything right. I'm too lazy now.
(for-each (if head-weak?
(if tail-weak?
(lambda (key.value)
(cond ((weak-pointer-ref (car key.value))
=> (lambda (key)
(cond ((weak-pointer-ref
(cdr key.value))
=> (lambda (value)
(proc key value))))))))
(lambda (key.value)
(cond ((weak-pointer-ref (car key.value))
=> (lambda (key)
(proc key (cdr key.value)))))))
(if tail-weak?
(lambda (key.value)
(cond ((weak-pointer-ref (cdr key.value))
=> (lambda (value)
(proc (car key.value) value)))))
(lambda (key.value)
(proc (car key.value) (cdr key.value)))))
alist))
@ -546,32 +547,37 @@
(define-syntax define-bucket-dumper (define-syntax define-bucket-dumper
(syntax-rules () (syntax-rules ()
((define-bucket-dumper name ((define-bucket-dumper name
entry entry-var
(key key-expression) (key-var key-expression)
test) test)
(define (name key-hash) (define (name key-hash)
(lambda (bucket-vector old-buckets index) (letrec ((loop
(let ((mod (vector-length bucket-vector))) (lambda (buckets index bucket count mod)
(let loop ((bucket (vector-ref old-buckets index))
(count 0))
(if (bucket-empty? bucket) (if (bucket-empty? bucket)
count count
(let* ((entry (bucket-entry bucket)) (let* ((entry-var (bucket-entry bucket))
(next (bucket-next bucket)) (next (bucket-next bucket))
(key key-expression)) (key-var key-expression))
(loop next (loop buckets index
next
(if test (if test
(let ((hash (key-hash key mod))) (let ((hash (key-hash key-var mod)))
(if (not (eq? hash index)) (if (not (eq? hash index))
(begin (set-bucket-next! (begin (set-bucket-next!
bucket bucket
(vector-ref bucket-vector (vector-ref buckets
hash)) hash))
(vector-set! bucket-vector (vector-set! buckets
hash hash
bucket))) bucket)))
(+ count 1)) (+ count 1))
count))))))))))) count)
mod))))))
(lambda (bucket-vector old-buckets index)
(loop bucket-vector index
(vector-ref old-buckets index)
0
(vector-length bucket-vector))))))))
(define-bucket-dumper make-weak-bucket-dumper (define-bucket-dumper make-weak-bucket-dumper
entry entry
@ -812,8 +818,9 @@
'integer-table)) 'integer-table))
(symbol-table-template make-symbol-table (symbol-table-template make-symbol-table
(make-strong-table-template symbol? eq? (make-strong-table-template symbol? eq?
(lambda (s mod) (lambda (sym mod)
(modular-string-hash (symbol->string s) (modular-string-hash
(symbol->string sym)
mod)) mod))
#f ; GC-insensitive hash function #f ; GC-insensitive hash function
'symbol-table))) 'symbol-table)))