Skip to content

Instantly share code, notes, and snippets.

@niyarin
Last active October 4, 2020 06:50
Show Gist options
  • Star 0 You must be signed in to star a gist
  • Fork 0 You must be signed in to fork a gist
  • Save niyarin/bfbf2e7da874eb0d310a64c3baf1f35f to your computer and use it in GitHub Desktop.
Save niyarin/bfbf2e7da874eb0d310a64c3baf1f35f to your computer and use it in GitHub Desktop.
ephemeron-hash-table
(define-library (ephemeron-hash-table)
(cond-expand
(gauche
(import (scheme base)
(scheme ephemeron)
;Comparator(withdrawn)
(only (srfi 114) eq-comparator comparator-hash))
(begin (define %comparator eq-comparator)))
(else
(import (scheme base)
(srfi 128)
(srfi 124))
(begin (define %comparator (make-eq-comparator)))))
(export make-ephemeron-hash-table ephemeron-hash-table-ref
ephemeron-hash-table? ephemeron-hash-table-set!
ephemeron-hash-table-delete!)
(begin
(define-record-type <ephemeron-hash-table>
(%make-ephemeron-hash-table table-data)
ephemeron-hash-table?
(table-data %table-data-ref %table-data-set!))
(define *DEFAULT-TABLE-SIZE* 128)
(define (make-ephemeron-hash-table . opt)
(let ((size (cond ((null? opt) *DEFAULT-TABLE-SIZE*)
((integer? (car opt)) (car opt))
(else (error "make-ephemeron-hash-table only accepts
1 or 0 integer arguments.")))))
(%make-ephemeron-hash-table (make-vector size '()))))
(define (%ephem-alist-ref-and-trim ealist key)
(let loop ((ealist ealist)
(prev '()))
(if (null? ealist)
#f
(let ((ekey (or (null? (car ealist))
(ephemeron-key (car ealist)))))
(cond
((or (null? (car ealist))
(ephemeron-broken? (car ealist)))
(unless (null? prev) (set-cdr! prev (cdr ealist)))
(loop (cdr ealist) prev))
((eq? ekey key) ealist)
(else (loop (cdr ealist) ealist)))))))
(define (ephemeron-hash-table-set! ephemeron-hash-table key val)
(unless (ephemeron-hash-table? ephemeron-hash-table)
(error "The first argument of ephemeron-hash-table-set!
must be ephemeron hash-table"))
(let* ((table-data (%table-data-ref ephemeron-hash-table))
(hash-value (comparator-hash %comparator key))
(mod-hash (modulo hash-value (vector-length table-data)))
(ephem-alist (vector-ref table-data mod-hash))
(tgt-ephemeron-apair-box
(%ephem-alist-ref-and-trim ephem-alist key)))
(if tgt-ephemeron-apair-box
(set-car! tgt-ephemeron-apair-box (make-ehemeron key val))
(vector-set! table-data
mod-hash
(cons (make-ephemeron key val) ephem-alist)))))
(define (ephemeron-hash-table-ref ephemeron-hash-table key)
(unless (ephemeron-hash-table? ephemeron-hash-table)
(error "The argument of ephemeron-hash-table-ref
must be ephemeron hash-table"))
(let* ((table-data (%table-data-ref ephemeron-hash-table))
(mod-hash (modulo (comparator-hash %comparator key)
(vector-length table-data)))
(tgt-ephemeron-apair-box
(%ephem-alist-ref-and-trim (vector-ref table-data mod-hash)
key)))
(if tgt-ephemeron-apair-box
(ephemeron-datum (car tgt-ephemeron-apair-box))
#f)))
(define (%ephem-ht->al-aux ephem-alist cdr-part)
(let loop ((ls ephem-alist~)
(res cdr-part))
(cond
((null? ls) res)
((or (null? (car ls)) (ephemeron-broken? (car ls)))
(loop (cdr ls) res))
(else
(loop (cdr ls)
(cons (cons (ephemeron-key (car ls))
(ephemeron-datum (car ls)))
res))))))
(define (ephemeron-hash-table->alist ephemeron-hash-table)
(unless (ephemeron-hash-table? ephemeron-hash-table)
(error "The argument of ephemeron-hash-table->alist
must be epehemron hash-table"))
(let ((table-data (%table-data-ref ephemeron-hash-table)))
(let loop ((idx 0)
(res '()))
(if (< idx (vector-length table-data))
(loop (+ idx 1)
(%ephem-ht->al-aux (vector-ref table-data idx) res))
res))))
(define (ephemeron-hash-table-delete! ephemeron-hash-table key)
(unless (ephemeron-hash-table? ephemeron-hash-table)
(error "The argument of ephemeron-hash-table->alist
must be epehemron hash-table"))
(let* ((table-data (%table-data-ref ephemeron-hash-table))
(mod-hash (modulo (comparator-hash %comparator key)
(vector-length table-data)))
(tgt-ephemeron-apair-box
(%ephem-alist-ref-and-trim (vector-ref table-data mod-hash)
key)))
(when tgt-ephemeron-apair-box
(set-car! tgt-ephemeron-apair-box '()))))))
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment