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.
This commit is contained in:
sperber 2001-05-28 13:44:48 +00:00
parent 1e212d78a4
commit 8f02923726
3 changed files with 96 additions and 0 deletions

View File

@ -0,0 +1,84 @@
; 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))))))

View File

@ -327,6 +327,13 @@
array->vector ; <array> array->vector ; <array>
array)) ; <bounds> . <elements> array)) ; <bounds> . <elements>
(define-interface thread-fluids-interface
(export make-thread-fluid
thread-fluid
let-thread-fluid
let-thread-fluids
set-thread-fluid!))
(define-interface search-trees-interface (define-interface search-trees-interface
(export make-search-tree (export make-search-tree
search-tree? search-tree?

View File

@ -479,6 +479,10 @@
(define general-tables tables) ; backward compatibility (define general-tables tables) ; backward compatibility
(define-structure thread-fluids thread-fluids-interface
(open scheme define-record-types thread-cells fluids)
(files (big thread-fluids)))
(define-structure big-util big-util-interface (define-structure big-util big-util-interface
(open scheme-level-2 (open scheme-level-2
formats formats
@ -709,6 +713,7 @@
sockets sockets
sort sort
strong strong
thread-fluids
traverse traverse
spatial spatial
big-scheme big-scheme