GitLab

at 2023-08-29T13:01:16+00:00

Address #240:  Rename processing macros for set operations

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

   (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

   (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."

   (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

 ;;; 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))

 ;; 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))

   (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))

   (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))

   (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))

Raymond Toy pushed to branch master at cmucl / cmucl

Commits:

1 changed file:

Changes: