From a83946f0cd8abb64b9b890668938675955815918 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?J=C3=A9ssica=20Milar=C3=A9?= Date: Tue, 8 Jan 2019 22:02:25 -0200 Subject: [PATCH 3/5] Reimplemented SRFI-69 using GENERIC-HASH-TABLES --- module/rnrs/hashtables.scm | 29 ++-- module/srfi/srfi-69.scm | 318 ++++++++-------------------------- test-suite/tests/srfi-69.test | 3 +- 3 files changed, 93 insertions(+), 257 deletions(-) diff --git a/module/rnrs/hashtables.scm b/module/rnrs/hashtables.scm index 22bae7f09..486452a2a 100644 --- a/module/rnrs/hashtables.scm +++ b/module/rnrs/hashtables.scm @@ -67,6 +67,7 @@ hash-table-fold) (hash equal-hash) (hash-by-identity symbol-hash)) + (only (ice-9 generic-hash-tables) hash-by-value) (rnrs base (6)) (rnrs records procedural (6))) @@ -90,9 +91,9 @@ (define hashtable-mutable? r6rs:hashtable-mutable?) - (define hash-by-value ((@@ (srfi srfi-69) caller-with-default-size) hashv)) - (define (wrap-hash-function proc) - (lambda (key capacity) (modulo (proc key) capacity))) + ;; (define hash-by-value ((@@ (srfi srfi-69) caller-with-default-size) hashv)) + ;; (define (wrap-hash-function proc) + ;; (lambda (key capacity) (modulo (proc key) capacity))) (define* (make-eq-hashtable #:optional k) (make-r6rs-hashtable @@ -109,14 +110,13 @@ 'eqv)) (define* (make-hashtable hash-function equiv #:optional k) - (let ((wrapped-hash-function (wrap-hash-function hash-function))) - (make-r6rs-hashtable - (if k - (make-hash-table equiv wrapped-hash-function k) - (make-hash-table equiv wrapped-hash-function)) - hash-function - #t - 'custom))) + (make-r6rs-hashtable + (if k + (make-hash-table equiv hash-function k) + (make-hash-table equiv hash-function)) + hash-function + #t + 'custom)) (define (hashtable-size hashtable) (hash-table-size (r6rs:hashtable-wrapped-table hashtable))) @@ -156,13 +156,12 @@ (if (r6rs:hashtable-mutable? hashtable) (let* ((ht (r6rs:hashtable-wrapped-table hashtable)) (equiv (hash-table-equivalence-function ht)) - (hash-function (r6rs:hashtable-orig-hash-function hashtable)) - (wrapped-hash-function (wrap-hash-function hash-function))) + (hash-function (r6rs:hashtable-orig-hash-function hashtable))) (r6rs:hashtable-set-wrapped-table! hashtable (if k - (make-hash-table equiv wrapped-hash-function k) - (make-hash-table equiv wrapped-hash-function))))) + (make-hash-table equiv hash-function k) + (make-hash-table equiv hash-function))))) *unspecified*) (define (hashtable-keys hashtable) diff --git a/module/srfi/srfi-69.scm b/module/srfi/srfi-69.scm index 2b7fb9a7f..ae5bc7f06 100644 --- a/module/srfi/srfi-69.scm +++ b/module/srfi/srfi-69.scm @@ -16,7 +16,8 @@ ;; License along with this library; if not, write to the Free Software ;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA -;;;; Commentary: + +;;;; Original (stale) SRFI-69 commentary: ;; My `hash' is compatible with core `hash', so I replace it. ;; However, my `hash-table?' and `make-hash-table' are different, so @@ -65,8 +66,7 @@ ;;;; Commentary by Jessica Milare 2018 -;; Make bug fixes for weak hash-tables, since handles don't work anymore, -;; and also some optimizations. +;; Now implemented using module (ice-9 generic-hash-tables) ;; ;; My personal comments are marked by J.M. @@ -75,300 +75,136 @@ ;;;; Module definition & exports (define-module (srfi srfi-69) - #:use-module (srfi srfi-1) ;alist-cons,second&c,assoc - #:use-module (srfi srfi-9) - #:use-module (srfi srfi-13) ;string-hash,string-hash-ci - #:use-module (ice-9 optargs) - #:export (;; Type constructors & predicate - make-hash-table hash-table? alist->hash-table + #:use-module (srfi srfi-1) + #:use-module ((ice-9 generic-hash-tables) #:prefix gen:) + #:replace (make-hash-table hash-table? hash) + #:export (;; Type constructors + make-hash-table + hash-table? alist->hash-table ;; Reflective queries hash-table-equivalence-function hash-table-hash-function ;; Dealing with single elements hash-table-ref hash-table-ref/default hash-table-set! - hash-table-delete! hash-table-exists? hash-table-update! + hash-table-delete! hash-table-update! hash-table-update!/default + hash-table-exists? ;; Dealing with the whole contents hash-table-size hash-table-keys hash-table-values - hash-table-walk hash-table-fold hash-table->alist - hash-table-copy hash-table-merge! + hash-table->alist hash-table-fold + hash-table-walk hash-table-merge! + hash-table-copy ;; Hashing - string-ci-hash hash-by-identity) - #:re-export (string-hash) - #:replace (hash make-hash-table hash-table?)) + string-ci-hash hash-by-identity hash) + #:re-export (string-hash)) (cond-expand-provide (current-module) '(srfi-69)) - -;;;; Internal helper macros - -;; Define these first, so the compiler will pick them up. - -;; I am a macro only for efficiency, to avoid varargs/apply. -(define-macro (hashx-invoke hashx-proc ht-var . args) - "Invoke HASHX-PROC, a `hashx-*' procedure taking a hash-function, -assoc-function, and the hash-table as first args." - `(,hashx-proc (hash-table-hash-function ,ht-var) - (ht-associator ,ht-var) - (ht-real-table ,ht-var) - . ,args)) -(define-macro (with-hashx-values bindings ht-var . body-forms) - "Bind BINDINGS to the hash-function, associator, and real-table of -HT-VAR, while evaluating BODY-FORMS." - `(let ((,(first bindings) (hash-table-hash-function ,ht-var)) - (,(second bindings) (ht-associator ,ht-var)) - (,(third bindings) (ht-real-table ,ht-var))) - . ,body-forms)) - - ;;;; Hashing - -;;; The largest fixnum is in `most-positive-fixnum' in module (guile), -;;; though not documented anywhere but libguile/numbers.c. - -(define (caller-with-default-size hash-fn) - "Answer a function that makes `most-positive-fixnum' the default -second argument to HASH-FN, a 2-arg procedure." - (lambda* (obj #:optional (size most-positive-fixnum)) - (hash-fn obj size))) - -(define hash (caller-with-default-size (@ (guile) hash))) - (define string-ci-hash string-hash-ci) +(define hash gen:hash) +(define hash-by-identity gen:hash-by-identity) -(define hash-by-identity (caller-with-default-size hashq)) ;;;; Reflective queries, construction, predicate -(define-record-type srfi-69:hash-table - (make-srfi-69-hash-table real-table associator size weakness - equivalence-function hash-function) - hash-table? - (real-table ht-real-table) - (associator ht-associator) - ;; required for O(1) by SRFI-69. It really makes a mess of things, - ;; and I'd like to compute it in O(n) and memoize it because it - ;; doesn't seem terribly useful, but SRFI-69 is final. - (size ht-size ht-size!) - ;; required for `hash-table-copy' - (weakness ht-weakness) - ;; used only to implement hash-table-equivalence-function; I don't - ;; use it internally other than for `ht-associator'. - (equivalence-function hash-table-equivalence-function) - (hash-function hash-table-hash-function)) +(define hash-table? gen:hash-table?) (define (guess-hash-function equal-proc) "Guess a hash function for EQUAL-PROC, falling back on `hash', as specified in SRFI-69 for `make-hash-table'." - (cond ((eq? equal? equal-proc) (@ (guile) hash)) ;shortcut most common case - ((eq? eq? equal-proc) hashq) - ((eq? eqv? equal-proc) hashv) - ((eq? string=? equal-proc) string-hash) - ((eq? string-ci=? equal-proc) string-ci-hash) - (else (@ (guile) hash)))) - -(define (without-keyword-args rest-list) - "Answer REST-LIST with all keywords removed along with items that -follow them." - (let lp ((acc '()) (rest-list rest-list)) - (cond ((null? rest-list) (reverse! acc)) - ((keyword? (first rest-list)) - (lp acc (cddr rest-list))) - (else (lp (cons (first rest-list) acc) (cdr rest-list)))))) - -(define (guile-ht-ctor weakness) - "Answer the Guile HT constructor for the given WEAKNESS." - (case weakness - ((#f) (@ (guile) make-hash-table)) - ((key) make-weak-key-hash-table) - ((value) make-weak-value-hash-table) - ((key-or-value) make-doubly-weak-hash-table) - (else (error "Invalid weak hash table type" weakness)))) - -(define (equivalence-proc->associator equal-proc) - "Answer an `assoc'-like procedure that compares the argument key to -alist keys with EQUAL-PROC." - (cond ((or (eq? equal? equal-proc) - (eq? string=? equal-proc)) (@ (guile) assoc)) - ((eq? eq? equal-proc) assq) - ((eq? eqv? equal-proc) assv) - (else (lambda (item alist) - (assoc item alist equal-proc))))) - -(define* (make-hash-table - #:optional (equal-proc equal?) - (hash-proc (guess-hash-function equal-proc)) - #:key (weak #f) #:rest guile-opts) + (cond ((eq? equal? equal-proc) gen:hash) ;shortcut most common case + ((eq? eq? equal-proc) gen:hash-by-identity) + ((eq? eqv? equal-proc) gen:hash-by-value) + ((eq? string=? equal-proc) gen:string-hash) + ((eq? string-ci=? equal-proc) gen:string-ci-hash) + (else gen:hash))) + +(define (normalize-weakness weak) + "Normalizes SRFI-69 standard #:weak to SRFI-126 weakness argument." + (case weak + ((#f) #f) + ((key) 'weak-key) + ((value) 'weak-value) + ((key-or-value) 'weak-key-and-value) + (else (error "Invalid weak hash table type" weak)))) + +(define* (make-hash-table #:optional (equal-proc equal?) + (hash-proc (guess-hash-function equal-proc)) + #:key (weak #f) #:rest args) "Answer a new hash table using EQUAL-PROC as the comparison function, and HASH-PROC as the hash function. See the reference manual for specifics, of which there are many." - (make-srfi-69-hash-table - (apply (guile-ht-ctor weak) (without-keyword-args guile-opts)) - (equivalence-proc->associator equal-proc) - 0 weak equal-proc hash-proc)) + (let ((capacity (find integer? args))) + (gen:make-hash-table equal-proc hash-proc + #:weakness (normalize-weakness weak) + #:capacity (or capacity 1)))) + +(define hash-table-equivalence-function gen:hash-table-equivalence-function) +(define hash-table-hash-function gen:hash-table-hash-function) +(define* (alist->hash-table alist #:optional (equal-proc equal?) + (hash-proc (guess-hash-function equal-proc)) + #:key (weak #f) #:rest args) + (let ((capacity (find integer? args))) + (gen:alist->hash-table alist equal-proc hash-proc + #:weakness (normalize-weakness weak) + #:capacity (or capacity 1)))) -(define (alist->hash-table alist . mht-args) - "Convert ALIST to a hash table created with MHT-ARGS." - (let* ((result (apply make-hash-table mht-args)) - (size (ht-size result))) - (with-hashx-values (hash-proc associator real-table) result - (for-each (lambda (pair) - (let ((value (hashx-ref hash-proc associator - real-table (car pair) - ht-unspecified))) - (cond ((eq? ht-unspecified value) - (set! size (1+ size)) - (hashx-set! hash-proc associator real-table - (car pair) (cdr pair)))))) - alist)) - (ht-size! result size) - result)) -;;;; Accessing table items - -;; We use this to denote missing or unspecified values to avoid - -;; possible collision with *unspecified*. -(define ht-unspecified (cons *unspecified* "ht-value")) +;; Dealing with single elements -(define* (hash-table-ref ht key #:optional (default-thunk ht-unspecified)) +(define* (hash-table-ref ht key #:optional failure) "Lookup KEY in HT and answer the value, invoke DEFAULT-THUNK if KEY isn't present, or signal an error if DEFAULT-THUNK isn't provided." - (let ((result (hashx-invoke hashx-ref ht key ht-unspecified))) - (if (eq? ht-unspecified result) - (if (eq? ht-unspecified default-thunk) - (error "Key not in table" key ht) - (default-thunk)) - result))) - -(define (hash-table-ref/default ht key default) - "Lookup KEY in HT and answer the value. Answer DEFAULT if KEY isn't -present." - (hashx-invoke hashx-ref ht key default)) - -(define (hash-table-set! ht key new-value) - "Set KEY to NEW-VALUE in HT." - (if (ht-weakness ht) - ;; J.M. separate the case where ht is weak - don't use handle - ;; J.M. don't need to update size for weak hash-tables - (hashx-invoke hashx-set! ht key new-value) - (let ((handle (hashx-invoke hashx-create-handle! ht key - ht-unspecified))) - (if (eq? ht-unspecified (cdr handle)) - (ht-size! ht (1+ (ht-size ht)))) - (set-cdr! handle new-value))) - *unspecified*) + (if failure + (gen:hash-table-ref ht key failure) + (gen:hash-table-ref ht key))) +(define hash-table-ref/default gen:hash-table-ref/default) +(define hash-table-exists? gen:hash-table-contains?) +(define hash-table-set! gen:hash-table-set-single!) (define (hash-table-delete! ht key) - "Remove KEY's association in HT." - (with-hashx-values (h a real-ht) ht - (if (not (eq? ht-unspecified (hashx-ref h a real-ht key ht-unspecified))) - (begin - (ht-size! ht (1- (ht-size ht))) - (hashx-remove! h a real-ht key)))) + (gen:hash-table-delete-single! ht key) *unspecified*) -(define (hash-table-exists? ht key) - "Return whether KEY is a key in HT." - (not (eq? ht-unspecified (hashx-invoke hashx-ref ht key ht-unspecified)))) - -;;; `hash-table-update!' non-locally. -(define* (hash-table-update! ht key modifier - #:optional (default-thunk ht-unspecified)) +(define* (hash-table-update! ht key modifier #:optional default-thunk) "Modify HT's value at KEY by passing its value to MODIFIER and setting it to the result thereof. Invoke DEFAULT-THUNK for the old value if KEY isn't in HT, or signal an error if DEFAULT-THUNK is not provided." - (with-hashx-values (hash-proc associator real-table) ht - (if (ht-weakness ht) - ;; J.M. separate the case where ht is weak - don't use handle - (let* ((old (hashx-ref hash-proc associator real-table key - ht-unspecified))) - (cond ((eq? ht-unspecified old) - (if (eq? ht-unspecified default-thunk) - (error "Key not in table" key ht) - (hashx-set! hash-proc associator real-table key - (modifier (default-thunk))))) - (else - (hashx-set! hash-proc associator real-table key - (modifier old))))) - (let ((handle (hashx-get-handle hash-proc associator real-table key))) - (cond (handle (if (eq? ht-unspecified (cdr handle)) - (begin (ht-size! ht (1+ (ht-size ht))) - (set-cdr! handle (modifier (default-thunk)))) - (set-cdr! handle (modifier (cdr handle))))) - (else (if (eq? ht-unspecified default-thunk) - (error "Key not in table" key ht) - (let ((default (default-thunk))) - (ht-size! ht (1+ (ht-size ht))) - (hashx-set! hash-proc associator real-table key - (modifier default))))))))) - *unspecified*) + (if default-thunk + (gen:hash-table-update! ht key modifier default-thunk) + (gen:hash-table-update! ht key modifier))) + +(define hash-table-update!/default gen:hash-table-update!/default) -;;; J.M. Custom implementation instead of using hash-table-update! -(define (hash-table-update!/default ht key modifier default) - "Modify HT's value at KEY by passing its old value, or DEFAULT if it -doesn't have one, to MODIFIER, and setting it to the result thereof." - (with-hashx-values (hash-proc associator real-table) ht - (if (ht-weakness ht) - ;; J.M. separate the case where ht is weak - don't use handle - (let* ((old (hashx-ref hash-proc associator real-table key default))) - (hashx-set! hash-proc associator real-table key (modifier old))) - (let ((handle (hashx-create-handle! hash-proc associator real-table key - ht-unspecified))) - (if (eq? ht-unspecified (cdr handle)) - (begin (ht-size! ht (1+ (ht-size ht))) - (set-cdr! handle (modifier default))) - (set-cdr! handle (modifier (cdr handle)))))))) ;;;; Accessing whole tables -(define (hash-table-size ht) - "Return the number of associations in HT. This is guaranteed O(1) -for tables where #:weak was #f or not specified at creation time." - (if (ht-weakness ht) - (let ((size (hash-table-fold ht (lambda (k v ans) (1+ ans)) 0))) - (ht-size! ht size) - size) - (ht-size ht))) - -(define (hash-table-keys ht) - "Return a list of the keys in HT." - (hash-table-fold ht (lambda (k v lst) (cons k lst)) '())) - -(define (hash-table-values ht) - "Return a list of the values in HT." - (hash-table-fold ht (lambda (k v lst) (cons v lst)) '())) +(define hash-table-size gen:hash-table-size) +(define hash-table-keys gen:hash-table-keys) +(define hash-table-values gen:hash-table-values) +(define hash-table->alist gen:hash-table->alist) (define (hash-table-walk ht proc) "Call PROC with each key and value as two arguments." - (hash-for-each proc (ht-real-table ht))) + (gen:hash-table-for-each proc ht)) (define (hash-table-fold ht f knil) "Invoke (F KEY VAL PREV) for each KEY and VAL in HT, where PREV is the result of the previous invocation, using KNIL as the first PREV. Answer the final F result." - (hash-fold f knil (ht-real-table ht))) - -(define (hash-table->alist ht) - "Return an alist for HT." - (hash-map->list cons (ht-real-table ht))) + (gen:hash-table-fold f knil ht)) (define (hash-table-copy ht) "Answer a copy of HT." - (with-hashx-values (h a real-ht) ht - (let* ((size (hash-table-size ht)) (weak (ht-weakness ht)) - (new-real-ht ((guile-ht-ctor weak) size))) - (hash-for-each (lambda (k v) (hashx-set! h a new-real-ht k v)) - real-ht) - (make-srfi-69-hash-table ;real,assoc,size,weak,equiv,h - new-real-ht a size weak - (hash-table-equivalence-function ht) h)))) + (gen:hash-table-copy ht)) (define (hash-table-merge! ht other-ht) "Add all key/value pairs from OTHER-HT to HT, overriding HT's mappings where present. Return HT." - (hash-for-each (lambda (k v) (hash-table-set! ht k v)) - (ht-real-table other-ht)) + ;; HASH-TABLE-SET! tests if HT is mutable. + (gen:hash-table-for-each (lambda (k v) (hash-table-set! ht k v)) + other-ht) ht) ;;; srfi-69.scm ends here diff --git a/test-suite/tests/srfi-69.test b/test-suite/tests/srfi-69.test index c2a554db3..e1579f73a 100644 --- a/test-suite/tests/srfi-69.test +++ b/test-suite/tests/srfi-69.test @@ -141,6 +141,7 @@ case-insensitive strings to `equal?'-tested values." (lset= equal? '((b . 3) (c . 4)) (hash-table->alist ht2)))))) (pass-if "can use all arguments, including size" - (hash-table? (make-hash-table equal? hash #:weak 'key 31))) + (let ((ht (make-hash-table equal? hash #:weak 'key 31))) + (hash-table? ht))) ) -- 2.19.1