Raymond Toy pushed to branch master at cmucl / cmucl Commits: ffe3625a by Raymond Toy at 2023-08-29T13:01:16+00:00 Address #240: Rename processing macros for set operations - - - - - 747a82ba by Raymond Toy at 2023-08-29T13:04:36+00:00 Merge branch 'issue-240-clean-up-hashtable-for-sets-impl' into 'master' Address #240: Rename processing macros for set operations See merge request cmucl/cmucl!171 - - - - - 1 changed file: - src/code/list.lisp Changes: ===================================== src/code/list.lisp ===================================== @@ -753,26 +753,31 @@ 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)))))) +;; 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 + 'when) + (:not-element-of-set + 'unless)))) + `(let ((hashtable (list-to-hashtable ,list2 key test test-not))) + (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-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. @@ -815,7 +820,7 @@ (declare (inline member)) (when (and testp notp) (error (intl:gettext "Test and test-not both supplied."))) - (process-set list2 t)) + (do-set-operation list1 list2 :initial-result list2 :is :not-element-of-set)) (defun intersection (list1 list2 &key key @@ -824,7 +829,7 @@ (declare (inline member)) (if (and testp notp) (error "Test and test-not both supplied.")) - (process-set nil nil)) + (do-set-operation list1 list2 :initial-result nil :is :element-of-set)) (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,7 +840,7 @@ (when (null list2) (return-from set-difference list1)) - (process-set nil t)) + (do-set-operation list1 list2 :initial-result nil :is :not-element-of-set)) ;;; Destination and source are setf-able and many-evaluable. Sets the source @@ -851,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)) @@ -867,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)) @@ -882,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)) @@ -891,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)) @@ -900,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/4542d55efe2291e2de73786... -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/4542d55efe2291e2de73786... You're receiving this email because of your account on gitlab.common-lisp.net.