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