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

Contents of /src/hemlock/ring.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.3 - (hide annotations)
Mon Oct 31 04:50:12 1994 UTC (19 years, 5 months ago) by ram
Branch: MAIN
CVS Tags: sparc-tramp-assem-base, double-double-array-base, post-merge-intl-branch, release-19b-pre1, release-19b-pre2, merged-unicode-utf16-extfmt-2009-06-11, double-double-init-sparc-2, unicode-utf16-extfmt-2009-03-27, double-double-base, snapshot-2007-09, snapshot-2007-08, snapshot-2008-08, snapshot-2008-09, ppc_gencgc_snap_2006-01-06, sse2-packed-2008-11-12, snapshot-2008-05, snapshot-2008-06, snapshot-2008-07, snapshot-2007-05, snapshot-2008-01, snapshot-2008-02, snapshot-2008-03, intl-branch-working-2010-02-19-1000, snapshot-2006-11, snapshot-2006-10, double-double-init-sparc, snapshot-2006-12, unicode-string-buffer-impl-base, sse2-base, release-20b-pre1, release-20b-pre2, unicode-string-buffer-base, RELEASE_18d, sse2-packed-base, sparc-tramp-assem-2010-07-19, amd64-dd-start, snapshot-2003-10, snapshot-2004-10, release-18e-base, release-19f-pre1, snapshot-2008-12, snapshot-2008-11, intl-2-branch-base, snapshot-2004-08, snapshot-2004-09, remove_negative_zero_not_zero, snapshot-2007-01, snapshot-2007-02, snapshot-2004-05, snapshot-2004-06, snapshot-2004-07, release-19e, release-19d, GIT-CONVERSION, double-double-init-ppc, release-19c, dynamic-extent-base, unicode-utf16-sync-2008-12, LINKAGE_TABLE, release-19c-base, cross-sol-x86-merged, label-2009-03-16, release-19f-base, PRE_LINKAGE_TABLE, merge-sse2-packed, mod-arith-base, sparc_gencgc_merge, merge-with-19f, snapshot-2004-12, snapshot-2004-11, intl-branch-working-2010-02-11-1000, RELEASE_18a, RELEASE_18b, RELEASE_18c, unicode-snapshot-2009-05, unicode-snapshot-2009-06, amd64-merge-start, ppc_gencgc_snap_2005-12-17, double-double-init-%make-sparc, unicode-utf16-sync-2008-07, release-18e-pre2, unicode-utf16-sync-2008-09, unicode-utf16-extfmts-sync-2008-12, prm-before-macosx-merge-tag, cold-pcl-base, RELEASE_20b, snapshot-2008-04, snapshot-2003-11, snapshot-2005-07, unicode-utf16-sync-label-2009-03-16, RELEASE_19f, snapshot-2007-03, release-20a-base, cross-sol-x86-base, unicode-utf16-char-support-2009-03-26, unicode-utf16-char-support-2009-03-25, release-19a-base, unicode-utf16-extfmts-pre-sync-2008-11, snapshot-2008-10, sparc_gencgc, snapshot-2007-04, snapshot-2010-12, snapshot-2010-11, unicode-utf16-sync-2008-11, snapshot-2007-07, snapshot-2011-09, snapshot-2011-06, snapshot-2011-07, snapshot-2011-04, snapshot-2007-06, snapshot-2011-02, snapshot-2011-03, snapshot-2011-01, snapshot-2003-12, release-19a-pre1, release-19a-pre3, release-19a-pre2, pre-merge-intl-branch, release-19a, UNICODE-BASE, double-double-array-checkpoint, double-double-reader-checkpoint-1, release-19d-base, release-19e-pre1, double-double-irrat-end, release-19e-pre2, snapshot-2010-05, snapshot-2010-04, snapshot-2010-07, snapshot-2010-06, snapshot-2010-01, snapshot-2010-03, snapshot-2010-02, release-19d-pre2, release-19d-pre1, snapshot-2010-08, release-18e, double-double-init-checkpoint-1, double-double-reader-base, label-2009-03-25, snapshot-2005-03, release-19b-base, cross-sol-x86-2010-12-20, double-double-init-x86, sse2-checkpoint-2008-10-01, intl-branch-2010-03-18-1300, snapshot-2005-11, double-double-sparc-checkpoint-1, snapshot-2004-04, sse2-merge-with-2008-11, sse2-merge-with-2008-10, snapshot-2005-10, RELEASE_20a, snapshot-2005-12, release-20a-pre1, snapshot-2005-01, snapshot-2009-11, snapshot-2009-12, unicode-utf16-extfmt-2009-06-11, portable-clx-import-2009-06-16, unicode-utf16-string-support, release-19c-pre1, cross-sparc-branch-base, release-19e-base, intl-branch-base, double-double-irrat-start, snapshot-2005-06, snapshot-2005-05, snapshot-2005-04, ppc_gencgc_snap_2005-05-14, snapshot-2005-02, unicode-utf16-base, portable-clx-base, snapshot-2005-09, snapshot-2005-08, lisp-executable-base, snapshot-2009-08, snapshot-2007-12, snapshot-2007-10, snapshot-2007-11, snapshot-2009-02, snapshot-2009-01, snapshot-2009-07, snapshot-2009-05, snapshot-2009-04, snapshot-2006-02, snapshot-2006-03, release-18e-pre1, snapshot-2006-01, snapshot-2006-06, snapshot-2006-07, snapshot-2006-04, snapshot-2006-05, pre-telent-clx, snapshot-2006-08, snapshot-2006-09, HEAD
Branch point for: release-19b-branch, double-double-reader-branch, double-double-array-branch, mod-arith-branch, RELEASE-19F-BRANCH, portable-clx-branch, sparc_gencgc_branch, cross-sparc-branch, RELEASE-20B-BRANCH, RELENG_18, unicode-string-buffer-branch, sparc-tramp-assem-branch, dynamic-extent, UNICODE-BRANCH, release-19d-branch, ppc_gencgc_branch, sse2-packed-branch, lisp-executable, RELEASE-20A-BRANCH, amd64-dd-branch, double-double-branch, unicode-string-buffer-impl-branch, intl-branch, release-18e-branch, cold-pcl, unicode-utf16-branch, cross-sol-x86-branch, release-19e-branch, sse2-branch, release-19a-branch, release-19c-branch, intl-2-branch, unicode-utf16-extfmt-branch
Changes since 1.2: +1 -3 lines
Fix headed boilerplate.
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     ;;;
7     (ext:file-comment
8 ram 1.3 "$Header: /tiger/var/lib/cvsroots/cmucl/src/hemlock/ring.lisp,v 1.3 1994/10/31 04:50:12 ram Rel $")
9 ram 1.2 ;;;
10 ram 1.1 ;;; **********************************************************************
11     ;;;
12     ;;; Written by Rob MacLachlan
13     ;;;
14     ;;; This file defines a ring-buffer type and access functions.
15     ;;;
16 ram 1.2 (in-package "HEMLOCK-INTERNALS")
17 ram 1.1 (export '(ring ringp make-ring ring-push ring-pop ring-length ring-ref
18     rotate-ring))
19    
20    
21     (defun %print-hring (obj stream depth)
22     (declare (ignore depth obj))
23     (write-string "#<Hemlock Ring>" stream))
24    
25     ;;;; The ring data structure:
26     ;;;
27     ;;; An empty ring is indicated by an negative First value.
28     ;;; The Bound is made (1- (- Size)) to make length work. Things are
29     ;;; pushed at high indices first.
30     ;;;
31     (defstruct (ring (:predicate ringp)
32     (:constructor internal-make-ring)
33     (:print-function %print-hring))
34     "Used with Ring-Push and friends to implement ring buffers."
35     (first -1 :type fixnum) ;The index of the first position used.
36 ram 1.2 (bound (required-argument) :type fixnum) ;The index after the last element.
37     delete-function ;The function to be called on deletion.
38     (vector (required-argument) :type simple-vector)) ;The vector.
39 ram 1.1
40     ;;; make-ring -- Public
41     ;;;
42     ;;; Make a new empty ring with some maximum size and type.
43     ;;;
44     (defun make-ring (size &optional (delete-function #'identity))
45     "Make a ring-buffer which can hold up to Size objects. Delete-Function
46     is a function which is called with each object that falls off the
47     end."
48     (unless (and (fixnump size) (> size 0))
49     (error "Ring size, ~S is not a positive fixnum." size))
50     (internal-make-ring :delete-function delete-function
51     :vector (make-array size)
52     :bound (1- (- size))))
53    
54     ;;; ring-push -- Public
55     ;;;
56     ;;; Decrement first modulo the maximum size, delete any old
57     ;;; element, and add the new one.
58     ;;;
59     (defun ring-push (object ring)
60     "Push an object into a ring, deleting an element if necessary."
61     (let ((first (ring-first ring))
62 ram 1.2 (vec (ring-vector ring))
63     (victim 0))
64 ram 1.1 (declare (simple-vector vec) (fixnum first victim))
65     (cond
66     ;; If zero, wrap around to end.
67     ((zerop first)
68     (setq victim (1- (length vec))))
69     ;; If empty then fix up pointers.
70     ((minusp first)
71     (setf (ring-bound ring) 0)
72     (setq victim (1- (length vec))))
73     (t
74     (setq victim (1- first))))
75     (when (= first (ring-bound ring))
76     (funcall (ring-delete-function ring) (aref vec victim))
77     (setf (ring-bound ring) victim))
78     (setf (ring-first ring) victim)
79     (setf (aref vec victim) object)))
80    
81    
82     ;;; ring-pop -- Public
83     ;;;
84     ;;; Increment first modulo the maximum size.
85     ;;;
86     (defun ring-pop (ring)
87     "Pop an object from a ring and return it."
88     (let* ((first (ring-first ring))
89     (vec (ring-vector ring))
90     (new (if (= first (1- (length vec))) 0 (1+ first)))
91     (bound (ring-bound ring)))
92     (declare (fixnum first new bound) (simple-vector vec))
93     (cond
94     ((minusp bound)
95     (error "Cannot pop from an empty ring."))
96     ((= new bound)
97     (setf (ring-first ring) -1 (ring-bound ring) (1- (- (length vec)))))
98     (t
99     (setf (ring-first ring) new)))
100     (shiftf (aref vec first) nil)))
101    
102    
103     ;;; ring-length -- Public
104     ;;;
105     ;;; Return the current and maximum size.
106     ;;;
107     (defun ring-length (ring)
108     "Return as values the current and maximum size of a ring."
109     (let ((diff (- (ring-bound ring) (ring-first ring)))
110     (max (length (ring-vector ring))))
111     (declare (fixnum diff max))
112     (values (if (plusp diff) diff (+ max diff)) max)))
113    
114     ;;; ring-ref -- Public
115     ;;;
116     ;;; Do modulo arithmetic to find the correct element.
117     ;;;
118     (defun ring-ref (ring index)
119     (declare (fixnum index))
120     "Return the index'th element of a ring. This can be set with Setf."
121     (let ((first (ring-first ring)))
122     (declare (fixnum first))
123     (cond
124     ((and (zerop index) (not (minusp first)))
125     (aref (ring-vector ring) first))
126     (t
127     (let* ((diff (- (ring-bound ring) first))
128     (sum (+ first index))
129     (vec (ring-vector ring))
130     (max (length vec)))
131     (declare (fixnum diff max sum) (simple-vector vec))
132     (when (or (>= index (if (plusp diff) diff (+ max diff)))
133     (minusp index))
134     (error "Ring index ~D out of bounds." index))
135     (aref vec (if (>= sum max) (- sum max) sum)))))))
136    
137    
138     ;;; %set-ring-ref -- Internal
139     ;;;
140     ;;; Setf form for ring-ref, set a ring element.
141     ;;;
142     (defun %set-ring-ref (ring index value)
143     (declare (fixnum index))
144     (let* ((first (ring-first ring))
145     (diff (- (ring-bound ring) first))
146     (sum (+ first index))
147     (vec (ring-vector ring))
148     (max (length vec)))
149     (declare (fixnum diff first max) (simple-vector vec))
150     (when (or (>= index (if (plusp diff) diff (+ max diff))) (minusp index))
151     (error "Ring index ~D out of bounds." index))
152     (setf (aref vec (if (>= sum max) (- sum max) sum)) value)))
153    
154     (eval-when (compile eval)
155     (defmacro 1+m (exp base)
156     `(if (= ,exp ,base) 0 (1+ ,exp)))
157     (defmacro 1-m (exp base)
158     `(if (zerop ,exp) ,base (1- ,exp)))
159     ) ;eval-when (compile eval)
160    
161     ;;; rotate-ring -- Public
162     ;;;
163     ;;; Rotate a ring, blt'ing elements as necessary.
164     ;;;
165     (defun rotate-ring (ring offset)
166     "Rotate a ring forward, i.e. second -> first, with positive offset,
167     or backwards with negative offset."
168     (declare (fixnum offset))
169     (let* ((first (ring-first ring))
170     (bound (ring-bound ring))
171     (vec (ring-vector ring))
172     (max (length vec)))
173     (declare (fixnum first bound max) (simple-vector vec))
174     (cond
175     ((= first bound)
176     (let ((new (rem (+ offset first) max)))
177     (declare (fixnum new))
178     (if (minusp new) (setq new (+ new max)))
179     (setf (ring-first ring) new)
180     (setf (ring-bound ring) new)))
181     ((not (minusp first))
182     (let* ((diff (- bound first))
183     (1-max (1- max))
184     (length (if (plusp diff) diff (+ max diff)))
185     (off (rem offset length)))
186     (declare (fixnum diff length off 1-max))
187     (cond
188     ((minusp offset)
189     (do ((dst (1-m first 1-max) (1-m dst 1-max))
190     (src (1-m bound 1-max) (1-m src 1-max))
191     (cnt off (1+ cnt)))
192     ((zerop cnt)
193     (setf (ring-first ring) (1+m dst 1-max))
194     (setf (ring-bound ring) (1+m src 1-max)))
195     (declare (fixnum dst src cnt))
196     (shiftf (aref vec dst) (aref vec src) nil)))
197     (t
198     (do ((dst bound (1+m dst 1-max))
199     (src first (1+m src 1-max))
200     (cnt off (1- cnt)))
201     ((zerop cnt)
202     (setf (ring-first ring) src)
203     (setf (ring-bound ring) dst))
204     (declare (fixnum dst src cnt))
205     (shiftf (aref vec dst) (aref vec src) nil))))))))
206     ring)

  ViewVC Help
Powered by ViewVC 1.1.5