From ce10994fd7cd7546b7707a40712ec9603e740107 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?J=C3=A9ssica=20Milar=C3=A9?= Date: Tue, 8 Jan 2019 21:55:40 -0200 Subject: [PATCH 1/5] Fix: SRFI-69 don't use handles with weak tables anymore. Many procedures used hashx-get-handle and hashx-create-handle! without checking whether real-hash-table was weak. Now that isn't the case anymore (Bug 33827). A bug was fixed in hash-table-merge! and a test case was added. A few other optimizations were made. * module/srfi/srfi-69.scm (alist->hash-table): (hash-table-delete!): (hash-table-exists?): (hash-table-ref): Don't use hashx-get-handle. (hash-table-set!): If weakness is set, don't use hashx-create-handle! and don't update size. (hash-table-update!): If weakness is set, don't use hashx-get-handle and don't update size. (hash-table-update!/default): Added an implementation that doesn't call hash-table-update!, avoiding allocating a procedure. (hash-table-size): Set ht-size for weak hash-tables. (hash-table-walk): (hash-table-copy): Use native hash-for-each instead of hash-table-fold. (hash-table->alist): Use native hash-map->list instead of hash-table-fold. (hash-table-merge!): Use native hash-for-each instead of hash-table-fold. Walks over other-ht rather than walking ht (and doing nothing). * test-suite/tests/srfi-69.test: all appropriate test are replicated for all possible #:weak arguments. Added a test for hash-table-merge!. --- THANKS | 1 + module/srfi/srfi-69.scm | 148 ++++++++++++++++++----------- test-suite/tests/srfi-69.test | 173 +++++++++++++++++++++------------- 3 files changed, 200 insertions(+), 122 deletions(-) diff --git a/THANKS b/THANKS index 616d3b04b..9056a795c 100644 --- a/THANKS +++ b/THANKS @@ -20,6 +20,7 @@ Contributors since the last release: Noah Lavine Daniel Llorens Gregory Marton + Jéssica Milaré Thien-Thi Nguyen Han-Wen Nienhuys Jan Nieuwenhuizen diff --git a/module/srfi/srfi-69.scm b/module/srfi/srfi-69.scm index b9486c465..2b7fb9a7f 100644 --- a/module/srfi/srfi-69.scm +++ b/module/srfi/srfi-69.scm @@ -62,6 +62,14 @@ ;; implementation, both answer ("xY"). However, I don't guarantee that ;; this won't change in the future. + +;;;; Commentary by Jessica Milare 2018 + +;; Make bug fixes for weak hash-tables, since handles don't work anymore, +;; and also some optimizations. +;; +;; My personal comments are marked by J.M. + ;;; Code: ;;;; Module definition & exports @@ -73,18 +81,18 @@ #:use-module (ice-9 optargs) #:export (;; Type constructors & predicate 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-update!/default - ;; 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! - ;; Hashing - string-ci-hash hash-by-identity) + ;; 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-update!/default + ;; 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! + ;; Hashing + string-ci-hash hash-by-identity) #:re-export (string-hash) #:replace (hash make-hash-table hash-table?)) @@ -204,30 +212,32 @@ manual for specifics, of which there are many." (size (ht-size result))) (with-hashx-values (hash-proc associator real-table) result (for-each (lambda (pair) - (let ((handle (hashx-get-handle hash-proc associator - real-table (car pair)))) - (cond ((not handle) - (set! size (1+ size)) - (hashx-set! hash-proc associator real-table - (car pair) (cdr pair)))))) - alist)) + (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")) -(define (hash-table-ref ht key . default-thunk-lst) +(define* (hash-table-ref ht key #:optional (default-thunk ht-unspecified)) "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 (pair? default-thunk-lst) - ((first default-thunk-lst)) - (error "Key not in table" key ht)) + (if (eq? ht-unspecified default-thunk) + (error "Key not in table" key ht) + (default-thunk)) result))) (define (hash-table-ref/default ht key default) @@ -237,49 +247,78 @@ present." (define (hash-table-set! ht key new-value) "Set KEY to NEW-VALUE in HT." - (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)) + (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*) (define (hash-table-delete! ht key) "Remove KEY's association in HT." (with-hashx-values (h a real-ht) ht - (if (hashx-get-handle h a real-ht key) - (begin - (ht-size! ht (1- (ht-size ht))) - (hashx-remove! h a real-ht key)))) + (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)))) *unspecified*) (define (hash-table-exists? ht key) "Return whether KEY is a key in HT." - (and (hashx-invoke hashx-get-handle ht key) #t)) + (not (eq? ht-unspecified (hashx-invoke hashx-ref ht key ht-unspecified)))) -;;; `hashx-set!' duplicates the hash lookup, but we use it anyway to -;;; avoid creating a handle in case DEFAULT-THUNK exits ;;; `hash-table-update!' non-locally. -(define (hash-table-update! ht key modifier . default-thunk-lst) +(define* (hash-table-update! ht key modifier + #:optional (default-thunk ht-unspecified)) "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 - (let ((handle (hashx-get-handle hash-proc associator real-table key))) - (cond (handle - (set-cdr! handle (modifier (cdr handle)))) - (else - (hashx-set! hash-proc associator real-table key - (if (pair? default-thunk-lst) - (modifier ((car default-thunk-lst))) - (error "Key not in table" key ht))) - (ht-size! ht (1+ (ht-size 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*) +;;; 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." - (hash-table-update! ht key modifier (lambda () default))) + (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 @@ -287,7 +326,9 @@ doesn't have one, to MODIFIER, and setting it to the result thereof." "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) - (hash-table-fold ht (lambda (k v ans) (1+ ans)) 0) + (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) @@ -300,10 +341,7 @@ for tables where #:weak was #f or not specified at creation time." (define (hash-table-walk ht proc) "Call PROC with each key and value as two arguments." - (hash-table-fold ht (lambda (k v unspec) - (call-with-values (lambda () (proc k v)) - (lambda vals unspec))) - *unspecified*)) + (hash-for-each proc (ht-real-table ht))) (define (hash-table-fold ht f knil) "Invoke (F KEY VAL PREV) for each KEY and VAL in HT, where PREV is @@ -313,15 +351,15 @@ Answer the final F result." (define (hash-table->alist ht) "Return an alist for HT." - (hash-table-fold ht alist-cons '())) + (hash-map->list cons (ht-real-table 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-fold (lambda (k v ign) (hashx-set! h a new-real-ht k v)) - #f real-ht) + (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)))) @@ -329,8 +367,8 @@ Answer the final F result." (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-table-fold - ht (lambda (k v ign) (hash-table-set! ht k v)) #f) + (hash-for-each (lambda (k v) (hash-table-set! ht k v)) + (ht-real-table 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 e99b76c6d..c2a554db3 100644 --- a/test-suite/tests/srfi-69.test +++ b/test-suite/tests/srfi-69.test @@ -28,80 +28,119 @@ case-insensitive strings to `equal?'-tested values." (and (string-ci=? (car left) (car right)) (equal? (cdr left) (cdr right)))) +(define-syntax with-weakness-list + (syntax-rules () + ((with-weakness-list weakness weakness-list expr ...) + (let loop ((weakness-list* weakness-list)) + (or (null? weakness-list*) + (and (let ((weakness (car weakness-list*))) + expr ...) + (loop (cdr weakness-list*)))))))) + +(define (test-str-weakness str weakness) + (if (not weakness) str (format #f "~a (weak: ~a)" str weakness))) + (with-test-prefix "SRFI-69" - (pass-if "small alist<->hash tables round-trip" - (let* ((start-alist '((a . 1) (b . 2) (c . 3) (a . 42))) - (ht (alist->hash-table start-alist eq?)) - (end-alist (hash-table->alist ht))) - (and (= 3 (hash-table-size ht)) - (lset= equal? end-alist (take start-alist 3)) - (= 1 (hash-table-ref ht 'a)) - (= 2 (hash-table-ref ht 'b)) - (= 3 (hash-table-ref ht 'c))))) - - (pass-if "string-ci=? tables work by default" - (let ((ht (alist->hash-table '(("xY" . 2) ("abc" . 54)) string-ci=?))) - (hash-table-set! ht "XY" 42) - (hash-table-set! ht "qqq" 100) - (and (= 54 (hash-table-ref ht "ABc")) - (= 42 (hash-table-ref ht "xy")) - (= 3 (hash-table-size ht)) - (lset= string-ci-assoc-equal? - '(("xy" . 42) ("abc" . 54) ("qqq" . 100)) - (hash-table->alist ht))))) + (with-weakness-list weakness (list #f 'key 'value 'key-or-value) + (pass-if (test-str-weakness "small alist<->hash tables round-trip" weakness) + (let* ((start-alist '((a . 1) (b . 2) (c . 3) (a . 42))) + (ht (alist->hash-table start-alist eq? #:weak weakness)) + (end-alist (hash-table->alist ht))) + (and (= 3 (hash-table-size ht)) + (lset= equal? end-alist (take start-alist 3)) + (= 1 (hash-table-ref ht 'a)) + (= 2 (hash-table-ref ht 'b)) + (= 3 (hash-table-ref ht 'c)))))) + + (with-weakness-list weakness (list #f 'key 'value 'key-or-value) + (pass-if (test-str-weakness "string-ci=? tables work by default" weakness) + (let ((ht (alist->hash-table '(("xY" . 2) ("abc" . 54)) string-ci=? + #:weak weakness))) + (hash-table-set! ht "XY" 42) + (hash-table-set! ht "qqq" 100) + (and (= 54 (hash-table-ref ht "ABc")) + (= 42 (hash-table-ref ht "xy")) + (= 3 (hash-table-size ht)) + (lset= string-ci-assoc-equal? + '(("xy" . 42) ("abc" . 54) ("qqq" . 100)) + (hash-table->alist ht)))))) (pass-if-exception "Bad weakness arg to mht signals an error" - '(misc-error . "^Invalid weak hash table type") + '(misc-error . "^Invalid weak hash table type") (make-hash-table equal? hash #:weak 'key-and-value)) - (pass-if "empty hash tables are empty" - (null? (hash-table->alist (make-hash-table eq?)))) - - (pass-if "hash-table-ref uses default" - (equal? '(4) - (hash-table-ref (alist->hash-table '((a . 1)) eq?) - 'b (cut list (+ 2 2))))) - - (pass-if "hash-table-delete! deletes present assocs, ignores others" - (let ((ht (alist->hash-table '((a . 1) (b . 2)) eq?))) - (hash-table-delete! ht 'c) - (and (= 2 (hash-table-size ht)) - (begin - (hash-table-delete! ht 'a) - (= 1 (hash-table-size ht))) - (lset= equal? '((b . 2)) (hash-table->alist ht))))) - - (pass-if "alist->hash-table does not require linear stack space" - (eqv? 99999 - (hash-table-ref (alist->hash-table - (unfold-right (cut >= <> 100000) - (lambda (s) `(x . ,s)) 1+ 0) - eq?) - 'x))) - - (pass-if "hash-table-walk ignores return values" - (let ((ht (alist->hash-table '((a . 1) (b . 2) (c . 3)) eq?))) - (for-each (cut hash-table-walk ht <>) - (list (lambda (k v) (values)) - (lambda (k v) (values 1 2 3)))) - #t)) - - (pass-if "hash-table-update! modifies existing binding" - (let ((ht (alist->hash-table '((a . 1)) eq?))) - (hash-table-update! ht 'a 1+) - (hash-table-update! ht 'a (cut + 4 <>) (lambda () 42)) - (and (= 1 (hash-table-size ht)) - (lset= equal? '((a . 6)) (hash-table->alist ht))))) - - (pass-if "hash-table-update! creates new binding when appropriate" - (let ((ht (make-hash-table eq?))) - (hash-table-update! ht 'b 1+ (lambda () 42)) - (hash-table-update! ht 'b (cut + 10 <>)) - (and (= 1 (hash-table-size ht)) - (lset= equal? '((b . 53)) (hash-table->alist ht))))) + (with-weakness-list weakness (list #f 'key 'value 'key-or-value) + (pass-if (test-str-weakness "empty hash tables are empty" weakness) + (null? (hash-table->alist (make-hash-table eq? #:weak weakness))))) + + (with-weakness-list weakness (list #f 'key 'value 'key-or-value) + (pass-if (test-str-weakness "hash-table-ref uses default" weakness) + (equal? '(4) + (hash-table-ref (alist->hash-table '((a . 1)) eq? #:weak weakness) + 'b (cut list (+ 2 2)))))) + + (with-weakness-list weakness (list #f 'key 'value 'key-or-value) + (pass-if (test-str-weakness "hash-table-delete! deletes present assocs, ignores others" + weakness) + (let ((ht (alist->hash-table '((a . 1) (b . 2)) eq? #:weak weakness))) + (hash-table-delete! ht 'c) + (and (= 2 (hash-table-size ht)) + (begin + (hash-table-delete! ht 'a) + (= 1 (hash-table-size ht))) + (lset= equal? '((b . 2)) (hash-table->alist ht)))))) + + (with-weakness-list weakness (list #f 'key 'value 'key-or-value) + (pass-if (test-str-weakness "alist->hash-table does not require linear stack space" + weakness) + (eqv? 99999 + (hash-table-ref (alist->hash-table + (unfold-right (cut >= <> 100000) + (lambda (s) `(x . ,s)) 1+ 0) + eq? + #:weak weakness) + 'x)))) + + (with-weakness-list weakness (list #f 'key 'value 'key-or-value) + (pass-if (test-str-weakness "hash-table-walk ignores return values" + weakness) + (let ((ht (alist->hash-table '((a . 1) (b . 2) (c . 3)) eq?))) + (for-each (cut hash-table-walk ht <>) + (list (lambda (k v) (values)) + (lambda (k v) (values 1 2 3)))) + #t))) + + (with-weakness-list weakness (list #f 'key 'value 'key-or-value) + (pass-if (test-str-weakness "hash-table-update! modifies existing binding" + weakness) + (let ((ht (alist->hash-table '((a . 1)) eq? #:weak weakness))) + (hash-table-update! ht 'a 1+) + (hash-table-update! ht 'a (cut + 4 <>) (lambda () 42)) + (and (= 1 (hash-table-size ht)) + (lset= equal? '((a . 6)) (hash-table->alist ht)))))) + + (with-weakness-list weakness (list #f 'key 'value 'key-or-value) + (pass-if (test-str-weakness "hash-table-update! creates new binding when appropriate" + weakness) + (let ((ht (make-hash-table eq? #:weak weakness))) + (hash-table-update! ht 'b 1+ (lambda () 42)) + (hash-table-update! ht 'b (cut + 10 <>)) + (and (= 1 (hash-table-size ht)) + (lset= equal? '((b . 53)) (hash-table->alist ht)))))) + + (with-weakness-list weakness (list #f 'key 'value 'key-or-value) + (pass-if (test-str-weakness "hash-table-merge! functions properly" + weakness) + (let* ((ht1 (alist->hash-table '((a . 1) (b . 2)) eq? #:weak weakness)) + (ht2 (alist->hash-table '((b . 3) (c . 4)) eq? #:weak weakness))) + (set! ht1 (hash-table-merge! ht1 ht2)) + (and (= 3 (hash-table-size ht1)) + (= 2 (hash-table-size ht2)) + (lset= equal? '((a . 1) (b . 3) (c . 4)) (hash-table->alist ht1)) + (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))) -) + ) -- 2.19.1