GitLab

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.

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.

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.

                       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

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

 ;;; 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 issue-240-clean-up-hashtable-for-sets-impl at cmucl / cmucl

Commits:

1 changed file:

Changes: