Raymond Toy pushed to branch issue-240-clean-up-hashtable-for-sets-impl at cmucl / cmucl Commits: 702fe16a by Raymond Toy at 2023-08-27T12:03:05-07:00 Rename/refactor nprocess-set Do the same for nprocess-set as we did for process-set, renaming it to do-destructive-set-operation. - - - - - 2a02ec67 by Raymond Toy at 2023-08-27T14:27:53-07:00 Move the process-set-body macro into do-set-operation Get rid the extra macro by moving inside the do-set-operation macro. This makes it a little neater. - - - - - 15ed5464 by Raymond Toy at 2023-08-27T14:55:27-07:00 Move the nprocess-set-body macro into do-destructive-set-operation Get rid the extra macro by moving it inside the do-destructive-set-operation macro. This makes it a little neater. - - - - - 1 changed file: - src/code/list.lisp Changes: ===================================== src/code/list.lisp ===================================== @@ -753,17 +753,11 @@ 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 (list1 init-res membership-test test-form) - `(let ((res ,init-res)) - (dolist (item ,list1) - (,membership-test ,test-form - (push item res))) - res)) - +;; Handle a non-destructive set operation. LIST1 and LIST2 are the +;; two arguments to the set function. INITIAL-RESULT is the value +;; used to initialize the result list. IS specifies whether the test +;; (or test-not) function implies an element of LIST1 should be +;; included in the result. (defmacro do-set-operation (list1 list2 &key initial-result is) (let ((membership-test (ecase is (:element-of-set @@ -771,11 +765,19 @@ (:not-element-of-set 'unless)))) `(let ((hashtable (list-to-hashtable ,list2 key test test-not))) - (if hashtable - (process-set-body ,list1 ,initial-result ,membership-test + (macrolet + ((process-set-op (list1 init-res member-form test-form) + `(let ((res ,init-res)) + (dolist (item ,list1) + (,member-form ,test-form + (push item res))) + res))) + + (if hashtable + (process-set-op ,list1 ,initial-result ,membership-test (nth-value 1 (gethash (apply-key key item) hashtable))) - (process-set-body ,list1 ,initial-result ,membership-test - (with-set-keys (member (apply-key key item) ,list2))))))) + (process-set-op ,list1 ,initial-result ,membership-test + (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. @@ -854,14 +856,14 @@ ;;; 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) +(defmacro nprocess-set-body (list1 init-res is-member-p test-form) `(let ((res ,init-res) - (list1 list1)) + (list1 ,list1)) (do () ((endp list1)) - (if ,(if invert-p - `(not ,test-form) - test-form) + (if ,(if is-member-p + test-form + `(not ,test-form)) (steve-splice list1 res) (setq list1 (cdr list1)))) res)) @@ -870,13 +872,30 @@ ;; 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)))))) +(defmacro do-destructive-set-operation (list1 list2 &key initial-result is) + (let ((is-member-p (ecase is + (:element-of-set + t) + (:not-element-of-set + nil)))) + `(let ((hashtable (list-to-hashtable ,list2 key test test-not))) + (macrolet + ((process-set-op (list1 init-res is-member-p test-form) + `(let ((res ,init-res) + (list1 ,list1)) + (do () + ((endp list1)) + (if ,(if is-member-p + test-form + `(not ,test-form)) + (steve-splice list1 res) + (setq list1 (cdr list1)))) + res))) + (if hashtable + (process-set-op ,list1 ,initial-result ,is-member-p + (nth-value 1 (gethash (apply-key key (car ,list1)) hashtable))) + (process-set-op ,list1 ,initial-result ,is-member-p + (with-set-keys (member (apply-key key (car ,list1)) list2)))))))) (defun nunion (list1 list2 &key key (test #'eql testp) (test-not nil notp)) @@ -885,7 +904,7 @@ (if (and testp notp) (error "Test and test-not both supplied.")) - (nprocess-set list2 t)) + (do-destructive-set-operation list1 list2 :initial-result list2 :is :not-element-of-set)) (defun nintersection (list1 list2 &key key (test #'eql testp) (test-not nil notp)) @@ -894,7 +913,7 @@ (if (and testp notp) (error "Test and test-not both supplied.")) - (nprocess-set nil nil)) + (do-destructive-set-operation list1 list2 :initial-result nil :is :element-of-set)) (defun nset-difference (list1 list2 &key key (test #'eql testp) (test-not nil notp)) @@ -903,7 +922,7 @@ (if (and testp notp) (error "Test and test-not both supplied.")) - (nprocess-set nil t)) + (do-destructive-set-operation list1 list2 :initial-result nil :is :not-element-of-set)) (declaim (end-block)) View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/bd928112a03960e68d419fc... -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/bd928112a03960e68d419fc... You're receiving this email because of your account on gitlab.common-lisp.net.