cmucl-cvs

cmucl-cvs@common-lisp.net

2904 discussions

[Git][cmucl/cmucl][master] Fix warning that SIGNED-CHAR is also exported from C-CALL
by Raymond Toy (＠rtoy) 23 Aug '23

23 Aug '23

Raymond Toy pushed to branch master 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. - - - - - 1 changed file: - src/code/exports.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")) View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/427aaa311105943b771698b… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/427aaa311105943b771698b… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][issue-240-clean-up-hashtable-impl] 2 commits: Refactor the body of set ops
by Raymond Toy (＠rtoy) 23 Aug '23

23 Aug '23

Raymond Toy pushed to branch issue-240-clean-up-hashtable-impl at cmucl / cmucl Commits: e6f1cc3e by Raymond Toy at 2023-08-22T16:30:18-07:00 Refactor the body of set ops The set functions have basically exactly the same body with the only difference being how the result list is initialized; the test form used to determine how the result list is updated; and whether a hashtable is used or not. Place all of the common stuff in the macro PROCESS-SET and rename the old PROCESS-SET to PROCESS-SET-BODY. - - - - - b4d8cfea by Raymond Toy at 2023-08-22T16:31:34-07:00 Remove commented out code - - - - - 1 changed file: - src/code/list.lisp Changes: ===================================== src/code/list.lisp ===================================== @@ -755,13 +755,23 @@ ;; 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 (init-res test-form) +(defmacro process-set-body (init-res invert-p test-form) `(let ((res ,init-res)) (dolist (item list1) - (when ,test-form + (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) @@ -803,10 +813,7 @@ (declare (inline member)) (when (and testp notp) (error (intl:gettext "Test and test-not both supplied."))) - (let ((hashtable (list-to-hashtable list2 key test test-not))) - (if hashtable - (process-set list2 (not (nth-value 1 (gethash (apply-key key item) hashtable)))) - (process-set list2 (not (with-set-keys (member (apply-key key item) list2))))))) + (process-set list2 t)) (defun intersection (list1 list2 &key key @@ -815,11 +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))) - (if hashtable - (process-set nil (nth-value 1 (gethash (apply-key key item) hashtable))) - (process-set nil (with-set-keys (member (apply-key key item) list2)))))) + (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." @@ -830,11 +833,7 @@ (when (null list2) (return-from set-difference list1)) - (let ((hashtable - (list-to-hashtable list2 key test test-not))) - (if hashtable - (process-set nil (not (nth-value 1 (gethash (apply-key key item) hashtable)))) - (process-set nil (not (with-set-keys (member (apply-key key item) list2))))))) + (process-set nil t)) (declaim (end-block)) View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/d046100fe1e8dc2aa9e2b5… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/d046100fe1e8dc2aa9e2b5… 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] Refactor the body of destructive set ops
by Raymond Toy (＠rtoy) 23 Aug '23

23 Aug '23

Raymond Toy pushed to branch issue-240-add-hashtable-for-destructive-set-ops at cmucl / cmucl Commits: f305c0ee by Raymond Toy at 2023-08-22T15:38:51-07:00 Refactor the body of destructive set ops The destructive set functions have basically exactly the same body with the only difference being how the result list is initialized; the test form used to determine how the result list is updated; and whether a hashtable is used or not. Place all of the common stuff in the macro NPROCESS-SET and rename the old NPROCESS-SET to NPROCESS-SET-BODY. - - - - - 1 changed file: - src/code/list.lisp Changes: ===================================== src/code/list.lisp ===================================== @@ -863,47 +863,42 @@ (cdr temp) ,destination ,destination temp))) -;;; Main processing for destructive set operations. Like PROCESS-SET with same args, -;;; but for destructive operations. -(defmacro nprocess-set (init-res test-form) +;;; 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 ,test-form + (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 (#+nil - (res list2) - (hashtable (list-to-hashtable list2 key test test-not)) - #+nil - (list1 list1)) - (if hashtable - (nprocess-set list2 (not (nth-value 1 (gethash (apply-key key (car list1)) hashtable)))) - (nprocess-set list2 (not (with-set-keys (member (apply-key key (car list1)) list2))))) - #+nil - (macrolet - ((process (test-form) - `(do () - ((endp list1)) - (if (not ,test-form) - (steve-splice list1 res) - (setf list1 (cdr list1)))))) - (cond - (hashtable - (process (nth-value 1 (gethash (apply-key key (car list1)) hashtable)))) - (t - (process (with-set-keys (member (apply-key key (car list1)) list2))))) - res))) + + (nprocess-set list2 t)) (defun nintersection (list1 list2 &key key (test #'eql testp) (test-not nil notp)) @@ -911,26 +906,8 @@ (declare (inline member)) (if (and testp notp) (error "Test and test-not both supplied.")) - (let (#+nil - (res nil) - (hashtable (list-to-hashtable list2 key test test-not)) - #+nil - (list1 list1)) - (if hashtable - (nprocess-set nil (nth-value 1 (gethash (apply-key key (car list1)) hashtable))) - (nprocess-set nil (with-set-keys (member (apply-key key (car list1)) list2)))) - #+nil - (macrolet - ((process (test-form) - `(do () ((endp list1)) - (if ,test-form - (steve-splice list1 res) - (setq list1 (Cdr list1)))))) - (cond (hashtable - (process (nth-value 1 (gethash (apply-key key (car list1)) hashtable)))) - (t - (process (with-set-keys (member (apply-key key (car list1)) list2))))) - res))) + + (nprocess-set nil nil)) (defun nset-difference (list1 list2 &key key (test #'eql testp) (test-not nil notp)) @@ -938,26 +915,8 @@ (declare (inline member)) (if (and testp notp) (error "Test and test-not both supplied.")) - (let (#+nil - (res nil) - (hashtable (list-to-hashtable list2 key test test-not)) - #+nil - (list1 list1)) - (if hashtable - (nprocess-set nil (not (nth-value 1 (gethash (apply-key key (car list1)) hashtable)))) - (nprocess-set nil (not (with-set-keys (member (apply-key key (car list1)) list2))))) - #+nil - (macrolet - ((process (test-form) - `(do () ((endp list1)) - (if (not ,test-form) - (steve-splice list1 res) - (setq list1 (cdr list1)))))) - (cond (hashtable - (process (nth-value 1 (gethash (apply-key key (car list1)) hashtable)))) - (t - (process (with-set-keys (member (apply-key key (car list1)) list2))))) - res))) + + (nprocess-set nil t)) (declaim (end-block)) View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/f305c0ee3440ffc83756e59… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/f305c0ee3440ffc83756e59… 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] Add macro NPROCESS-SET for destructive set ops
by Raymond Toy (＠rtoy) 23 Aug '23

23 Aug '23

Raymond Toy pushed to branch issue-240-add-hashtable-for-destructive-set-ops at cmucl / cmucl Commits: 6b3621ac by Raymond Toy at 2023-08-22T15:13:03-07:00 Add macro NPROCESS-SET for destructive set ops The destructive set functions all have basically the same body. The only difference is how to initialize the result list and the test function. Capture this similarity in the macro NPROCESS-SET. - - - - - 1 changed file: - src/code/list.lisp Changes: ===================================== src/code/list.lisp ===================================== @@ -863,15 +863,34 @@ (cdr temp) ,destination ,destination temp))) +;;; Main processing for destructive set operations. Like PROCESS-SET with same args, +;;; but for destructive operations. +(defmacro nprocess-set (init-res test-form) + `(let ((res ,init-res) + (list1 list1)) + (do () + ((endp list1)) + (if ,test-form + (steve-splice list1 res) + (setq list1 (cdr list1)))) + res)) + + (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) + (let (#+nil + (res list2) (hashtable (list-to-hashtable list2 key test test-not)) + #+nil (list1 list1)) + (if hashtable + (nprocess-set list2 (not (nth-value 1 (gethash (apply-key key (car list1)) hashtable)))) + (nprocess-set list2 (not (with-set-keys (member (apply-key key (car list1)) list2))))) + #+nil (macrolet ((process (test-form) `(do () @@ -892,9 +911,15 @@ (declare (inline member)) (if (and testp notp) (error "Test and test-not both supplied.")) - (let ((res nil) + (let (#+nil + (res nil) (hashtable (list-to-hashtable list2 key test test-not)) - (list1 list1)) + #+nil + (list1 list1)) + (if hashtable + (nprocess-set nil (nth-value 1 (gethash (apply-key key (car list1)) hashtable))) + (nprocess-set nil (with-set-keys (member (apply-key key (car list1)) list2)))) + #+nil (macrolet ((process (test-form) `(do () ((endp list1)) @@ -913,9 +938,15 @@ (declare (inline member)) (if (and testp notp) (error "Test and test-not both supplied.")) - (let ((res nil) + (let (#+nil + (res nil) (hashtable (list-to-hashtable list2 key test test-not)) - (list1 list1)) + #+nil + (list1 list1)) + (if hashtable + (nprocess-set nil (not (nth-value 1 (gethash (apply-key key (car list1)) hashtable)))) + (nprocess-set nil (not (with-set-keys (member (apply-key key (car list1)) list2))))) + #+nil (macrolet ((process (test-form) `(do () ((endp list1)) View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/6b3621aca7ff60f1e0d7917… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/6b3621aca7ff60f1e0d7917… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][issue-240-clean-up-hashtable-impl] Add macro PROCESS-SET to handle processing of set functions
by Raymond Toy (＠rtoy) 22 Aug '23

22 Aug '23

Raymond Toy pushed to branch issue-240-clean-up-hashtable-impl at cmucl / cmucl Commits: d046100f by Raymond Toy at 2023-08-22T14:39:12-07:00 Add macro PROCESS-SET to handle processing of set functions All of the (non-destructive) set functions have basically the same processing code. The only difference is how to initialize the result and the test used to determine if an item is to be added to the result. We encapsulate this similarity in the macro `PROCESS-SET` and use it in `union`, `intersection`, and `set-difference`. - - - - - 1 changed file: - src/code/list.lisp Changes: ===================================== src/code/list.lisp ===================================== @@ -750,6 +750,18 @@ 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 (init-res test-form) + `(let ((res ,init-res)) + (dolist (item list1) + (when ,test-form + (push item res))) + res)) + ;; 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,18 +803,10 @@ (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))) - (macrolet - ((process (test-form) - `(dolist (item list1) - (unless ,test-form - (push item res))))) - (cond (hashtable - (process (nth-value 1 (gethash (apply-key key item) hashtable)))) - (t - (process (with-set-keys (member (apply-key key item) list2))))) - res))) + (let ((hashtable (list-to-hashtable list2 key test test-not))) + (if hashtable + (process-set list2 (not (nth-value 1 (gethash (apply-key key item) hashtable)))) + (process-set list2 (not (with-set-keys (member (apply-key key item) list2))))))) (defun intersection (list1 list2 &key key @@ -812,18 +816,10 @@ (if (and testp notp) (error "Test and test-not both supplied.")) (let ((hashtable - (list-to-hashtable list2 key test test-not))) - (macrolet - ((process (test-form) - `(let ((res nil)) - (dolist (item list1) - (if ,test-form - (push item res))) - res))) - (cond (hashtable - (process (nth-value 1 (gethash (apply-key key item) hashtable)))) - (t - (process (with-set-keys (member (apply-key key item) list2)))))))) + (list-to-hashtable list2 key test test-not))) + (if hashtable + (process-set nil (nth-value 1 (gethash (apply-key key item) hashtable))) + (process-set nil (with-set-keys (member (apply-key key item) list2)))))) (defun set-difference (list1 list2 &key key (test #'eql testp) (test-not nil notp)) "Returns the elements of list1 which are not in list2." @@ -835,21 +831,10 @@ (return-from set-difference list1)) (let ((hashtable - (list-to-hashtable list2 key test test-not))) - (macrolet - ((process (test-form) - `(let ((res nil)) - (dolist (item list1) - (if (not ,test-form) - (push item res))) - res))) - - (cond (hashtable - (process (nth-value 1 (gethash (apply-key key item) hashtable)))) - (t - ;; Default implementation because we didn't create the hash - ;; table. - (process (with-set-keys (member (apply-key key item) list2)))))))) + (list-to-hashtable list2 key test test-not))) + (if hashtable + (process-set nil (not (nth-value 1 (gethash (apply-key key item) hashtable)))) + (process-set nil (not (with-set-keys (member (apply-key key item) list2))))))) (declaim (end-block)) View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/d046100fe1e8dc2aa9e2b53… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/d046100fe1e8dc2aa9e2b53… 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] Add destructive functions to start-block
by Raymond Toy (＠rtoy) 22 Aug '23

22 Aug '23

Raymond Toy pushed to branch issue-240-add-hashtable-for-destructive-set-ops at cmucl / cmucl Commits: 8f262bac by Raymond Toy at 2023-08-22T13:01:02-07:00 Add destructive functions to start-block We forgot to add `nunion`, `nintersection`, and `nset-difference` to the `start-block` to make the available. Without this, they're not globally defined. - - - - - 1 changed file: - src/code/list.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)) ;; 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) View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/8f262bac2129c7d8532c3df… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/8f262bac2129c7d8532c3df… 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] Block compile destructive ops too
by Raymond Toy (＠rtoy) 22 Aug '23

22 Aug '23

Raymond Toy pushed to branch issue-240-add-hashtable-for-destructive-set-ops at cmucl / cmucl Commits: 0d14e908 by Raymond Toy at 2023-08-22T07:19:14-07:00 Block compile destructive ops too And remove old commented-out code. - - - - - 1 changed file: - src/code/list.lisp Changes: ===================================== src/code/list.lisp ===================================== @@ -852,8 +852,6 @@ (push item res))) res))))) -(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. ;;; @@ -905,11 +903,6 @@ (process (nth-value 1 (gethash (apply-key key (car list1)) hashtable)))) (t (process (with-set-keys (member (apply-key key (car list1)) list2))))) - #+nil - (do () ((endp list1)) - (if (with-set-keys (member (apply-key key (car list1)) list2)) - (steve-splice list1 res) - (setq list1 (Cdr list1)))) res))) (defun nset-difference (list1 list2 &key key @@ -931,13 +924,10 @@ (process (nth-value 1 (gethash (apply-key key (car list1)) hashtable)))) (t (process (with-set-keys (member (apply-key key (car list1)) list2))))) - #+nil - (do () ((endp list1)) - (if (not (with-set-keys (member (apply-key key (car list1)) list2))) - (steve-splice list1 res) - (setq list1 (cdr list1)))) res))) +(declaim (end-block)) + (defun set-exclusive-or (list1 list2 &key key (test #'eql testp) (test-not nil notp)) "Return new list of elements appearing exactly once in LIST1 and LIST2." View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/0d14e90845074a14424fec7… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/0d14e90845074a14424fec7… 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] 3 commits: Fix #253: Block-compile list-to-hashtable and callers
by Raymond Toy (＠rtoy) 22 Aug '23

