[Scsh-checkins] CVS: scsh-0.6/scheme/big thread-fluids.scm,NONE,1.1

[Mike Sperber <sperber@users.sourceforge.net>]

Update of /cvsroot/scsh/scsh-0.6/scheme/big
In directory usw-pr-cvs1:/tmp/cvs-serv14617/scheme/big

Added Files:
        thread-fluids.scm 
Log Message:
Added thread-fluids which are a cross between thread cells and fluids.
They encapsulate thread-local state and have a binding construct
analogous to LET-FLUID.


--- NEW FILE ---
; Copyright (c) 1993-2001 by Richard Kelsey and Jonathan Rees. See file COPYING.

(define-record-type thread-fluid :thread-fluid
  (really-make-thread-fluid top cell)
  thread-fluid?
  (top thread-fluid-top-level-value)
  (cell thread-fluid-cell set-thread-fluid-cell!))

(define *no-fluid-value* (list 'no-fluid-value))

(define (thread-fluid thread-fluid)
  (let ((val (thread-cell-ref (thread-fluid-cell thread-fluid))))
    (if (eq? val *no-fluid-value*)
        (thread-fluid-top-level-value thread-fluid)
        val)))

(define (set-thread-fluid! thread-fluid val)
  (thread-cell-set! (thread-fluid-cell thread-fluid) val))

(define (let-thread-fluid t-fluid val thunk)
  (let ((old-val (thread-fluid t-fluid)))
    (dynamic-wind
     (lambda () (set-thread-fluid! t-fluid val))
     thunk
     (lambda () (set-thread-fluid! t-fluid old-val)))))

(define (let-thread-fluids . args)
  (call-with-values
   (lambda ()
     (let loop ((args args) (rev-old-vals '()))
       (if (null? (cdr args))
           (values (car args) (reverse rev-old-vals))
           (loop (cddr args)
                 (cons (thread-fluid (car args))
                       rev-old-vals)))))
   (lambda (thunk old-vals)
    (dynamic-wind
     (lambda ()
       (let loop ((args args))
         (if (not (null? (cdr args)))
             (begin
               (set-thread-fluid! (car args) (cadr args))
               (loop (cddr args))))))
     thunk
     (lambda ()
       (let loop ((args args) (old-vals old-vals))
         (if (not (null? (cdr args)))
             (begin
               (set-thread-fluid! (car args) (car old-vals))
               (loop (cddr args) (cdr old-vals))))))))))

(define (make-thread-fluid top)
  (really-make-thread-fluid top (make-thread-cell *no-fluid-value*)))


;; (define-record-type thread-fluid :thread-fluid
;;   (really-make-thread-fluid fluid)
;;   thread-fluid?
;;   (fluid thread-fluid-fluid))
;; 
;; (define (make-thread-fluid top)
;;   (really-make-thread-fluid (make-fluid (make-thread-cell top))))
;; 
;; (define (thread-fluid t-fluid)
;;   (thread-cell-ref (fluid (thread-fluid-fluid t-fluid))))
;; 
;; (define (set-thread-fluid! thread-fluid val)
;;   (thread-cell-set! (fluid (thread-fluid-fluid thread-fluid)) val))
;; 
;; (define (let-thread-fluid t-fluid val thunk)
;;   (let-fluid (thread-fluid-fluid t-fluid)
;;           (make-thread-cell val)
;;           thunk))
;; 
;; ;; avoid creating too many dynamic environments
;; (define (let-thread-fluids . args)
;;   (let loop ((args args) (rev-new-args '()))
;;     (if (not (null? (cdr args)))
;;      (loop (cddr args)
;;            (cons (make-thread-cell (cadr args))
;;                  (cons (thread-fluid-fluid (car args))
;;                        rev-new-args)))
;;      ;; we're done
;;      (apply let-fluids (reverse (cons (car args) rev-new-args))))))