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

Contents of /src/hemlock/ring.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5