GitLab

at 2023-08-20T15:17:51-07:00

Always hash list2 and add tests

Made a logic error; we can't hash the shorter of the two lists, at
least not without a big change to the implementation.  We always hash
the second list now.  Remove shorter-list-to-hashtable.

Add tests for subsetp.

@@ -991,35 +991,6 @@
  (defvar *allow-hashtable-for-set-functions* t)
 -(declaim (start-block shorter-list-to-hashtable subsetp))
+-
 -(defun shorter-list-to-hashtable (list1 list2 key test test-not)
 -  ;; Find the shorter list and return the length and the shorter list
 -  (when test-not
 -    (return-from shorter-list-to-hashtable nil))
 -  (let ((hash-test (let ((test-fn (if (and (symbolp test)
 -                                           (fboundp test))
 -                                      (fdefinition test)
 -                                      test)))
 -                     (cond ((eql test-fn #'eq) 'eq)
 -                           ((eql test-fn #'eql) 'eql)
 -                           ((eql test-fn #'equal) 'equal)
 -                           ((eql test-fn #'equalp) 'equalp)))))
 -    (unless hash-test
 -      (return-from shorter-list-to-hashtable nil))
 -    (multiple-value-bind (min-length shorter-list)
 -        (do ((len 0 (1+ len))
 -             (lst1 list1 (cdr lst1))
 -             (lst2 list2 (cdr lst2)))
 -            ((or (null lst1) (null lst2))
 -             (values len (if (null lst1) list1 list2))))
 -      (when (< min-length *min-list-length-for-hashtable*)
 -        (return-from shorter-list-to-hashtable nil))
 -      (let ((hashtable (make-hash-table :test hash-test :size min-length)))
 -        (dolist (item shorter-list)
 -          (setf (gethash (apply-key key item) hashtable) item))
 -        (values hashtable shorter-list)))))
+-
  (defun subsetp (list1 list2 &key key (test #'eql testp) (test-not nil notp))
    "Returns T if every element in list1 is also in list2."
    (declare (inline member))
@@ -1029,28 +1000,21 @@
    ;; SUBSETP is used early in TYPE-INIT where hash tables aren't
    ;; available yet, so we can't use hashtables then.  LISPINIT will
    ;; take care to disable this for the kernel.core.  SAVE will set
 -  ;; this to true it's safe to use hash tables for SUBSETP.
 -  (multiple-value-bind (hashtable shorter-list)
 -      (when *allow-hashtable-for-set-functions*
 -        (shorter-list-to-hashtable list1 list2 key test test-not))
 +  ;; this to true when it's safe to use hash tables for SUBSETP.
 +  (let ((hashtable
 +          (when *allow-hashtable-for-set-functions*
 +            (list-to-hashtable list2 key test test-not))))
      (cond (hashtable
 -           (cond ((eq shorter-list list1)
 -                  (dolist (item list2)
 -	            (unless (nth-value 1 (gethash (apply-key key item) hashtable))
 -	              (return-from subsetp nil))))
 -                 ((eq shorter-list list2)
 -	          (dolist (item list1)
 -	            (unless (nth-value 1 (gethash (apply-key key item) hashtable))
 -	              (return-from subsetp nil)))))
 +	   (dolist (item list1)
 +	     (unless (nth-value 1 (gethash (apply-key key item) hashtable))
 +	       (return-from subsetp nil)))
             t)
 -	  ((null hashtable)
 +	  (t
  	   (dolist (item list1)
  	     (unless (with-set-keys (member (apply-key key item) list2))
  	       (return-from subsetp nil)))
  	   T))))
 -(declaim (end-block))
+-
  ;;; Functions that operate on association lists

@@ -172,3 +172,54 @@
  		       '(3 4)
  		       :test 'eql
  		       :test-not 'eql)))
++
++
 +(define-test subsetp.hash-eq
 +    (:tag :issues)
 +  (let ((lisp::*min-list-length-for-hashtable* 2))
 +    (assert-true
 +     (subsetp '(a b c a) '(a a d d c b) :test 'eq))
 +    (assert-true
 +     (subsetp '(a b c a b c a b c) '(a a d d c b) :test 'eq))
 +    (assert-false
 +     (subsetp '(a b c a z) '(a a d d c b) :test 'eq))
 +    (assert-false
 +     (subsetp '(a b c a b cz) '(a a d d c b) :test 'eq))))
++
 +(define-test subsetp.hash-eql
 +    (:tag :issues)
 +  (let ((lisp::*min-list-length-for-hashtable* 2))
 +    (assert-true
 +     (subsetp '(a b c a) '(a a d d c b) :test 'eql))
 +    (assert-false
 +     (subsetp '(a b c a z) '(a a d d c b) :test 'eql))))
++
 +(define-test subsetp.hash-equal
 +    (:tag :issues)
 +  (let ((lisp::*min-list-length-for-hashtable* 2))
 +    (assert-true
 +     (subsetp '("a" "b" "c" "a") '("a" "a" "d" "d" "c" "b") :test 'equal))
 +    (assert-false
 +     (subsetp '("a" "b" "c" "a" "z") '("a" "a" "d" "d" "c" "b") :test 'equal))))
++
 +(define-test subsetp.hash-equalp
 +    (:tag :issues)
 +  (let ((lisp::*min-list-length-for-hashtable* 2))
 +    (assert-true
 +     (subsetp '("a" "b" "C" "A") '("a" "a" "d" "d" "c" "b") :test 'equalp))
 +    (assert-false
 +     (subsetp '("a" "b" "C" "A" "z") '("a" "a" "d" "d" "c" "b") :test 'equalp))))
++
 +(define-test subsetp.hash-eql-with-key
 +    (:tag :issues)
 +  (assert-true (subsetp '((1 "a") (2 "b") (3 "c"))
 +                        '((3 "c") (3 "c") (2 "b") (1 "a"))
 +                        :test 'eql
 +                        :key #'first)))
++
 +(define-test subsetp.test-and-test-not
 +  (assert-error 'simple-error
 +                (subsetp '(1 2)
 +                         '(3 4)
 +                         :test 'eql
 +                         :test-not 'equal)))

Raymond Toy pushed to branch issue-240-subsetp-with-hash-table at cmucl / cmucl

Commits:

2 changed files:

Changes: