reduce-historical/psl-1983/emode/ring-buffer.sl

%
% 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)))))