[Clean up top-level startup code and properly support single-session SLIME48.
Taylor Campbell <campbell@mumble.net>**20060713052935
 
 The former mess of a procedure SPAWN-SLIME48-TCP-SERVER is now
 considerably cleaned up and better abstracted.  There is now a
 separate operation for running a Swank server socket that accepts a
 solitary session and then closes.  There is a new Emacs variable in
 slime48.el controlling the persistence of the server.
] {
hunk ./interfaces.scm 71
-  (export spawn-swank-tcp-server
-          close-swank-tcp-server
-          swank-tcp-server?
-          swank-tcp-server-world
-          swank-tcp-server-port-number
-          encode-swank-message
-          decode-swank-message
-          ))
+  (export
+    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
+    encode-swank-message
+    decode-swank-message
+    ))
hunk ./load.scm 55
-                  (export slime48
-                          make-slime48-world
+                  (export make-slime48-world
+                          spawn-slime48-session
hunk ./load.scm 93
-(define (slime48-start exit-on-quit? . port-opt)
-  (in 'slime48
-      `(RUN (BEGIN (DEFINE SLIME48-WORLD)
-                   (DEFINE SLIME48-TCP-SERVER)
-                   (CALL-WITH-VALUES
-                       (LAMBDA ()
-                         (SLIME48 ,exit-on-quit? ,@port-opt))
-                     (LAMBDA (WORLD SERVER)
-                       (SET! SLIME48-WORLD WORLD)
-                       (SET! SLIME48-TCP-SERVER SERVER)))))))
+(define (slime48-start single-session? . port-opt)
+  (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))))))))
hunk ./slime48.el 18
+(defvar slime48-persistent-server nil
+  "*Nil means SLIME48 should accept only a single session at a time.
+True means starting SLIME48 will start a persistent SLIME48 server.")
+
hunk ./slime48.el 30
-               (",exec (slime48-start #t %S)\n" ,port-filename))
+               (",exec (slime48-start %s %S)\n"
+                ,(if slime48-persistent-server "#f" "#t")
+                ,port-filename))
hunk ./slime48.el 50
-
+
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))))))
+
hunk ./top.scm 9
-(define (slime48 exit-on-quit? . port-opt)
-  (let ((world (make-slime48-world)))
-    (values world (apply spawn-slime48-tcp-server
-                         world exit-on-quit? port-opt))))
+(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 (spawn-slime48-tcp-server world . port)
+  (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)))
hunk ./top.scm 39
-(define (spawn-slime48-tcp-server world exit-on-quit? . port-opt)
-  (let ((server (apply spawn-swank-tcp-server world
-                       (lambda (session-placeholder body)
-                         (with-sldb-handler #f
-                           (lambda ()
-                             ((lambda (body)        ;++ yucky structure
-                                (if exit-on-quit?
-                                    (with-swank-quitter
-                                        (lambda ()
-                                          (scheme-exit-now 0))
-                                      body)
-                                    (body)))
-                              (lambda ()
-                                (with-slime48-port-redirection
-                                    session-placeholder
-                                  body))))))
-                       (if (and (pair? port-opt)
-                                (number? (car port-opt)))
-                           port-opt
-                           '()))))
-    (if (and (pair? port-opt)
-             (string? (car port-opt)))
-        (call-with-output-file (car port-opt)
-          (lambda (out)
-            (write (swank-tcp-server-port-number server)
-                   out))))
-    server))
+(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 (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))))
}
