From 5eec37d7a8d934b61331f70bb03f7c5c0e221bd3 Mon Sep 17 00:00:00 2001 From: Matt Birkholz Date: Mon, 14 Aug 2017 14:16:08 -0700 Subject: [PATCH] Add thread-get and thread-put!. --- src/runtime/runtime.pkg | 2 ++ src/runtime/thread.scm | 13 ++++++++++++- 2 files changed, 14 insertions(+), 1 deletion(-) 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))))) -- 2.25.1