source: trunk/ccl/compiler/dll-node.lisp @ 723

Last change on this file since 723 was 723, checked in by gb, 16 years ago

PROVIDE's been in the CL package for the last decade or so.
(This (small) change was made from a Hemlock/Cocoa? editor !)

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 7.5 KB
Line 
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(provide "DLL-NODE")
Note: See TracBrowser for help on using the repository browser.