/[cmucl]/src/hemlock/ring.lisp
ViewVC logotype

Contents of /src/hemlock/ring.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.1 - (show annotations)
Wed May 9 13:05:39 1990 UTC (23 years, 11 months ago) by ram
Branch: MAIN
Initial revision
1 ;;; -*- Log: Hemlock.Log; Package: Hemlock-Internals -*-
2 ;;;
3 ;;; **********************************************************************
4 ;;; This code was written as part of the Spice Lisp project at
5 ;;; Carnegie-Mellon University, and has been placed in the public domain.
6 ;;; Spice Lisp is currently incomplete and under active development.
7 ;;; If you want to use this code or any part of Spice Lisp, please contact
8 ;;; Scott Fahlman (FAHLMAN@CMUC).
9 ;;; **********************************************************************
10 ;;;
11 ;;; Written by Rob MacLachlan
12 ;;;
13 ;;; This file defines a ring-buffer type and access functions.
14 ;;;
15 (in-package 'hemlock-internals)
16 (export '(ring ringp make-ring ring-push ring-pop ring-length ring-ref
17 rotate-ring))
18
19
20 (defun %print-hring (obj stream depth)
21 (declare (ignore depth obj))
22 (write-string "#<Hemlock Ring>" stream))
23
24 ;;;; The ring data structure:
25 ;;;
26 ;;; An empty ring is indicated by an negative First value.
27 ;;; The Bound is made (1- (- Size)) to make length work. Things are
28 ;;; pushed at high indices first.
29 ;;;
30 (defstruct (ring (:predicate ringp)
31 (:constructor internal-make-ring)
32 (:print-function %print-hring))
33 "Used with Ring-Push and friends to implement ring buffers."
34 (first -1 :type fixnum) ;The index of the first position used.
35 (bound () :type fixnum) ;The index after the last element.
36 delete-function ;The function to be called on deletion.
37 (vector () :type simple-vector)) ;The vector.
38
39 ;;; make-ring -- Public
40 ;;;
41 ;;; Make a new empty ring with some maximum size and type.
42 ;;;
43 (defun make-ring (size &optional (delete-function #'identity))
44 "Make a ring-buffer which can hold up to Size objects. Delete-Function
45 is a function which is called with each object that falls off the
46 end."
47 (unless (and (fixnump size) (> size 0))
48 (error "Ring size, ~S is not a positive fixnum." size))
49 (internal-make-ring :delete-function delete-function
50 :vector (make-array size)
51 :bound (1- (- size))))
52
53 ;;; ring-push -- Public
54 ;;;
55 ;;; Decrement first modulo the maximum size, delete any old
56 ;;; element, and add the new one.
57 ;;;
58 (defun ring-push (object ring)
59 "Push an object into a ring, deleting an element if necessary."
60 (let ((first (ring-first ring))
61 (vec (ring-vector ring)) victim)
62 (declare (simple-vector vec) (fixnum first victim))
63 (cond
64 ;; If zero, wrap around to end.
65 ((zerop first)
66 (setq victim (1- (length vec))))
67 ;; If empty then fix up pointers.
68 ((minusp first)
69 (setf (ring-bound ring) 0)
70 (setq victim (1- (length vec))))
71 (t
72 (setq victim (1- first))))
73 (when (= first (ring-bound ring))
74 (funcall (ring-delete-function ring) (aref vec victim))
75 (setf (ring-bound ring) victim))
76 (setf (ring-first ring) victim)
77 (setf (aref vec victim) object)))
78
79
80 ;;; ring-pop -- Public
81 ;;;
82 ;;; Increment first modulo the maximum size.
83 ;;;
84 (defun ring-pop (ring)
85 "Pop an object from a ring and return it."
86 (let* ((first (ring-first ring))
87 (vec (ring-vector ring))
88 (new (if (= first (1- (length vec))) 0 (1+ first)))
89 (bound (ring-bound ring)))
90 (declare (fixnum first new bound) (simple-vector vec))
91 (cond
92 ((minusp bound)
93 (error "Cannot pop from an empty ring."))
94 ((= new bound)
95 (setf (ring-first ring) -1 (ring-bound ring) (1- (- (length vec)))))
96 (t
97 (setf (ring-first ring) new)))
98 (shiftf (aref vec first) nil)))
99
100
101 ;;; ring-length -- Public
102 ;;;
103 ;;; Return the current and maximum size.
104 ;;;
105 (defun ring-length (ring)
106 "Return as values the current and maximum size of a ring."
107 (let ((diff (- (ring-bound ring) (ring-first ring)))
108 (max (length (ring-vector ring))))
109 (declare (fixnum diff max))
110 (values (if (plusp diff) diff (+ max diff)) max)))
111
112 ;;; ring-ref -- Public
113 ;;;
114 ;;; Do modulo arithmetic to find the correct element.
115 ;;;
116 (defun ring-ref (ring index)
117 (declare (fixnum index))
118 "Return the index'th element of a ring. This can be set with Setf."
119 (let ((first (ring-first ring)))
120 (declare (fixnum first))
121 (cond
122 ((and (zerop index) (not (minusp first)))
123 (aref (ring-vector ring) first))
124 (t
125 (let* ((diff (- (ring-bound ring) first))
126 (sum (+ first index))
127 (vec (ring-vector ring))
128 (max (length vec)))
129 (declare (fixnum diff max sum) (simple-vector vec))
130 (when (or (>= index (if (plusp diff) diff (+ max diff)))
131 (minusp index))
132 (error "Ring index ~D out of bounds." index))
133 (aref vec (if (>= sum max) (- sum max) sum)))))))
134
135
136 ;;; %set-ring-ref -- Internal
137 ;;;
138 ;;; Setf form for ring-ref, set a ring element.
139 ;;;
140 (defun %set-ring-ref (ring index value)
141 (declare (fixnum index))
142 (let* ((first (ring-first ring))
143 (diff (- (ring-bound ring) first))
144 (sum (+ first index))
145 (vec (ring-vector ring))
146 (max (length vec)))
147 (declare (fixnum diff first max) (simple-vector vec))
148 (when (or (>= index (if (plusp diff) diff (+ max diff))) (minusp index))
149 (error "Ring index ~D out of bounds." index))
150 (setf (aref vec (if (>= sum max) (- sum max) sum)) value)))
151
152 (eval-when (compile eval)
153 (defmacro 1+m (exp base)
154 `(if (= ,exp ,base) 0 (1+ ,exp)))
155 (defmacro 1-m (exp base)
156 `(if (zerop ,exp) ,base (1- ,exp)))
157 ) ;eval-when (compile eval)
158
159 ;;; rotate-ring -- Public
160 ;;;
161 ;;; Rotate a ring, blt'ing elements as necessary.
162 ;;;
163 (defun rotate-ring (ring offset)
164 "Rotate a ring forward, i.e. second -> first, with positive offset,
165 or backwards with negative offset."
166 (declare (fixnum offset))
167 (let* ((first (ring-first ring))
168 (bound (ring-bound ring))
169 (vec (ring-vector ring))
170 (max (length vec)))
171 (declare (fixnum first bound max) (simple-vector vec))
172 (cond
173 ((= first bound)
174 (let ((new (rem (+ offset first) max)))
175 (declare (fixnum new))
176 (if (minusp new) (setq new (+ new max)))
177 (setf (ring-first ring) new)
178 (setf (ring-bound ring) new)))
179 ((not (minusp first))
180 (let* ((diff (- bound first))
181 (1-max (1- max))
182 (length (if (plusp diff) diff (+ max diff)))
183 (off (rem offset length)))
184 (declare (fixnum diff length off 1-max))
185 (cond
186 ((minusp offset)
187 (do ((dst (1-m first 1-max) (1-m dst 1-max))
188 (src (1-m bound 1-max) (1-m src 1-max))
189 (cnt off (1+ cnt)))
190 ((zerop cnt)
191 (setf (ring-first ring) (1+m dst 1-max))
192 (setf (ring-bound ring) (1+m src 1-max)))
193 (declare (fixnum dst src cnt))
194 (shiftf (aref vec dst) (aref vec src) nil)))
195 (t
196 (do ((dst bound (1+m dst 1-max))
197 (src first (1+m src 1-max))
198 (cnt off (1- cnt)))
199 ((zerop cnt)
200 (setf (ring-first ring) src)
201 (setf (ring-bound ring) dst))
202 (declare (fixnum dst src cnt))
203 (shiftf (aref vec dst) (aref vec src) nil))))))))
204 ring)

  ViewVC Help
Powered by ViewVC 1.1.5