Artifact 2ef2679e5608450bf29ae0c8dc46536e6987978b30ec412d83dfb30aeb61667d:

• File psl-1983/emode/ring-buffer.sl — part of check-in [eb17ceb7f6] at 2020-04-21 19:40:01 on branch master — Add Reduce 3.0 to the historical section of the archive, and some more
  files relating to version sof PSL from the early 1980s. Thanks are due to
  Paul McJones and Nelson Beebe for these, as well as to all the original
  authors.

  git-svn-id: https://svn.code.sf.net/p/reduce-algebra/code/historical@5328 2bfe0521-f11c-4a00-b80e-6202646ff360 (user: arthurcnorman@users.sourceforge.net, size: 1665) [annotate] [blame] [check-ins using] [more...]

%
% RING-BUFFER.SL - Ring Buffers
% 
% Author:      Alan Snyder
%              Hewlett-Packard/CRC
% Date:        6 July 1982
%
% This file implements general ring buffers.
% This file requires COMMON, NSTRUCT.

% Modifications by William Galway:
%   "defun" -> "de" so TAGS can find things.
%   "setq" -> "setf"

(defstruct (ring-buffer)
  ring-buffer-vector	% Elements 1..N are used.
  ring-buffer-top-ptr	% Elements 1..Top are valid.
  ring-buffer-pointer	% Element Vector[POINTER] is current.
  )

(de ring-buffer-create (number-of-elements)
  (let ((rb (make-ring-buffer)))
    (setf (ring-buffer-vector rb) (mkvect number-of-elements))
    (setf (ring-buffer-top-ptr rb) 0)
    (setf (ring-buffer-pointer rb) 0)
    rb
    ))

(de ring-buffer-push (rb new-element)
  (let ((new-pointer (+ (ring-buffer-pointer rb) 1))
	(v (ring-buffer-vector rb))
	)
    (if (> new-pointer (upbv v))
      (setf new-pointer 1))
    (if (> new-pointer (ring-buffer-top-ptr rb))
      (setf (ring-buffer-top-ptr rb) new-pointer))
    (setf (ring-buffer-pointer rb) new-pointer)
    (setf (getv (ring-buffer-vector rb) new-pointer) new-element)
    new-element
    ))

(de ring-buffer-top (rb)
  % Returns NIL if the buffer is empty.
  (let* ((ptr (ring-buffer-pointer rb))
	 (v (ring-buffer-vector rb))
	 )
    (cond ((= ptr 0) NIL)
	  (t (getv v ptr)))))

(de ring-buffer-pop (rb)
  % Returns NIL if the buffer is empty.
  (let* ((ptr (ring-buffer-pointer rb))
	 (new-ptr (- ptr 1))
	 (v (ring-buffer-vector rb))
	 )
    (cond ((= ptr 0) NIL)
	  (t (if (= new-ptr 0) (setf new-ptr (ring-buffer-top-ptr rb)))
	     (setf (ring-buffer-pointer rb) new-ptr)
	     (getv v ptr)))))