22 Aug '23

Raymond Toy pushed to branch issue-240-add-hashtable-for-destructive-set-ops at cmucl / cmucl Commits: afaeb420 by Raymond Toy at 2023-08-22T14:00:25+00:00 Fix #253: Block-compile list-to-hashtable and callers - - - - - a5b2c0f8 by Raymond Toy at 2023-08-22T14:02:24+00:00 Merge branch 'issue-253-block-compile-list-to-hashtable' into 'master' Fix #253: Block-compile list-to-hashtable and callers Closes #253 See merge request cmucl/cmucl!166 - - - - - 3fb1adf8 by Raymond Toy at 2023-08-22T07:14:56-07:00 Merge branch 'master' into issue-240-add-hashtable-for-destructive-set-ops - - - - - 2 changed files: - src/code/list.lisp - src/i18n/locale/cmucl.pot Changes: ===================================== src/code/list.lisp ===================================== @@ -749,6 +749,7 @@ (defparameter *min-list-length-for-hashtable* 15) +(declaim (start-block list-to-hashtable union intersection set-difference)) ;; 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) @@ -802,6 +803,57 @@ (push item res))))) res)) + +(defun intersection (list1 list2 &key key + (test #'eql testp) (test-not nil notp)) + "Returns the intersection of list1 and list2." + (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))))) + +(defun set-difference (list1 list2 &key key (test #'eql testp) (test-not nil notp)) + "Returns the elements of list1 which are not in list2." + (declare (inline member)) + (if (and testp notp) + (error "Test and test-not both supplied.")) + ;; Quick exit + (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))))) + +(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. ;;; @@ -834,28 +886,6 @@ (process (with-set-keys (member (apply-key key (car list1)) list2))))) res))) - -(defun intersection (list1 list2 &key key - (test #'eql testp) (test-not nil notp)) - "Returns the intersection of list1 and list2." - (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))))) - (defun nintersection (list1 list2 &key key (test #'eql testp) (test-not nil notp)) "Destructively returns the intersection of list1 and list2." @@ -882,33 +912,6 @@ (setq list1 (Cdr list1)))) res))) -(defun set-difference (list1 list2 &key key (test #'eql testp) (test-not nil notp)) - "Returns the elements of list1 which are not in list2." - (declare (inline member)) - (if (and testp notp) - (error "Test and test-not both supplied.")) - ;; Quick exit - (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))))) - (defun nset-difference (list1 list2 &key key (test #'eql testp) (test-not nil notp)) "Destructively returns the elements of list1 which are not in list2." @@ -935,7 +938,6 @@ (setq list1 (cdr list1)))) res))) - (defun set-exclusive-or (list1 list2 &key key (test #'eql testp) (test-not nil notp)) "Return new list of elements appearing exactly once in LIST1 and LIST2." ===================================== src/i18n/locale/cmucl.pot ===================================== @@ -3216,19 +3216,19 @@ msgid "Test and test-not both supplied." msgstr "" #: src/code/list.lisp -msgid "Destructively returns the union list1 and list2." +msgid "Returns the intersection of list1 and list2." msgstr "" #: src/code/list.lisp -msgid "Returns the intersection of list1 and list2." +msgid "Returns the elements of list1 which are not in list2." msgstr "" #: src/code/list.lisp -msgid "Destructively returns the intersection of list1 and list2." +msgid "Destructively returns the union list1 and list2." msgstr "" #: src/code/list.lisp -msgid "Returns the elements of list1 which are not in list2." +msgid "Destructively returns the intersection of list1 and list2." msgstr "" #: src/code/list.lisp View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/260b94a55db82b20489b41… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/260b94a55db82b20489b41… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][issue-240-clean-up-hashtable-impl] 5 commits: Address #240: Speed up subsetp with a hashtable
by Raymond Toy (＠rtoy) 22 Aug '23

