[slime-cvs] CVS slime
CVS User heller
heller at common-lisp.net
Sun Nov 6 17:06:09 UTC 2011
Update of /project/slime/cvsroot/slime
In directory tiger.common-lisp.net:/tmp/cvs-serv11312
Modified Files:
ChangeLog slime.el swank-backend.lisp swank-rpc.lisp
swank-sbcl.lisp swank.lisp
Log Message:
New wire format.
Switch from character streams to binary streams. Counting
characters was error prone because some Lisps use utf-16
internally and so READ-SEQUENCE can't be used easily.
The new format looks so:
| byte0 | 3 bytes length |
| ... payload ... |
The playload is an s-exp encoded as UTF-8 string. byte0 is
currently always 0; other values are reserved for future use.
* swank-rpc.lisp (write-message): Use new format.
(write-header, parse-header, asciify, encoding-error): New.
* swank.lisp (accept-connections): Create a binary stream.
(input-available-p): Can't read-char-no-hang on binary streams.
* slime.el (slime-net-connect): Use binary as coding system.
(slime-net-send, slime-net-read, slime-net-decode-length)
(slime-net-encode-length, slime-net-have-input-p): Use new format.
(slime-unibyte-string, slime-handle-net-read-error): New.
(featurep): Require 'un-define for XEmacs.
([test] break): Longer timeouts.
* swank-sbcl.lisp (input-ready-p): Use sb-sys:wait-until-fd-usable.
--- /project/slime/cvsroot/slime/ChangeLog 2011/11/06 17:05:52 1.2233
+++ /project/slime/cvsroot/slime/ChangeLog 2011/11/06 17:06:08 1.2234
@@ -1,5 +1,36 @@
2011-11-06 Helmut Eller <heller at common-lisp.net>
+ New wire format.
+
+ Switch from character streams to binary streams. Counting
+ characters was error prone because some Lisps use utf-16
+ internally and so READ-SEQUENCE can't be used easily.
+
+ The new format looks so:
+
+ | byte0 | 3 bytes length |
+ | ... payload ... |
+
+ The playload is an s-exp encoded as UTF-8 string. byte0 is
+ currently always 0; other values are reserved for future use.
+
+ * swank-rpc.lisp (write-message): Use new format.
+ (write-header, parse-header, asciify, encoding-error): New.
+
+ * swank.lisp (accept-connections): Create a binary stream.
+ (input-available-p): Can't read-char-no-hang on binary streams.
+
+ * slime.el (slime-net-connect): Use binary as coding system.
+ (slime-net-send, slime-net-read, slime-net-decode-length)
+ (slime-net-encode-length, slime-net-have-input-p): Use new format.
+ (slime-unibyte-string, slime-handle-net-read-error): New.
+ (featurep): Require 'un-define for XEmacs.
+ ([test] break): Longer timeouts.
+
+ * swank-sbcl.lisp (input-ready-p): Use sb-sys:wait-until-fd-usable.
+
+2011-11-06 Helmut Eller <heller at common-lisp.net>
+
* swank.lisp (close-connection): Fix thinko.
2011-11-06 Helmut Eller <heller at common-lisp.net>
--- /project/slime/cvsroot/slime/slime.el 2011/09/28 16:49:53 1.1376
+++ /project/slime/cvsroot/slime/slime.el 2011/11/06 17:06:09 1.1377
@@ -67,7 +67,8 @@
(require 'pp)
(require 'font-lock)
(when (featurep 'xemacs)
- (require 'overlay))
+ (require 'overlay)
+ (require 'un-define))
(require 'easymenu)
(eval-when (compile)
(require 'arc-mode)
@@ -1475,10 +1476,16 @@
;;; This section covers the low-level networking: establishing
;;; connections and encoding/decoding protocol messages.
;;;
-;;; Each SLIME protocol message beings with a 3-byte length header
-;;; followed by an S-expression as text. The sexp must be readable
-;;; both by Emacs and by Common Lisp, so if it contains any embedded
-;;; code fragments they should be sent as strings.
+;;; Each SLIME protocol message beings with a 4-byte header followed
+;;; by an S-expression as text. The sexp must be readable both by
+;;; Emacs and by Common Lisp, so if it contains any embedded code
+;;; fragments they should be sent as strings:
+;;;
+;;; | byte0 | 3 bytes length |
+;;; | ... s-exp ... |
+;;;
+;;; The s-exp text is encoded in UTF8. byte0 is currently always 0;
+;;; other values are reserved for future use.
;;;
;;; The set of meaningful protocol messages are not specified
;;; here. They are defined elsewhere by the event-dispatching
@@ -1514,8 +1521,7 @@
(set-process-sentinel proc 'slime-net-sentinel)
(slime-set-query-on-exit-flag proc)
(when (fboundp 'set-process-coding-system)
- (slime-check-coding-system coding-system)
- (set-process-coding-system proc coding-system coding-system))
+ (set-process-coding-system proc 'binary 'binary))
(when-let (secret (slime-secret))
(slime-net-send secret proc))
proc))
@@ -1561,14 +1567,14 @@
"Send a SEXP to Lisp over the socket PROC.
This is the lowest level of communication. The sexp will be READ and
EVAL'd by Lisp."
- (let* ((msg (concat (slime-prin1-to-string sexp) "\n"))
- (string (concat (slime-net-encode-length (length msg)) msg))
- (coding-system (cdr (process-coding-system proc))))
+ (let* ((payload (encode-coding-string
+ (concat (slime-prin1-to-string sexp) "\n")
+ 'utf-8-unix))
+ (string (concat (slime-unibyte-string 0)
+ (slime-net-encode-length (length payload))
+ payload)))
(slime-log-event sexp)
- (cond ((slime-safe-encoding-p coding-system string)
- (process-send-string proc string))
- (t (error "Coding system %s not suitable for %S"
- coding-system string)))))
+ (process-send-string proc string)))
(defun slime-safe-encoding-p (coding-system string)
"Return true iff CODING-SYSTEM can safely encode STRING."
@@ -1626,8 +1632,8 @@
(defun slime-net-have-input-p ()
"Return true if a complete message is available."
(goto-char (point-min))
- (and (>= (buffer-size) 6)
- (>= (- (buffer-size) 6) (slime-net-decode-length))))
+ (and (>= (buffer-size) 4)
+ (>= (- (buffer-size) 4) (slime-net-decode-length))))
(defun slime-run-when-idle (function &rest args)
"Call FUNCTION as soon as Emacs is idle."
@@ -1635,11 +1641,22 @@
(if (featurep 'xemacs) itimer-short-interval 0)
nil function args))
+(defun slime-handle-net-read-error (error)
+ (let ((packet (buffer-string)))
+ (slime-with-popup-buffer ((slime-buffer-name :error))
+ (princ (format "%s\nin packet:\n%s" (error-message-string error) packet))
+ (goto-char (point-min)))
+ (cond ((y-or-n-p "Skip this packet? ")
+ `(:emacs-skipped-packet ,packet))
+ (t
+ (when (y-or-n-p "Enter debugger instead? ")
+ (debug 'error error))
+ (signal (car error) (cdr error))))))
+
(defun slime-net-read-or-lose (process)
(condition-case error
(slime-net-read)
(error
- (debug 'error error)
(slime-net-close process t)
(error "net-read error: %S" error))))
@@ -1647,21 +1664,33 @@
"Read a message from the network buffer."
(goto-char (point-min))
(let* ((length (slime-net-decode-length))
- (start (+ 6 (point)))
+ (start (+ (point) 4))
(end (+ start length)))
(assert (plusp length))
(prog1 (save-restriction
(narrow-to-region start end)
- (read (current-buffer)))
+ (condition-case error
+ (progn
+ (decode-coding-region start end 'utf-8-unix)
+ (setq end (point-max))
+ (read (current-buffer)))
+ (error
+ (slime-handle-net-read-error error))))
(delete-region (point-min) end))))
(defun slime-net-decode-length ()
- "Read a 24-bit hex-encoded integer from buffer."
- (string-to-number (buffer-substring-no-properties (point) (+ (point) 6)) 16))
+ "Read a 24-bit little endian integer from buffer."
+ ;; extra masking for "raw bytes" in multibyte text above #x3FFF00
+ (logior (lsh (logand (char-after (+ (point) 1)) #xff) 16)
+ (lsh (logand (char-after (+ (point) 2)) #xff) 8)
+ (lsh (logand (char-after (+ (point) 3)) #xff) 0)))
(defun slime-net-encode-length (n)
- "Encode an integer into a 24-bit hex string."
- (format "%06x" n))
+ (assert (<= 0 n))
+ (assert (<= n #xffffff))
+ (slime-unibyte-string (logand (lsh n -16) #xff)
+ (logand (lsh n -8) #xff)
+ (logand (lsh n 0) #xff)))
(defun slime-prin1-to-string (sexp)
"Like `prin1-to-string' but don't octal-escape non-ascii characters.
@@ -2339,14 +2368,16 @@
(slime-send `(:emacs-pong ,thread ,tag)))
((:reader-error packet condition)
(slime-with-popup-buffer ((slime-buffer-name :error))
- (princ (format "Invalid protocol message:\n%s\n\n%S"
+ (princ (format "Invalid protocol message:\n%s\n\n%s"
condition packet))
(goto-char (point-min)))
(error "Invalid protocol message"))
((:invalid-rpc id message)
(setf (slime-rex-continuations)
(remove* id (slime-rex-continuations) :key #'car))
- (error "Invalid rpc: %s" message))))))
+ (error "Invalid rpc: %s" message))
+ ((:emacs-skipped-packet _pkg))
+ ))))
(defun slime-send (sexp)
"Send SEXP directly over the wire on the current connection."
@@ -8249,12 +8280,12 @@
(and (slime-sldb-level= 1)
(get-buffer-window
(sldb-get-default-buffer))))
- 1)
+ 3)
(with-current-buffer (sldb-get-default-buffer)
(sldb-continue))
(slime-wait-condition "sldb closed"
(lambda () (not (sldb-get-default-buffer)))
- 0.2))
+ 1))
(slime-sync-to-top-level 1))
(def-slime-test (break2 (:fails-for "cmucl" "allegro" "ccl"))
@@ -8801,6 +8832,12 @@
;; Emacs 21 uses microsecs; Emacs 22 millisecs
(if timeout (truncate (* timeout 1000000)))))))
+(defun slime-unibyte-string (&rest bytes)
+ (cond ((fboundp 'unibyte-string)
+ (apply #'unibyte-string bytes))
+ (t
+ (apply #'string bytes))))
+
(defun slime-pop-to-buffer (buffer &optional other-window)
"Select buffer BUFFER in some window.
This is like `pop-to-buffer' but also sets the input focus
--- /project/slime/cvsroot/slime/swank-backend.lisp 2011/11/06 17:05:41 1.209
+++ /project/slime/cvsroot/slime/swank-backend.lisp 2011/11/06 17:06:09 1.210
@@ -1207,18 +1207,19 @@
(definterface wait-for-input (streams &optional timeout)
"Wait for input on a list of streams. Return those that are ready.
STREAMS is a list of streams
-TIMEOUT nil, t, or real number. If TIMEOUT is t, return
-those streams which are ready immediately, without waiting.
+TIMEOUT nil, t, or real number. If TIMEOUT is t, return those streams
+which are ready (or have reached end-of-file) without waiting.
If TIMEOUT is a number and no streams is ready after TIMEOUT seconds,
return nil.
-Return :interrupt if an interrupt occurs while waiting."
- (assert (member timeout '(nil t)))
- (cond #+(or)
- ((null (cdr streams))
- (wait-for-one-stream (car streams) timeout))
- (t
- (wait-for-streams streams timeout))))
+Return :interrupt if an interrupt occurs while waiting.")
+
+;; (assert (member timeout '(nil t)))
+;; (cond #+(or)
+;; ((null (cdr streams))
+;; (wait-for-one-stream (car streams) timeout))
+;; (t
+;; (wait-for-streams streams timeout))))
(defun wait-for-streams (streams timeout)
(loop
--- /project/slime/cvsroot/slime/swank-rpc.lisp 2010/10/09 23:02:33 1.7
+++ /project/slime/cvsroot/slime/swank-rpc.lisp 2011/11/06 17:06:09 1.8
@@ -23,26 +23,46 @@
;;;;; Input
(define-condition swank-reader-error (reader-error)
- ((packet :type string :initarg :packet :reader swank-reader-error.packet)
- (cause :type reader-error :initarg :cause :reader swank-reader-error.cause)))
+ ((packet :type string :initarg :packet
+ :reader swank-reader-error.packet)
+ (cause :type reader-error :initarg :cause
+ :reader swank-reader-error.cause)))
(defun read-message (stream package)
(let ((packet (read-packet stream)))
(handler-case (values (read-form packet package))
(reader-error (c)
- (error (make-condition 'swank-reader-error :packet packet :cause c))))))
+ (error (make-condition 'swank-reader-error
+ :packet packet :cause c))))))
-;; use peek-char to detect EOF, read-sequence may return 0 instead of
-;; signaling a condition.
(defun read-packet (stream)
- (peek-char nil stream)
- (let* ((header (read-chunk stream 6))
- (length (parse-integer header :radix #x10))
- (payload (read-chunk stream length)))
- payload))
-
+ (multiple-value-bind (byte0 length) (parse-header stream)
+ (cond ((= byte0 0)
+ (let ((octets (read-chunk stream length)))
+ (handler-case (swank-backend:utf8-to-string octets)
+ (error (c)
+ (error (make-condition 'swank-reader-error
+ :packet (asciify octets)
+ :cause c))))))
+ (t
+ (error "Invalid header byte0 #b~b" byte0)))))
+
+(defun asciify (packet)
+ (with-output-to-string (*standard-output*)
+ (loop for code across (etypecase packet
+ (string (map 'vector #'char-code packet))
+ (vector packet))
+ do (cond ((<= code #x7f) (write-char (code-char code)))
+ (t (format t "\\x~x" code))))))
+
+(defun parse-header (stream)
+ (values (read-byte stream)
+ (logior (ash (read-byte stream) 16)
+ (ash (read-byte stream) 8)
+ (read-byte stream))))
+
(defun read-chunk (stream length)
- (let* ((buffer (make-string length))
+ (let* ((buffer (make-array length :element-type '(unsigned-byte 8)))
(count (read-sequence buffer stream)))
(assert (= count length) () "Short read: length=~D count=~D" length count)
buffer))
@@ -92,12 +112,33 @@
(defun write-message (message package stream)
(let* ((string (prin1-to-string-for-emacs message package))
- (length (swank-backend:codepoint-length string)))
- (let ((*print-pretty* nil))
- (format stream "~6,'0x" length))
- (write-string string stream)
+ (octets (handler-case (swank-backend:string-to-utf8 string)
+ (error (c) (encoding-error c string))))
+ (length (length octets)))
+ (write-header stream 0 length)
+ (write-sequence octets stream)
(finish-output stream)))
+;; FIXME: for now just tell emacs that we and an encoding problem.
+(defun encoding-error (condition string)
+ (swank-backend:string-to-utf8
+ (prin1-to-string-for-emacs
+ `(:reader-error
+ ,(asciify string)
+ ,(format nil "Error during string-to-utf8: ~a"
+ (or (ignore-errors (asciify (princ-to-string condition)))
+ (asciify (princ-to-string (type-of condition))))))
+ (find-package :cl))))
+
+(defun write-header (stream byte0 length)
+ (declare (type (unsigned-byte 8) byte0)
+ (type (unsigned-byte 24) length))
+ ;;(format *trace-output* "byte0: ~d length: ~d (#x~x)~%" byte0 length length)
+ (write-byte byte0 stream)
+ (write-byte (ldb (byte 8 16) length) stream)
+ (write-byte (ldb (byte 8 8) length) stream)
+ (write-byte (ldb (byte 8 0) length) stream))
+
(defun prin1-to-string-for-emacs (object package)
(with-standard-io-syntax
(let ((*print-case* :downcase)
--- /project/slime/cvsroot/slime/swank-sbcl.lisp 2011/11/06 17:05:41 1.291
+++ /project/slime/cvsroot/slime/swank-sbcl.lisp 2011/11/06 17:06:09 1.292
@@ -194,11 +194,9 @@
#-win32
(defun input-ready-p (stream)
- (let ((c (read-char-no-hang stream nil :eof)))
- (etypecase c
- (character (unread-char c stream) t)
- (null nil)
- ((member :eof) t))))
+ (sb-sys:wait-until-fd-usable (sb-impl::fd-stream-fd stream)
+ :input
+ 0))
#+win32
(progn
--- /project/slime/cvsroot/slime/swank.lisp 2011/11/06 17:05:53 1.756
+++ /project/slime/cvsroot/slime/swank.lisp 2011/11/06 17:06:09 1.757
@@ -876,10 +876,12 @@
(create-server :port port :style style :dont-close dont-close
:coding-system coding-system))
+;; FIXME: get rid of coding-system argument
(defun accept-connections (socket style coding-system dont-close)
(let* ((ef (find-external-format-or-lose coding-system))
(client (unwind-protect
- (accept-connection socket :external-format ef)
+ (accept-connection socket :external-format nil
+ :buffering t)
(unless dont-close
(close-socket socket)))))
(authenticate-client client)
@@ -1745,14 +1747,11 @@
(defun input-available-p (stream)
- ;; return true iff we can read from STREAM without waiting or if we
- ;; hit EOF
- (let ((c (read-char-no-hang stream nil :eof)))
- (cond ((not c) nil)
- ((eq c :eof) t)
- (t
- (unread-char c stream)
- t))))
+ (loop
+ (etypecase (wait-for-input (list stream) t)
+ (null (return nil))
+ (cons (return t))
+ ((member :interrupt)))))
(defvar *slime-features* nil
"The feature list that has been sent to Emacs.")
More information about the slime-cvs
mailing list