queue.scm 4.0 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156
  1. ; Copyright (c) 1993-2008 by Richard Kelsey and Jonathan Rees. See file COPYING.
  2. ; Queues
  3. ; Richard's code with Jonathan's names.
  4. ;
  5. ; Richard's names: Jonathan's names (modified by popular demand):
  6. ; make-empty-queue make-queue
  7. ; add-to-queue! enqueue!
  8. ; remove-from-queue! dequeue!
  9. ;
  10. ; Now using optimistic concurrency. We really need two sets of procedures to
  11. ; allow those who don't care to avoid the cost of the concurrency checks.
  12. (define-synchronized-record-type queue :queue
  13. (really-make-queue uid head tail)
  14. (head tail) ; synchronize on these
  15. queue?
  16. (uid queue-uid)
  17. (head real-queue-head set-queue-head!)
  18. (tail queue-tail set-queue-tail!))
  19. (define queue-uid (list 0))
  20. (define (next-uid)
  21. (atomically
  22. (let ((uid (provisional-car queue-uid)))
  23. (provisional-set-car! queue-uid (+ uid 1))
  24. uid)))
  25. (define (make-queue)
  26. (really-make-queue (next-uid) '() '()))
  27. ; The procedures for manipulating queues.
  28. (define (queue-empty? q)
  29. (null? (real-queue-head q)))
  30. (define (enqueue! q v)
  31. (ensure-atomicity!
  32. (let ((p (cons v '())))
  33. (cond ((null? (real-queue-head q))
  34. (set-queue-head! q p))
  35. ((null? (queue-tail q)) ; someone got in first
  36. (invalidate-current-proposal!))
  37. (else
  38. (provisional-set-cdr! (queue-tail q) p)))
  39. (set-queue-tail! q p))))
  40. (define (queue-head q)
  41. (ensure-atomicity
  42. (if (queue-empty? q)
  43. (error "queue is empty" q)
  44. (car (real-queue-head q)))))
  45. (define (dequeue! q)
  46. (ensure-atomicity
  47. (let ((pair (real-queue-head q)))
  48. (cond ((null? pair) ;(queue-empty? q)
  49. (error "empty queue" q))
  50. (else
  51. (queue-tail q) ; touch
  52. (let ((value (car pair))
  53. (next (cdr pair)))
  54. (set-queue-head! q next)
  55. (if (null? next)
  56. (set-queue-tail! q '())) ; don't retain pointers
  57. value))))))
  58. ; Same again, except that we return #F if the queue is empty.
  59. ; This is a simple way of avoiding a race condition if the queue is known
  60. ; not to contain #F.
  61. (define (maybe-dequeue! q)
  62. (ensure-atomicity
  63. (let ((pair (real-queue-head q)))
  64. (cond ((null? pair) ;(queue-empty? q)
  65. #f)
  66. (else
  67. (queue-tail q) ; touch
  68. (let ((value (car pair))
  69. (next (cdr pair)))
  70. (set-queue-head! q next)
  71. (if (null? next)
  72. (set-queue-tail! q '())) ; don't retain pointers
  73. value))))))
  74. (define (empty-queue! q)
  75. (ensure-atomicity
  76. (set-queue-head! q '())
  77. (set-queue-tail! q '())))
  78. (define (on-queue? q v)
  79. (ensure-atomicity
  80. (memq v (real-queue-head q))))
  81. ; This removes the first occurrence of V from Q.
  82. (define (delete-from-queue! q v)
  83. (delete-from-queue-if! q
  84. (lambda (x)
  85. (eq? x v))))
  86. (define (delete-from-queue-if! q pred)
  87. (ensure-atomicity
  88. (let ((head (real-queue-head q)))
  89. (cond ((null? head)
  90. #f)
  91. ((pred (car head))
  92. (set-queue-head! q (cdr head))
  93. ;; force proposal check
  94. (set-queue-tail! q (if (null? (cdr head))
  95. '()
  96. (let ((p (queue-tail q)))
  97. (cons (car p) (cdr p)))))
  98. #t)
  99. ((null? (cdr head))
  100. #f)
  101. (else
  102. (let loop ((list head))
  103. (let ((tail (cdr list)))
  104. (cond ((null? tail)
  105. #f)
  106. ((pred (car tail))
  107. (provisional-set-cdr! list (cdr tail))
  108. ;; force proposal check
  109. (set-queue-head! q (cons (car head) (cdr head)))
  110. (set-queue-tail! q (if (null? (cdr tail))
  111. list
  112. (let ((p (queue-tail q)))
  113. (cons (car p) (cdr p)))))
  114. #t)
  115. (else
  116. (loop tail))))))))))
  117. (define (queue->list q)
  118. (ensure-atomicity
  119. (map (lambda (x) x)
  120. (real-queue-head q))))
  121. (define (list->queue list)
  122. (if (null? list)
  123. (make-queue)
  124. (let ((head (cons (car list) '())))
  125. (let loop ((rest (cdr list)) (tail head))
  126. (if (null? rest)
  127. (really-make-queue (next-uid) head tail)
  128. (begin
  129. (let ((next (cons (car rest) '())))
  130. (set-cdr! tail next)
  131. (loop (cdr rest) next))))))))
  132. (define (queue-length q)
  133. (ensure-atomicity
  134. (length (real-queue-head q))))