Add thread-get and thread-put!.

diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index 0d2a7249f0dd848d1dd16de19f46bd0650181259..0aa88c530404b6ffdadb137d80e0cd39c323ad63 100644 (file)
--- 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 bed9c0fb056741374d9e5877fb35415fdc7ae5ee..8fce69f9ef4da7ab53efad9a072a7a805fb4d6bf 100644 (file)
--- 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))
 \f
 (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)))))