cmucl-cvs

cmucl-cvs@common-lisp.net

2904 discussions

[Git][cmucl/cmucl][issue-240-add-hashtable-set-exclusive-or] Clean up error in set-exclusive-or test
by Raymond Toy (＠rtoy) 27 Aug '23

27 Aug '23

Raymond Toy pushed to branch issue-240-add-hashtable-set-exclusive-or at cmucl / cmucl Commits: 6a53d42c by Raymond Toy at 2023-08-26T16:25:01-07:00 Clean up error in set-exclusive-or test Somehow the test set-exclusive-or.1 had incorporated lots of other tests inside it. Remove the random junk. - - - - - 1 changed file: - tests/sets.lisp Changes: ===================================== tests/sets.lisp ===================================== @@ -230,238 +230,6 @@ (test 1))) -(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))) - -(define-test set-exclusive-or.1 - (:tag :issues) - ;; From CLHS - (assert-equal '("b" "A" "b" "a") - (set-exclusive-or '(1 "a" "b") - '(1 "A" "b"))) - ;; Tests for sets - -(defpackage :sets-tests - (:use :cl :lisp-unit)) - -(in-package "SETS-TESTS") - -(define-test set-diff.hash-eql - (:tag :issues) - ;; For set-difference to use hashtables by making the threshold - ;; small. - (let ((lisp::*min-list-length-for-hashtable* 2)) - (assert-equal '(2 2 1) - (set-difference '(1 2 2 3) '(3 4))) - (assert-equal '(2 2 1) - (set-difference '(1 2 2 3) '(3 4 5 6 7 8))) - (assert-equal '(2 2 1) - (set-difference '(1 2 2 3) '(3 4) - :test #'eql)) - (assert-equal '(2 2 1) - (set-difference '(1 2 2 3) '(3 4 5 6 7 8) - :test #'eql)))) - -(define-test set-diff.hash-eq - (:tag :issues) - (let ((lisp::*min-list-length-for-hashtable* 2)) - (assert-equal '(b b a) - (set-difference '(a b b c) '(c d e) :test 'eq)) - (assert-equal '(b b a) - (set-difference '(a b b c) '(c d e f g h) :test 'eq)) - (assert-equal '(b b a) - (set-difference '(a b b c) '(c d e) :test #'eq)) - (assert-equal '(b b a) - (set-difference '(a b b c) '(c d e f g h) :test #'eq)))) - -(define-test set-diff.hash-equal - (:tag :issues) - (let ((lisp::*min-list-length-for-hashtable* 2)) - (assert-equal '("b" "b" "a") - (set-difference '("a" "b" "b" "c") - '("c" "d" "e") - :test 'equal)) - (assert-equal '("b" "b" "a") - (set-difference '("a" "b" "b" "c") - '("c" "d" "e" "f" "g" "h") - :test 'equal)) - (assert-equal '("b" "b" "a") - (set-difference '("a" "b" "b" "c") - '("c" "d" "e") - :test #'equal)) - (assert-equal '("b" "b" "a") - (set-difference '("a" "b" "b" "c") - '("c" "d" "e" "f" "g" "h") - :test #'equal)))) - -(define-test set-diff.hash-equalp - (:tag :issues) - (let ((lisp::*min-list-length-for-hashtable* 2)) - (assert-equal '("b" "b" "a") - (set-difference '("a" "b" "b" "c") - '("C" "d" "e") - :test 'equalp)) - (assert-equal '("b" "b" "a") - (set-difference '("a" "b" "b" "C") - '("c" "D" "e" "f" "g" "h") - :test 'equalp)) - (assert-equal '("b" "b" "a") - (set-difference '("a" "b" "b" "c") - '("C" "d" "e") - :test #'equalp)) - (assert-equal '("b" "b" "a") - (set-difference '("a" "b" "b" "C") - '("c" "D" "e" "f" "g" "h") - :test #'equalp)))) - -;; Simple test that we handle a key correctly -(define-test set-diff.hash-eql-with-key - (let ((lisp::*min-list-length-for-hashtable* 2)) - (assert-equal '((3 "b") (2 "b")) - (set-difference '((1 "a") (2 "b") (3 "b")) - '((1 "a") (4 "c") (5 "d")) - :key #'first)))) - -(define-test set-diff.test-and-test-not - (assert-error 'simple-error - (set-difference '(1 2) - '(3 4) - :test 'eql - :test-not 'eql))) - - - -(define-test union.hash-eql - (:tag :issues) - ;; For union to use hashtables by making the threshold - ;; small. - (let ((lisp::*min-list-length-for-hashtable* 2)) - (assert-equal '(2 2 1 3 4) - (union '(1 2 2 3) '(3 4))) - (assert-equal '(2 2 1 3 4 5 6 7 8) - (union '(1 2 2 3) '(3 4 5 6 7 8))) - (assert-equal '(2 2 1 3 4) - (union '(1 2 2 3) '(3 4) - :test #'eql)) - (assert-equal '(2 2 1 3 4 5 6 7 8) - (union '(1 2 2 3) '(3 4 5 6 7 8) - :test #'eql)))) - -(define-test union.hash-eq - (:tag :issues) - (let ((lisp::*min-list-length-for-hashtable* 2)) - (assert-equal '(b b a c d e) - (union '(a b b c) '(c d e) :test 'eq)) - (assert-equal '(b b a c d e f g h) - (union '(a b b c) '(c d e f g h) :test 'eq)) - (assert-equal '(b b a c d e) - (union '(a b b c) '(c d e) :test #'eq)) - (assert-equal '(b b a c d e f g h) - (union '(a b b c) '(c d e f g h) :test #'eq)))) - -(define-test union.hash-equal - (:tag :issues) - (let ((lisp::*min-list-length-for-hashtable* 2)) - (assert-equal '("b" "b" "a" "c" "d" "e") - (union '("a" "b" "b" "c") - '("c" "d" "e") - :test 'equal)) - (assert-equal '("b" "b" "a" "c" "d" "e" "f" "g" "h") - (union '("a" "b" "b" "c") - '("c" "d" "e" "f" "g" "h") - :test 'equal)) - (assert-equal '("b" "b" "a" "c" "d" "e") - (union '("a" "b" "b" "c") - '("c" "d" "e") - :test #'equal)) - (assert-equal '("b" "b" "a" "c" "d" "e" "f" "g" "h") - (union '("a" "b" "b" "c") - '("c" "d" "e" "f" "g" "h") - :test #'equal)))) - -(define-test union.hash-equalp - (:tag :issues) - (let ((lisp::*min-list-length-for-hashtable* 2)) - (assert-equal '("b" "b" "a" "C" "d" "e") - (union '("a" "b" "b" "c") - '("C" "d" "e") - :test 'equalp)) - (assert-equal '("b" "b" "a" "c" "D" "e" "f" "g" "h") - (union '("a" "b" "b" "C") - '("c" "D" "e" "f" "g" "h") - :test 'equalp)) - (assert-equal '("b" "b" "a" "C" "d" "e") - (union '("a" "b" "b" "c") - '("C" "d" "e") - :test #'equalp)) - (assert-equal '("b" "b" "a" "c" "D" "e" "f" "g" "h") - (union '("a" "b" "b" "C") - '("c" "D" "e" "f" "g" "h") - :test #'equalp)))) - -;; Simple test that we handle a key correctly -(define-test union.hash-eql-with-key - (let ((lisp::*min-list-length-for-hashtable* 2)) - (assert-equal '((3 "b") (2 "b") (1 "a") (4 "c") (5 "d")) - (union '((1 "a") (2 "b") (3 "b")) - '((1 "a") (4 "c") (5 "d")) - :key #'first)))) - -(define-test union.test-and-test-not - (assert-error 'simple-error - (union '(1 2) - '(3 4) - :test 'eql - :test-not 'eql))) - - (define-test subsetp.hash-eq (:tag :issues) (let ((lisp::*min-list-length-for-hashtable* 2)) View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/6a53d42ce2f1a6a8ea3b871… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/6a53d42ce2f1a6a8ea3b871… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][issue-240-add-hashtable-set-exclusive-or] Fix typo.
by Raymond Toy (＠rtoy) 26 Aug '23

26 Aug '23

Raymond Toy pushed to branch issue-240-add-hashtable-set-exclusive-or at cmucl / cmucl Commits: c8f2c87d by Raymond Toy at 2023-08-25T20:12:46-07:00 Fix typo. Somehow a stray "g" got added to steve-splice. Remove it. - - - - - 1 changed file: - src/code/list.lisp Changes: ===================================== src/code/list.lisp ===================================== @@ -842,7 +842,7 @@ ;;; to the cdr, and "conses" the 1st elt of source to destination. ;;; (defmacro steve-splice (source destination) - `(let ((temp ,source))g + `(let ((temp ,source)) (setf ,source (cdr ,source) (cdr temp) ,destination ,destination temp))) View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/c8f2c87db5e3ab95e5371e5… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/c8f2c87db5e3ab95e5371e5… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][issue-255-add-sacla-tests] 2 commits: Only ignore build-* in the top-level dir
by Raymond Toy (＠rtoy) 26 Aug '23

26 Aug '23

Raymond Toy pushed to branch issue-255-add-sacla-tests at cmucl / cmucl Commits: 083a78da by Raymond Toy at 2023-08-25T15:14:06-07:00 Only ignore build-* in the top-level dir - - - - - f1ff2d63 by Raymond Toy at 2023-08-25T15:14:45-07:00 Add script to convert sacla test to lisp-unit test. - - - - - 2 changed files: - .gitignore - + sacla/build-sacla-tests.lisp Changes: ===================================== .gitignore ===================================== @@ -12,7 +12,7 @@ *.x86f *~ /test-tmp -build-* +/build-* darwin-8bit-[234] darwin-[234] linux-8bit-[234] ===================================== sacla/build-sacla-tests.lisp ===================================== @@ -0,0 +1,41 @@ +(defun get-sacla-test-files () + (let ((test-files + ;; We only want files named "must-*.lisp", using a cmucl + ;; pathname extension. + (directory "lisp/tests/must-*.lisp"))) + test-files)) + +(defun process-one-file (file) + (let* ((base-name (pathname-name file)) + (output-file (make-pathname :name (pathname-name file) + :type (pathname-type file))) + (test-base-name (symbolicate "SACLA-" (string-upcase base-name))) + (*print-case* :downcase)) + (with-open-file (output output-file + :direction :output + :if-exists :supersede) + (format *trace-output* "load-truename ~S~%" *load-truename*) + (format *trace-output* "Reading ~S~%" file) + (format *trace-output* "Writing ~S~%" output-file) + (format output "(in-package #:sacla-lisp-unit)~%") + (with-open-file (input file) + (loop for count from 1 + for sexp = (read input nil) + while sexp + do (progn + (write `(define-test ,(symbolicate test-base-name (format nil ".~d" count)) + (:tag ,(intern (string test-base-name) :keyword)) + (assert-true ,sexp)) + :stream output + :circle t + :level nil + :length nil) + (terpri output)))) + (terpri output)))) + +(defun create-lisp-unit-sacla-tests () + (let ((test-files (get-sacla-test-files))) + ;; For each test file, convert the file to a lisp-unit test file + ;; by wrapping each sexp in a define-test form. + (dolist (file test-files) + (process-one-file file)))) View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/4c44b23fcd11b67a25314b… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/4c44b23fcd11b67a25314b… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][issue-255-add-sacla-tests] Remove these files that were accidentally checked in
by Raymond Toy (＠rtoy) 26 Aug '23

26 Aug '23

Raymond Toy pushed to branch issue-255-add-sacla-tests at cmucl / cmucl Commits: 4c44b23f by Raymond Toy at 2023-08-25T15:10:11-07:00 Remove these files that were accidentally checked in - - - - - 1 changed file: - − sacla/must-array.lisp The diff was not included because it is too large. View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/4c44b23fcd11b67a25314b9… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/4c44b23fcd11b67a25314b9… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl] Pushed new branch issue-255-add-sacla-tests
by Raymond Toy (＠rtoy) 25 Aug '23

25 Aug '23

Raymond Toy pushed new branch issue-255-add-sacla-tests at cmucl / cmucl -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/tree/issue-255-add-sacla-tests You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][issue-240-add-hashtable-set-exclusive-or] 3 commits: Address #240: Use hashtable for nset-diff, nunion, nintersection
by Raymond Toy (＠rtoy) 25 Aug '23

25 Aug '23

Raymond Toy pushed to branch issue-240-add-hashtable-set-exclusive-or at cmucl / cmucl Commits: 87e54e03 by Raymond Toy at 2023-08-25T14:15:52+00:00 Address #240: Use hashtable for nset-diff, nunion, nintersection - - - - - 4542d55e by Raymond Toy at 2023-08-25T14:16:04+00:00 Merge branch 'issue-240-add-hashtable-for-destructive-set-ops' into 'master' Address #240: Use hashtable for nset-diff, nunion, nintersection See merge request cmucl/cmucl!167 - - - - - d1bf9185 by Raymond Toy at 2023-08-25T08:34:43-07:00 Merge branch 'master' into issue-240-add-hashtable-set-exclusive-or - - - - - 2 changed files: - src/code/list.lisp - tests/sets.lisp Changes: ===================================== src/code/list.lisp ===================================== @@ -749,7 +749,9 @@ (defparameter *min-list-length-for-hashtable* 15) -(declaim (start-block list-to-hashtable union intersection set-difference)) +(declaim (start-block list-to-hashtable + union intersection set-difference + nunion nintersection nset-difference)) ;; Main code to process a set function. INIT-RES initializes the ;; value of RES, which holds the result of the set function. @@ -836,8 +838,6 @@ (process-set nil t)) -(declaim (end-block)) - ;;; Destination and source are setf-able and many-evaluable. Sets the source ;;; to the cdr, and "conses" the 1st elt of source to destination. ;;; @@ -847,19 +847,42 @@ (cdr temp) ,destination ,destination temp))) +;;; Main body for destructive set operations. INIT-RES initializes +;;; the result list. INVERT-P is T if the result of the TEST-FORM +;;; should be inverted. TEST-FORM is the form used for determining +;;; how to update the result. +(defmacro nprocess-set-body (init-res invert-p test-form) + `(let ((res ,init-res) + (list1 list1)) + (do () + ((endp list1)) + (if ,(if invert-p + `(not ,test-form) + test-form) + (steve-splice list1 res) + (setq list1 (cdr list1)))) + res)) + +;; Implementation of the destructive set operations. INIT-RES +;; initializes the value of the result list. INVERT-P indicates +;; whether to invert the test-form used to determine how the result +;; should be updated. +(defmacro nprocess-set (init-res invert-p) + `(let ((hashtable (list-to-hashtable list2 key test test-not))) + (if hashtable + (nprocess-set-body ,init-res ,invert-p + (nth-value 1 (gethash (apply-key key (car list1)) hashtable))) + (nprocess-set-body ,init-res ,invert-p + (with-set-keys (member (apply-key key (car list1)) list2)))))) + + (defun nunion (list1 list2 &key key (test #'eql testp) (test-not nil notp)) "Destructively returns the union list1 and list2." (declare (inline member)) (if (and testp notp) (error "Test and test-not both supplied.")) - (let ((res list2) - (list1 list1)) - (do () - ((endp list1)) - (if (not (with-set-keys (member (apply-key key (car list1)) list2))) - (steve-splice list1 res) - (setf list1 (cdr list1)))) - res)) + + (nprocess-set list2 t)) (defun nintersection (list1 list2 &key key (test #'eql testp) (test-not nil notp)) @@ -867,13 +890,8 @@ (declare (inline member)) (if (and testp notp) (error "Test and test-not both supplied.")) - (let ((res nil) - (list1 list1)) - (do () ((endp list1)) - (if (with-set-keys (member (apply-key key (car list1)) list2)) - (steve-splice list1 res) - (setq list1 (Cdr list1)))) - res)) + + (nprocess-set nil nil)) (defun nset-difference (list1 list2 &key key (test #'eql testp) (test-not nil notp)) @@ -881,14 +899,10 @@ (declare (inline member)) (if (and testp notp) (error "Test and test-not both supplied.")) - (let ((res nil) - (list1 list1)) - (do () ((endp list1)) - (if (not (with-set-keys (member (apply-key key (car list1)) list2))) - (steve-splice list1 res) - (setq list1 (cdr list1)))) - res)) + (nprocess-set nil t)) + +(declaim (end-block)) (defun set-exclusive-or (list1 list2 &key key (test #'eql testp) (test-not nil notp)) ===================================== tests/sets.lisp ===================================== @@ -88,8 +88,37 @@ :test 'eql :test-not 'eql))) - +(define-test nset-diff.1 + (:tag :issues) + ;; From CLHS + (flet + ((test1 (min-length-limit) + (let ((lisp::*min-list-length-for-hashtable* min-length-limit) + (lst1 (list "A" "b" "C" "d")) + (lst2 (list "a" "B" "C" "d"))) + (assert-equal '("b" "A") + (nset-difference lst1 lst2 :test 'equal)) + ;; This isn't specified by the CLHS, but it is what we do. + (assert-equal '("A") lst1)))) + (test1 100) + (test1 1))) + +(define-test nset-diff.key + (:tag :issues) + (flet + ((test (min-length-limit) + ;; From CLHS + (let ((lisp::*min-list-length-for-hashtable* min-length-limit) + (lst1 (list '("a" . "b") '("c" . "d") '("e" . "f"))) + (lst2 (list '("c" . "a") '("e" . "b") '("d" . "a")))) + (assert-equal '(("e" . "f") ("c" . "d")) + (nset-difference lst1 lst2 :test 'equal :key #'cdr)) + ;; This isn't specified by the CLHS, but it is what we do. + (assert-equal '(("a" . "b") ("c" . "d")) lst1)))) + (test 100) + (test 1))) + (define-test union.hash-eql (:tag :issues) ;; For union to use hashtables by making the threshold @@ -173,6 +202,33 @@ :test 'eql :test-not 'eql))) +(define-test nunion.1 + (:tag :issues) + (flet + ((test (min-list-length) + (let ((lisp::*min-list-length-for-hashtable* min-list-length) + (lst1 (list 1 2 '(1 2) "a" "b")) + (lst2 (list 2 3 '(2 3) "B" "C"))) + (assert-equal '("b" "a" (1 2) 1 2 3 (2 3) "B" "C") + (nunion lst1 lst2)) + (assert-equal '(1 2 3 (2 3) "B" "C") + lst1)))) + (test 100) + (test 1))) + +(define-test nintersection.1 + (:tag :issues) + (flet + ((test (min-list-length) + (let ((lisp::*min-list-length-for-hashtable* min-list-length) + (lst1 (list 1 1 2 3 4 'a 'b 'c "A" "B" "C" "d")) + (lst2 (list 1 4 5 'b 'c 'd "a" "B" "c" "D"))) + (assert-equal '(c b 4 1 1) + (nintersection lst1 lst2)) + (assert-equal '(1) lst1)))) + (test 100) + (test 1))) + (define-test subsetp.hash-eq (:tag :issues) View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/fc0d7a8d541e5ccd95a4cc… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/fc0d7a8d541e5ccd95a4cc… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl] Pushed new branch issue-240-add-hashtable-set-exclusive-or
by Raymond Toy (＠rtoy) 25 Aug '23

25 Aug '23

Raymond Toy pushed new branch issue-240-add-hashtable-set-exclusive-or at cmucl / cmucl -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/tree/issue-240-add-hashtable-s… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][master] 2 commits: Address #240: Use hashtable for nset-diff, nunion, nintersection
by Raymond Toy (＠rtoy) 25 Aug '23

25 Aug '23

Raymond Toy pushed to branch master at cmucl / cmucl Commits: 87e54e03 by Raymond Toy at 2023-08-25T14:15:52+00:00 Address #240: Use hashtable for nset-diff, nunion, nintersection - - - - - 4542d55e by Raymond Toy at 2023-08-25T14:16:04+00:00 Merge branch 'issue-240-add-hashtable-for-destructive-set-ops' into 'master' Address #240: Use hashtable for nset-diff, nunion, nintersection See merge request cmucl/cmucl!167 - - - - - 2 changed files: - src/code/list.lisp - tests/sets.lisp Changes: ===================================== src/code/list.lisp ===================================== @@ -749,7 +749,9 @@ (defparameter *min-list-length-for-hashtable* 15) -(declaim (start-block list-to-hashtable union intersection set-difference)) +(declaim (start-block list-to-hashtable + union intersection set-difference + nunion nintersection nset-difference)) ;; Main code to process a set function. INIT-RES initializes the ;; value of RES, which holds the result of the set function. @@ -836,8 +838,6 @@ (process-set nil t)) -(declaim (end-block)) - ;;; Destination and source are setf-able and many-evaluable. Sets the source ;;; to the cdr, and "conses" the 1st elt of source to destination. ;;; @@ -847,19 +847,42 @@ (cdr temp) ,destination ,destination temp))) +;;; Main body for destructive set operations. INIT-RES initializes +;;; the result list. INVERT-P is T if the result of the TEST-FORM +;;; should be inverted. TEST-FORM is the form used for determining +;;; how to update the result. +(defmacro nprocess-set-body (init-res invert-p test-form) + `(let ((res ,init-res) + (list1 list1)) + (do () + ((endp list1)) + (if ,(if invert-p + `(not ,test-form) + test-form) + (steve-splice list1 res) + (setq list1 (cdr list1)))) + res)) + +;; Implementation of the destructive set operations. INIT-RES +;; initializes the value of the result list. INVERT-P indicates +;; whether to invert the test-form used to determine how the result +;; should be updated. +(defmacro nprocess-set (init-res invert-p) + `(let ((hashtable (list-to-hashtable list2 key test test-not))) + (if hashtable + (nprocess-set-body ,init-res ,invert-p + (nth-value 1 (gethash (apply-key key (car list1)) hashtable))) + (nprocess-set-body ,init-res ,invert-p + (with-set-keys (member (apply-key key (car list1)) list2)))))) + + (defun nunion (list1 list2 &key key (test #'eql testp) (test-not nil notp)) "Destructively returns the union list1 and list2." (declare (inline member)) (if (and testp notp) (error "Test and test-not both supplied.")) - (let ((res list2) - (list1 list1)) - (do () - ((endp list1)) - (if (not (with-set-keys (member (apply-key key (car list1)) list2))) - (steve-splice list1 res) - (setf list1 (cdr list1)))) - res)) + + (nprocess-set list2 t)) (defun nintersection (list1 list2 &key key (test #'eql testp) (test-not nil notp)) @@ -867,13 +890,8 @@ (declare (inline member)) (if (and testp notp) (error "Test and test-not both supplied.")) - (let ((res nil) - (list1 list1)) - (do () ((endp list1)) - (if (with-set-keys (member (apply-key key (car list1)) list2)) - (steve-splice list1 res) - (setq list1 (Cdr list1)))) - res)) + + (nprocess-set nil nil)) (defun nset-difference (list1 list2 &key key (test #'eql testp) (test-not nil notp)) @@ -881,14 +899,10 @@ (declare (inline member)) (if (and testp notp) (error "Test and test-not both supplied.")) - (let ((res nil) - (list1 list1)) - (do () ((endp list1)) - (if (not (with-set-keys (member (apply-key key (car list1)) list2))) - (steve-splice list1 res) - (setq list1 (cdr list1)))) - res)) + (nprocess-set nil t)) + +(declaim (end-block)) (defun set-exclusive-or (list1 list2 &key key (test #'eql testp) (test-not nil notp)) ===================================== tests/sets.lisp ===================================== @@ -88,8 +88,37 @@ :test 'eql :test-not 'eql))) - +(define-test nset-diff.1 + (:tag :issues) + ;; From CLHS + (flet + ((test1 (min-length-limit) + (let ((lisp::*min-list-length-for-hashtable* min-length-limit) + (lst1 (list "A" "b" "C" "d")) + (lst2 (list "a" "B" "C" "d"))) + (assert-equal '("b" "A") + (nset-difference lst1 lst2 :test 'equal)) + ;; This isn't specified by the CLHS, but it is what we do. + (assert-equal '("A") lst1)))) + (test1 100) + (test1 1))) + +(define-test nset-diff.key + (:tag :issues) + (flet + ((test (min-length-limit) + ;; From CLHS + (let ((lisp::*min-list-length-for-hashtable* min-length-limit) + (lst1 (list '("a" . "b") '("c" . "d") '("e" . "f"))) + (lst2 (list '("c" . "a") '("e" . "b") '("d" . "a")))) + (assert-equal '(("e" . "f") ("c" . "d")) + (nset-difference lst1 lst2 :test 'equal :key #'cdr)) + ;; This isn't specified by the CLHS, but it is what we do. + (assert-equal '(("a" . "b") ("c" . "d")) lst1)))) + (test 100) + (test 1))) + (define-test union.hash-eql (:tag :issues) ;; For union to use hashtables by making the threshold @@ -173,6 +202,33 @@ :test 'eql :test-not 'eql))) +(define-test nunion.1 + (:tag :issues) + (flet + ((test (min-list-length) + (let ((lisp::*min-list-length-for-hashtable* min-list-length) + (lst1 (list 1 2 '(1 2) "a" "b")) + (lst2 (list 2 3 '(2 3) "B" "C"))) + (assert-equal '("b" "a" (1 2) 1 2 3 (2 3) "B" "C") + (nunion lst1 lst2)) + (assert-equal '(1 2 3 (2 3) "B" "C") + lst1)))) + (test 100) + (test 1))) + +(define-test nintersection.1 + (:tag :issues) + (flet + ((test (min-list-length) + (let ((lisp::*min-list-length-for-hashtable* min-list-length) + (lst1 (list 1 1 2 3 4 'a 'b 'c "A" "B" "C" "d")) + (lst2 (list 1 4 5 'b 'c 'd "a" "B" "c" "D"))) + (assert-equal '(c b 4 1 1) + (nintersection lst1 lst2)) + (assert-equal '(1) lst1)))) + (test 100) + (test 1))) + (define-test subsetp.hash-eq (:tag :issues) View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/39817da21c213415dd494c… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/39817da21c213415dd494c… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][issue-240-add-hashtable-for-destructive-set-ops] 4 commits: Fix warning that SIGNED-CHAR is also exported from C-CALL
by Raymond Toy (＠rtoy) 25 Aug '23

25 Aug '23

Raymond Toy pushed to branch issue-240-add-hashtable-for-destructive-set-ops at cmucl / cmucl Commits: 427aaa31 by Raymond Toy at 2023-08-22T19:50:31-07:00 Fix warning that SIGNED-CHAR is also exported from C-CALL When we added `c-call:signed-char`, we forgot to also add it to the package exports list for the `c-call` package. Add it to get rid of the compiler warning. - - - - - 9581820a by Raymond Toy at 2023-08-25T13:32:42+00:00 Address #240: Clean up hashtable implementation of set functions - - - - - 39817da2 by Raymond Toy at 2023-08-25T13:32:51+00:00 Merge branch 'issue-240-clean-up-hashtable-impl' into 'master' Address #240: Clean up hashtable implementation of set functions See merge request cmucl/cmucl!168 - - - - - 51df6ed9 by Raymond Toy at 2023-08-25T06:55:36-07:00 Merge branch 'master' into issue-240-add-hashtable-for-destructive-set-ops - - - - - 2 changed files: - src/code/exports.lisp - src/code/list.lisp Changes: ===================================== src/code/exports.lisp ===================================== @@ -169,6 +169,7 @@ (defpackage "C-CALL" (:import-from "COMMON-LISP" "CHAR" "FLOAT") (:export "C-STRING" "CHAR" "DOUBLE" "FLOAT" "INT" "LONG" "SHORT" + "SIGNED-CHAR" "UNSIGNED-CHAR" "UNSIGNED-INT" "UNSIGNED-LONG" "UNSIGNED-SHORT" "LONG-LONG" "UNSIGNED-LONG-LONG" "VOID")) ===================================== src/code/list.lisp ===================================== @@ -752,6 +752,28 @@ (declaim (start-block list-to-hashtable union intersection set-difference nunion nintersection nset-difference)) + +;; Main code to process a set function. INIT-RES initializes the +;; value of RES, which holds the result of the set function. +;; TEST-FORM is a form that tests whether to add the item from LIST1 +;; to RES. +(defmacro process-set-body (init-res invert-p test-form) + `(let ((res ,init-res)) + (dolist (item list1) + (when ,(if invert-p + `(not ,test-form) + test-form) + (push item res))) + res)) + +(defmacro process-set (init-res invert-p) + `(let ((hashtable (list-to-hashtable list2 key test test-not))) + (if hashtable + (process-set-body ,init-res ,invert-p + (nth-value 1 (gethash (apply-key key item) hashtable))) + (process-set-body ,init-res ,invert-p + (with-set-keys (member (apply-key key item) list2)))))) + ;; Convert a list to a hashtable. The hashtable does not handle ;; duplicated values in the list. Returns the hashtable. (defun list-to-hashtable (list key test test-not) @@ -793,17 +815,7 @@ (declare (inline member)) (when (and testp notp) (error (intl:gettext "Test and test-not both supplied."))) - (let ((res list2) - (hashtable (list-to-hashtable list2 key test test-not))) - (cond (hashtable - (dolist (item list1) - (unless (nth-value 1 (gethash (apply-key key item) hashtable)) - (push item res)))) - ((null hashtable) - (dolist (item list1) - (unless (with-set-keys (member (apply-key key item) list2)) - (push item res))))) - res)) + (process-set list2 t)) (defun intersection (list1 list2 &key key @@ -812,20 +824,7 @@ (declare (inline member)) (if (and testp notp) (error "Test and test-not both supplied.")) - (let ((hashtable - (list-to-hashtable list2 key test test-not))) - (cond (hashtable - (let ((res nil)) - (dolist (item list1) - (when (nth-value 1 (gethash (apply-key key item) hashtable)) - (push item res))) - res)) - ((null hashtable) - (let ((res nil)) - (dolist (elt list1) - (if (with-set-keys (member (apply-key key elt) list2)) - (push elt res))) - res))))) + (process-set nil nil)) (defun set-difference (list1 list2 &key key (test #'eql testp) (test-not nil notp)) "Returns the elements of list1 which are not in list2." @@ -836,23 +835,8 @@ (when (null list2) (return-from set-difference list1)) - (let ((hashtable - (list-to-hashtable list2 key test test-not))) - (cond (hashtable - ;; list2 was placed in hash table. - (let ((res nil)) - (dolist (item list1) - (unless (nth-value 1 (gethash (apply-key key item) hashtable)) - (push item res))) - res)) - ((null hashtable) - ;; Default implementation because we didn't create the hash - ;; table. - (let ((res nil)) - (dolist (item list1) - (if (not (with-set-keys (member (apply-key key item) list2))) - (push item res))) - res))))) + (process-set nil t)) + ;;; Destination and source are setf-able and many-evaluable. Sets the source ;;; to the cdr, and "conses" the 1st elt of source to destination. View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/f305c0ee3440ffc83756e5… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/f305c0ee3440ffc83756e5… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][master] 2 commits: Address #240: Clean up hashtable implementation of set functions
by Raymond Toy (＠rtoy) 25 Aug '23

25 Aug '23

Raymond Toy pushed to branch master at cmucl / cmucl Commits: 9581820a by Raymond Toy at 2023-08-25T13:32:42+00:00 Address #240: Clean up hashtable implementation of set functions - - - - - 39817da2 by Raymond Toy at 2023-08-25T13:32:51+00:00 Merge branch 'issue-240-clean-up-hashtable-impl' into 'master' Address #240: Clean up hashtable implementation of set functions See merge request cmucl/cmucl!168 - - - - - 1 changed file: - src/code/list.lisp Changes: ===================================== src/code/list.lisp ===================================== @@ -750,6 +750,28 @@ 15) (declaim (start-block list-to-hashtable union intersection set-difference)) + +;; Main code to process a set function. INIT-RES initializes the +;; value of RES, which holds the result of the set function. +;; TEST-FORM is a form that tests whether to add the item from LIST1 +;; to RES. +(defmacro process-set-body (init-res invert-p test-form) + `(let ((res ,init-res)) + (dolist (item list1) + (when ,(if invert-p + `(not ,test-form) + test-form) + (push item res))) + res)) + +(defmacro process-set (init-res invert-p) + `(let ((hashtable (list-to-hashtable list2 key test test-not))) + (if hashtable + (process-set-body ,init-res ,invert-p + (nth-value 1 (gethash (apply-key key item) hashtable))) + (process-set-body ,init-res ,invert-p + (with-set-keys (member (apply-key key item) list2)))))) + ;; Convert a list to a hashtable. The hashtable does not handle ;; duplicated values in the list. Returns the hashtable. (defun list-to-hashtable (list key test test-not) @@ -791,17 +813,7 @@ (declare (inline member)) (when (and testp notp) (error (intl:gettext "Test and test-not both supplied."))) - (let ((res list2) - (hashtable (list-to-hashtable list2 key test test-not))) - (cond (hashtable - (dolist (item list1) - (unless (nth-value 1 (gethash (apply-key key item) hashtable)) - (push item res)))) - ((null hashtable) - (dolist (item list1) - (unless (with-set-keys (member (apply-key key item) list2)) - (push item res))))) - res)) + (process-set list2 t)) (defun intersection (list1 list2 &key key @@ -810,20 +822,7 @@ (declare (inline member)) (if (and testp notp) (error "Test and test-not both supplied.")) - (let ((hashtable - (list-to-hashtable list2 key test test-not))) - (cond (hashtable - (let ((res nil)) - (dolist (item list1) - (when (nth-value 1 (gethash (apply-key key item) hashtable)) - (push item res))) - res)) - ((null hashtable) - (let ((res nil)) - (dolist (elt list1) - (if (with-set-keys (member (apply-key key elt) list2)) - (push elt res))) - res))))) + (process-set nil nil)) (defun set-difference (list1 list2 &key key (test #'eql testp) (test-not nil notp)) "Returns the elements of list1 which are not in list2." @@ -834,23 +833,8 @@ (when (null list2) (return-from set-difference list1)) - (let ((hashtable - (list-to-hashtable list2 key test test-not))) - (cond (hashtable - ;; list2 was placed in hash table. - (let ((res nil)) - (dolist (item list1) - (unless (nth-value 1 (gethash (apply-key key item) hashtable)) - (push item res))) - res)) - ((null hashtable) - ;; Default implementation because we didn't create the hash - ;; table. - (let ((res nil)) - (dolist (item list1) - (if (not (with-set-keys (member (apply-key key item) list2))) - (push item res))) - res))))) + (process-set nil t)) + (declaim (end-block)) View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/427aaa311105943b771698… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/427aaa311105943b771698… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

Jump to page:

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

cmucl-cvs