From 8f02923726f689cce1b18c923a985e0b75fd650d Mon Sep 17 00:00:00 2001
From: sperber <sperber>
Date: Mon, 28 May 2001 13:44:48 +0000
Subject: [PATCH] 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.

---
 scheme/big/thread-fluids.scm | 84 ++++++++++++++++++++++++++++++++++++
 scheme/more-interfaces.scm   |  7 +++
 scheme/more-packages.scm     |  5 +++
 3 files changed, 96 insertions(+)
 create mode 100644 scheme/big/thread-fluids.scm

diff --git a/scheme/big/thread-fluids.scm b/scheme/big/thread-fluids.scm
new file mode 100644
index 0000000..79e253d
--- /dev/null
+++ b/scheme/big/thread-fluids.scm
@@ -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))))))
diff --git a/scheme/more-interfaces.scm b/scheme/more-interfaces.scm
index 5dbaa05..9112f82 100644
--- a/scheme/more-interfaces.scm
+++ b/scheme/more-interfaces.scm
@@ -327,6 +327,13 @@
 	  array->vector		; <array>
 	  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
   (export make-search-tree
 	  search-tree?
diff --git a/scheme/more-packages.scm b/scheme/more-packages.scm
index e696650..8a28685 100644
--- a/scheme/more-packages.scm
+++ b/scheme/more-packages.scm
@@ -479,6 +479,10 @@
 
 (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
   (open scheme-level-2
 	formats
@@ -709,6 +713,7 @@
 	    sockets
 	    sort
 	    strong
+	    thread-fluids
 	    traverse
 	    spatial
 	    big-scheme