/usr/share/scheme48-1.9/big/lock.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 | ; Part of Scheme 48 1.9. See file COPYING for notices and license.
; Authors: Richard Kelsey, Jonathan Rees, Mike Sperber
; Locks (= semaphores)
; Each lock has:
; The owning thread, or #f if not locked. We use the owning thread instead
; of #t as an aid to debugging.
; A queue of waiting threads
(define-synchronized-record-type lock :lock
(really-make-lock owner queue uid)
(owner)
lock?
(owner lock-owner set-lock-owner!)
(queue lock-queue)
(uid lock-uid)) ; for debugging
(define lock-uid (list 0))
(define (next-uid)
(atomically
(let ((uid (provisional-car lock-uid)))
(provisional-set-car! lock-uid (+ uid 1))
uid)))
(define (make-lock)
(really-make-lock #f (make-queue) (next-uid)))
(define (obtain-lock lock)
(with-new-proposal (lose)
(or (cond ((lock-owner lock)
(maybe-commit-and-block-on-queue (lock-queue lock)))
(else
(set-lock-owner! lock (current-thread))
(maybe-commit)))
(lose))))
; Returns #T if the lock is obtained and #F if not. Doesn't block.
(define (maybe-obtain-lock lock)
(with-new-proposal (lose)
(cond ((lock-owner lock) ; no need to commit - we have only done
#f) ; a single read
(else
(set-lock-owner! lock (current-thread))
(or (maybe-commit)
(lose))))))
; Returns #t if the lock has no new owner.
(define (release-lock lock)
(with-new-proposal (lose)
(let ((next (maybe-dequeue-thread! (lock-queue lock))))
(cond (next
(set-lock-owner! lock next)
(or (maybe-commit-and-make-ready next)
(lose)))
(else
(set-lock-owner! lock #f)
(or (maybe-commit)
(lose)))))))
(define (with-lock lock thunk)
(dynamic-wind
(lambda () (obtain-lock lock))
thunk
(lambda () (release-lock lock))))
|