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/f305c0ee3440ffc83756e59...