Raymond Toy pushed to branch master at cmucl / cmucl

Commits:

2 changed files:

Changes:

  • src/code/list.lisp
    ... ... @@ -785,6 +785,7 @@
    785 785 
     ;;; will apply the test to the elements from list1 and list2 in the correct
    786 786 
     ;;; order.
    787 787 
     ;;;
    788 
    +#+nil
    788 789 
     (defun union (list1 list2 &key key (test #'eql testp) (test-not nil notp))
    789 790 
       "Returns the union of list1 and list2."
    790 791 
       (declare (inline member))
    ... ... @@ -795,6 +796,23 @@
    795 796 
     	(push elt res)))
    796 797 
         res))
    797 798
    799 
    +(defun union (list1 list2 &key key (test #'eql testp) (test-not nil notp))
    800 
    +  "Returns the union of list1 and list2."
    801 
    +  (declare (inline member))
    802 
    +  (when (and testp notp)
    803 
    +    (error (intl:gettext "Test and test-not both supplied.")))
    804 
    +  (let ((res list2)
    805 
    +	(hashtable (list-to-hashtable list2 key test test-not)))
    806 
    +    (cond (hashtable
    807 
    +	   (dolist (item list1)
    808 
    +	     (unless (nth-value 1 (gethash (apply-key key item) hashtable))
    809 
    +	       (push item res))))
    810 
    +	  ((null hashtable)
    811 
    +	   (dolist (item list1)
    812 
    +	     (unless (with-set-keys (member (apply-key key item) list2))
    813 
    +	       (push item res)))))
    814 
    +    res))
    815 
    +
    798 816 
     ;;; Destination and source are setf-able and many-evaluable.  Sets the source
    799 817 
     ;;; to the cdr, and "conses" the 1st elt of source to destination.
    800 818 
     ;;;

  • tests/sets.lisp
    ... ... @@ -89,3 +89,86 @@
    89 89 
     				:test-not 'eql)))
    90 90
    91 91
    92 
    +
    93 
    +(define-test union.hash-eql
    94 
    +    (:tag :issues)
    95 
    +  ;; For union to use hashtables by making the threshold
    96 
    +  ;; small.
    97 
    +  (let ((lisp::*min-list-length-for-hashtable* 2))
    98 
    +    (assert-equal '(2 2 1 3 4)
    99 
    +		  (union '(1 2 2 3) '(3 4)))
    100 
    +    (assert-equal '(2 2 1 3 4 5 6 7 8)
    101 
    +		  (union '(1 2 2 3) '(3 4 5 6 7 8)))
    102 
    +    (assert-equal '(2 2 1 3 4)
    103 
    +		  (union '(1 2 2 3) '(3 4)
    104 
    +			 :test #'eql))
    105 
    +    (assert-equal '(2 2 1 3 4 5 6 7 8)
    106 
    +		  (union '(1 2 2 3) '(3 4 5 6 7 8)
    107 
    +			 :test #'eql))))
    108 
    +
    109 
    +(define-test union.hash-eq
    110 
    +    (:tag :issues)
    111 
    +  (let ((lisp::*min-list-length-for-hashtable* 2))
    112 
    +    (assert-equal '(b b a c d e)
    113 
    +		  (union '(a b b c) '(c d e) :test 'eq))
    114 
    +    (assert-equal '(b b a c d e f g h)
    115 
    +		  (union '(a b b c) '(c d e f g h) :test 'eq))
    116 
    +    (assert-equal '(b b a c d e)
    117 
    +		  (union '(a b b c) '(c d e) :test #'eq))
    118 
    +    (assert-equal '(b b a c d e f g h)
    119 
    +		  (union '(a b b c) '(c d e f g h) :test #'eq))))
    120 
    +
    121 
    +(define-test union.hash-equal
    122 
    +    (:tag :issues)
    123 
    +  (let ((lisp::*min-list-length-for-hashtable* 2))
    124 
    +    (assert-equal '("b" "b" "a" "c" "d" "e")
    125 
    +		  (union '("a" "b" "b" "c")
    126 
    +			 '("c" "d" "e")
    127 
    +			 :test 'equal))
    128 
    +    (assert-equal '("b" "b" "a" "c" "d" "e" "f" "g" "h")
    129 
    +		  (union '("a" "b" "b" "c")
    130 
    +			 '("c" "d" "e" "f" "g" "h")
    131 
    +			 :test 'equal))
    132 
    +    (assert-equal '("b" "b" "a" "c" "d" "e")
    133 
    +		  (union '("a" "b" "b" "c")
    134 
    +			 '("c" "d" "e")
    135 
    +			 :test #'equal))
    136 
    +    (assert-equal '("b" "b" "a" "c" "d" "e" "f" "g" "h")
    137 
    +		  (union '("a" "b" "b" "c")
    138 
    +			 '("c" "d" "e" "f" "g" "h")
    139 
    +			 :test #'equal))))
    140 
    +
    141 
    +(define-test union.hash-equalp
    142 
    +    (:tag :issues)
    143 
    +  (let ((lisp::*min-list-length-for-hashtable* 2))
    144 
    +    (assert-equal '("b" "b" "a" "C" "d" "e")
    145 
    +		  (union '("a" "b" "b" "c")
    146 
    +			 '("C" "d" "e")
    147 
    +			 :test 'equalp))
    148 
    +    (assert-equal '("b" "b" "a" "c" "D" "e" "f" "g" "h")
    149 
    +		  (union '("a" "b" "b" "C")
    150 
    +			 '("c" "D" "e" "f" "g" "h")
    151 
    +			 :test 'equalp))
    152 
    +    (assert-equal '("b" "b" "a" "C" "d" "e")
    153 
    +		  (union '("a" "b" "b" "c")
    154 
    +			 '("C" "d" "e")
    155 
    +			 :test #'equalp))
    156 
    +    (assert-equal '("b" "b" "a" "c" "D" "e" "f" "g" "h")
    157 
    +		  (union '("a" "b" "b" "C")
    158 
    +			 '("c" "D" "e" "f" "g" "h")
    159 
    +			 :test #'equalp))))
    160 
    +
    161 
    +;; Simple test that we handle a key correctly
    162 
    +(define-test union.hash-eql-with-key
    163 
    +  (let ((lisp::*min-list-length-for-hashtable* 2))
    164 
    +    (assert-equal '((3 "b") (2 "b") (1 "a") (4 "c") (5 "d"))
    165 
    +		  (union '((1 "a") (2 "b") (3 "b"))
    166 
    +			 '((1 "a") (4 "c") (5 "d"))
    167 
    +			 :key #'first))))
    168 
    +
    169 
    +(define-test union.test-and-test-not
    170 
    +  (assert-error 'simple-error
    171 
    +		(union '(1 2)
    172 
    +		       '(3 4)
    173 
    +		       :test 'eql
    174 
    +		       :test-not 'eql)))

    • —
    View it on GitLab.
    You're receiving this email because of your account on gitlab.common-lisp.net. Manage all notifications · Help