Last active
October 4, 2020 06:50
-
-
Save niyarin/bfbf2e7da874eb0d310a64c3baf1f35f to your computer and use it in GitHub Desktop.
ephemeron-hash-table
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
(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