[New teledebugging support, along with a number of smaller features, after massive changes to several parts of the SLIME48 system.
Taylor R Campbell <campbell@mumble.net>**20061015232327
 
 SLIME48 sessions now have infrastructure for connection to and
 disconnection from I/O interfaces.  This allows for detached sessions
 that can be controlled programmatically, and for attaching to
 detached sessions in order to debug them, possibly remotely.
 Documentation for this feature, which should make SLIME48 very useful
 in deploying and debugging server applications, is forthcoming.
 
 The network interface has been completely redesigned and better
 abstracted, and it now has hooks for authentication, implemented
 currently by SLIME's simple (and not exactly secure) mechanism of
 storing a secret key in `~/.slime-secret'.  (Still missing, though,
 is a decent socket interface and restriction of incoming connections
 to particular peer addresses...)
 
 The implementation of support for single- versus multi-session
 servers has been greatly simplified by the changes in the network
 interface abstraction.
 
 SLDB and the session system have been extended to support the
 explicit specification of sessions to work with, rather than assuming
 that some scheduler of the current thread knows what the current
 session is.  This allows straightforward interleaving of level stacks
 without getting mixed up, and some parts of the level system are
 simplified by the reliable availability of a current session fluid in
 any threads running under a Swank session.
 
 The network I/O interface has been rewritten to be more robust in
 general, to signal conditions better, to handle EOF gracefully, and
 to disconnect the session on the reception of EOF.
 
 There may be still other changes lurking in the patch which have long
 since escaped my memory.  I think I have identified all, though.
] {
hunk ./general.scm 21
-(define $swank-quitter
-  (make-fluid terminate-current-swank-session))
-
-(define (with-swank-quitter quitter thunk)
-  (let-fluid $swank-quitter quitter thunk))
-
hunk ./general.scm 22
-  ((fluid $swank-quitter)))
+  (disconnect-swank-session (current-swank-session))
+  'nil)
hunk ./interfaces.scm 33
+          connect-swank-session
+          disconnect-swank-session
+          swank-session-connected?
+
hunk ./interfaces.scm 60
+          call-in-swank-session-repl
hunk ./interfaces.scm 62
+          with-swank-session
hunk ./interfaces.scm 79
-    make-one-shot-swank-tcp-server
-    spawn-swank-tcp-server
-    close-swank-tcp-server
-    swank-tcp-server?
-    swank-tcp-server-world
-    swank-tcp-server-port-number
+    make-swank-tcp-server
hunk ./load.scm 54
-(config '(run (define-structure slime48
-                  (export make-slime48-world
-                          spawn-slime48-session
-                          spawn-slime48-tcp-server
-                          )
+(config '(run (define-interface slime48-interface
+                (export
+                  make-slime48-world
+                  spawn-slime48-session
+                  serve-one-slime48-session
+                  spawn-slime48-tcp-server
+                  ))))
+
+(config '(run (define-structure slime48 slime48-interface
hunk ./load.scm 66
+                      threads
+                      threads-internal
+                      placeholders
hunk ./load.scm 75
+                      silly             ;reverse-list->string
hunk ./load.scm 90
-                      (subset root-scheduler (scheme-exit-now))
-                      swank-quitting
hunk ./load.scm 91
+                      swank-sessions
hunk ./load.scm 95
+                      swank-logging
hunk ./load.scm 102
-  (call-with-values       ;No RECEIVE in the exec language.
-      (lambda ()
-        (if single-session?
-            (values 'SLIME48-SESSION 'SPAWN-SLIME48-SESSION)
-            (values 'SLIME48-TCP-SERVER 'SPAWN-SLIME48-TCP-SERVER)))
-    (lambda (name spawner)
-      (in 'SLIME48
-          `(RUN (BEGIN (DEFINE SLIME48-WORLD (MAKE-SLIME48-WORLD))
-                       (DEFINE ,name
-                         (,spawner SLIME48-WORLD ,@port-opt))))))))
+  (in 'SLIME48
+      `(RUN
+        (BEGIN
+          ,@(cond (single-session?
+                   `((DEFINE SLIME48-WORLD (MAKE-SLIME48-WORLD))
+                     (DEFINE SLIME48-SESSION
+                       (SPAWN-SLIME48-SESSION SLIME48-WORLD))
+                     (SERVE-ONE-SLIME48-SESSION SLIME48-SESSION
+                                                ,@port-opt)))
+                  (else
+                   `((DEFINE SLIME48-WORLD (MAKE-SLIME48-WORLD))
+                     (DEFINE CLOSE-SLIME48
+                       (SPAWN-SLIME48-TCP-SERVER SLIME48-WORLD
+                                                 ,@port-opt)))))))))
hunk ./packages.scm 81
-        define-record-type*
hunk ./packages.scm 85
-        placeholders
hunk ./packages.scm 92
-        swank-worlds
hunk ./packages.scm 93
-        swank-sldb
-        swank-i/o
hunk ./packages.scm 109
-(define-structures ((swank-general-rpc swank-general-rpc-interface)
-                    (swank-quitting (export with-swank-quitter)))
+(define-structure swank-general-rpc swank-general-rpc-interface
hunk ./session.scm 26
+   (disconnector #f)
hunk ./session.scm 65
+(define (disconnect-swank-session session)
+  (cond ((swank-session-disconnector session)
+         => (lambda (disconnector)
+              (disconnector session)
+              (set-swank-session-disconnector! session #f)))))
+
+(define (connect-swank-session session connector)
+  (disconnect-swank-session session)
+  (set-swank-session-disconnector! session (connector session)))
+
+(define (swank-session-connected? session)
+  (and (swank-session-disconnector session)
+       #t))
+
hunk ./session.scm 471
-      (destructure (((form package-id return-tag) (pipe-read! pipe)))
-        (swank-eval form package-id return-tag session))
+      (let ((message (pipe-read! pipe)))
+        (if (procedure? message)
+            (message)
+            (destructure (((form package-id return-tag) message))
+              (swank-eval form package-id return-tag session))))
hunk ./session.scm 521
+(define (call-in-swank-session-repl session thunk)
+  (if (procedure? thunk)       ;Protect against silly {ab,l}users.
+      (pipe-write! (swank-session-repl-pipe session)
+                   thunk)
+      (call-error "invalid procedure"
+                  call-in-swank-session-repl session thunk)))
+
hunk ./session.scm 534
-  (let* ((top-dynamic-env
-          (with-restarter-invoker-hook swank-restarter-invoker-hook
-            (lambda ()
-              (with-interaction-environment
-                  (swank-world-scratch-env
-                   (swank-session-world session))
-                get-dynamic-env))))
-         (thread
-          (spawn (lambda ()
-                   (dynamic-wind
-                     top-winder
-                     (lambda ()
-                       (with-handler
-                           (lambda (c punt)
-                             (swank-condition-handler c punt))
-                         (lambda ()
-                           (set-swank-session-top-dynamic-env!
-                            session
-                            top-dynamic-env)
-                           (push-top-level session))))
-                     top-unwinder))
-                 `(swank-session-scheduler
-                   ,(swank-session-id session)))))
-    (set-swank-session-scheduler-thread! session thread)))
+  (set-swank-session-top-dynamic-env!
+   session
+   (with-restarter-invoker-hook
+       (make-swank-restarter-invoker-hook session)
+     (lambda ()
+       (with-interaction-environment (swank-world-scratch-env
+                                      (swank-session-world session))
+         (lambda ()
+           (with-swank-session session
+             get-dynamic-env))))))
+  (set-swank-session-scheduler-thread!
+   session
+   (spawn (lambda ()
+            (with-swank-session session
+              (lambda ()
+                (dynamic-wind top-winder
+                              (lambda () (push-top-level session))
+                              top-unwinder))))
+          `(swank-session-scheduler ,(swank-session-id session)))))
+
+(define $session (make-fluid #f))
+
+(define (with-swank-session session thunk)
+  (let-fluid $session session thunk))
+
+(define (current-swank-session)
+  (fluid $session))
+
+(define (current-swank-world)
+  (swank-session-world (current-swank-session)))
hunk ./session.scm 710
+             (disconnect-swank-session session)
hunk ./session.scm 728
-    (if (swank-upcall? token)
+    (if (and (swank-upcall? token)
+             (eq? (car args) (level-session level)))
hunk ./session.scm 731
-               origin-thread level args)
+               origin-thread level (cdr args))
hunk ./session.scm 757
+                       ((CURRENT-SWANK-SESSION)
+                        => (LAMBDA (SESSION)
+                             (UPCALL TOKEN SESSION arg ...)))
hunk ./session.scm 761
-                        (UPCALL TOKEN arg ...)))))))))
+                        (ERROR "not in Swank"
+                               `(,id ,arg ...))))))))))
hunk ./session.scm 773
-
-(define-swank-upcall (current-swank-session) thread level
-  (level-session level))
-
-(define (current-swank-world)
-  (swank-session-world (current-swank-session)))
hunk ./session.scm 868
-(define swank-restarter-invoker-hook
-        (lambda (invoker)
-          (let ((level (current-level)))
-            (lambda args
-              (if (eq? level (current-level))
-                  (apply invoker args)
-                  (throw-to-level-pusher (level-child level)
-                                         (lambda ()
-                                           (apply invoker args))))))))
+(define (make-swank-restarter-invoker-hook session)
+  (lambda (invoker)
+    (let ((level (swank-session-level session)))
+      (lambda args
+        (if (eq? level (swank-session-level session))
+            (apply invoker args)
+            (throw-to-level-pusher (level-child level)
+                                   (lambda ()
+                                     (apply invoker args))))))))
hunk ./sldb.scm 12
-(define (with-sldb-handler filter thunk)
-  (with-handler (let ((filter (or filter error?)))
-                  (lambda (condition punt)
-                    (if (or (filter condition)
-                            (breakpoint? condition))
-                        (sldb-condition-handler condition punt)
-                        (punt))))
-    thunk))
-
hunk ./sldb.scm 15
-; (put 'with-sldb-handler 'scheme-indent-function 1)
-
hunk ./sldb.scm 18
-      (sldb-condition-handler '(BREAKPOINT)
-                              ;; Nothing to punt.
-                              values)))
+      (invoke-sldb '(BREAKPOINT)
+                   ;; Nothing to punt.
+                   values)))
hunk ./sldb.scm 23
-(define sldb-condition-handler
-        (lambda (condition punt)
-          ((call-with-current-continuation
-            (lambda (k)
-              (lambda ()
-                (let-fluid $sldb-condition-punter (lambda () (k punt))
-                  (lambda ()
-                    (push-swank-level condition
-                      send-sldb-activation
-                      send-sldb-return)))))))))
+;++ Optional arguments?  What're those?...
+
+(define (make-sldb-invoker session-getter . attacher)
+  (let ((attacher (or (and (pair? attacher)
+                           (car attacher))
+                      (lambda (condition session)
+                        condition session
+                        #t))))
+    (lambda (condition punt)
+      (cond ((session-getter)
+             => (lambda (session)
+                  (if (or (swank-session-connected? session)
+                          (attacher condition session))
+                      (with-sldb-condition-punter punt
+                        (lambda ()
+                          (with-swank-session session
+                            (lambda ()
+                              (push-swank-level condition
+                                send-sldb-activation
+                                send-sldb-return)))))
+                      (punt))))
+            (else (punt))))))
+
+(define (make-sldb-condition-handler filter session-getter . attacher)
+  (let ((filter (or filter error?))
+        (sldb-invoker
+         (apply make-sldb-invoker session-getter attacher)))
+    (lambda (condition punt)
+      (if (or (filter condition)
+              (breakpoint? condition))
+          (sldb-invoker condition punt)
+          (punt)))))
+
+(define (with-sldb-handler filter session-getter attacher
+          thunk)
+  (with-handler
+      (make-sldb-condition-handler filter session-getter attacher)
+    thunk))
+
+;** This is safe to call *only* from the session which it is meant to
+;** debug.  That is, it's useful pretty much only inside RPCs.  Use
+;** carefully.
+
+(define invoke-sldb
+  (make-sldb-invoker current-swank-session))
+
+(define sldb-condition-handler invoke-sldb)    ;++ deprecated
hunk ./sldb.scm 157
+(define (with-sldb-condition-punter punter thunk)
+  ((call-with-current-continuation
+     (lambda (k)
+       (lambda ()
+         (let-fluid $sldb-condition-punter
+             (lambda () (k punter))
+           thunk))))))
+
hunk ./tcp-server.scm 9
-(define (make-one-shot-swank-tcp-server world . port-number)
-  (let* ((socket (apply open-socket port-number))
-         (port-number (socket-port-number socket)))
-    (swank-log "(world ~S) Spawning one-shot TCP server on port ~A"
-               (swank-world-id world)
-               (socket-port-number socket))
-    (values port-number
-            (lambda (session-wrapper)
-              (receive (in out) (socket-accept socket)
-                (close-socket socket)
-                (spawn-swank-tcp-session in out world
-                                         session-wrapper))))))
-
-(define-record-type* swank-tcp-server
-  (make-swank-tcp-server world socket)
-  (thread))
-
-(define (spawn-swank-tcp-server world session-wrapper . port-number)
+(define (make-swank-tcp-server . port-number)
hunk ./tcp-server.scm 11
-    (swank-log "(world ~S) Spawning TCP server on port ~A"
-               (swank-world-id world)
-               (socket-port-number socket))
-    (let* ((server (make-swank-tcp-server world socket))
-           (thread (spawn (lambda ()
-                            (run-swank-tcp-server server
-                                                  session-wrapper))
-                          `(swank-tcp-server
-                            ,(swank-world-id world)
-                            ,(socket-port-number socket)))))
-      (set-swank-tcp-server-thread! server thread)
-      server)))
-
-(define (close-swank-tcp-server server)
-  (let ((socket (swank-tcp-server-socket server)))
-    (swank-log "(world ~S) Closing TCP server on port ~A"
-               (swank-world-id (swank-tcp-server-world server))
-               (socket-port-number socket))
-    (terminate-thread! (swank-tcp-server-thread server))
-    (close-socket socket)))
+    (values (socket-port-number socket)
+            (make-swank-tcp-server-procedure socket)
+            (lambda ()
+              (swank-log "Closing server socket on port ~S"
+                         (socket-port-number socket))
+              (close-socket socket)))))
hunk ./tcp-server.scm 18
-(define (swank-tcp-server-port-number server)
-  (socket-port-number (swank-tcp-server-socket server)))
+(define (make-swank-tcp-server-procedure socket)
+  (lambda (authenticator winner loser)
+    (receive (in out) (socket-accept socket)
+      (if (and authenticator
+               (not (authenticator in out)))
+          (loser)
+          (winner
+           (lambda (session)
+             (let ((reader (spawn-swank-tcp-reader in session))
+                   (writer (spawn-swank-tcp-writer out session)))
+               (lambda (session)
+                 session
+                 (terminate-thread! reader)
+                 (terminate-thread! writer)
+                 (close-input-port in)
+                 (close-output-port out)))))))))
hunk ./tcp-server.scm 35
-(define (run-swank-tcp-server server session-wrapper)
-  (let ((socket (swank-tcp-server-socket server))
-        (world (swank-tcp-server-world server)))
-    (let loop ()
-      (receive (in out) (socket-accept socket)
-        (spawn-swank-tcp-session in out world session-wrapper))
-      (loop))))
+(define (spawn-swank-tcp-reader in session)
+  (spawn (lambda ()
+           (run-swank-tcp-reader in session))
+         `(swank-tcp-reader ,(swank-session-id session))))
hunk ./tcp-server.scm 40
-(define (spawn-swank-tcp-session in out world session-wrapper)
-  (let ((session-placeholder (make-placeholder))
-        (reader-placeholder (make-placeholder))
-        (writer-placeholder (make-placeholder)))
-    (let ((session
-           (session-wrapper session-placeholder
-             (lambda (init exit)
-               (spawn-swank-session world
-                 ;; These next two procedures will be called in other
-                 ;; threads, so we must be careful about synchronizing
-                 ;; access to the session descriptor and the two I/O
-                 ;; thread descriptors.
-                 (lambda ()             ; session winder
-                   (spawn-swank-tcp-i/o
-                    in out
-                    (placeholder-value session-placeholder)
-                    reader-placeholder
-                    writer-placeholder)
-                   (init))
-                 (lambda ()             ; session unwinder
-                   (exit)
-                   (terminate-thread!
-                    (placeholder-value reader-placeholder))
-                   (terminate-thread!
-                    (placeholder-value writer-placeholder))
-                   (close-input-port in)
-                   (close-output-port out)))))))
-      (placeholder-set! session-placeholder session))))
+(define (run-swank-tcp-reader in session)
+  (let ((message (decode-swank-message in)))
+    ;++ This is a hack.  We can't disconnect in this thread, because
+    ;++ disconnecting involves terminating this thread and doing other
+    ;++ important things afterward.  So we send a message to the
+    ;++ session that we happen to know will cause it to disconnect.
+    ;++ This message has null package id, thread id, and return tag.
+    (if (eof-object? message)
+        (send-incoming-swank-message session
+          '(:EMACS-REX (SWANK:QUIT-LISP) NIL NIL NIL))
+        (begin (send-incoming-swank-message session message)
+               (run-swank-tcp-reader in session)))))
hunk ./tcp-server.scm 53
-(define (spawn-swank-tcp-i/o in out session
-                             reader-placeholder
-                             writer-placeholder)
-  (let ((reader (spawn (lambda ()
-                         (run-swank-tcp-reader session in))
-                       `(swank-tcp-reader ,session)))
-        (writer (spawn (lambda ()
-                         (run-swank-tcp-writer session out))
-                       `(swank-tcp-writer ,session))))
-    (placeholder-set! reader-placeholder reader)
-    (placeholder-set! writer-placeholder writer)))
-
-(define (run-swank-tcp-reader session in)
-  (let loop ()
-    (send-incoming-swank-message session (decode-swank-message in))
-    (loop)))
+(define (spawn-swank-tcp-writer out session)
+  (spawn (lambda ()
+           (run-swank-tcp-writer out session))
+         `(swank-tcp-writer ,(swank-session-id session))))
hunk ./tcp-server.scm 58
+(define (run-swank-tcp-writer out session)
+  (encode-swank-message (receive-outgoing-swank-message session)
+                        out)
+  (run-swank-tcp-writer out session))
+
hunk ./tcp-server.scm 69
-  (let* ((length (decode-swank-message-length in))
-         (string (make-string length))
-         (count-read (read-block string 0 length in)))
-    (if (not (= count-read length))
-        (signal 'swank-protocol-error
-                "number of bytes read does not match expected length"
-                in
-                `(expected ,length)
-                `(read ,count-read)))
-    (with-handler (lambda (condition punt)
-                    (if (read-error? condition)
-                        (signal 'swank-protocol-error
-                                "malformed input expression"
-                                in
-                                condition)
-                        (punt)))
-      (lambda ()
-        (read-from-string string)))))
+  (if (eof-object? (peek-char in))
+      (peek-char in)
+      (with-handler (lambda (condition punt)
+                      (if (read-error? condition)
+                          (signal 'swank-protocol-error
+                                  "malformed input expression"
+                                  in
+                                  condition)
+                          (punt)))
+        (lambda ()
+          (let* ((length (decode-swank-message-length in))
+                 (string (make-string length))
+                 (count-read (read-block string 0 length in)))
+            (if (or (eof-object? count-read)
+                    (< count-read length))
+                (signal 'swank-protocol-error
+                        "premature end of file"
+                        in)
+                (read-from-string string)))))))
hunk ./tcp-server.scm 95
+(define (encode-swank-message message out)
+  (let* ((string (write-to-string message)))
+    (encode-swank-message-length string out)
+    (write-string string out)
+    (force-output out)))
+
+(define (encode-swank-message-length string out)
+  (let ((length (string-length string)))
+    (if (>= length (arithmetic-shift 2 24))
+        (error "message too long to be encoded in Swank" string)
+        (let ()
+          (define (extract-digit n)
+            (bitwise-and (arithmetic-shift length (* -4 n))
+                         #xF))
+          (define (write-digit n)
+            (write-hex-digit (extract-digit n) out))
+          (write-digit 5)
+          (write-digit 4)
+          (write-digit 3)
+          (write-digit 2)
+          (write-digit 1)
+          (write-digit 0)))))
+
hunk ./tcp-server.scm 121
-        (signal 'swank-protocol-error
+        (signal 'read-error
hunk ./tcp-server.scm 132
-                 (signal 'swank-protocol-error
-                         "invalid hex digit for message length read"
-                         port
-                         char)))))))
+                 (signal 'read-error
+                         "invalid hex digit"
+                         char
+                         port)))))))
hunk ./tcp-server.scm 142
-(define (run-swank-tcp-writer session out)
-  (let loop ()
-    (encode-swank-message (receive-outgoing-swank-message session)
-                          out)
-    (loop)))
-
-(define (encode-swank-message message out)
-  (let* ((string (write-to-string message)))
-    (write-string (encode-swank-message-length string) out)
-    (write-string string out)
-    (write-char #\newline out)          ; Careful not to call NEWLINE!
-    (force-output out)))
-
-(define (encode-swank-message-length string)
-  (let ((length (+ (string-length string) 1)))
-    (if (>= length (arithmetic-shift 2 24))
-        (error "message too long to be encoded in Swank" string)
-        (let ((hex (number->string length 16)))
-          (string-append (make-string (- 6 (string-length hex)) #\0)
-                         hex)))))
+(define (write-hex-digit digit port)
+  (cond ((<= 0 digit 9)
+         (write-char (ascii->char (+ digit (char->ascii #\0)))
+                     port))
+        ((<= 10 digit 16)
+         (write-char (ascii->char (+ (- digit 10) (char->ascii #\A)))
+                     port))
+        (else
+         (call-error "invalid hex digit"
+                     write-hex-digit digit port))))
hunk ./top.scm 9
-(define (spawn-slime48-session world . port)
-  (receive (rest writer) (port-number-option port)
-    (receive (port-number serve)
-             (apply make-one-shot-swank-tcp-server world rest)
-      (writer port-number)
-      (serve slime48-session-wrapper))))
+(define (serve-one-slime48-session session . port)
+  (receive (port-number server closer) (make-slime48-tcp-server port)
+    (swank-log "(session ~S) Serving one remote session on port ~S"
+               (swank-session-id session)
+               port-number)
+    (server slime48-authenticator
+            (lambda (connector)
+              (connect-swank-session session connector)
+              (closer))
+            (lambda ()
+              (swank-log "(session ~S) Client failed authentication"
+                         (swank-session-id session))))))
hunk ./top.scm 23
-  (receive (rest writer) (port-number-option port)
-    (let ((server
-           (apply spawn-swank-tcp-server
-                  world
-                  slime48-session-wrapper
-                  rest)))
-      (writer (swank-tcp-server-port-number server))
-      server)))
+  (receive (port-number server closer) (make-slime48-tcp-server port)
+    (let ((server-thread
+           (spawn (lambda ()
+                    (swank-log "(world ~S) Serving on port ~S"
+                               (swank-world-id world)
+                               port-number)
+                    (serve-slime48-sessions server world))
+                  `(slime48-server ,(swank-world-id world)))))
+      (lambda ()
+        (terminate-thread! server-thread)
+        (closer)))))
+
+(define (serve-slime48-sessions server world)
+  (server slime48-authenticator
+          (lambda (connector)
+            (connect-swank-session (spawn-slime48-session world)
+                                   connector))
+          values)
+  (serve-slime48-sessions server world))
+
+(define (make-slime48-tcp-server port-opt)
+  (cond ((null? port-opt) (make-swank-tcp-server))
+        ((or (and (string? (car port-opt))   ;name of file to write
+                  (lambda (port-number)
+                    (call-with-output-file (car port-opt)
+                      (lambda (output-port)
+                        (write port-number output-port)))))
+             (and (procedure? (car port-opt))
+                  (car port-opt)))
+         => (lambda (announcer)
+              (receive (port-number server closer)
+                       (make-swank-tcp-server)
+                (announcer port-number)
+                (values port-number server closer))))
+        ((integer? (car port-opt))      ;port number
+         (make-swank-tcp-server (car port-opt)))
+        (else
+         (error "invalid port number option" port-opt))))
+
+(define slime48-authenticator
+  (lambda (in out)
+    (let ((secret-key (slime48-secret-key)))
+      (or (not secret-key)
+          (equal? secret-key (decode-swank-message in))))))
hunk ./top.scm 68
+(define (slime48-secret-key)
+  (call-with-current-continuation
+    (lambda (abort)
+      (with-handler (lambda (condition propagate)
+                      (if (error? condition)
+                          (abort #f)
+                          (propagate)))
+        (lambda ()
+          (call-with-input-file "~/.slime-secret" read-line))))))
+
hunk ./top.scm 88
-(define slime48-session-wrapper
-  (lambda (session-placeholder body)
-    (with-sldb-handler #f
-      (lambda ()
-        (with-slime48-port-redirection session-placeholder
-          (lambda (init exit)
-            (body init exit)))))))
+(define (spawn-slime48-session world . debugger-attacher)
+  (call-with-result-placeholder
+    (lambda (session-placeholder)
+      (with-sldb-handler #f
+          (lambda ()
+            (placeholder-value session-placeholder))
+          (and (pair? debugger-attacher)
+               (wrap-debugger-attacher (car debugger-attacher)))
+        (lambda ()
+          (with-slime48-port-redirection session-placeholder
+            (lambda ()
+              (spawn-swank-session world values values))))))))
hunk ./top.scm 101
-(define (port-number-option option)
-  (cond ((null? option)
-         (values '()
-                 (lambda (port-number)
-                   port-number
-                   (values))))
-        ((string? (car option))
-         (values '()
-                 (let ((filename (car option)))
-                   (lambda (port-number)
-                     (call-with-output-file filename
-                       (lambda (output-port)
-                         (write port-number output-port)))))))
-        ((integer? (car option))
-         (values (list (car option))
-                 (lambda (port-number)
-                   port-number
-                   (values))))
-        (else
-         (error "invalid port option" option))))
+(define (wrap-debugger-attacher procedure)
+  (let ((spawn (spawner-on-current-scheduler)))
+    (lambda (condition session)
+      (let ((placeholder (make-placeholder)))
+        (spawn (lambda ()
+                 (placeholder-set! placeholder
+                                   (procedure condition session)))
+               `(swank-teledebugger ,(swank-session-id session)))
+        (placeholder-value placeholder)))))
hunk ./top.scm 120
-        (lambda ()
-          ;; No init or exit thunks.  (Hook for separate TCP stream.)
-          (body values values))))))
+        body))))
+
+
+
+;++ Is the placeholder the right abstraction here?  What about promises
+;++ or thunks built on top of placeholders?
+
+(define (call-with-result-placeholder procedure)
+  (let* ((placeholder (make-placeholder))
+         (value (procedure placeholder)))
+    (placeholder-set! placeholder value)
+    value))
+
+(define (spawner-on-current-scheduler)
+  (let ((scheduler (thread-scheduler (current-thread))))
+    (lambda (thunk . name)
+      (apply spawn-on-scheduler scheduler thunk name))))
+
+(define (read-line input-port)
+  (let loop ((chars '())
+             (count 0))
+    (let ((char (read-char input-port)))
+      (cond ((eof-object? char)
+             (if (zero? count)
+                 char
+                 (reverse-list->string chars count)))
+            ((char=? char #\newline)
+             (reverse-list->string chars count))
+            (else
+             (loop (cons char chars) (+ count 1)))))))
hunk ./top.scm 247
+                           ;++ This is wrong!
}