22 Aug '23

Raymond Toy pushed to branch issue-240-clean-up-hashtable-impl at cmucl / cmucl Commits: 0b497d8c by Raymond Toy at 2023-08-21T20:15:07+00:00 Address #240: Speed up subsetp with a hashtable - - - - - bfae1626 by Raymond Toy at 2023-08-21T20:15:21+00:00 Merge branch 'issue-240-subsetp-with-hash-table' into 'master' Address #240: Speed up subsetp with a hashtable Closes #240 See merge request cmucl/cmucl!164 - - - - - afaeb420 by Raymond Toy at 2023-08-22T14:00:25+00:00 Fix #253: Block-compile list-to-hashtable and callers - - - - - a5b2c0f8 by Raymond Toy at 2023-08-22T14:02:24+00:00 Merge branch 'issue-253-block-compile-list-to-hashtable' into 'master' Fix #253: Block-compile list-to-hashtable and callers Closes #253 See merge request cmucl/cmucl!166 - - - - - 97b6cca7 by Raymond Toy at 2023-08-22T07:07:49-07:00 Merge branch 'master' into issue-240-clean-up-hashtable-impl - - - - - 4 changed files: - src/code/list.lisp - src/code/type.lisp - src/i18n/locale/cmucl.pot - tests/sets.lisp Changes: ===================================== src/code/list.lisp ===================================== @@ -749,6 +749,7 @@ (defparameter *min-list-length-for-hashtable* 15) +(declaim (start-block list-to-hashtable union intersection set-difference)) ;; 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) @@ -803,29 +804,6 @@ (process (with-set-keys (member (apply-key key item) list2))))) res))) -;;; Destination and source are setf-able and many-evaluable. Sets the source -;;; to the cdr, and "conses" the 1st elt of source to destination. -;;; -(defmacro steve-splice (source destination) - `(let ((temp ,source)) - (setf ,source (cdr ,source) - (cdr temp) ,destination - ,destination temp))) - -(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)) - (defun intersection (list1 list2 &key key (test #'eql testp) (test-not nil notp)) @@ -847,20 +825,6 @@ (t (process (with-set-keys (member (apply-key key item) list2)))))))) -(defun nintersection (list1 list2 &key key - (test #'eql testp) (test-not nil notp)) - "Destructively returns the intersection of list1 and list2." - (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)) - (defun set-difference (list1 list2 &key key (test #'eql testp) (test-not nil notp)) "Returns the elements of list1 which are not in list2." (declare (inline member)) @@ -888,6 +852,45 @@ (process (with-set-keys (member (apply-key key item) list2)))))))) +(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. +;;; +(defmacro steve-splice (source destination) + `(let ((temp ,source)) + (setf ,source (cdr ,source) + (cdr temp) ,destination + ,destination temp))) + +(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)) + +(defun nintersection (list1 list2 &key key + (test #'eql testp) (test-not nil notp)) + "Destructively returns the intersection of list1 and list2." + (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)) + (defun nset-difference (list1 list2 &key key (test #'eql testp) (test-not nil notp)) "Destructively returns the elements of list1 which are not in list2." @@ -989,14 +992,69 @@ (rplacd splicex (cdr x))) (setq splicex x))))) +(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 kernel::*min-list-length-for-subsetp-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)) - (dolist (elt list1) - (unless (with-set-keys (member (apply-key key elt) list2)) - (return-from subsetp nil))) - T) - + (when (and testp notp) + (error "Test and test-not both supplied.")) + + ;; 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 when it's safe to use hash tables for SUBSETP. + (multiple-value-bind (hashtable shorter-list) + (when t + (shorter-list-to-hashtable list1 list2 key test test-not)) + (cond (hashtable + (cond ((eq shorter-list list1) + ;; Remove any item from list2 from the hashtable containing list1. + (dolist (item list2) + (remhash (apply-key key item) hashtable)) + ;; If the hash table is now empty, then every + ;; element in list1 appeared in list2, so list1 is a + ;; subset of list2. + (zerop (hash-table-count hashtable))) + ((eq shorter-list list2) + (dolist (item list1) + (unless (nth-value 1 (gethash (apply-key key item) hashtable)) + (return-from subsetp nil))) + t))) + (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 ===================================== src/code/type.lisp ===================================== @@ -377,6 +377,14 @@ (cold-load-init (setq *use-implementation-types* t)) (declaim (type boolean *use-implementation-types*)) +(defvar *min-list-length-for-subsetp-hashtable* 150 + "The minimum length of either list argument for subsetp where a + hashtable is used to speed up processing instead of using a basic + list implementation. This value was determined by experimentation.") + +(cold-load-init (setq *min-list-length-for-subsetp-hashtable* 150)) +(declaim (type fixnum *min-list-length-for-subsetp-hashtable*)) + ;;; DELEGATE-COMPLEX-{SUBTYPEP-ARG2,INTERSECTION} -- Interface ;;; ;;; These functions are used as method for types which need a complex ===================================== src/i18n/locale/cmucl.pot ===================================== @@ -1155,6 +1155,13 @@ msgid "" " affects array types." msgstr "" +#: src/code/type.lisp +msgid "" +"The minimum length of either list argument for subsetp where a\n" +" hashtable is used to speed up processing instead of using a basic\n" +" list implementation. This value was determined by experimentation." +msgstr "" + #: src/code/type.lisp msgid "Subtypep is illegal on this type:~% ~S" msgstr "" @@ -3209,19 +3216,19 @@ msgid "Test and test-not both supplied." msgstr "" #: src/code/list.lisp -msgid "Destructively returns the union list1 and list2." +msgid "Returns the intersection of list1 and list2." msgstr "" #: src/code/list.lisp -msgid "Returns the intersection of list1 and list2." +msgid "Returns the elements of list1 which are not in list2." msgstr "" #: src/code/list.lisp -msgid "Destructively returns the intersection of list1 and list2." +msgid "Destructively returns the union list1 and list2." msgstr "" #: src/code/list.lisp -msgid "Returns the elements of list1 which are not in list2." +msgid "Destructively returns the intersection of list1 and list2." msgstr "" #: src/code/list.lisp ===================================== tests/sets.lisp ===================================== @@ -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))) View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/ce2eadfcb1f890cd1c96b6… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/ce2eadfcb1f890cd1c96b6… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][master] 2 commits: Fix #253: Block-compile list-to-hashtable and callers
by Raymond Toy (＠rtoy) 22 Aug '23

