| ... |
... |
@@ -863,47 +863,42 @@ |
|
863
|
863
|
(cdr temp) ,destination
|
|
864
|
864
|
,destination temp)))
|
|
865
|
865
|
|
|
866
|
|
-;;; Main processing for destructive set operations. Like PROCESS-SET with same args,
|
|
867
|
|
-;;; but for destructive operations.
|
|
868
|
|
-(defmacro nprocess-set (init-res test-form)
|
|
|
866
|
+;;; Main body for destructive set operations. INIT-RES initializes
|
|
|
867
|
+;;; the result list. INVERT-P is T if the result of the TEST-FORM
|
|
|
868
|
+;;; should be inverted. TEST-FORM is the form used for determining
|
|
|
869
|
+;;; how to update the result.
|
|
|
870
|
+(defmacro nprocess-set-body (init-res invert-p test-form)
|
|
869
|
871
|
`(let ((res ,init-res)
|
|
870
|
872
|
(list1 list1))
|
|
871
|
873
|
(do ()
|
|
872
|
874
|
((endp list1))
|
|
873
|
|
- (if ,test-form
|
|
|
875
|
+ (if ,(if invert-p
|
|
|
876
|
+ `(not ,test-form)
|
|
|
877
|
+ test-form)
|
|
874
|
878
|
(steve-splice list1 res)
|
|
875
|
879
|
(setq list1 (cdr list1))))
|
|
876
|
880
|
res))
|
|
877
|
881
|
|
|
|
882
|
+;; Implementation of the destructive set operations. INIT-RES
|
|
|
883
|
+;; initializes the value of the result list. INVERT-P indicates
|
|
|
884
|
+;; whether to invert the test-form used to determine how the result
|
|
|
885
|
+;; should be updated.
|
|
|
886
|
+(defmacro nprocess-set (init-res invert-p)
|
|
|
887
|
+ `(let ((hashtable (list-to-hashtable list2 key test test-not)))
|
|
|
888
|
+ (if hashtable
|
|
|
889
|
+ (nprocess-set-body ,init-res ,invert-p
|
|
|
890
|
+ (nth-value 1 (gethash (apply-key key (car list1)) hashtable)))
|
|
|
891
|
+ (nprocess-set-body ,init-res ,invert-p
|
|
|
892
|
+ (with-set-keys (member (apply-key key (car list1)) list2))))))
|
|
|
893
|
+
|
|
878
|
894
|
|
|
879
|
895
|
(defun nunion (list1 list2 &key key (test #'eql testp) (test-not nil notp))
|
|
880
|
896
|
"Destructively returns the union list1 and list2."
|
|
881
|
897
|
(declare (inline member))
|
|
882
|
898
|
(if (and testp notp)
|
|
883
|
899
|
(error "Test and test-not both supplied."))
|
|
884
|
|
-
|
|
885
|
|
- (let (#+nil
|
|
886
|
|
- (res list2)
|
|
887
|
|
- (hashtable (list-to-hashtable list2 key test test-not))
|
|
888
|
|
- #+nil
|
|
889
|
|
- (list1 list1))
|
|
890
|
|
- (if hashtable
|
|
891
|
|
- (nprocess-set list2 (not (nth-value 1 (gethash (apply-key key (car list1)) hashtable))))
|
|
892
|
|
- (nprocess-set list2 (not (with-set-keys (member (apply-key key (car list1)) list2)))))
|
|
893
|
|
- #+nil
|
|
894
|
|
- (macrolet
|
|
895
|
|
- ((process (test-form)
|
|
896
|
|
- `(do ()
|
|
897
|
|
- ((endp list1))
|
|
898
|
|
- (if (not ,test-form)
|
|
899
|
|
- (steve-splice list1 res)
|
|
900
|
|
- (setf list1 (cdr list1))))))
|
|
901
|
|
- (cond
|
|
902
|
|
- (hashtable
|
|
903
|
|
- (process (nth-value 1 (gethash (apply-key key (car list1)) hashtable))))
|
|
904
|
|
- (t
|
|
905
|
|
- (process (with-set-keys (member (apply-key key (car list1)) list2)))))
|
|
906
|
|
- res)))
|
|
|
900
|
+
|
|
|
901
|
+ (nprocess-set list2 t))
|
|
907
|
902
|
|
|
908
|
903
|
(defun nintersection (list1 list2 &key key
|
|
909
|
904
|
(test #'eql testp) (test-not nil notp))
|
| ... |
... |
@@ -911,26 +906,8 @@ |
|
911
|
906
|
(declare (inline member))
|
|
912
|
907
|
(if (and testp notp)
|
|
913
|
908
|
(error "Test and test-not both supplied."))
|
|
914
|
|
- (let (#+nil
|
|
915
|
|
- (res nil)
|
|
916
|
|
- (hashtable (list-to-hashtable list2 key test test-not))
|
|
917
|
|
- #+nil
|
|
918
|
|
- (list1 list1))
|
|
919
|
|
- (if hashtable
|
|
920
|
|
- (nprocess-set nil (nth-value 1 (gethash (apply-key key (car list1)) hashtable)))
|
|
921
|
|
- (nprocess-set nil (with-set-keys (member (apply-key key (car list1)) list2))))
|
|
922
|
|
- #+nil
|
|
923
|
|
- (macrolet
|
|
924
|
|
- ((process (test-form)
|
|
925
|
|
- `(do () ((endp list1))
|
|
926
|
|
- (if ,test-form
|
|
927
|
|
- (steve-splice list1 res)
|
|
928
|
|
- (setq list1 (Cdr list1))))))
|
|
929
|
|
- (cond (hashtable
|
|
930
|
|
- (process (nth-value 1 (gethash (apply-key key (car list1)) hashtable))))
|
|
931
|
|
- (t
|
|
932
|
|
- (process (with-set-keys (member (apply-key key (car list1)) list2)))))
|
|
933
|
|
- res)))
|
|
|
909
|
+
|
|
|
910
|
+ (nprocess-set nil nil))
|
|
934
|
911
|
|
|
935
|
912
|
(defun nset-difference (list1 list2 &key key
|
|
936
|
913
|
(test #'eql testp) (test-not nil notp))
|
| ... |
... |
@@ -938,26 +915,8 @@ |
|
938
|
915
|
(declare (inline member))
|
|
939
|
916
|
(if (and testp notp)
|
|
940
|
917
|
(error "Test and test-not both supplied."))
|
|
941
|
|
- (let (#+nil
|
|
942
|
|
- (res nil)
|
|
943
|
|
- (hashtable (list-to-hashtable list2 key test test-not))
|
|
944
|
|
- #+nil
|
|
945
|
|
- (list1 list1))
|
|
946
|
|
- (if hashtable
|
|
947
|
|
- (nprocess-set nil (not (nth-value 1 (gethash (apply-key key (car list1)) hashtable))))
|
|
948
|
|
- (nprocess-set nil (not (with-set-keys (member (apply-key key (car list1)) list2)))))
|
|
949
|
|
- #+nil
|
|
950
|
|
- (macrolet
|
|
951
|
|
- ((process (test-form)
|
|
952
|
|
- `(do () ((endp list1))
|
|
953
|
|
- (if (not ,test-form)
|
|
954
|
|
- (steve-splice list1 res)
|
|
955
|
|
- (setq list1 (cdr list1))))))
|
|
956
|
|
- (cond (hashtable
|
|
957
|
|
- (process (nth-value 1 (gethash (apply-key key (car list1)) hashtable))))
|
|
958
|
|
- (t
|
|
959
|
|
- (process (with-set-keys (member (apply-key key (car list1)) list2)))))
|
|
960
|
|
- res)))
|
|
|
918
|
+
|
|
|
919
|
+ (nprocess-set nil t))
|
|
961
|
920
|
|
|
962
|
921
|
(declaim (end-block))
|
|
963
|
922
|
|