Store copies of data at trace-time.

contrib/swank-fuzzy.lisp

@@ -74,7 +74,9 @@ designator's format. The cases are as follows:
                               (zerop time-limit-in-msec)))
          (time-limit (if no-time-limit-p nil time-limit-in-msec)))
     (multiple-value-bind (completion-set interrupted-p)
-        (fuzzy-completion-set string default-package-name :limit limit
+        ;; Deep down there's a type SIMPLE-STRING required...
+        (fuzzy-completion-set (coerce string 'simple-string)
+                              default-package-name :limit limit
                               :time-limit-in-msec time-limit)
       ;; We may send this as elisp [] arrays to spare a coerce here,
       ;; but then the network serialization were slower by handling arrays.

swank.lisp

@@ -167,6 +167,10 @@ Backend code should treat the connection structure as opaque.")
   (indentation-cache-packages '())
   ;; The communication style used.
   (communication-style nil :type (member nil :spawn :sigio :fd-handler))
+  ;; A function to interpret packets coming in
+  (form-decoder nil :type (or null function))
+  ;; A function to format outgoing packets
+  (form-encoder nil :type (or null function))
   )
 
 (defun print-connection (conn stream depth)
@@ -227,6 +231,13 @@ Backend code should treat the connection structure as opaque.")
 (defslimefun ping (tag)
   tag)
 
+(defun set-data-protocol (encoder decoder)
+  (setf (connection.form-encoder *emacs-connection*)
+        encoder
+        (connection.form-decoder *emacs-connection*)
+        decoder)
+  T)
+
 (defun safe-backtrace ()
   (ignore-errors 
     (call-with-debugging-environment 
@@ -248,7 +259,7 @@ to T unless you want to debug swank internals.")
 
 (defmacro with-swank-error-handler ((connection) &body body)
   "Close the connection on internal `swank-error's."
-  (let ((conn (gensym)))
+  (let ((conn '*emacs-connection* #+(or) (gensym)))
   `(let ((,conn ,connection))
      (handler-case 
          (handler-bind ((swank-error 
@@ -710,10 +721,10 @@ If PACKAGE is not specified, the home package of SYMBOL is used."
 
 (defun start-server (port-file &key (style *communication-style*)
                                     (dont-close *dont-close*))
-  "Start the server and write the listen port number to PORT-FILE.
+  "Start the server and write the listen address and port number to PORT-FILE.
 This is the entry point for Emacs."
   (setup-server 0
-                (lambda (port) (announce-server-port port-file port))
+                (lambda (addr port) (announce-server-port port-file addr port))
                 style dont-close nil))
 
 (defun create-server (&key (port default-server-port)
@@ -754,11 +765,17 @@ e.g.: (restart-loop (http-request url) (use-value (new) (setq url new)))"
         (ignore-errors (list (parse-integer (read-line *query-io*)))))
       (setq port new-port))))
 
+(defun octets-to-ip-string (addr)
+  (ecase (length addr)
+    (4 (format nil "~{~d~^.~}" (coerce addr 'list)))
+    (16 (format nil "~{~2,'0x~2,'0x~^:~}" (coerce addr 'list)))))
+
 (defun setup-server (port announce-fn style dont-close backlog)
   (init-log-output)
   (let* ((socket (socket-quest port backlog))
+         (addr (octets-to-ip-string (local-addr socket)))
          (port (local-port socket)))
-    (funcall announce-fn port)
+    (funcall announce-fn addr port)
     (labels ((serve () (accept-connections socket style dont-close))
              (note () (send-to-sentinel `(:add-server ,socket ,port
                                                       ,(current-thread))))
@@ -836,38 +853,49 @@ if the file doesn't exist; otherwise the first line of the file."
        (:sigio (deinstall-sigio-handler connection))
        (:fd-handler (deinstall-fd-handler connection))))))
 
-(defun announce-server-port (file port)
+(defun announce-server-port (file address port)
   (with-open-file (s file
                      :direction :output
                      :if-exists :error
                      :if-does-not-exist :create)
-    (format s "~S~%" port))
-  (simple-announce-function port))
+    (format s "~S ~S~%" address port))
+  (simple-announce-function address port))
 
-(defun simple-announce-function (port)
+(defun simple-announce-function (address port)
   (when *swank-debug-p*
-    (format *log-output* "~&;; Swank started at port: ~D.~%" port)
+    (format *log-output* "~&;; Swank started at ~a, port: ~D.~%" address port)
     (force-output *log-output*)))
 
 
 ;;;;; Event Decoding/Encoding
 
-(defun decode-message (stream)
-  "Read an S-expression from STREAM using the SLIME protocol."
-  (log-event "decode-message~%")
+
+(defun decode-message (stream) ;; =PM
+  "Read an expression from STREAM."
+  #+(or)
+  (format *trace-output* "conn ~a, dec ~a ~%"
+          *emacs-connection*
+          (connection.form-decoder *emacs-connection*))
   (without-slime-interrupts
     (handler-bind ((error #'signal-swank-error))
-      (handler-case (read-message stream *swank-io-package*)
+      (handler-case (read-message stream 
+                                  *swank-io-package*
+                                  (lambda ()
+                                    (connection.form-decoder *emacs-connection*)))
+        ; =PM 
         (swank-reader-error (c) 
           `(:reader-error ,(swank-reader-error.packet c)
                           ,(swank-reader-error.cause c)))))))
 
 (defun encode-message (message stream)
-  "Write an S-expression to STREAM using the SLIME protocol."
+  "Write an S-expression to STREAM."
   (log-event "encode-message~%")
   (without-slime-interrupts
     (handler-bind ((error #'signal-swank-error))
-      (write-message message *swank-io-package* stream))))
+      (write-message message 
+                     *swank-io-package* 
+                     stream
+                     (connection.form-encoder *emacs-connection*)))))
 
 
 ;;;;; Event Processing
@@ -956,6 +984,10 @@ The processing is done in the extent of the toplevel restart."
   (let ((input-stream (connection.socket-io connection))
         (control-thread (mconn.control-thread connection)))
     (with-swank-error-handler (connection)
+	  ;; PM
+      ;; Auto-guess communication protocol (S-expr or JSON)
+      ;; (let ((ch (peek-char input-stream nil nil)))
+      ;;   (when (eql ch #\[)))
       (loop (send control-thread (decode-message input-stream))))))
 
 (defun dispatch-loop (connection)
@@ -1103,7 +1135,7 @@ The processing is done in the extent of the toplevel restart."
 
 (defun wait-for-event (pattern &optional timeout)
   "Scan the event queue for PATTERN and return the event.
-If TIMEOUT is 'nil wait until a matching event is enqued.
+If TIMEOUT is 'nil wait until a matching event is enqueued.
 If TIMEOUT is 't only scan the queue without waiting.
 The second return value is t if the timeout expired before a matching
 event was found."
@@ -2101,7 +2133,7 @@ after Emacs causes a restart to be invoked."
   "The initial number of backtrace frames to send to Emacs.")
 
 (defvar *sldb-restarts* nil
-  "The list of currenlty active restarts.")
+  "The list of currently active restarts.")
 
 (defvar *sldb-stepping-p* nil
   "True during execution of a step command.")
@@ -2243,7 +2275,7 @@ where
   restart     ::= (name description)
   stack-frame ::= (number description [plist])
   extra       ::= (:references and other random things)
-  cont        ::= continutation
+  cont        ::= continuation
   plist       ::= (:restartable {nil | t | :unknown})
 
 condition---a pair of strings: message, and type.  If show-source is
@@ -2254,7 +2286,7 @@ restart---a pair of strings: restart name, and description.
 stack-frame---a number from zero (the top), and a printed
 representation of the frame's call.
 
-continutation---the id of a pending Emacs continuation.
+continuation---the id of a pending Emacs continuation.
 
 Below is an example return value. In this case the condition was a
 division by zero (multi-line description), and only one frame is being

swank/abcl.lisp

@@ -218,6 +218,9 @@
 (defimplementation create-socket (host port &key backlog)
   (ext:make-server-socket port))
 
+(defimplementation local-address (socket)
+  (jcall (jmethod "java.net.ServerSocket" "getLocalAddress") socket)) ;; ??
+
 (defimplementation local-port (socket)
   (jcall (jmethod "java.net.ServerSocket" "getLocalPort") socket))
 

swank/backend.lisp

@@ -342,6 +342,9 @@ form suitable for testing with #+."
   "Create a listening TCP socket on interface HOST and port PORT.
 BACKLOG queue length for incoming connections.")
 
+(definterface local-addr (socket)
+  "Return the local address used by SOCKET.")
+
 (definterface local-port (socket)
   "Return the local port number of SOCKET.")
 

swank/clasp.lisp

@@ -67,6 +67,8 @@
     (sb-bsd-sockets:socket-listen socket (or backlog 5))
     socket))
 
+(defimplementation local-addr (socket)
+  (nth-value 0 (sb-bsd-sockets:socket-name socket)))
 (defimplementation local-port (socket)
   (nth-value 1 (sb-bsd-sockets:socket-name socket)))
 

swank/cmucl.lisp

@@ -67,6 +67,8 @@
   (declare (ignore host))
   (ext:create-inet-listener port :stream :reuse-address t))
 
+(defimplementation local-addr (socket)
+  (nth-value 0 (ext::get-socket-host-and-port (socket-fd socket))))
 (defimplementation local-port (socket)
   (nth-value 1 (ext::get-socket-host-and-port (socket-fd socket))))
 

swank/ecl.lisp

@@ -84,6 +84,8 @@
     (sb-bsd-sockets:socket-listen socket (or backlog 5))
     socket))
 
+(defimplementation local-addr (socket)
+  (nth-value 0 (sb-bsd-sockets:socket-name socket)))
 (defimplementation local-port (socket)
   (nth-value 1 (sb-bsd-sockets:socket-name socket)))
 

swank/lispworks.lisp

@@ -99,6 +99,8 @@
                                       (list #+unix (lw:get-unix-error errno))
                                       errno))))))
 
+(defimplementation local-addr (socket)
+  (nth-value 0 (comm:get-socket-address (socket-fd socket))))
 (defimplementation local-port (socket)
   (nth-value 1 (comm:get-socket-address (socket-fd socket))))
 

swank/mkcl.lisp

@@ -63,6 +63,8 @@
     (sb-bsd-sockets:socket-listen socket (or backlog 5))
     socket))
 
+(defimplementation local-addr (socket)
+  (nth-value 0 (sb-bsd-sockets:socket-name socket)))
 (defimplementation local-port (socket)
   (nth-value 1 (sb-bsd-sockets:socket-name socket)))
 

swank/rpc.lisp

@@ -8,7 +8,7 @@
 ;;; are disclaimed.
 ;;;
 
-(in-package swank/rpc)
+(in-package :swank/rpc)
 
 
 ;;;;; Input
@@ -19,12 +19,24 @@
    (cause :type reader-error :initarg :cause 
           :reader swank-reader-error.cause)))
 
-(defun read-message (stream package)
+(defun read-message (stream package &optional decoder-fn)
   (let ((packet (read-packet stream)))
-    (handler-case (values (read-form packet package))
+    ;; READ-MESSAGE / DECODE-MESSAGE are run in an asynchronous thread that won't know about the FORM-DECODER slot change when the loop is restarted
+    (handler-case (values (funcall 
+                            (if (eql (aref packet 0) #\[)
+                                (find-symbol "RECOVER-SYMBOLS" (find-package :vlime))
+                                #'read-form)
+                            #+(or) (or (if decoder-fn 
+                                    (funcall decoder-fn))
+                                #'read-form)
+                               #+(or)
+                            (or (and (eql (aref packet 0) #\[)
+                                     (funcall decoder-fn))
+                                #'read-form)
+                            packet package))
       (reader-error (c)
-        (error 'swank-reader-error 
-               :packet packet :cause c)))))
+                    (error 'swank-reader-error 
+                           :packet packet :cause c)))))
 
 (defun read-packet (stream)
   (let* ((length (parse-header stream))
@@ -40,6 +52,7 @@
     (loop for code across (etypecase packet 
                             (string (map 'vector #'char-code packet))
                             (vector packet))
+          ; =PM TODO ignore § ?
           do (cond ((<= code #x7f) (write-char (code-char code)))
                    (t (format t "\\x~x" code))))))
 
@@ -97,16 +110,18 @@
 
 ;;;;; Output
 
-(defun write-message (message package stream)
-  (let* ((string (prin1-to-string-for-emacs message package))
+(defun write-message (message package stream &optional encoder)
+  (let* ((string (funcall (or encoder
+                              #'prin1-to-string-for-emacs)
+                          message package))
          (octets (handler-case (swank/backend:string-to-utf8 string)
                    (error (c) (encoding-error c string))))
          (length (length octets)))
     (write-header stream length)
     (write-sequence octets stream)
     (finish-output stream)))
 
-;; FIXME: for now just tell emacs that we and an encoding problem.
+;; FIXME: for now just tell emacs that we had an encoding problem.
 (defun encoding-error (condition string)
   (swank/backend:string-to-utf8
    (prin1-to-string-for-emacs

swank/sbcl.lisp

@@ -131,6 +131,8 @@
     (sb-bsd-sockets:socket-listen socket (or backlog 5))
     socket))
 
+(defimplementation local-addr (socket)
+  (nth-value 0 (sb-bsd-sockets:socket-name socket)))
 (defimplementation local-port (socket)
   (nth-value 1 (sb-bsd-sockets:socket-name socket)))
 

swank/scl.lisp

@@ -34,6 +34,8 @@
     (ext:create-inet-listener port :stream :host addr :reuse-address t
                               :backlog (or backlog 5))))
 
+(defimplementation local-addr (socket)
+  (nth-value 0 (ext::get-socket-host-and-port (socket-fd socket))))
 (defimplementation local-port (socket)
   (nth-value 1 (ext::get-socket-host-and-port (socket-fd socket))))