[New thread browser support.
Taylor R Campbell <campbell@mumble.net>**20061015220304] {
hunk ./interfaces.scm 60
+          current-swank-threads
+          current-swank-focus-thread
+          with-swank-focus-thread
hunk ./interfaces.scm 265
+(define-interface swank-thread-control-interface
+  (export
+    nested-swank-starter                ; This ought to go elsewhere.
+    set-nested-swank-starter!
+    ))
+
hunk ./interfaces.scm 276
-          swank:start-swank-server-in-thread ;(*)
+          swank:start-swank-server-in-thread
hunk ./interfaces.scm 361
+          weak-table-values->list
hunk ./packages.scm 359
+(define-structures ((swank-thread-control
+                     swank-thread-control-interface)
+                    (swank-thread-control-rpc
+                     swank-thread-control-rpc-interface))
+  (open scheme
+        string-i/o
+        threads
+        threads-internal
+        weak-utilities
+        swank-sessions
+        swank-sldb
+        )
+  (optimize auto-integrate)
+  (files thread))
+
hunk ./packages.scm 394
+  swank-thread-control-rpc
hunk ./session.scm 132
-       ;; Brazenly ignore values of THREAD-ID other than :REPL-THREAD.
-       ;; The way the CL SLIME uses this argument is incompatible with
-       ;; how SLIME48 works, and it's unnecessary anyway.
hunk ./session.scm 134
-           (eval-in-worker-thread form package-id return-tag session)))
+           (eval-in-worker-thread form package-id thread-id return-tag
+                                  session)))
hunk ./session.scm 227
-(define (eval-in-worker-thread form package-id return-tag session)
+(define (eval-in-worker-thread form package-id thread-id return-tag
+                               session)
hunk ./session.scm 231
-      (swank-eval form package-id return-tag session))
+      ((lambda (thunk)
+         (if (exact-nonnegative-integer? thread-id)
+             (with-swank-focus-thread thread-id thunk)
+             (thunk)))
+       (lambda ()
+         (swank-eval form package-id return-tag session))))
hunk ./session.scm 244
+(define $swank-focus-thread (make-fluid #f))
+
+(define (with-swank-focus-thread thread thunk)
+  (let-fluid $swank-focus-thread
+      (if (thread? thread)
+          (thread-uid thread)
+          thread)
+    thunk))
+
+(define (current-swank-focus-thread)
+  (let ((level (current-level)))
+    (or (let ((thread-id (fluid $swank-focus-thread)))
+          (and thread-id
+               (level-thread-for-id (level-parent level) thread-id)))
+        (level-pusher-thread level))))
+
hunk ./session.scm 763
+(define-swank-upcall (current-swank-threads) thread level
+  (level-threads (level-parent level)))
+
hunk ./sldb.scm 49
-             ,(sldb-disclose-condition)
+             ,(if (sldb-debugging-signaller?)
+                  (sldb-disclose-condition)
+                  (sldb-nondisclose-condition))
hunk ./sldb.scm 74
-  (swank-session-pusher-thread (current-swank-session)))
+  (current-swank-focus-thread))
+
+(define (sldb-debugging-signaller?)
+  (eq? (sldb-thread-to-debug)
+       (swank-session-pusher-thread (current-swank-session))))
hunk ./sldb.scm 110
+(define (sldb-nondisclose-condition)
+  (list "" "[No condition]" '() '()))
+
hunk ./sldb.scm 213
+;;; Or, if we're not debugging the pusher thread, i.e. we just debugged
+;;; some random other thread, simply quit the debugger.
hunk ./sldb.scm 217
-  (sldb-restart 'RESET (sldb-restarters)))
+  (cond ((sldb-debugging-signaller?)
+         (sldb-restart 'RESET (sldb-restarters)))
+        (else
+         (send-sldb-return)
+         (abort-swank-rpc))))
addfile ./thread.scm
hunk ./thread.scm 1
+;;; -*- Mode: Scheme; scheme48-package: swank-thread-control -*-
+
+;;;; SLIME for Scheme48
+;;;; Thread Control RPC
+
+;;; This code is written by Taylor Campbell and placed in the Public
+;;; Domain.  All warranties are disclaimed.
+
+(define-swank-session-slot cached-swank-threads
+  set-cached-swank-threads!
+  modify-cached-swank-threads!
+  #f)
+
+(define (clear-cached-swank-threads!)
+  (set-cached-swank-threads! #f))
+
+(define (swank-threads)
+  (let ((threads (cached-swank-threads))
+        (level (swank-session-level-number (current-swank-session))))
+    (if (and threads
+             (eq? (car threads) level))
+        (cdr threads)
+        (let ((threads
+               (weak-table-values->list (current-swank-threads))))
+          (set-cached-swank-threads! (cons level threads))
+          threads))))
+
+(define (nth-swank-thread n)
+  (let ((threads (cached-swank-threads))
+        (level (swank-session-level-number (current-swank-session))))
+    (if (and threads
+             (eq? (car threads) level))
+        (list-ref (cdr threads) n)
+        (abort-swank-rpc
+         "(session ~S, level ~S) No such thread by number: ~S"
+         (swank-session-id (current-swank-session))
+         level
+         n))))
+
+(define (swank:list-threads)
+  (map (lambda (thread)
+         (list (hybrid-write-to-string (thread-name thread))
+               (cond ((running? thread) "running")
+                     ;; ((thread-cell thread) "waiting")
+                     ((thread-continuation thread) "ready")
+                     (else "terminated"))
+               (thread-uid thread)))
+       (swank-threads)))
+
+(define (swank:quit-thread-browser)
+  (clear-cached-swank-threads!)
+  'nil)
+
+(define (swank:debug-nth-thread n)
+  (with-swank-focus-thread (nth-swank-thread n)
+    send-sldb-activation)
+  'nil)
+
+(define (swank:kill-nth-thread n)
+  (terminate-thread! (nth-swank-thread n))
+  'nil)
+
+(define-swank-session-slot nested-swank-starter
+  set-nested-swank-starter!
+  modify-nested-swank-starter!
+  #f)
+
+(define (swank:start-swank-server-in-thread index port-filename)
+  (cond ((nested-swank-starter)
+         => (lambda (start-swank)
+              (interrupt-thread (nth-swank-thread index)
+                (lambda arguments
+                  (start-swank port-filename)
+                  (apply values arguments)))))
+        (else
+         (abort-swank-rpc "(session ~S) No nested Swank starter"
+                          (swank-session-id
+                           (current-swank-session))))))
hunk ./weak.scm 171
+(define (weak-table-values->list table)
+  (let ((values '()))
+    (weak-table-walk table
+      (lambda (key value)
+        key
+        (set! values (cons value values))))
+    values))
+
}
