Raymond Toy pushed to branch master at cmucl / cmucl

Commits:

1 changed file:

Changes:

  • src/code/list.lisp
    ... ... @@ -753,26 +753,31 @@
    753 753
                           union intersection set-difference
    
    754 754
                           nunion nintersection nset-difference))
    
    755 755
     
    
    756
    -;; Main code to process a set function.  INIT-RES initializes the
    
    757
    -;; value of RES, which holds the result of the set function.
    
    758
    -;; TEST-FORM is a form that tests whether to add the item from LIST1
    
    759
    -;; to RES.
    
    760
    -(defmacro process-set-body (init-res invert-p test-form)
    
    761
    -  `(let ((res ,init-res))
    
    762
    -     (dolist (item list1)
    
    763
    -       (when ,(if invert-p
    
    764
    -                  `(not ,test-form)
    
    765
    -                  test-form)
    
    766
    -         (push item res)))
    
    767
    -     res))
    
    768
    -
    
    769
    -(defmacro process-set (init-res invert-p)
    
    770
    -  `(let ((hashtable (list-to-hashtable list2 key test test-not)))
    
    771
    -     (if hashtable
    
    772
    -         (process-set-body ,init-res ,invert-p
    
    773
    -                      (nth-value 1 (gethash (apply-key key item) hashtable)))
    
    774
    -         (process-set-body ,init-res ,invert-p
    
    775
    -                      (with-set-keys (member (apply-key key item) list2))))))
    
    756
    +;; Handle a non-destructive set operation.  LIST1 and LIST2 are the
    
    757
    +;; two arguments to the set function.  INITIAL-RESULT is the value
    
    758
    +;; used to initialize the result list.  IS specifies whether the test
    
    759
    +;; (or test-not) function implies an element of LIST1 should be
    
    760
    +;; included in the result.
    
    761
    +(defmacro do-set-operation (list1 list2 &key initial-result is)
    
    762
    +  (let ((membership-test (ecase is
    
    763
    +                           (:element-of-set
    
    764
    +                            'when)
    
    765
    +                           (:not-element-of-set
    
    766
    +                            'unless))))
    
    767
    +    `(let ((hashtable (list-to-hashtable ,list2 key test test-not)))
    
    768
    +       (macrolet
    
    769
    +           ((process-set-op (list1 init-res member-form test-form)
    
    770
    +              `(let ((res ,init-res))
    
    771
    +                 (dolist (item ,list1)
    
    772
    +                   (,member-form ,test-form
    
    773
    +                                 (push item res)))
    
    774
    +                 res)))
    
    775
    +
    
    776
    +         (if hashtable
    
    777
    +             (process-set-op ,list1 ,initial-result ,membership-test
    
    778
    +                             (nth-value 1 (gethash (apply-key key item) hashtable)))
    
    779
    +             (process-set-op ,list1 ,initial-result ,membership-test
    
    780
    +                             (with-set-keys (member (apply-key key item) list2))))))))
    
    776 781
     
    
    777 782
     ;; Convert a list to a hashtable.  The hashtable does not handle
    
    778 783
     ;; duplicated values in the list.  Returns the hashtable.
    
    ... ... @@ -815,7 +820,7 @@
    815 820
       (declare (inline member))
    
    816 821
       (when (and testp notp)
    
    817 822
         (error (intl:gettext "Test and test-not both supplied.")))
    
    818
    -  (process-set list2 t))
    
    823
    +  (do-set-operation list1 list2 :initial-result list2 :is :not-element-of-set))
    
    819 824
     
    
    820 825
     
    
    821 826
     (defun intersection (list1 list2 &key key
    
    ... ... @@ -824,7 +829,7 @@
    824 829
       (declare (inline member))
    
    825 830
       (if (and testp notp)
    
    826 831
           (error "Test and test-not both supplied."))
    
    827
    -  (process-set nil nil))
    
    832
    +  (do-set-operation list1 list2 :initial-result nil :is :element-of-set))
    
    828 833
     
    
    829 834
     (defun set-difference (list1 list2 &key key (test #'eql testp) (test-not nil notp))
    
    830 835
       "Returns the elements of list1 which are not in list2."
    
    ... ... @@ -835,7 +840,7 @@
    835 840
       (when (null list2)
    
    836 841
         (return-from set-difference list1))
    
    837 842
     
    
    838
    -  (process-set nil t))
    
    843
    +  (do-set-operation list1 list2 :initial-result nil :is :not-element-of-set))
    
    839 844
     
    
    840 845
     
    
    841 846
     ;;; Destination and source are setf-able and many-evaluable.  Sets the source
    
    ... ... @@ -851,14 +856,14 @@
    851 856
     ;;; the result list.  INVERT-P is T if the result of the TEST-FORM
    
    852 857
     ;;; should be inverted.  TEST-FORM is the form used for determining
    
    853 858
     ;;; how to update the result.
    
    854
    -(defmacro nprocess-set-body (init-res invert-p test-form)
    
    859
    +(defmacro nprocess-set-body (list1 init-res is-member-p test-form)
    
    855 860
       `(let ((res ,init-res)
    
    856
    -         (list1 list1))
    
    861
    +         (list1 ,list1))
    
    857 862
          (do ()
    
    858 863
              ((endp list1))
    
    859
    -       (if ,(if invert-p
    
    860
    -                `(not ,test-form)
    
    861
    -                test-form)
    
    864
    +       (if ,(if is-member-p
    
    865
    +                test-form
    
    866
    +                `(not ,test-form))
    
    862 867
                (steve-splice list1 res)
    
    863 868
                (setq list1 (cdr list1))))
    
    864 869
          res))
    
    ... ... @@ -867,13 +872,30 @@
    867 872
     ;; initializes the value of the result list.  INVERT-P indicates
    
    868 873
     ;; whether to invert the test-form used to determine how the result
    
    869 874
     ;; should be updated.
    
    870
    -(defmacro nprocess-set (init-res invert-p)
    
    871
    -  `(let ((hashtable (list-to-hashtable list2 key test test-not)))
    
    872
    -     (if hashtable
    
    873
    -         (nprocess-set-body ,init-res ,invert-p
    
    874
    -                            (nth-value 1 (gethash (apply-key key (car list1)) hashtable)))
    
    875
    -         (nprocess-set-body ,init-res ,invert-p
    
    876
    -                            (with-set-keys (member (apply-key key (car list1)) list2))))))
    
    875
    +(defmacro do-destructive-set-operation (list1 list2 &key initial-result is)
    
    876
    +  (let ((is-member-p (ecase is
    
    877
    +                       (:element-of-set
    
    878
    +                        t)
    
    879
    +                       (:not-element-of-set
    
    880
    +                        nil))))
    
    881
    +    `(let ((hashtable (list-to-hashtable ,list2 key test test-not)))
    
    882
    +       (macrolet
    
    883
    +           ((process-set-op (list1 init-res is-member-p test-form)
    
    884
    +              `(let ((res ,init-res)
    
    885
    +                     (list1 ,list1))
    
    886
    +                 (do ()
    
    887
    +                     ((endp list1))
    
    888
    +                   (if ,(if is-member-p
    
    889
    +                            test-form
    
    890
    +                            `(not ,test-form))
    
    891
    +                       (steve-splice list1 res)
    
    892
    +                       (setq list1 (cdr list1))))
    
    893
    +                 res)))
    
    894
    +         (if hashtable
    
    895
    +             (process-set-op ,list1 ,initial-result ,is-member-p
    
    896
    +                             (nth-value 1 (gethash (apply-key key (car ,list1)) hashtable)))
    
    897
    +             (process-set-op ,list1 ,initial-result ,is-member-p
    
    898
    +                             (with-set-keys (member (apply-key key (car ,list1)) list2))))))))
    
    877 899
     
    
    878 900
     
    
    879 901
     (defun nunion (list1 list2 &key key (test #'eql testp) (test-not nil notp))
    
    ... ... @@ -882,7 +904,7 @@
    882 904
       (if (and testp notp)
    
    883 905
           (error "Test and test-not both supplied."))
    
    884 906
     
    
    885
    -  (nprocess-set list2 t))
    
    907
    +  (do-destructive-set-operation list1 list2 :initial-result list2 :is :not-element-of-set))
    
    886 908
       
    
    887 909
     (defun nintersection (list1 list2 &key key
    
    888 910
     			    (test #'eql testp) (test-not nil notp))
    
    ... ... @@ -891,7 +913,7 @@
    891 913
       (if (and testp notp)
    
    892 914
           (error "Test and test-not both supplied."))
    
    893 915
     
    
    894
    -  (nprocess-set nil nil))
    
    916
    +  (do-destructive-set-operation list1 list2 :initial-result nil :is :element-of-set))
    
    895 917
     
    
    896 918
     (defun nset-difference (list1 list2 &key key
    
    897 919
     			      (test #'eql testp) (test-not nil notp))
    
    ... ... @@ -900,7 +922,7 @@
    900 922
       (if (and testp notp)
    
    901 923
           (error "Test and test-not both supplied."))
    
    902 924
     
    
    903
    -  (nprocess-set nil t))
    
    925
    +  (do-destructive-set-operation list1 list2 :initial-result nil :is :not-element-of-set))
    
    904 926
     
    
    905 927
     (declaim (end-block))
    
    906 928