1 ;;;; This file implements a sparse set abstraction, represented as a
2 ;;;; sorted linked list. We don't use bit-vectors to represent sets in
3 ;;;; flow analysis, since the universe may be quite large but the
4 ;;;; average number of elements is small. We keep the list sorted so
5 ;;;; that we can do union and intersection in linear time.
7 ;;;; This software is part of the SBCL system. See the README file for
10 ;;;; This software is derived from the CMU CL system, which was
11 ;;;; written at Carnegie Mellon University and released into the
12 ;;;; public domain. The software is in the public domain and is
13 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
14 ;;;; files for more information.
21 ;;; Each structure that may be placed in a SSet must include the
22 ;;; SSet-Element structure. We allow an initial value of NIL to mean
23 ;;; that no ordering has been assigned yet (although an ordering must
24 ;;; be assigned before doing set operations.)
25 (defstruct (sset-element (:constructor nil))
26 (number nil :type (or index null)))
28 (defstruct (sset (:constructor make-sset ())
30 (elements (list nil) :type list))
32 (elements :prin1 (cdr elements)))
34 ;;; Iterate over the elements in SSET, binding VAR to each element in
36 (defmacro do-sset-elements ((var sset &optional result) &body body)
37 `(dolist (,var (cdr (sset-elements ,sset)) ,result) ,@body))
39 ;;; Destructively add Element to Set. If Element was not in the set,
40 ;;; then we return true, otherwise we return false.
41 (declaim (ftype (function (sset-element sset) boolean) sset-adjoin))
42 (defun sset-adjoin (element set)
43 (let ((number (sset-element-number element))
44 (elements (sset-elements set)))
45 (do ((prev elements current)
46 (current (cdr elements) (cdr current)))
48 (setf (cdr prev) (list element))
50 (let ((el (car current)))
51 (when (>= (sset-element-number el) number)
54 (setf (cdr prev) (cons element current))
57 ;;; Destructively remove Element from Set. If element was in the set,
58 ;;; then return true, otherwise return false.
59 (declaim (ftype (function (sset-element sset) boolean) sset-delete))
60 (defun sset-delete (element set)
61 (let ((elements (sset-elements set)))
62 (do ((prev elements current)
63 (current (cdr elements) (cdr current)))
65 (when (eq (car current) element)
66 (setf (cdr prev) (cdr current))
69 ;;; Return true if Element is in Set, false otherwise.
70 (declaim (ftype (function (sset-element sset) boolean) sset-member))
71 (defun sset-member (element set)
72 (declare (inline member))
73 (not (null (member element (cdr (sset-elements set)) :test #'eq))))
75 ;;; Return true if SET contains no elements, false otherwise.
76 (declaim (ftype (function (sset) boolean) sset-empty))
77 (defun sset-empty (set)
78 (null (cdr (sset-elements set))))
80 ;;; Return a new copy of SET.
81 (declaim (ftype (function (sset) sset) copy-sset))
82 (defun copy-sset (set)
83 (let ((res (make-sset)))
84 (setf (sset-elements res) (copy-list (sset-elements set)))
87 ;;; Perform the appropriate set operation on Set1 and Set2 by destructively
88 ;;; modifying Set1. We return true if Set1 was modified, false otherwise.
89 (declaim (ftype (function (sset sset) boolean) sset-union sset-intersection
91 (defun sset-union (set1 set2)
92 (let* ((prev-el1 (sset-elements set1))
95 (do ((el2 (cdr (sset-elements set2)) (cdr el2)))
98 (num2 (sset-element-number e)))
101 (setf (cdr prev-el1) (copy-list el2))
102 (return-from sset-union t))
103 (let ((num1 (sset-element-number (car el1))))
106 (let ((new (cons e el1)))
107 (setf (cdr prev-el1) new)
108 (setq prev-el1 new changed t))
109 (shiftf prev-el1 el1 (cdr el1)))
111 (shiftf prev-el1 el1 (cdr el1))))))))
112 (defun sset-intersection (set1 set2)
113 (let* ((prev-el1 (sset-elements set1))
116 (do ((el2 (cdr (sset-elements set2)) (cdr el2)))
119 (setf (cdr prev-el1) nil)
122 (let ((num2 (sset-element-number (car el2))))
125 (return-from sset-intersection changed))
126 (let ((num1 (sset-element-number (car el1))))
129 (shiftf prev-el1 el1 (cdr el1)))
132 (setf (cdr prev-el1) el1)
133 (setq changed t)))))))
134 (defun sset-difference (set1 set2)
135 (let* ((prev-el1 (sset-elements set1))
138 (do ((el2 (cdr (sset-elements set2)) (cdr el2)))
140 (let ((num2 (sset-element-number (car el2))))
143 (return-from sset-difference changed))
144 (let ((num1 (sset-element-number (car el1))))
148 (setf (cdr prev-el1) el1)
151 (shiftf prev-el1 el1 (cdr el1))))))))
153 ;;; Destructively modify Set1 to include its union with the difference
154 ;;; of Set2 and Set3. We return true if Set1 was modified, false
156 (declaim (ftype (function (sset sset sset) boolean) sset-union-of-difference))
157 (defun sset-union-of-difference (set1 set2 set3)
158 (let* ((prev-el1 (sset-elements set1))
160 (el3 (cdr (sset-elements set3)))
162 (do ((el2 (cdr (sset-elements set2)) (cdr el2)))
165 (num2 (sset-element-number e)))
170 (setf (cdr prev-el1) (copy-list el2))
171 (return-from sset-union-of-difference t))
172 (let ((num1 (sset-element-number (car el1))))
175 (let ((new (cons e el1)))
176 (setf (cdr prev-el1) new)
177 (setq prev-el1 new changed t))
178 (shiftf prev-el1 el1 (cdr el1)))
180 (shiftf prev-el1 el1 (cdr el1))))
182 (let ((num3 (sset-element-number (car el3))))
184 (unless (= num2 num3)
187 (do ((el2 el2 (cdr el2)))
189 (return-from sset-union-of-difference changed))
191 (num2 (sset-element-number e)))
194 (setf (cdr prev-el1) (copy-list el2))
195 (return-from sset-union-of-difference t))
196 (setq num3 (sset-element-number (car el3)))
198 (unless (= num2 num3)
199 (let ((new (cons e el1)))
200 (setf (cdr prev-el1) new)
201 (setq prev-el1 new changed t)))
204 (let ((num1 (sset-element-number (car el1))))
207 (let ((new (cons e el1)))
208 (setf (cdr prev-el1) new)
209 (setq prev-el1 new changed t))
210 (shiftf prev-el1 el1 (cdr el1)))
212 (shiftf prev-el1 el1 (cdr el1)))))