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

Contents of /src/hemlock/ring.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.1 - (hide annotations)
Wed May 9 13:05:39 1990 UTC (23 years, 11 months ago) by ram
Branch: MAIN
Initial revision
1 ram 1.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