scsh-0.6/scheme/big/placeholder.scm

49 lines
1.6 KiB
Scheme
Raw Normal View History

1999-09-14 08:45:02 -04:00
; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
; Placeholders (single-assignment cells for use with threads)
(define-record-type placeholder :placeholder
(really-make-placeholder queue id)
placeholder?
(queue placeholder-queue set-placeholder-queue!) ; #f means VALUE has been set
(value placeholder-real-value set-placeholder-value!)
(id placeholder-id))
(define-record-discloser :placeholder
(lambda (placeholder)
(cons 'placeholder
(if (placeholder-id placeholder)
(list (placeholder-id placeholder))
'()))))
(define (make-placeholder . id-option)
(really-make-placeholder (make-queue)
1999-09-14 08:45:02 -04:00
(if (null? id-option) #f (car id-option))))
(define (placeholder-value placeholder)
(with-interrupts-inhibited
(lambda ()
(if (placeholder-queue placeholder)
(block-on-queue (placeholder-queue placeholder)))
1999-09-14 08:45:02 -04:00
(placeholder-real-value placeholder))))
(define (placeholder-set! placeholder value)
(let ((waiters (with-interrupts-inhibited
(lambda ()
(let ((queue (placeholder-queue placeholder)))
(cond (queue
(set-placeholder-value! placeholder value)
(set-placeholder-queue! placeholder #f)
(let loop ((waiters '()))
(cond
((maybe-dequeue-thread! queue)
=> (lambda (thread)
(loop (cons thread waiters))))
(else
waiters))))
(else #f)))))))
1999-09-14 08:45:02 -04:00
(if waiters
(for-each make-ready waiters)
(if (not (eq? value (placeholder-value placeholder)))
(error "placeholder is already assigned"
placeholder
value)))))