From: Matt Birkholz <matt@birchwood-abbey.net>
Date: Mon, 14 Aug 2017 21:16:08 +0000 (-0700)
Subject: Add thread-get and thread-put!.
X-Git-Tag: mit-scheme-pucked-9.2.12~88
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=5eec37d7a8d934b61331f70bb03f7c5c0e221bd3;p=mit-scheme.git

Add thread-get and thread-put!.
---

diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index 0d2a7249f..0aa88c530 100644
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -4764,8 +4764,10 @@ USA.
 	  thread-continuation
 	  thread-dead?
 	  thread-execution-state
+	  thread-get
 	  thread-mutex-owner
 	  thread-mutex?
+	  thread-put!
 	  thread-timer-interval
 	  thread?
 	  threads-list
diff --git a/src/runtime/thread.scm b/src/runtime/thread.scm
index bed9c0fb0..8fce69f9e 100644
--- a/src/runtime/thread.scm
+++ b/src/runtime/thread.scm
@@ -99,6 +99,14 @@ USA.
 (define (thread-dead? thread)
   (guarantee thread? thread 'THREAD-DEAD?)
   (eq? 'DEAD (thread/execution-state thread)))
+
+(define (thread-get thread property)
+  (guarantee thread? thread 'thread-get)
+  (1d-table/get (thread/properties thread) property #f))
+
+(define (thread-put! thread property value)
+  (guarantee thread? thread 'thread-put!)
+  (1d-table/put! (thread/properties thread) property value))
 
 (define thread-population)
 (define first-running-thread)
@@ -199,7 +207,7 @@ USA.
   (guarantee thread? thread 'THREAD-EXECUTION-STATE)
   (thread/execution-state thread))
 
-(define (create-thread root-continuation thunk)
+(define (create-thread root-continuation thunk #!optional name)
   (if (not (or (not root-continuation) (continuation? root-continuation)))
       (error:wrong-type-argument root-continuation
 				 "continuation or #f"
@@ -215,6 +223,9 @@ USA.
 	      (call-with-current-continuation
 		(lambda (continuation)
 		  (let ((thread (make-thread continuation)))
+		    (if (not (default-object? name))
+			(1d-table/put! (thread/properties thread)
+				       'name name))
 		    (%within-continuation (let ((k return)) (set! return #f) k)
 					  #t
 					  (lambda () thread)))))