85 lines
2.6 KiB
Scheme
85 lines
2.6 KiB
Scheme
|
; 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))))))
|