source: trunk/q.lisp @ 3

Revision 3, 2.8 KB checked in by gz, 9 years ago (diff)

Recovered version 0.961 from Sheldon Ball <s.ball@…>

  • Property svn:eol-style set to native
Line 
1;;;-*- Mode: Lisp; Package: CCL -*-
2
3;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
4;;
5;; q.lisp
6;; A simple fifo queue. Why isn't this part of Common Lisp
7;;
8;; Copyright © 1996 Digitool, Inc.
9;; Copyright © 1992-1995 Apple Computer, Inc.
10;; All rights reserved.
11;; Permission is given to use, copy, and modify this software provided
12;; that Digitool is given credit in all derivative works.
13;; This software is provided "as is". Digitool makes no warranty or
14;; representation, either express or implied, with respect to this software,
15;; its quality, accuracy, merchantability, or fitness for a particular
16;; purpose.
17
18;;;;;;;;;;;;;;;;;;;;;;;;;;
19;;
20;; Modification History
21;;
22;; -------------  0.96
23;; 08/27/96 bill  Added copyright and mod history comments
24;;
25
26(in-package :ccl)
27
28(export '(make-q enq deq q-empty-p))
29
30(require "LISPEQU")                     ; %cons-pool, pool.data
31
32(defstruct q
33  start-buf
34  start-index
35  end-buf
36  end-index)
37
38(defmethod print-object ((q q) stream)
39  (print-unreadable-object (q stream :type t :identity t)
40    ))
41
42(defconstant $q-buf-size 512)
43
44(defvar *q-bufs* (%cons-pool))
45
46(defun make-q-buf ()
47  (without-interrupts
48   (let ((buf (pool.data *q-bufs*)))
49     (if buf
50       (progn
51         (setf (pool.data *q-bufs*) (svref buf 0))
52         (dotimes (i $q-buf-size)
53           (setf (svref buf i) nil))
54         buf)
55       (make-array $q-buf-size)))))
56
57(defun free-q-buf (buf)
58  (without-interrupts
59   (setf (svref buf 0) (pool.data *q-bufs*)
60         (pool.data *q-bufs*) buf)
61   nil))
62
63(defun enq (q elt)
64  (setq q (require-type q 'q))
65  (let ((buf (q-end-buf q))
66        (index (q-end-index q)))
67    (if (null buf)
68      (setf buf (make-q-buf)
69            (q-start-buf q) buf
70            (q-start-index q) 1
71            (q-end-buf q) buf
72            (q-end-index q) (setq index 1))
73      (when (>= index $q-buf-size)
74        (setf (q-end-buf q)
75              (setf buf
76                    (setf (svref buf 0) (make-q-buf)))
77              (q-end-index q) (setq index 1))))
78    (setf (svref buf index) elt)
79    (setf (q-end-index q) (1+ index)))
80  elt)
81
82(defun q-empty-p (q)
83  (setq q (require-type q 'q))
84  (let ((start-buf (q-start-buf q)))
85    (or (null start-buf)
86        (and (eq start-buf (q-end-buf q))
87             (eql (q-start-index q)
88                  (q-end-index q))))))
89
90(defun deq (q &optional (error-if-empty t))
91  (when (q-empty-p q)
92    (if error-if-empty
93      (error "Empty q: ~s" q)
94      (return-from deq nil)))
95  (let ((buf (q-start-buf q))
96        (index (q-start-index q)))
97    (prog1
98      (svref buf index)
99      (when (eql (incf index) $q-buf-size)
100        (setq index 1)
101        (unless (setf (q-start-buf q) (svref buf 0))
102          (setf (q-end-buf q) nil))
103        (free-q-buf buf))
104      (setf (q-start-index q) index))))
105
106(provide "Q")
107;;;    1   3/10/94  bill         1.8d247
Note: See TracBrowser for help on using the repository browser.