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

Contents of /src/hemlock/ring.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.1.1.1 - (hide annotations) (vendor branch)
Sun Jun 17 12:21:00 1990 UTC (23 years, 10 months ago) by ram
Changes since 1.1: +2 -1 lines
Supply some legal initial variable values.
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 ram 1.1.1.1 (vec (ring-vector ring))
62     (victim 0))
63 ram 1.1 (declare (simple-vector vec) (fixnum first victim))
64     (cond
65     ;; If zero, wrap around to end.
66     ((zerop first)
67     (setq victim (1- (length vec))))
68     ;; If empty then fix up pointers.
69     ((minusp first)
70     (setf (ring-bound ring) 0)
71     (setq victim (1- (length vec))))
72     (t
73     (setq victim (1- first))))
74     (when (= first (ring-bound ring))
75     (funcall (ring-delete-function ring) (aref vec victim))
76     (setf (ring-bound ring) victim))
77     (setf (ring-first ring) victim)
78     (setf (aref vec victim) object)))
79    
80    
81     ;;; ring-pop -- Public
82     ;;;
83     ;;; Increment first modulo the maximum size.
84     ;;;
85     (defun ring-pop (ring)
86     "Pop an object from a ring and return it."
87     (let* ((first (ring-first ring))
88     (vec (ring-vector ring))
89     (new (if (= first (1- (length vec))) 0 (1+ first)))
90     (bound (ring-bound ring)))
91     (declare (fixnum first new bound) (simple-vector vec))
92     (cond
93     ((minusp bound)
94     (error "Cannot pop from an empty ring."))
95     ((= new bound)
96     (setf (ring-first ring) -1 (ring-bound ring) (1- (- (length vec)))))
97     (t
98     (setf (ring-first ring) new)))
99     (shiftf (aref vec first) nil)))
100    
101    
102     ;;; ring-length -- Public
103     ;;;
104     ;;; Return the current and maximum size.
105     ;;;
106     (defun ring-length (ring)
107     "Return as values the current and maximum size of a ring."
108     (let ((diff (- (ring-bound ring) (ring-first ring)))
109     (max (length (ring-vector ring))))
110     (declare (fixnum diff max))
111     (values (if (plusp diff) diff (+ max diff)) max)))
112    
113     ;;; ring-ref -- Public
114     ;;;
115     ;;; Do modulo arithmetic to find the correct element.
116     ;;;
117     (defun ring-ref (ring index)
118     (declare (fixnum index))
119     "Return the index'th element of a ring. This can be set with Setf."
120     (let ((first (ring-first ring)))
121     (declare (fixnum first))
122     (cond
123     ((and (zerop index) (not (minusp first)))
124     (aref (ring-vector ring) first))
125     (t
126     (let* ((diff (- (ring-bound ring) first))
127     (sum (+ first index))
128     (vec (ring-vector ring))
129     (max (length vec)))
130     (declare (fixnum diff max sum) (simple-vector vec))
131     (when (or (>= index (if (plusp diff) diff (+ max diff)))
132     (minusp index))
133     (error "Ring index ~D out of bounds." index))
134     (aref vec (if (>= sum max) (- sum max) sum)))))))
135    
136    
137     ;;; %set-ring-ref -- Internal
138     ;;;
139     ;;; Setf form for ring-ref, set a ring element.
140     ;;;
141     (defun %set-ring-ref (ring index value)
142     (declare (fixnum index))
143     (let* ((first (ring-first ring))
144     (diff (- (ring-bound ring) first))
145     (sum (+ first index))
146     (vec (ring-vector ring))
147     (max (length vec)))
148     (declare (fixnum diff first max) (simple-vector vec))
149     (when (or (>= index (if (plusp diff) diff (+ max diff))) (minusp index))
150     (error "Ring index ~D out of bounds." index))
151     (setf (aref vec (if (>= sum max) (- sum max) sum)) value)))
152    
153     (eval-when (compile eval)
154     (defmacro 1+m (exp base)
155     `(if (= ,exp ,base) 0 (1+ ,exp)))
156     (defmacro 1-m (exp base)
157     `(if (zerop ,exp) ,base (1- ,exp)))
158     ) ;eval-when (compile eval)
159    
160     ;;; rotate-ring -- Public
161     ;;;
162     ;;; Rotate a ring, blt'ing elements as necessary.
163     ;;;
164     (defun rotate-ring (ring offset)
165     "Rotate a ring forward, i.e. second -> first, with positive offset,
166     or backwards with negative offset."
167     (declare (fixnum offset))
168     (let* ((first (ring-first ring))
169     (bound (ring-bound ring))
170     (vec (ring-vector ring))
171     (max (length vec)))
172     (declare (fixnum first bound max) (simple-vector vec))
173     (cond
174     ((= first bound)
175     (let ((new (rem (+ offset first) max)))
176     (declare (fixnum new))
177     (if (minusp new) (setq new (+ new max)))
178     (setf (ring-first ring) new)
179     (setf (ring-bound ring) new)))
180     ((not (minusp first))
181     (let* ((diff (- bound first))
182     (1-max (1- max))
183     (length (if (plusp diff) diff (+ max diff)))
184     (off (rem offset length)))
185     (declare (fixnum diff length off 1-max))
186     (cond
187     ((minusp offset)
188     (do ((dst (1-m first 1-max) (1-m dst 1-max))
189     (src (1-m bound 1-max) (1-m src 1-max))
190     (cnt off (1+ cnt)))
191     ((zerop cnt)
192     (setf (ring-first ring) (1+m dst 1-max))
193     (setf (ring-bound ring) (1+m src 1-max)))
194     (declare (fixnum dst src cnt))
195     (shiftf (aref vec dst) (aref vec src) nil)))
196     (t
197     (do ((dst bound (1+m dst 1-max))
198     (src first (1+m src 1-max))
199     (cnt off (1- cnt)))
200     ((zerop cnt)
201     (setf (ring-first ring) src)
202     (setf (ring-bound ring) dst))
203     (declare (fixnum dst src cnt))
204     (shiftf (aref vec dst) (aref vec src) nil))))))))
205     ring)

  ViewVC Help
Powered by ViewVC 1.1.5