22 Aug '23

Raymond Toy pushed to branch master at cmucl / cmucl Commits: afaeb420 by Raymond Toy at 2023-08-22T14:00:25+00:00 Fix #253: Block-compile list-to-hashtable and callers - - - - - a5b2c0f8 by Raymond Toy at 2023-08-22T14:02:24+00:00 Merge branch 'issue-253-block-compile-list-to-hashtable' into 'master' Fix #253: Block-compile list-to-hashtable and callers Closes #253 See merge request cmucl/cmucl!166 - - - - - 2 changed files: - src/code/list.lisp - src/i18n/locale/cmucl.pot Changes: ===================================== src/code/list.lisp ===================================== @@ -749,6 +749,7 @@ (defparameter *min-list-length-for-hashtable* 15) +(declaim (start-block list-to-hashtable union intersection set-difference)) ;; 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) @@ -802,29 +803,6 @@ (push item res))))) res)) -;;; Destination and source are setf-able and many-evaluable. Sets the source -;;; to the cdr, and "conses" the 1st elt of source to destination. -;;; -(defmacro steve-splice (source destination) - `(let ((temp ,source)) - (setf ,source (cdr ,source) - (cdr temp) ,destination - ,destination temp))) - -(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)) - (defun intersection (list1 list2 &key key (test #'eql testp) (test-not nil notp)) @@ -847,20 +825,6 @@ (push elt res))) res))))) -(defun nintersection (list1 list2 &key key - (test #'eql testp) (test-not nil notp)) - "Destructively returns the intersection of list1 and list2." - (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)) - (defun set-difference (list1 list2 &key key (test #'eql testp) (test-not nil notp)) "Returns the elements of list1 which are not in list2." (declare (inline member)) @@ -888,6 +852,45 @@ (push item res))) res))))) +(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. +;;; +(defmacro steve-splice (source destination) + `(let ((temp ,source)) + (setf ,source (cdr ,source) + (cdr temp) ,destination + ,destination temp))) + +(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)) + +(defun nintersection (list1 list2 &key key + (test #'eql testp) (test-not nil notp)) + "Destructively returns the intersection of list1 and list2." + (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)) + (defun nset-difference (list1 list2 &key key (test #'eql testp) (test-not nil notp)) "Destructively returns the elements of list1 which are not in list2." ===================================== src/i18n/locale/cmucl.pot ===================================== @@ -3216,19 +3216,19 @@ msgid "Test and test-not both supplied." msgstr "" #: src/code/list.lisp -msgid "Destructively returns the union list1 and list2." +msgid "Returns the intersection of list1 and list2." msgstr "" #: src/code/list.lisp -msgid "Returns the intersection of list1 and list2." +msgid "Returns the elements of list1 which are not in list2." msgstr "" #: src/code/list.lisp -msgid "Destructively returns the intersection of list1 and list2." +msgid "Destructively returns the union list1 and list2." msgstr "" #: src/code/list.lisp -msgid "Returns the elements of list1 which are not in list2." +msgid "Destructively returns the intersection of list1 and list2." msgstr "" #: src/code/list.lisp View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/bfae1626b04fcf606a4a2d… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/bfae1626b04fcf606a4a2d… 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