Subject: bug#33827: Patch

From: Jéssica Milaré <[email-masked]>
Date: Sun, 23 Dec 2018 15:09:22 -0200

From 87ff519b9288dedcc62a2fd1b2c03eccbf631e56 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?J=C3=A9ssica=20Milar=C3=A9?= <[email-masked]>
Date: Sun, 23 Dec 2018 15:07:32 -0200
Subject: [PATCH] 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. Otherwise, check whether default-thunk is given
and, if so, use hashx-create-handle! to avoid double lookup.
(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       | 149 +++++++++++++++++-----------
 test-suite/tests/srfi-69.test | 177 +++++++++++++++++++++-------------
 3 files changed, 205 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..a05ec61ea 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,79 @@ 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
+               (if (eq? ht-unspecified default-thunk)
+                   (hashx-get-handle hash-proc associator real-table key)
+                   (hashx-create-handle! hash-proc associator real-table key
+                                         ht-unspecified))))
+          (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
+                 (error "Key not in table" key ht))))))
   *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 +327,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 +342,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 +352,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 +368,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..105ae3759 100644
--- a/test-suite/tests/srfi-69.test
+++ b/test-suite/tests/srfi-69.test
@@ -28,80 +28,123 @@ 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?))
+             (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)
+      (let loop ((weakness-list (list #f 'key 'value 'key-or-value)))
+        (or (null? weakness-list)
+            (let ((weakness (car weakness-list)))
+              (and (null? (hash-table->alist (make-hash-table eq? #:weak weakness)))
+                   (loop (cdr weakness-list))))))))
+
+  (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