home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / mitsch75.zip / scheme-7_5_17-src.zip / scheme-7.5.17 / src / runtime / queue.scm < prev    next >
Text File  |  1999-01-02  |  3KB  |  90 lines
  1. #| -*-Scheme-*-
  2.  
  3. $Id: queue.scm,v 14.4 1999/01/02 06:11:34 cph Exp $
  4.  
  5. Copyright (c) 1988-1999 Massachusetts Institute of Technology
  6.  
  7. This program is free software; you can redistribute it and/or modify
  8. it under the terms of the GNU General Public License as published by
  9. the Free Software Foundation; either version 2 of the License, or (at
  10. your option) any later version.
  11.  
  12. This program is distributed in the hope that it will be useful, but
  13. WITHOUT ANY WARRANTY; without even the implied warranty of
  14. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  15. General Public License for more details.
  16.  
  17. You should have received a copy of the GNU General Public License
  18. along with this program; if not, write to the Free Software
  19. Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  20. |#
  21.  
  22. ;;;; Simple Queue Abstraction
  23. ;;; package: ()
  24.  
  25. (declare (usual-integrations))
  26.  
  27. (define-integrable (make-queue)
  28.   (cons '() '()))
  29.  
  30. (define-integrable (queue-empty? queue)
  31.   (null? (car queue)))
  32.  
  33. (define-integrable (queued?/unsafe queue item)
  34.   (memq item (car queue)))
  35.  
  36. (define (enqueue!/unsafe queue object)
  37.   (let ((next (cons object '())))
  38.     (if (null? (cdr queue))
  39.     (set-car! queue next)
  40.     (set-cdr! (cdr queue) next))
  41.     (set-cdr! queue next)
  42.     unspecific))
  43.  
  44. (define (dequeue!/unsafe queue)
  45.   (let ((next (car queue)))
  46.     (if (null? next)
  47.     (error "Attempt to dequeue from empty queue"))
  48.     (if (null? (cdr next))
  49.     (begin (set-car! queue '())
  50.            (set-cdr! queue '()))
  51.     (set-car! queue (cdr next)))
  52.     (car next)))
  53.  
  54. (define (queue-map!/unsafe queue procedure)
  55.   (let loop ()
  56.     (if (not (queue-empty? queue))
  57.     (begin (procedure (dequeue!/unsafe queue))
  58.            (loop)))))
  59.  
  60. (define-integrable (queue->list/unsafe queue)
  61.   (car queue))
  62.  
  63. ;;; Safe (interrupt locked) versions of the above operations.
  64.  
  65. (define-integrable (queued? queue item)
  66.   (without-interrupts (lambda () (queued?/unsafe queue item))))
  67.  
  68. (define-integrable (enqueue! queue object)
  69.   (without-interrupts (lambda () (enqueue!/unsafe queue object))))
  70.  
  71. (define-integrable (dequeue! queue)
  72.   (without-interrupts (lambda () (dequeue!/unsafe queue))))
  73.  
  74. (define (queue-map! queue procedure)
  75.   (let ((empty "empty"))
  76.     (let loop ()
  77.       (let ((item
  78.          (without-interrupts
  79.           (lambda ()
  80.         (if (queue-empty? queue)
  81.             empty
  82.             (dequeue!/unsafe queue))))))
  83.     (if (not (eq? item empty))
  84.         (begin (procedure item)
  85.            (loop)))))))
  86.  
  87. (define (queue->list queue)
  88.   (without-interrupts
  89.     (lambda ()
  90.       (list-copy (queue->list/unsafe queue)))))