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/427aaa311105943b771698b...