source: tags/pre_1_0_pre_hash_modifications/ccl/hemlock/src/ring.lisp @ 2475

Last change on this file since 2475 was 2475, checked in by anonymous, 14 years ago

This commit was manufactured by cvs2svn to create tag
'pre_1_0_pre_hash_modifications'.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 7.4 KB
Line 
1;;; -*- Log: Hemlock.Log; Package: Hemlock-Internals -*-
2;;;
3;;; **********************************************************************
4;;; 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;;;
7#+CMU (ext:file-comment
8  "$Header$")
9;;;
10;;; **********************************************************************
11;;;
12;;;    Written by Rob MacLachlan
13;;;
14;;;  This file defines a ring-buffer type and access functions.
15;;;
16(in-package :hemlock-internals)
17
18(defun %print-hring (obj stream depth)
19  (declare (ignore depth obj))
20  (write-string "#<Hemlock Ring>" stream))
21
22;;;; The ring data structure:
23;;;
24;;;    An empty ring is indicated by an negative First value.
25;;; The Bound is made (1- (- Size)) to make length work.  Things are
26;;; pushed at high indices first.
27;;;
28(defstruct (ring (:predicate ringp)
29                 (:constructor internal-make-ring)
30                 (:print-function %print-hring))
31  "Used with Ring-Push and friends to implement ring buffers."
32  (first -1 :type fixnum)          ;The index of the first position used.
33  (bound (required-argument) :type fixnum)   ;The index after the last element.
34  delete-function ;The function  to be called on deletion.
35  (vector (required-argument) :type simple-vector) ;The vector.
36  (lock (ccl:make-lock)))
37                         
38(defmacro with-ring-locked ((ring) &body body)
39  `(ccl:with-lock-grabbed ((ring-lock ,ring))
40    ,@body))
41
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 (hemlock-ext: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  (with-ring-locked (ring)
64    (let ((first (ring-first ring))
65          (vec (ring-vector ring))
66          (victim 0))
67      (declare (simple-vector vec) (fixnum first victim))
68      (cond
69        ;; If zero, wrap around to end.
70        ((zerop first)
71         (setq victim (1- (length vec))))
72        ;; If empty then fix up pointers.
73        ((minusp first)
74         (setf (ring-bound ring) 0)
75         (setq victim (1- (length vec))))
76        (t
77         (setq victim (1- first))))
78      (when (= first (ring-bound ring))
79        (funcall (ring-delete-function ring) (aref vec victim))
80        (setf (ring-bound ring) victim))
81      (setf (ring-first ring) victim)
82      (setf (aref vec victim) object))))
83
84
85;;; ring-pop  --  Public
86;;;
87;;;    Increment first modulo the maximum size.
88;;;
89(defun ring-pop (ring)
90  "Pop an object from a ring and return it."
91  (with-ring-locked (ring)
92    (let* ((first (ring-first ring))
93           (vec (ring-vector ring))
94           (new (if (= first (1- (length vec))) 0 (1+ first)))
95           (bound (ring-bound ring)))
96      (declare (fixnum first new bound) (simple-vector vec))
97      (cond
98        ((minusp bound)
99         (error "Cannot pop from an empty ring."))
100        ((= new bound)
101         (setf (ring-first ring) -1  (ring-bound ring) (1- (- (length vec)))))
102        (t
103         (setf (ring-first ring) new)))
104      (shiftf (aref vec first) nil))))
105
106
107;;; ring-length  --  Public
108;;;
109;;;    Return the current and maximum size.
110;;;
111(defun ring-length (ring)
112  "Return as values the current and maximum size of a ring."
113  (with-ring-locked (ring)
114    (let ((diff (- (ring-bound ring) (ring-first ring)))
115          (max (length (ring-vector ring))))
116      (declare (fixnum diff max))
117      (values (if (plusp diff) diff (+ max diff)) max))))
118
119;;; ring-ref  --  Public
120;;;
121;;;    Do modulo arithmetic to find the correct element.
122;;;
123(defun ring-ref (ring index)
124  (declare (fixnum index))
125  "Return the index'th element of a ring.  This can be set with Setf."
126  (with-ring-locked (ring)
127    (let ((first (ring-first ring)))
128      (declare (fixnum first))
129      (cond
130        ((and (zerop index) (not (minusp first)))
131         (aref (ring-vector ring) first))
132        (t
133         (let* ((diff (- (ring-bound ring) first))
134                (sum (+ first index))
135                (vec (ring-vector ring))
136                (max (length vec)))
137           (declare (fixnum diff max sum) (simple-vector vec))
138           (when (or (>= index (if (plusp diff) diff (+ max diff)))
139                     (minusp index))
140             (error "Ring index ~D out of bounds." index))
141           (aref vec (if (>= sum max) (- sum max) sum))))))))
142
143
144;;; %set-ring-ref  --  Internal
145;;;
146;;;    Setf form for ring-ref, set a ring element.
147;;;
148(defun %set-ring-ref (ring index value)
149  (declare (fixnum index))
150  (with-ring-locked (ring)
151    (let* ((first (ring-first ring))
152           (diff (- (ring-bound ring) first))
153           (sum (+ first index))
154           (vec (ring-vector ring))
155           (max (length vec)))
156      (declare (fixnum diff first max) (simple-vector vec))
157      (when (or (>= index (if (plusp diff) diff (+ max diff))) (minusp index))
158        (error "Ring index ~D out of bounds." index))
159      (setf (aref vec (if (>= sum max) (- sum max) sum)) value))))
160
161(eval-when (:compile-toplevel :execute)
162(defmacro 1+m (exp base)
163  `(if (= ,exp ,base) 0 (1+ ,exp)))
164(defmacro 1-m (exp base)
165  `(if (zerop ,exp) ,base (1- ,exp)))
166) ;eval-when (:compile-toplevel :execute)
167
168;;; rotate-ring  --  Public
169;;;
170;;;    Rotate a ring, blt'ing elements as necessary.
171;;;
172(defun rotate-ring (ring offset)
173  "Rotate a ring forward, i.e. second -> first, with positive offset,
174  or backwards with negative offset."
175  (declare (fixnum offset))
176  (with-ring-locked (ring)
177    (let* ((first (ring-first ring))
178           (bound (ring-bound ring))
179           (vec (ring-vector ring))
180           (max (length vec)))
181      (declare (fixnum first bound max) (simple-vector vec))
182      (cond
183        ((= first bound)
184         (let ((new (rem (+ offset first) max)))
185           (declare (fixnum new))
186           (if (minusp new) (setq new (+ new max)))
187           (setf (ring-first ring) new)
188           (setf (ring-bound ring) new)))
189        ((not (minusp first))
190         (let* ((diff (- bound first))
191                (1-max (1- max))
192                (length (if (plusp diff) diff (+ max diff)))
193                (off (rem offset length)))
194           (declare (fixnum diff length off 1-max))
195           (cond
196             ((minusp offset)
197              (do ((dst (1-m first 1-max) (1-m dst 1-max))
198                   (src (1-m bound 1-max) (1-m src 1-max))
199                   (cnt off (1+ cnt)))
200                  ((zerop cnt)
201                   (setf (ring-first ring) (1+m dst 1-max))
202                   (setf (ring-bound ring) (1+m src 1-max)))
203                (declare (fixnum dst src cnt))
204                (shiftf (aref vec dst) (aref vec src) nil)))
205             (t
206              (do ((dst bound (1+m dst 1-max))
207                   (src first (1+m src 1-max))
208                   (cnt off (1- cnt)))
209                  ((zerop cnt)
210                   (setf (ring-first ring) src)
211                   (setf (ring-bound ring) dst))
212                (declare (fixnum dst src cnt))
213                (shiftf (aref vec dst) (aref vec src) nil)))))))))
214  ring)
Note: See TracBrowser for help on using the repository browser.