;;; Originally: scheme/placeholder.scm
;;; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
;;; Copyright (c) 2010 Clinton Ebadi
;;; Placeholders (single-assignment cells for use with threads)

;;; Reimplemented from using manual thread queues to using a condition
;;; variable to ensure that the value is only written to once. Might
;;; not be entirely correct.

(define-module (scsh placeholder)
  #:use-module (srfi srfi-9)
  #:use-module (ice-9 threads)
  #:export (make-placeholder placeholder-value placeholder-set!))

(define-record-type placeholder
  (really-make-placeholder cvar id)
  placeholder?
  (cvar placeholder-condition set-placeholder-condition!) ; #f means
							  ; VALUE has
							  ; been set
  (value placeholder-real-value set-placeholder-value!)
  (id placeholder-id))

;; unsupported with srfi-9 (maybe add a guile extension?)
;; (define-record-discloser :placeholder
;;   (lambda (placeholder)
;;     (cons 'placeholder
;; 	  (if (placeholder-id placeholder)
;; 	      (list (placeholder-id placeholder))
;; 	      '()))))

;; fixme: should these also disable system asyncs? (seems to be the
;; intent of without-interrupts in the original code)

(define (monitor* closure)
  (let ((monitor-lock (make-mutex)))
    (lambda ()
      (with-mutex monitor-lock
	(closure monitor-lock)))))

(define* (make-placeholder #:optional id)
  (really-make-placeholder (make-condition-variable) id))

(define placeholder-value
  (let ((read-lock (make-mutex)))
    (lambda (placeholder)
      (with-mutex read-lock
	(if (placeholder-condition placeholder)
	    (wait-condition-variable (placeholder-condition placeholder)
				     read-lock))
	(placeholder-real-value placeholder)))))

(define (placeholder-set! placeholder value)
  (monitor
   (let ((cvar (placeholder-condition placeholder)))
     (cond ((condition-variable? cvar)
	    (set-placeholder-value! placeholder value)
	    (set-placeholder-condition! placeholder #f)
	    (broadcast-condition-variable cvar))
	   (else (if (not (eq? value (placeholder-value placeholder)))
		     (error "placeholder is already assigned"
			    placeholder
			    value)))))))