| ... |
... |
@@ -991,62 +991,65 @@ |
|
991
|
991
|
|
|
992
|
992
|
(defvar *allow-hashtable-for-set-functions* t)
|
|
993
|
993
|
|
|
|
994
|
+;;(declaim (start-block shorter-list-to-hashtable subsetp))
|
|
|
995
|
+
|
|
|
996
|
+(defun shorter-list-to-hashtable (list1 list2 key test test-not)
|
|
|
997
|
+ ;; Find the shorter list and return the length and the shorter list
|
|
|
998
|
+ (when test-not
|
|
|
999
|
+ (return-from shorter-list-to-hashtable nil))
|
|
|
1000
|
+ (let ((hash-test (let ((test-fn (if (and (symbolp test)
|
|
|
1001
|
+ (fboundp test))
|
|
|
1002
|
+ (fdefinition test)
|
|
|
1003
|
+ test)))
|
|
|
1004
|
+ (cond ((eql test-fn #'eq) 'eq)
|
|
|
1005
|
+ ((eql test-fn #'eql) 'eql)
|
|
|
1006
|
+ ((eql test-fn #'equal) 'equal)
|
|
|
1007
|
+ ((eql test-fn #'equalp) 'equalp)))))
|
|
|
1008
|
+ (unless hash-test
|
|
|
1009
|
+ (return-from shorter-list-to-hashtable nil))
|
|
|
1010
|
+ (multiple-value-bind (min-length shorter-list)
|
|
|
1011
|
+ (do ((len 0 (1+ len))
|
|
|
1012
|
+ (lst1 list1 (cdr lst1))
|
|
|
1013
|
+ (lst2 list2 (cdr lst2)))
|
|
|
1014
|
+ ((or (null lst1) (null lst2))
|
|
|
1015
|
+ (values len (if (null lst1) list1 list2))))
|
|
|
1016
|
+ (when (< min-length *min-list-length-for-hashtable*)
|
|
|
1017
|
+ (return-from shorter-list-to-hashtable nil))
|
|
|
1018
|
+ (let ((hashtable (make-hash-table :test hash-test :size min-length)))
|
|
|
1019
|
+ (dolist (item shorter-list)
|
|
|
1020
|
+ (setf (gethash (apply-key key item) hashtable) item))
|
|
|
1021
|
+ (values hashtable shorter-list)))))
|
|
|
1022
|
+
|
|
994
|
1023
|
(defun subsetp (list1 list2 &key key (test #'eql testp) (test-not nil notp))
|
|
995
|
1024
|
"Returns T if every element in list1 is also in list2."
|
|
996
|
1025
|
(declare (inline member))
|
|
997
|
1026
|
(when (and testp notp)
|
|
998
|
1027
|
(error "Test and test-not both supplied."))
|
|
999
|
1028
|
|
|
1000
|
|
- (flet ((lists-to-hashtable ()
|
|
1001
|
|
- ;; Find the shorter list and return the length and the shorter list
|
|
1002
|
|
- (when test-not
|
|
1003
|
|
- (return-from lists-to-hashtable nil))
|
|
1004
|
|
- (let ((hash-test (let ((test-fn (if (and (symbolp test)
|
|
1005
|
|
- (fboundp test))
|
|
1006
|
|
- (fdefinition test)
|
|
1007
|
|
- test)))
|
|
1008
|
|
- (cond ((eql test-fn #'eq) 'eq)
|
|
1009
|
|
- ((eql test-fn #'eql) 'eql)
|
|
1010
|
|
- ((eql test-fn #'equal) 'equal)
|
|
1011
|
|
- ((eql test-fn #'equalp) 'equalp)))))
|
|
1012
|
|
- (unless hash-test
|
|
1013
|
|
- (return-from lists-to-hashtable nil))
|
|
1014
|
|
- (multiple-value-bind (min-length shorter-list)
|
|
1015
|
|
- (do ((len 0 (1+ len))
|
|
1016
|
|
- (lst1 list1 (cdr lst1))
|
|
1017
|
|
- (lst2 list2 (cdr lst2)))
|
|
1018
|
|
- ((or (null lst1) (null lst2))
|
|
1019
|
|
- (values len (if (null lst1) list1 list2))))
|
|
1020
|
|
- (when (< min-length *min-list-length-for-hashtable*)
|
|
1021
|
|
- (return-from lists-to-hashtable nil))
|
|
1022
|
|
- (let ((hashtable (make-hash-table :test hash-test :size min-length)))
|
|
1023
|
|
- (dolist (item shorter-list)
|
|
1024
|
|
- (setf (gethash (apply-key key item) hashtable) item))
|
|
1025
|
|
- (values hashtable shorter-list))))))
|
|
1026
|
|
-
|
|
1027
|
|
- ;; SUBSETP is used early in TYPE-INIT where hash tables aren't
|
|
1028
|
|
- ;; available yet, so we can't use hashtables then. LISPINIT will
|
|
1029
|
|
- ;; take care to disable this for the kernel.core. SAVE will set
|
|
1030
|
|
- ;; this to true it's safe to use hash tables for SUBSETP.
|
|
1031
|
|
- (multiple-value-bind (hashtable shorter-list)
|
|
1032
|
|
- (when *allow-hashtable-for-set-functions*
|
|
1033
|
|
- (lists-to-hashtable))
|
|
1034
|
|
- (cond (hashtable
|
|
1035
|
|
- (cond ((eq shorter-list list1)
|
|
1036
|
|
- (dolist (item list2)
|
|
1037
|
|
- (unless (nth-value 1 (gethash (apply-key key item) hashtable))
|
|
1038
|
|
- (return-from subsetp nil))))
|
|
1039
|
|
- ((eq shorter-list list2)
|
|
1040
|
|
- (dolist (item list1)
|
|
1041
|
|
- (unless (nth-value 1 (gethash (apply-key key item) hashtable))
|
|
1042
|
|
- (return-from subsetp nil)))))
|
|
1043
|
|
- t)
|
|
1044
|
|
- ((null hashtable)
|
|
1045
|
|
- (dolist (item list1)
|
|
1046
|
|
- (unless (with-set-keys (member (apply-key key item) list2))
|
|
1047
|
|
- (return-from subsetp nil)))
|
|
1048
|
|
- T)))))
|
|
|
1029
|
+ ;; SUBSETP is used early in TYPE-INIT where hash tables aren't
|
|
|
1030
|
+ ;; available yet, so we can't use hashtables then. LISPINIT will
|
|
|
1031
|
+ ;; take care to disable this for the kernel.core. SAVE will set
|
|
|
1032
|
+ ;; this to true it's safe to use hash tables for SUBSETP.
|
|
|
1033
|
+ (multiple-value-bind (hashtable shorter-list)
|
|
|
1034
|
+ (when *allow-hashtable-for-set-functions*
|
|
|
1035
|
+ (shorter-list-to-hashtable list1 list2 key test test-not))
|
|
|
1036
|
+ (cond (hashtable
|
|
|
1037
|
+ (cond ((eq shorter-list list1)
|
|
|
1038
|
+ (dolist (item list2)
|
|
|
1039
|
+ (unless (nth-value 1 (gethash (apply-key key item) hashtable))
|
|
|
1040
|
+ (return-from subsetp nil))))
|
|
|
1041
|
+ ((eq shorter-list list2)
|
|
|
1042
|
+ (dolist (item list1)
|
|
|
1043
|
+ (unless (nth-value 1 (gethash (apply-key key item) hashtable))
|
|
|
1044
|
+ (return-from subsetp nil)))))
|
|
|
1045
|
+ t)
|
|
|
1046
|
+ ((null hashtable)
|
|
|
1047
|
+ (dolist (item list1)
|
|
|
1048
|
+ (unless (with-set-keys (member (apply-key key item) list2))
|
|
|
1049
|
+ (return-from subsetp nil)))
|
|
|
1050
|
+ T))))
|
|
1049
|
1051
|
|
|
|
1052
|
+;;(declaim (end-block))
|
|
1050
|
1053
|
|
|
1051
|
1054
|
|
|
1052
|
1055
|
;;; Functions that operate on association lists
|