1 | ;;;-*- Mode: Lisp; Package: CCL -*- |
---|
2 | ;;; |
---|
3 | ;;; Copyright (C) 2009 Clozure Associates |
---|
4 | ;;; Copyright (C) 1994-2001 Digitool, Inc |
---|
5 | ;;; This file is part of Clozure CL. |
---|
6 | ;;; |
---|
7 | ;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public |
---|
8 | ;;; License , known as the LLGPL and distributed with Clozure CL as the |
---|
9 | ;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, |
---|
10 | ;;; which is distributed with Clozure CL as the file "LGPL". Where these |
---|
11 | ;;; conflict, the preamble takes precedence. |
---|
12 | ;;; |
---|
13 | ;;; Clozure CL is referenced in the preamble as the "LIBRARY." |
---|
14 | ;;; |
---|
15 | ;;; The LLGPL is also available online at |
---|
16 | ;;; http://opensource.franz.com/preamble.html |
---|
17 | |
---|
18 | |
---|
19 | (in-package "CCL") |
---|
20 | |
---|
21 | |
---|
22 | (defstruct (dll-node (:print-function print-dll-node)) |
---|
23 | pred |
---|
24 | succ) |
---|
25 | |
---|
26 | ; Doubly-linked list header (just a distinguished type of node) |
---|
27 | (defstruct (dll-header |
---|
28 | (:include dll-node) |
---|
29 | (:constructor %make-dll-header)) |
---|
30 | ) |
---|
31 | |
---|
32 | |
---|
33 | (defmacro dll-header-last (h) `(dll-header-pred ,h)) |
---|
34 | (defmacro dll-header-first (h) `(dll-header-succ ,h)) |
---|
35 | |
---|
36 | (defun init-dll-header (h) |
---|
37 | (setf (dll-header-first h) h |
---|
38 | (dll-header-last h) h)) |
---|
39 | |
---|
40 | (defun make-dll-header () |
---|
41 | (init-dll-header (%make-dll-header))) |
---|
42 | |
---|
43 | |
---|
44 | ;;; DLL-NODEs are sort of "abstract classes", so we should rarely (if |
---|
45 | ;;; ever) have to print one. On the other hand, they're very circular |
---|
46 | ;;; abstract classes ... |
---|
47 | (defun print-dll-node (n stream d) |
---|
48 | (declare (ignore d)) |
---|
49 | (print-unreadable-object (n stream :type t :identity t))) |
---|
50 | |
---|
51 | ;;; Return NODE's list header, if it has one. |
---|
52 | (defun dll-node-header (node) |
---|
53 | (do* ((n node (dll-node-succ node))) |
---|
54 | ((or (null n) (typep n 'dll-header)) n))) |
---|
55 | |
---|
56 | ;;; Make node be the last node in header's linked list |
---|
57 | (defun append-dll-node (node header) |
---|
58 | (let* ((last (dll-header-last header))) |
---|
59 | (setf (dll-node-pred node) last |
---|
60 | (dll-header-last header) node |
---|
61 | (dll-node-succ node) header |
---|
62 | (dll-node-succ last) node))) |
---|
63 | |
---|
64 | ;;; Splice one or more nodes out of the containing doubly-linked list. |
---|
65 | ;;; Return the first and last nodes in the new chain. |
---|
66 | (defun remove-dll-node (node &optional (count 1)) |
---|
67 | (declare (fixnum count)) |
---|
68 | (do* ((last node (dll-node-succ last)) |
---|
69 | (i 1 (1+ i))) |
---|
70 | ((= i count) |
---|
71 | (let* ((prev (dll-node-pred node)) |
---|
72 | (after (dll-node-succ last))) |
---|
73 | (setf (dll-node-pred after) prev |
---|
74 | (dll-node-succ prev) after |
---|
75 | (dll-node-pred node) nil |
---|
76 | (dll-node-succ last) nil) |
---|
77 | (values node last))) |
---|
78 | (declare (fixnum i)) |
---|
79 | ;; This check shouldn't cost much and keeps us from doing |
---|
80 | ;; something really stupid. |
---|
81 | (when (typep last 'dll-header) |
---|
82 | (error "Can't remove header node .")))) |
---|
83 | |
---|
84 | ;;; Insert one or mode nodes after a specified node. To be sane, the |
---|
85 | ;;; "chainlast" argument must be "node" or a transitive successor of |
---|
86 | ;;; "node", (and "node" EQ to or a transitive predecessor of |
---|
87 | ;;; "chainlast", and no list header should appear on the chain between |
---|
88 | ;;; "node" and "chainlast". The typical cases where this is used are |
---|
89 | ;;; to insert a freshly consed node into a list or to insert a chain |
---|
90 | ;;; of one or more freshly deleted nodes. Both of these cases satisfy |
---|
91 | ;;; the sanity check, so it isn't performed here. |
---|
92 | (defun insert-dll-node-after (node after &optional (chainlast node)) |
---|
93 | (let* ((after-after (dll-node-succ after))) |
---|
94 | (setf (dll-node-pred node) after |
---|
95 | (dll-node-succ chainlast) after-after |
---|
96 | (dll-node-pred after-after) chainlast |
---|
97 | (dll-node-succ after) node))) |
---|
98 | |
---|
99 | ;;; More concise, somehow ... |
---|
100 | (defun insert-dll-node-before (node before &optional (chainlast node)) |
---|
101 | (insert-dll-node-after node (dll-node-pred before) chainlast)) |
---|
102 | |
---|
103 | (defun move-dll-nodes (node after &optional (count 1)) |
---|
104 | (multiple-value-bind (first last) (remove-dll-node node count) |
---|
105 | (insert-dll-node-after first after last))) |
---|
106 | |
---|
107 | ;;; Return chain head and tail, or (values nil nil) if empty header. |
---|
108 | (defun detach-dll-nodes (header) |
---|
109 | (let* ((first (dll-header-first header))) |
---|
110 | (if (eq first header) |
---|
111 | (values nil nil) |
---|
112 | (let* ((last (dll-header-last header))) |
---|
113 | (setf (dll-header-first header) header |
---|
114 | (dll-header-last header) header |
---|
115 | (dll-node-pred first) nil |
---|
116 | (dll-node-succ last) nil) |
---|
117 | (values first last))))) |
---|
118 | |
---|
119 | (defun merge-dll-nodes (target &rest others) |
---|
120 | (declare (dynamic-extent others)) |
---|
121 | (dolist (other others target) |
---|
122 | (multiple-value-bind (head tail) (detach-dll-nodes other) |
---|
123 | (when head |
---|
124 | (insert-dll-node-after head (dll-header-last target) tail))))) |
---|
125 | |
---|
126 | ;;; This definition doesn't work when the body unlinks "more than" the |
---|
127 | ;;; current node. |
---|
128 | (defmacro do-dll-nodes ((valvar header &optional result) &body body) |
---|
129 | (let* ((headervar (make-symbol "HEADER")) |
---|
130 | (next (make-symbol "NEXT"))) |
---|
131 | `(do* ((,headervar ,header) |
---|
132 | (,valvar (dll-header-first ,headervar) ,next) |
---|
133 | (,next (dll-node-succ ,valvar) (dll-node-succ ,valvar))) |
---|
134 | ((eq ,valvar ,headervar) |
---|
135 | ,result) |
---|
136 | ,@body))) |
---|
137 | |
---|
138 | (defun dll-header-length (header) |
---|
139 | (let* ((count 0)) |
---|
140 | (declare (fixnum count)) |
---|
141 | (do-dll-nodes (n header count) |
---|
142 | (incf count)))) |
---|
143 | |
---|
144 | (defun dll-node-position (node header) |
---|
145 | (let* ((pos 0)) |
---|
146 | (declare (fixnum pos)) |
---|
147 | (do-dll-nodes (n header) |
---|
148 | (if (eq n node) |
---|
149 | (return pos) |
---|
150 | (incf pos))))) |
---|
151 | |
---|
152 | ;;; dll-node freelisting ... |
---|
153 | |
---|
154 | (defun make-dll-node-freelist () |
---|
155 | (%cons-pool)) |
---|
156 | |
---|
157 | ;;; header shouldn't be used after this is called |
---|
158 | (defun return-dll-nodes (header freelist) |
---|
159 | (without-interrupts |
---|
160 | (let* ((pool-header (pool.data freelist))) |
---|
161 | (if (null pool-header) |
---|
162 | (setf (pool.data freelist) header) |
---|
163 | (multiple-value-bind (first last) (detach-dll-nodes header) |
---|
164 | (if first |
---|
165 | (insert-dll-node-after first (dll-header-last pool-header) last)))) |
---|
166 | nil))) |
---|
167 | |
---|
168 | ;;; Pop a node off off the freelist; return NIL if the freelist is |
---|
169 | ;;; empty. Set the succ and pred slots of the node to NIL; other |
---|
170 | ;;; slots are undefined. |
---|
171 | (defun alloc-dll-node (freelist) |
---|
172 | (without-interrupts |
---|
173 | (let* ((pool-header (pool.data freelist)) |
---|
174 | (node (if pool-header (dll-header-first pool-header)))) |
---|
175 | (if (and node (not (eq node pool-header))) |
---|
176 | (remove-dll-node node))))) |
---|
177 | |
---|
178 | (defun free-dll-node (node freelist) |
---|
179 | (without-interrupts |
---|
180 | (let* ((pool-header (pool.data freelist))) |
---|
181 | (if (null pool-header) |
---|
182 | (progn |
---|
183 | (setq pool-header (make-dll-header)) |
---|
184 | (setf (pool.data freelist) pool-header))) |
---|
185 | (append-dll-node node pool-header) |
---|
186 | nil))) |
---|
187 | |
---|
188 | (defun remove-and-free-dll-node (node freelist) |
---|
189 | (remove-dll-node node) |
---|
190 | (free-dll-node node freelist)) |
---|
191 | |
---|
192 | (defmacro with-dll-node-freelist ((header-var freelist) &body body) |
---|
193 | (let* ((internal-header-name (gensym)) |
---|
194 | (internal-freelist-name (gensym)) |
---|
195 | (constructor-name 'make-dll-header)) |
---|
196 | (if (consp header-var) |
---|
197 | (setq constructor-name (cadr header-var) |
---|
198 | header-var (car header-var))) |
---|
199 | `(let* ((,internal-header-name (,constructor-name)) |
---|
200 | (,internal-freelist-name ,freelist)) |
---|
201 | (unwind-protect |
---|
202 | (let* ((,header-var ,internal-header-name)) |
---|
203 | ,@body) |
---|
204 | (return-dll-nodes ,internal-header-name ,internal-freelist-name))))) |
---|
205 | |
---|
206 | (defstruct (locked-dll-header |
---|
207 | (:include dll-header) |
---|
208 | (:constructor %make-locked-dll-header)) |
---|
209 | (lock (make-lock))) |
---|
210 | |
---|
211 | (defun make-locked-dll-header () |
---|
212 | (init-dll-header (%make-locked-dll-header))) |
---|
213 | |
---|
214 | (defmacro with-locked-dll-header ((h) &body body) |
---|
215 | `(with-lock-grabbed ((locked-dll-header-lock ,h)) |
---|
216 | ,@body)) |
---|
217 | |
---|
218 | (defun locked-dll-header-enqueue (node header) |
---|
219 | (with-locked-dll-header (header) |
---|
220 | (append-dll-node node header))) |
---|
221 | |
---|
222 | (defun locked-dll-header-dequeue (header) |
---|
223 | (with-locked-dll-header (header) |
---|
224 | (let* ((first (dll-header-first header))) |
---|
225 | (unless (eq first header) |
---|
226 | (remove-dll-node first))))) |
---|
227 | |
---|
228 | (provide "DLL-NODE") |
---|