;; Locks als Rendezvous mit einem Lock-Server

(define-record-type :lock
  (really-make-lock id)
  lock?
  (id lock-id))

(define make-lock
  (let ((id 0))
    (lambda ()
      (set! id (+ 1 id))
      (really-make-lock id))))

(define-record-type :obtain-message
  (make-obtain-message id reply-channel abort-rv)
  obtain-message?
  (id obtain-message-id)
  (reply-channel obtain-message-reply-channel)
  (abort-rv obtain-message-abort-rv))

(define-record-type :release-message
  (make-release-message id)
  release-message?
  (id release-message-id))

(define request-channel (make-channel))

(define (obtain-lock-rv lock)
  (with-nack
   (lambda (nack)
     (let ((reply-channel (make-channel)))
       (spawn
	(lambda ()
	  (send request-channel
		(make-obtain-message (lock-id lock)
				     reply-channel
				     nack))))
       (receive-rv reply-channel)))))


(define (reply-to-obtain reply-channel abort-rv)
  (select
   (wrap (send-rv reply-channel #f)
	 (lambda (ignore) #t))
   (wrap abort-rv
	 (lambda (ignore) #f))))

(define (start-lock-server!)
  (spawn
   (lambda ()
     (let serve ((lock-alist '()))
       (let ((request (receive request-channel)))
	 (cond
	  ((obtain-message? request)
	   (let ((id (obtain-message-id request))
		 (reply-channel (obtain-message-reply-channel request))
		 (abort-rv (obtain-message-abort-rv request)))
	     (cond
	      ((assoc id lock-alist)
	       => (lambda (pair)
		    (set-cdr! pair
			      (append (cdr pair)
				      (list (cons reply-channel abort-rv))))
		    (serve lock-alist)))
	      (else
	       (if (reply-to-obtain reply-channel abort-rv)
		   (serve (cons (cons id '()) lock-alist))
		   (serve lock-alist))))))
	  ((release-message? request)
	   (let ((id (release-message-id request)))
	     (cond
	      ((assoc id lock-alist)
	       => (lambda (pair)
		    (let assign ((pending (cdr pair)))
		      (cond
		       ((null? pending)
			(serve (delq pair lock-alist)))
		       ((reply-to-obtain (caar pending) (cdar pending))
			(set-cdr! pair (cdr pending))
			(serve lock-alist))
		       (else
			(assign (cdr pending))))))))))))))))

(define (release-lock lock)
  (send request-channel (make-release-message (lock-id lock))))