;;; -*- 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))))
    (cond ((and threads
                (eq? (car threads) level))
           (cdr threads))
          ((current-swank-threads)
           => (lambda (threads)
                (let ((threads (weak-table-values->list threads)))
                  (set-cached-swank-threads! (cons level threads))
                  threads)))
          (else
           (abort-swank-rpc "(session ~S) No threads to browse at top level"
                            (swank-session-id (current-swank-session)))))))

(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))))))