/usr/share/scheme48-1.9/cml/jar.scm is in scheme48 1.9-5.
This file is owned by root:root, with mode 0o644.
The actual contents of the file can be viewed below.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 | ; Part of Scheme 48 1.9. See file COPYING for notices and license.
; Authors: Mike Sperber
; Jars (multiple-assignment cells for use with threads)
; these are equivalent to ID-90 M-structures
(define-synchronized-record-type jar :jar
(really-make-jar priority queue value id)
(priority value)
jar?
(priority jar-priority set-jar-priority!)
(queue jar-queue)
(value jar-value set-jar-value!)
(id jar-id))
(define the-empty-jar-value (list 'empty-jar))
(define (empty-jar-value? thing)
(eq? thing the-empty-jar-value))
(define-record-discloser :jar
(lambda (jar)
(cons 'jar
(if (jar-id jar)
(list (jar-id jar))
'()))))
(define-record-type q-item :q-item
(make-q-item trans-id cleanup-proc wrap-proc)
q-item?
(trans-id q-item-trans-id)
(cleanup-proc q-item-cleanup-proc)
(wrap-proc q-item-wrap-proc))
(define (clean-and-enqueue! queue value)
(clean-queue-head! queue)
(enqueue! queue value))
(define (clean-and-dequeue! queue)
(let loop ()
(if (queue-empty? queue)
#f
(let ((front (dequeue! queue)))
(if (trans-id-cancelled? (q-item-trans-id front))
(loop)
front)))))
(define (clean-queue-head! queue)
(let loop ()
(if (not (queue-empty? queue))
(let ((front (queue-head queue)))
(if (trans-id-cancelled? (q-item-trans-id front))
(begin
(dequeue! queue)
(loop)))))))
(define (make-jar . id-option)
(really-make-jar 0
(make-queue)
the-empty-jar-value
(if (null? id-option)
#f
(car id-option))))
(define (jar-take-rv jar)
(make-base
(lambda ()
(cond
((empty-jar-value? (jar-value jar))
(make-blocked
(lambda (trans-id cleanup-proc wrap-proc)
(clean-and-enqueue! (jar-queue jar)
(make-q-item trans-id
cleanup-proc
wrap-proc)))))
(else
(let ((priority (jar-priority jar)))
(set-jar-priority! jar (+ 1 priority))
(make-enabled
priority
(lambda (queue)
(let ((value (jar-value jar)))
(set-jar-value! jar the-empty-jar-value)
value)))))))))
(define (jar-put! jar value)
(if (not
(with-new-proposal (lose)
(cond
((not (empty-jar-value? (jar-value jar)))
#f)
((clean-and-dequeue! (jar-queue jar))
=> (lambda (q-item)
(let ((thread-queue (make-queue)))
((q-item-cleanup-proc q-item) thread-queue)
(let ((trans-id (q-item-trans-id q-item)))
(trans-id-set-value! trans-id
(cons value
(q-item-wrap-proc q-item)))
(enqueue! thread-queue (trans-id-thread-cell trans-id))
(or (maybe-commit-and-make-ready thread-queue)
(lose))))))
(else
(set-jar-value! jar value)
(or (maybe-commit)
(lose))))))
(assertion-violation 'jar-put! "jar is already full" jar value)))
(define (jar-take jar)
(sync (jar-take-rv jar)))
|