From heller at common-lisp.net Thu Nov 3 18:31:20 2011 From: heller at common-lisp.net (CVS User heller) Date: Thu, 03 Nov 2011 11:31:20 -0700 Subject: [slime-cvs] CVS slime Message-ID: Update of /project/slime/cvsroot/slime In directory tiger.common-lisp.net:/tmp/cvs-serv9961 Modified Files: ChangeLog swank-lispworks.lisp Log Message: Remove dependecy on FLEXI-STREAMS for Lispworks. * swank-lispworks.lisp (make-flexi-stream): Deleted. (utf8-stream): New class to do the transcoding. (accept-connection): Use it. --- /project/slime/cvsroot/slime/ChangeLog 2011/10/19 09:47:57 1.2220 +++ /project/slime/cvsroot/slime/ChangeLog 2011/11/03 18:31:19 1.2221 @@ -1,3 +1,11 @@ +2011-11-03 Helmut Eller + + Remove dependecy on FLEXI-STREAMS for Lispworks. + + * swank-lispworks.lisp (make-flexi-stream): Deleted. + (utf8-stream): New class to do the transcoding. + (accept-connection): Use it. + 2011-10-19 Andrew Myers * swank-allegro.lisp (frob-allegro-field-def): Add missing type to --- /project/slime/cvsroot/slime/swank-lispworks.lisp 2010/12/02 16:39:00 1.141 +++ /project/slime/cvsroot/slime/swank-lispworks.lisp 2011/11/03 18:31:19 1.142 @@ -104,23 +104,227 @@ :read-timeout timeout :element-type 'base-char)) (t - (make-flexi-stream - (make-instance 'comm:socket-stream - :socket fd - :direction :io - :read-timeout timeout - :element-type '(unsigned-byte 8)) - external-format))))) - -(defun make-flexi-stream (stream external-format) - (unless (member :flexi-streams *features*) - (error "Cannot use external format ~A without having installed flexi-streams in the inferior-lisp." - external-format)) - (funcall (read-from-string "FLEXI-STREAMS:MAKE-FLEXI-STREAM") - stream - :external-format - (apply (read-from-string "FLEXI-STREAMS:MAKE-EXTERNAL-FORMAT") - external-format))) + (assert (member (first external-format) '(:utf-8))) + (make-instance 'utf8-stream + :byte-stream + (make-instance 'comm:socket-stream + :socket fd + :direction :io + :read-timeout timeout + :element-type '(unsigned-byte 8))))))) + +(defclass utf8-stream (stream:fundamental-character-input-stream + stream:fundamental-character-output-stream) + ((byte-stream :type comm:socket-stream + :initform nil + :initarg :byte-stream + :accessor utf8-stream-byte-stream))) + +;; Helper function. Decode the next N bytes starting from INDEX. +;; Return the decoded char and the new index. +(defun utf8-decode-aux (buffer index limit byte0 n) + (declare (simple-string buffer) (fixnum index limit byte0 n)) + (if (< (- limit index) n) + (values nil index) + (do ((i 0 (1+ i)) + (code byte0 (let ((byte (char-code (schar buffer (+ index i))))) + (cond ((= (ldb (byte 2 6) byte) #b10) + (+ (ash code 6) (ldb (byte 6 0) byte))) + (t + (error "Invalid encoding")))))) + ((= i n) + (values (cond ((<= code #xff) (code-char code)) + ((<= #xdc00 code #xdbff) + (error "Invalid Unicode code point: #x~x" code)) + ((< code char-code-limit) + (code-char code)) + (t + (error + "Can't represent code point: #x~x ~ + (char-code-limit is #x~x)" + code char-code-limit))) + (+ index n)))))) + +;; Decode one character in BUFFER starting at INDEX. +;; Return 2 values: the character and the new index. +;; If there aren't enough bytes between INDEX and LIMIT return nil. +(defun utf8-decode (buffer index limit) + (declare (simple-string buffer) (fixnum index limit)) + (if (= index limit) + (values nil index) + (let ((b (char-code (schar buffer index)))) + (if (<= b #x7f) + (values (code-char b) (1+ index)) + (macrolet ((try (marker else) + (let* ((l (integer-length marker)) + (n (- l 2))) + `(if (= (ldb (byte ,l ,(- 8 l)) b) ,marker) + (utf8-decode-aux buffer (1+ index) limit + (ldb (byte ,(- 8 l) 0) b) + ,n) + ,else)))) + (try #b110 + (try #b1110 + (try #b11110 + (try #b111110 + (try #b1111110 + (error "Invalid encoding"))))))))))) + +;; Decode characters from BUFFER and write them to STRING. +;; Return 2 values: LASTINDEX and LASTSTART where +;; LASTINDEX is the last index in BUFFER that was not decoded +;; and LASTSTART is the last index in STRING not written. +(defun utf8-decode-into (buffer index limit string start end) + (declare (string string) (fixnum index limit start end)) + (loop + (cond ((= start end) + (return (values index start))) + (t + (multiple-value-bind (c i) (utf8-decode buffer index limit) + (cond (c + (setf (aref string start) c) + (setq index i) + (setq start (1+ start))) + (t + (return (values index start))))))))) + +(defmacro utf8-encode-aux (code buffer start end n) + `(cond ((< (- ,end ,start) ,n) + ,start) + (t + (setf (schar ,buffer ,start) + (code-char + (dpb (ldb (byte ,(- 7 n) ,(* 6 (1- n))) ,code) + (byte ,(- 7 n) 0) + ,(dpb 0 (byte 1 (- 7 n)) #xff)))) + ,@(loop for i from 0 upto (- n 2) collect + `(setf (schar ,buffer (+ ,start ,(- n 1 i))) + (code-char + (dpb (ldb (byte 6 ,(* 6 i)) ,code) + (byte 6 0) + #b10111111)))) + (+ ,start ,n)))) + +(defun utf8-encode (char buffer start end) + (declare (fixnum start end)) + (let ((code (char-code char))) + (cond ((<= code #x7f) + (cond ((< start end) + (setf (schar buffer start) char) + (1+ start)) + (t start))) + ((<= code #x7ff) (utf8-encode-aux code buffer start end 2)) + ((<= #xd800 code #xdfff) + (error "Invalid Unicode code point (surrogate): #x~x" code)) + ((<= code #xffff) (utf8-encode-aux code buffer start end 3)) + ((<= code #x1fffff) (utf8-encode-aux code buffer start end 4)) + ((<= code #x3ffffff) (utf8-encode-aux code buffer start end 5)) + ((<= code #x7fffffff) (utf8-encode-aux code buffer start end 6)) + (t (error "Can't encode ~s (~x)" char code))))) + +(defun utf8-encode-into (string start end buffer index limit) + (loop + (cond ((= start end) + (return (values start index))) + ((= index limit) + (return (values start index))) + (t + (let ((i2 (utf8-encode (char string start) buffer index limit))) + (cond ((= i2 index) + (return (values start index))) + (t + (setq index i2) + (incf start)))))))) + +(defun utf8-stream-read-char (stream no-hang) + (with-slots (byte-stream) stream + (loop + (stream:with-stream-input-buffer (b i l) byte-stream + (multiple-value-bind (c i2) (utf8-decode b i l) + (cond (c + (setf i i2) + (return c)) + ((and no-hang + (not (sys:wait-for-input-streams-returning-first + (list byte-stream) :timeout 0))) + (return nil)) + ((stream:stream-fill-buffer byte-stream) + #| next iteration |# ) + (t + (return :eof)))))))) + +(defmethod stream:stream-read-char ((stream utf8-stream)) + (utf8-stream-read-char stream nil)) + +(defmethod stream:stream-read-char-no-hang ((stream utf8-stream)) + (utf8-stream-read-char stream t)) + +(defmethod stream:stream-read-sequence ((stream utf8-stream) (string string) + start end) + (with-slots (byte-stream) stream + (loop + (stream:with-stream-input-buffer (b i l) byte-stream + (multiple-value-bind (i2 s2) (utf8-decode-into b i l string start end) + (setq i i2) + (setq start s2) + (cond ((= start end) + (return start)) + ((stream:stream-fill-buffer byte-stream) + #| next iteration |# ) + (t + (return start)))))))) + +(defmethod stream:stream-unread-char ((stream utf8-stream) (c character)) + (with-slots (byte-stream) stream + (stream:with-stream-input-buffer (b i l) byte-stream + (declare (ignorable l)) + (let* ((bytes (ef:encode-lisp-string (string c) :utf-8)) + (len (length bytes)) + (i2 (- i len))) + (assert (equal (utf8-decode b i2 i) c)) + (setq i i2) + nil)))) + +(defmethod stream:stream-write-char ((stream utf8-stream) (char character)) + (with-slots (byte-stream) stream + (loop + (stream:with-stream-output-buffer (b i l) byte-stream + (let ((i2 (utf8-encode char b i l))) + (cond ((< i i2) + (setf i i2) + (return char)) + ((stream:stream-flush-buffer byte-stream) + ) + (t + (error "Can't flush buffer")))))))) + +(defmethod stream:stream-write-string ((stream utf8-stream) + (string string) + &optional (start 0) + (end (length string))) + (with-slots (byte-stream) stream + (loop + (stream:with-stream-output-buffer (b i l) byte-stream + (multiple-value-bind (s2 i2) (utf8-encode-into string start end + b i l) + (setf i i2) + (setf start s2) + (cond ((= start end) + (return string)) + ((stream:stream-flush-buffer byte-stream) + ) + (t + (error "Can't flush buffer")))))))) + +(defmethod stream:stream-write-sequence ((stream utf8-stream) + seq start end) + (stream:stream-write-string seq start end)) + +(defmethod stream:stream-force-output ((stream utf8-stream)) + (with-slots (byte-stream) stream (force-output byte-stream))) + +(defmethod stream:stream-finish-output ((stream utf8-stream)) + (with-slots (byte-stream) stream (finish-output byte-stream))) ;;; Coding Systems @@ -131,13 +335,12 @@ (defvar *external-format-to-coding-system* '(((:latin-1 :eol-style :lf) "latin-1-unix" "iso-latin-1-unix" "iso-8859-1-unix") - ((:latin-1) - "latin-1" "iso-latin-1" "iso-8859-1") - ((:utf-8) "utf-8") + ;;((:latin-1) "latin-1" "iso-latin-1" "iso-8859-1") + ;;((:utf-8) "utf-8") ((:utf-8 :eol-style :lf) "utf-8-unix") - ((:euc-jp) "euc-jp") + ;;((:euc-jp) "euc-jp") ((:euc-jp :eol-style :lf) "euc-jp-unix") - ((:ascii) "us-ascii") + ;;((:ascii) "us-ascii") ((:ascii :eol-style :lf) "us-ascii-unix"))) (defimplementation find-external-format (coding-system) From heller at common-lisp.net Thu Nov 3 18:31:32 2011 From: heller at common-lisp.net (CVS User heller) Date: Thu, 03 Nov 2011 11:31:32 -0700 Subject: [slime-cvs] CVS slime Message-ID: Update of /project/slime/cvsroot/slime In directory tiger.common-lisp.net:/tmp/cvs-serv10007 Modified Files: ChangeLog swank.lisp Log Message: * swank.lisp (close-connection): Be more careful with non-ascii. --- /project/slime/cvsroot/slime/ChangeLog 2011/11/03 18:31:19 1.2221 +++ /project/slime/cvsroot/slime/ChangeLog 2011/11/03 18:31:31 1.2222 @@ -1,5 +1,9 @@ 2011-11-03 Helmut Eller + * swank.lisp (close-connection): Be more careful with non-ascii. + +2011-11-03 Helmut Eller + Remove dependecy on FLEXI-STREAMS for Lispworks. * swank-lispworks.lisp (make-flexi-stream): Deleted. --- /project/slime/cvsroot/slime/swank.lisp 2011/10/13 09:24:03 1.754 +++ /project/slime/cvsroot/slime/swank.lisp 2011/11/03 18:31:31 1.755 @@ -1073,8 +1073,9 @@ (defun close-connection (c condition backtrace) (let ((*debugger-hook* nil)) - (log-event "close-connection: ~a ...~%" condition) - (format *log-output* "~&;; swank:close-connection: ~A~%" condition) + (log-event "close-connection: ~a ...~%" condition)) + (format *log-output* "~&;; swank:close-connection: ~A~%" + (escape-non-ascii (safe-condition-message condition))) (let ((cleanup (connection.cleanup c))) (when cleanup (funcall cleanup c))) @@ -1094,15 +1095,15 @@ ;; type: ~S~%~ ;; encoding: ~A vs. ~A~%~ ;; style: ~S dedicated: ~S]~%" - backtrace + (mapcar #'escape-non-ascii (mapcar #'frame-to-string backtrace)) (escape-non-ascii (safe-condition-message condition) ) (type-of condition) (connection.coding-system c) (connection.external-format c) (connection.communication-style c) - *use-dedicated-output-stream*) - (finish-output *log-output*)) - (log-event "close-connection ~a ... done.~%" condition))) + *use-dedicated-output-stream*)) + (finish-output *log-output*) + (log-event "close-connection ~a ... done.~%" condition)) ;;;;;; Thread based communication From heller at common-lisp.net Sun Nov 6 17:03:59 2011 From: heller at common-lisp.net (CVS User heller) Date: Sun, 06 Nov 2011 09:03:59 -0800 Subject: [slime-cvs] CVS slime Message-ID: Update of /project/slime/cvsroot/slime In directory tiger.common-lisp.net:/tmp/cvs-serv10785 Modified Files: ChangeLog swank-backend.lisp Log Message: * swank-backend.lisp (utf8-to-string, string-to-utf8): New. --- /project/slime/cvsroot/slime/ChangeLog 2011/11/03 18:31:31 1.2222 +++ /project/slime/cvsroot/slime/ChangeLog 2011/11/06 17:03:59 1.2223 @@ -1,3 +1,7 @@ +2011-11-06 Helmut Eller + + * swank-backend.lisp (utf8-to-string, string-to-utf8): New. + 2011-11-03 Helmut Eller * swank.lisp (close-connection): Be more careful with non-ascii. --- /project/slime/cvsroot/slime/swank-backend.lisp 2011/06/14 15:34:18 1.206 +++ /project/slime/cvsroot/slime/swank-backend.lisp 2011/11/06 17:03:59 1.207 @@ -266,6 +266,15 @@ '(:or))) +;;;; UFT8 + +(definterface string-to-utf8 (string) + "Convert the string STRING to a (simple-array (unsigned-byte 8))") + +(definterface utf8-to-string (octets) + "Convert the (simple-array (unsigned-byte 8)) OCTETS to a string.") + + ;;;; TCP server (definterface create-socket (host port) From heller at common-lisp.net Sun Nov 6 17:04:10 2011 From: heller at common-lisp.net (CVS User heller) Date: Sun, 06 Nov 2011 09:04:10 -0800 Subject: [slime-cvs] CVS slime Message-ID: Update of /project/slime/cvsroot/slime In directory tiger.common-lisp.net:/tmp/cvs-serv10844 Modified Files: ChangeLog swank-abcl.lisp Log Message: * swank-abcl.lisp (string-to-utf8, string-to-utf8): Implemented. (octets-to-jbytes, jbytes-to-octets): New helpers. --- /project/slime/cvsroot/slime/ChangeLog 2011/11/06 17:03:59 1.2223 +++ /project/slime/cvsroot/slime/ChangeLog 2011/11/06 17:04:10 1.2224 @@ -1,5 +1,10 @@ 2011-11-06 Helmut Eller + * swank-abcl.lisp (string-to-utf8, string-to-utf8): Implemented. + (octets-to-jbytes, jbytes-to-octets): New helpers. + +2011-11-06 Helmut Eller + * swank-backend.lisp (utf8-to-string, string-to-utf8): New. 2011-11-03 Helmut Eller --- /project/slime/cvsroot/slime/swank-abcl.lisp 2011/09/27 06:06:28 1.87 +++ /project/slime/cvsroot/slime/swank-abcl.lisp 2011/11/06 17:04:10 1.88 @@ -146,6 +146,44 @@ (ext:get-socket-stream (ext:socket-accept socket) :external-format external-format)) +;;;; UTF8 + +;; faster please! +(defimplementation string-to-utf8 (s) + (jbytes-to-octets + (java:jcall + (java:jmethod "java.lang.String" "getBytes" "java.lang.String") + s + "UTF8"))) + +(defimplementation utf8-to-string (u) + (java:jnew + (java:jconstructor "org.armedbear.lisp.SimpleString" + "java.lang.String") + (java:jnew (java:jconstructor "java.lang.String" "[B" "java.lang.String") + (octets-to-jbytes u) + "UTF8"))) + +(defun octets-to-jbytes (octets) + (declare (type octets (simple-array (unsigned-byte 8) (*)))) + (let* ((len (length octets)) + (bytes (java:jnew-array "byte" len))) + (loop for byte across octets + for i from 0 + do (java:jstatic (java:jmethod "java.lang.reflect.Array" "setByte" + "java.lang.Object" "int" "byte") + "java.lang.relect.Array" + bytes i byte)) + bytes)) + +(defun jbytes-to-octets (jbytes) + (let* ((len (java:jarray-length jbytes)) + (octets (make-array len :element-type '(unsigned-byte 8)))) + (loop for i from 0 below len + for jbyte = (java:jarray-ref jbytes i) + do (setf (aref octets i) jbyte)) + octets)) + ;;;; External formats (defvar *external-format-to-coding-system* From heller at common-lisp.net Sun Nov 6 17:04:21 2011 From: heller at common-lisp.net (CVS User heller) Date: Sun, 06 Nov 2011 09:04:21 -0800 Subject: [slime-cvs] CVS slime Message-ID: Update of /project/slime/cvsroot/slime In directory tiger.common-lisp.net:/tmp/cvs-serv10887 Modified Files: ChangeLog swank-allegro.lisp Log Message: * swank-allegro.lisp (string-to-utf8, string-to-utf8): Implemented. --- /project/slime/cvsroot/slime/ChangeLog 2011/11/06 17:04:10 1.2224 +++ /project/slime/cvsroot/slime/ChangeLog 2011/11/06 17:04:21 1.2225 @@ -1,5 +1,9 @@ 2011-11-06 Helmut Eller + * swank-allegro.lisp (string-to-utf8, string-to-utf8): Implemented. + +2011-11-06 Helmut Eller + * swank-abcl.lisp (string-to-utf8, string-to-utf8): Implemented. (octets-to-jbytes, jbytes-to-octets): New helpers. --- /project/slime/cvsroot/slime/swank-allegro.lisp 2011/10/19 09:47:57 1.145 +++ /project/slime/cvsroot/slime/swank-allegro.lisp 2011/11/06 17:04:21 1.146 @@ -27,6 +27,15 @@ (documentation slot t)) +;;;; UTF8 + +(defimplementation string-to-utf8 (s) + (excl:string-to-octets s :external-format :utf8)) + +(defimplementation utf8-to-string (u) + (excl:octets-to-string u :external-format :utf8)) + + ;;;; TCP Server (defimplementation preferred-communication-style () From heller at common-lisp.net Sun Nov 6 17:04:32 2011 From: heller at common-lisp.net (CVS User heller) Date: Sun, 06 Nov 2011 09:04:32 -0800 Subject: [slime-cvs] CVS slime Message-ID: Update of /project/slime/cvsroot/slime In directory tiger.common-lisp.net:/tmp/cvs-serv10923 Modified Files: ChangeLog swank-ccl.lisp Log Message: * swank-ccl.lisp (string-to-utf8, string-to-utf8): Implemented. --- /project/slime/cvsroot/slime/ChangeLog 2011/11/06 17:04:21 1.2225 +++ /project/slime/cvsroot/slime/ChangeLog 2011/11/06 17:04:32 1.2226 @@ -1,5 +1,9 @@ 2011-11-06 Helmut Eller + * swank-ccl.lisp (string-to-utf8, string-to-utf8): Implemented. + +2011-11-06 Helmut Eller + * swank-allegro.lisp (string-to-utf8, string-to-utf8): Implemented. 2011-11-06 Helmut Eller --- /project/slime/cvsroot/slime/swank-ccl.lisp 2010/08/06 14:10:50 1.22 +++ /project/slime/cvsroot/slime/swank-ccl.lisp 2011/11/06 17:04:32 1.23 @@ -82,6 +82,13 @@ (let ((str (symbol-name sym))) `(or (find-symbol ,str :swank) (error "There is no symbol named ~a in the SWANK package" ,str)))) +;;; UTF8 + +(defimplementation string-to-utf8 (string) + (ccl:encode-string-to-octets string :external-format :utf-8)) + +(defimplementation utf8-to-string (octets) + (ccl:decode-string-from-octets octets :external-format :utf-8)) ;;; TCP Server From heller at common-lisp.net Sun Nov 6 17:04:43 2011 From: heller at common-lisp.net (CVS User heller) Date: Sun, 06 Nov 2011 09:04:43 -0800 Subject: [slime-cvs] CVS slime Message-ID: Update of /project/slime/cvsroot/slime In directory tiger.common-lisp.net:/tmp/cvs-serv10966 Modified Files: ChangeLog swank-clisp.lisp Log Message: * swank-clisp.lisp (string-to-utf8, string-to-utf8): Implemented. --- /project/slime/cvsroot/slime/ChangeLog 2011/11/06 17:04:32 1.2226 +++ /project/slime/cvsroot/slime/ChangeLog 2011/11/06 17:04:43 1.2227 @@ -1,5 +1,9 @@ 2011-11-06 Helmut Eller + * swank-clisp.lisp (string-to-utf8, string-to-utf8): Implemented. + +2011-11-06 Helmut Eller + * swank-ccl.lisp (string-to-utf8, string-to-utf8): Implemented. 2011-11-06 Helmut Eller --- /project/slime/cvsroot/slime/swank-clisp.lisp 2010/09/22 14:53:14 1.95 +++ /project/slime/cvsroot/slime/swank-clisp.lisp 2011/11/06 17:04:43 1.96 @@ -135,6 +135,20 @@ :name file :type type))))) +;;;; UTF + +(defimplementation string-to-utf8 (string) + (let ((enc (load-time-value + (ext:make-encoding :charset "utf-8" :line-terminator :unix) + t))) + (ext:convert-string-to-bytes string enc))) + +(defimplementation utf8-to-string (octets) + (let ((enc (load-time-value + (ext:make-encoding :charset "utf-8" :line-terminator :unix) + t))) + (ext:convert-string-from-bytes octets enc))) + ;;;; TCP Server (defimplementation create-socket (host port) From heller at common-lisp.net Sun Nov 6 17:04:54 2011 From: heller at common-lisp.net (CVS User heller) Date: Sun, 06 Nov 2011 09:04:54 -0800 Subject: [slime-cvs] CVS slime Message-ID: Update of /project/slime/cvsroot/slime In directory tiger.common-lisp.net:/tmp/cvs-serv11012 Modified Files: ChangeLog swank-cmucl.lisp Log Message: * swank-cmucl.lisp (string-to-utf8, string-to-utf8): Implemented. --- /project/slime/cvsroot/slime/ChangeLog 2011/11/06 17:04:43 1.2227 +++ /project/slime/cvsroot/slime/ChangeLog 2011/11/06 17:04:54 1.2228 @@ -1,5 +1,9 @@ 2011-11-06 Helmut Eller + * swank-cmucl.lisp (string-to-utf8, string-to-utf8): Implemented. + +2011-11-06 Helmut Eller + * swank-clisp.lisp (string-to-utf8, string-to-utf8): Implemented. 2011-11-06 Helmut Eller --- /project/slime/cvsroot/slime/swank-cmucl.lisp 2010/10/09 23:02:33 1.232 +++ /project/slime/cvsroot/slime/swank-cmucl.lisp 2011/11/06 17:04:54 1.233 @@ -63,6 +63,16 @@ ) (in-package :swank-backend) + +;;; UTF8 + +(defimplementation string-to-utf8 (string) + (let ((ef (load-time-value (stream::find-external-format :utf-8) t))) + (stream:string-to-octets string :external-format ef))) + +(defimplementation utf8-to-string (octets) + (let ((ef (load-time-value (stream::find-external-format :utf-8) t))) + (stream:octets-to-string octets :external-format ef))) ;;;; TCP server From heller at common-lisp.net Sun Nov 6 17:05:05 2011 From: heller at common-lisp.net (CVS User heller) Date: Sun, 06 Nov 2011 09:05:05 -0800 Subject: [slime-cvs] CVS slime Message-ID: Update of /project/slime/cvsroot/slime In directory tiger.common-lisp.net:/tmp/cvs-serv11050 Modified Files: ChangeLog swank-lispworks.lisp Log Message: * swank-lispworks.lisp (string-to-utf8, string-to-utf8): Implemented. --- /project/slime/cvsroot/slime/ChangeLog 2011/11/06 17:04:54 1.2228 +++ /project/slime/cvsroot/slime/ChangeLog 2011/11/06 17:05:05 1.2229 @@ -1,5 +1,9 @@ 2011-11-06 Helmut Eller + * swank-lispworks.lisp (string-to-utf8, string-to-utf8): Implemented. + +2011-11-06 Helmut Eller + * swank-cmucl.lisp (string-to-utf8, string-to-utf8): Implemented. 2011-11-06 Helmut Eller --- /project/slime/cvsroot/slime/swank-lispworks.lisp 2011/11/03 18:31:19 1.142 +++ /project/slime/cvsroot/slime/swank-lispworks.lisp 2011/11/06 17:05:05 1.143 @@ -62,6 +62,14 @@ :check-redefinition-p nil) ,(funcall *original-defimplementation* whole env)))) +;;; UTF8 + +(defimplementation string-to-utf8 (string) + (ef:encode-lisp-string string :utf-8)) + +(defimplementation utf8-to-string (octets) + (ef:decode-external-string octets :utf-8)) + ;;; TCP server (defimplementation preferred-communication-style () From heller at common-lisp.net Sun Nov 6 17:05:16 2011 From: heller at common-lisp.net (CVS User heller) Date: Sun, 06 Nov 2011 09:05:16 -0800 Subject: [slime-cvs] CVS slime Message-ID: Update of /project/slime/cvsroot/slime In directory tiger.common-lisp.net:/tmp/cvs-serv11095 Modified Files: ChangeLog swank-sbcl.lisp Log Message: * swank-sbcl.lisp (string-to-utf8, string-to-utf8): Implemented. --- /project/slime/cvsroot/slime/ChangeLog 2011/11/06 17:05:05 1.2229 +++ /project/slime/cvsroot/slime/ChangeLog 2011/11/06 17:05:16 1.2230 @@ -1,5 +1,9 @@ 2011-11-06 Helmut Eller + * swank-sbcl.lisp (string-to-utf8, string-to-utf8): Implemented. + +2011-11-06 Helmut Eller + * swank-lispworks.lisp (string-to-utf8, string-to-utf8): Implemented. 2011-11-06 Helmut Eller --- /project/slime/cvsroot/slime/swank-sbcl.lisp 2011/09/01 06:29:30 1.289 +++ /project/slime/cvsroot/slime/swank-sbcl.lisp 2011/11/06 17:05:16 1.290 @@ -61,6 +61,14 @@ (defimplementation getpid () (sb-posix:getpid)) +;;; UTF8 + +(defimplementation string-to-utf8 (string) + (sb-ext:string-to-octets string :external-format :utf8)) + +(defimplementation utf8-to-string (octets) + (sb-ext:octets-to-string octets :external-format :utf8)) + ;;; TCP Server (defimplementation preferred-communication-style () From heller at common-lisp.net Sun Nov 6 17:05:27 2011 From: heller at common-lisp.net (CVS User heller) Date: Sun, 06 Nov 2011 09:05:27 -0800 Subject: [slime-cvs] CVS slime Message-ID: Update of /project/slime/cvsroot/slime In directory tiger.common-lisp.net:/tmp/cvs-serv11142 Modified Files: ChangeLog swank-backend.lisp Log Message: * swank-backend.lisp (accept-connection): Improve docstring. In particular say that we want a binary stream if the EXTERNAL-FORMAT argument is nil. --- /project/slime/cvsroot/slime/ChangeLog 2011/11/06 17:05:16 1.2230 +++ /project/slime/cvsroot/slime/ChangeLog 2011/11/06 17:05:27 1.2231 @@ -1,5 +1,11 @@ 2011-11-06 Helmut Eller + * swank-backend.lisp (accept-connection): Improve docstring. In + particular say that we want a binary stream if the EXTERNAL-FORMAT + argument is nil. + +2011-11-06 Helmut Eller + * swank-sbcl.lisp (string-to-utf8, string-to-utf8): Implemented. 2011-11-06 Helmut Eller --- /project/slime/cvsroot/slime/swank-backend.lisp 2011/11/06 17:03:59 1.207 +++ /project/slime/cvsroot/slime/swank-backend.lisp 2011/11/06 17:05:27 1.208 @@ -289,7 +289,13 @@ (definterface accept-connection (socket &key external-format buffering timeout) "Accept a client connection on the listening socket SOCKET. -Return a stream for the new connection.") +Return a stream for the new connection. +If EXTERNAL-FORMAT is nil return a binary stream +otherwise create a character stream. +BUFFERING can be one of: + nil or :none ... no buffering + t or :full ... enable buffering + :line ... some buffering with autmatic flushing on eol.") (definterface add-sigio-handler (socket fn) "Call FN whenever SOCKET is readable.") From heller at common-lisp.net Sun Nov 6 17:05:41 2011 From: heller at common-lisp.net (CVS User heller) Date: Sun, 06 Nov 2011 09:05:41 -0800 Subject: [slime-cvs] CVS slime Message-ID: Update of /project/slime/cvsroot/slime In directory tiger.common-lisp.net:/tmp/cvs-serv11179 Modified Files: ChangeLog swank-abcl.lisp swank-backend.lisp swank-clisp.lisp swank-cmucl.lisp swank-lispworks.lisp swank-sbcl.lisp swank-scl.lisp Log Message: * swank-abcl.lisp (accept-connection): Make it so. * swank-clisp.lisp (accept-connection): Make it so. * swank-cmucl.lisp (accept-connection): Make it so. * swank-lispworks.lisp (accept-connection): Make it so. * swank-sbcl.lisp (accept-connection): Make it so. * swank-scl.lisp (accept-connection): Make it so. --- /project/slime/cvsroot/slime/ChangeLog 2011/11/06 17:05:27 1.2231 +++ /project/slime/cvsroot/slime/ChangeLog 2011/11/06 17:05:41 1.2232 @@ -4,39 +4,26 @@ particular say that we want a binary stream if the EXTERNAL-FORMAT argument is nil. -2011-11-06 Helmut Eller - - * swank-sbcl.lisp (string-to-utf8, string-to-utf8): Implemented. + * swank-abcl.lisp (accept-connection): Make it so. + * swank-clisp.lisp (accept-connection): Make it so. + * swank-cmucl.lisp (accept-connection): Make it so. + * swank-lispworks.lisp (accept-connection): Make it so. + * swank-sbcl.lisp (accept-connection): Make it so. + * swank-scl.lisp (accept-connection): Make it so. 2011-11-06 Helmut Eller - * swank-lispworks.lisp (string-to-utf8, string-to-utf8): Implemented. - -2011-11-06 Helmut Eller + * swank-backend.lisp (utf8-to-string, string-to-utf8): New. + * swank-sbcl.lisp (string-to-utf8, string-to-utf8): Implemented . + * swank-lispworks.lisp (string-to-utf8, string-to-utf8): Implemented. * swank-cmucl.lisp (string-to-utf8, string-to-utf8): Implemented. - -2011-11-06 Helmut Eller - * swank-clisp.lisp (string-to-utf8, string-to-utf8): Implemented. - -2011-11-06 Helmut Eller - * swank-ccl.lisp (string-to-utf8, string-to-utf8): Implemented. - -2011-11-06 Helmut Eller - * swank-allegro.lisp (string-to-utf8, string-to-utf8): Implemented. - -2011-11-06 Helmut Eller - * swank-abcl.lisp (string-to-utf8, string-to-utf8): Implemented. (octets-to-jbytes, jbytes-to-octets): New helpers. -2011-11-06 Helmut Eller - - * swank-backend.lisp (utf8-to-string, string-to-utf8): New. - 2011-11-03 Helmut Eller * swank.lisp (close-connection): Be more careful with non-ascii. --- /project/slime/cvsroot/slime/swank-abcl.lisp 2011/11/06 17:04:10 1.88 +++ /project/slime/cvsroot/slime/swank-abcl.lisp 2011/11/06 17:05:41 1.89 @@ -144,7 +144,10 @@ &key external-format buffering timeout) (declare (ignore buffering timeout)) (ext:get-socket-stream (ext:socket-accept socket) - :external-format external-format)) + :element-type (if external-format + 'character + '(unsigned-byte 8)) + :external-format (or external-format :default))) ;;;; UTF8 --- /project/slime/cvsroot/slime/swank-backend.lisp 2011/11/06 17:05:27 1.208 +++ /project/slime/cvsroot/slime/swank-backend.lisp 2011/11/06 17:05:41 1.209 @@ -292,10 +292,10 @@ Return a stream for the new connection. If EXTERNAL-FORMAT is nil return a binary stream otherwise create a character stream. -BUFFERING can be one of: - nil or :none ... no buffering - t or :full ... enable buffering - :line ... some buffering with autmatic flushing on eol.") +BUFFERING can be one of: + nil ... no buffering + t ... enable buffering + :line ... enable buffering with automatic flushing on eol.") (definterface add-sigio-handler (socket fn) "Call FN whenever SOCKET is readable.") --- /project/slime/cvsroot/slime/swank-clisp.lisp 2011/11/06 17:04:43 1.96 +++ /project/slime/cvsroot/slime/swank-clisp.lisp 2011/11/06 17:05:41 1.97 @@ -165,9 +165,11 @@ &key external-format buffering timeout) (declare (ignore buffering timeout)) (socket:socket-accept socket - :buffered nil ;; XXX should be t - :element-type 'character - :external-format external-format)) + :buffered buffering ;; XXX may not work if t + :element-type (if external-format + 'character + '(unsigned-byte 8)) + :external-format (or external-format :default))) #-win32 (defimplementation wait-for-input (streams &optional timeout) --- /project/slime/cvsroot/slime/swank-cmucl.lisp 2011/11/06 17:04:54 1.233 +++ /project/slime/cvsroot/slime/swank-cmucl.lisp 2011/11/06 17:05:41 1.234 @@ -112,8 +112,11 @@ external-format buffering timeout) (declare (ignore timeout)) (make-socket-io-stream (ext:accept-tcp-connection socket) - (or buffering :full) - (or external-format :iso-8859-1))) + (ecase buffering + (:full :full) + (:line :line) + ((:none nil) :none)) + external-format)) ;;;;; Sockets @@ -141,11 +144,15 @@ (defun make-socket-io-stream (fd buffering external-format) "Create a new input/output fd-stream for FD." - #-unicode(declare (ignore external-format)) - (sys:make-fd-stream fd :input t :output t :element-type 'base-char - :buffering buffering - #+unicode :external-format - #+unicode external-format)) + (cond ((and external-format (ext:featurep :unicode)) + (sys:make-fd-stream fd :input t :output t + :element-type '(unsigned-byte 8) + :buffering buffering + :external-format external-format)) + (t + (sys:make-fd-stream fd :input t :output t + :element-type '(unsigned-byte 8) + :buffering buffering)))) (defimplementation make-fd-stream (fd external-format) (make-socket-io-stream fd :full external-format)) --- /project/slime/cvsroot/slime/swank-lispworks.lisp 2011/11/06 17:05:05 1.143 +++ /project/slime/cvsroot/slime/swank-lispworks.lisp 2011/11/06 17:05:41 1.144 @@ -104,22 +104,29 @@ (declare (ignore buffering)) (let* ((fd (comm::get-fd-from-socket socket))) (assert (/= fd -1)) - (assert (valid-external-format-p external-format)) - (cond ((member (first external-format) '(:latin-1 :ascii)) + (cond ((not external-format) (make-instance 'comm:socket-stream :socket fd :direction :io :read-timeout timeout - :element-type 'base-char)) + :element-type '(unsigned-byte 8))) (t - (assert (member (first external-format) '(:utf-8))) - (make-instance 'utf8-stream - :byte-stream - (make-instance 'comm:socket-stream - :socket fd - :direction :io - :read-timeout timeout - :element-type '(unsigned-byte 8))))))) + (assert (valid-external-format-p external-format)) + (ecase (first external-format) + ((:latin-1 :ascii) + (make-instance 'comm:socket-stream + :socket fd + :direction :io + :read-timeout timeout + :element-type 'base-char)) + (:utf-8 + (make-instance 'utf8-stream :byte-stream + (make-instance + 'comm:socket-stream + :socket fd + :direction :io + :read-timeout timeout + :element-type '(unsigned-byte 8))))))))) (defclass utf8-stream (stream:fundamental-character-input-stream stream:fundamental-character-output-stream) --- /project/slime/cvsroot/slime/swank-sbcl.lisp 2011/11/06 17:05:16 1.290 +++ /project/slime/cvsroot/slime/swank-sbcl.lisp 2011/11/06 17:05:41 1.291 @@ -103,9 +103,11 @@ external-format buffering timeout) (declare (ignore timeout)) - (make-socket-io-stream (accept socket) - (or external-format :iso-latin-1-unix) - (or buffering :full))) + (make-socket-io-stream (accept socket) external-format + (ecase buffering + ((t :full) :full) + ((nil :none) :none) + ((:line) :line)))) #-win32 (defimplementation install-sigint-handler (function) @@ -281,22 +283,25 @@ *external-format-to-coding-system*))) (defun make-socket-io-stream (socket external-format buffering) - (sb-bsd-sockets:socket-make-stream socket - :output t - :input t - :element-type 'character - :buffering buffering - #+sb-unicode :external-format - #+sb-unicode external-format - :serve-events - (eq :fd-handler - ;; KLUDGE: SWANK package isn't - ;; available when backend is loaded. - (symbol-value - (intern "*COMMUNICATION-STYLE*" :swank))) - ;; SBCL < 1.0.42.43 doesn't support :SERVE-EVENTS - ;; argument. - :allow-other-keys t)) + (let ((args `(,@() + :output t + :input t + :element-type ,(if external-format + 'character + '(unsigned-byte 8)) + :buffering ,buffering + ,@(cond ((and external-format (sb-int:featurep :sb-unicode)) + `(:external-format ,external-format)) + (t '())) + :serve-events ,(eq :fd-handler + ;; KLUDGE: SWANK package isn't + ;; available when backend is loaded. + (symbol-value + (intern "*COMMUNICATION-STYLE*" :swank))) + ;; SBCL < 1.0.42.43 doesn't support :SERVE-EVENTS + ;; argument. + :allow-other-keys t))) + (apply #'sb-bsd-sockets:socket-make-stream socket args))) (defun accept (socket) "Like socket-accept, but retry on EAGAIN." --- /project/slime/cvsroot/slime/swank-scl.lisp 2010/05/06 06:18:32 1.37 +++ /project/slime/cvsroot/slime/swank-scl.lisp 2011/11/06 17:05:41 1.38 @@ -38,8 +38,7 @@ (defimplementation accept-connection (socket &key external-format buffering timeout) - (let ((external-format (or external-format :default)) - (buffering (or buffering :full)) + (let ((buffering (or buffering :full)) (fd (socket-fd socket))) (loop (let ((ready (sys:wait-until-fd-usable fd :input timeout))) @@ -47,7 +46,11 @@ (error "Timeout accepting connection on socket: ~S~%" socket))) (let ((new-fd (ignore-errors (ext:accept-tcp-connection fd)))) (when new-fd - (return (make-socket-io-stream new-fd external-format buffering))))))) + (return (make-socket-io-stream new-fd external-format + (ecase buffering + ((t) :full) + ((nil) :none) + (:line :line))))))))) (defimplementation set-stream-timeout (stream timeout) (check-type timeout (or null real)) @@ -82,15 +85,22 @@ (defun make-socket-io-stream (fd external-format buffering) "Create a new input/output fd-stream for 'fd." - (let* ((stream (sys:make-fd-stream fd :input t :output t - :element-type 'base-char - :buffering buffering - :external-format external-format))) - ;; Ignore character conversion errors. Without this the communication - ;; channel is prone to lockup if a character conversion error occurs. - (setf (lisp::character-conversion-stream-input-error-value stream) #\?) - (setf (lisp::character-conversion-stream-output-error-value stream) #\?) - stream)) + (cond ((not external-format) + (sys:make-fd-stream fd :input t :output t :buffering buffering + :element-type '(unsigned-byte 8))) + (t + (let* ((stream (sys:make-fd-stream fd :input t :output t + :element-type 'base-char + :buffering buffering + :external-format external-format))) + ;; Ignore character conversion errors. Without this the + ;; communication channel is prone to lockup if a character + ;; conversion error occurs. + (setf (lisp::character-conversion-stream-input-error-value stream) + #\?) + (setf (lisp::character-conversion-stream-output-error-value stream) + #\?) + stream)))) ;;;; Stream handling From heller at common-lisp.net Sun Nov 6 17:05:53 2011 From: heller at common-lisp.net (CVS User heller) Date: Sun, 06 Nov 2011 09:05:53 -0800 Subject: [slime-cvs] CVS slime Message-ID: Update of /project/slime/cvsroot/slime In directory tiger.common-lisp.net:/tmp/cvs-serv11262 Modified Files: ChangeLog swank.lisp Log Message: * swank.lisp (close-connection): Fix thinko. --- /project/slime/cvsroot/slime/ChangeLog 2011/11/06 17:05:41 1.2232 +++ /project/slime/cvsroot/slime/ChangeLog 2011/11/06 17:05:52 1.2233 @@ -1,5 +1,9 @@ 2011-11-06 Helmut Eller + * swank.lisp (close-connection): Fix thinko. + +2011-11-06 Helmut Eller + * swank-backend.lisp (accept-connection): Improve docstring. In particular say that we want a binary stream if the EXTERNAL-FORMAT argument is nil. --- /project/slime/cvsroot/slime/swank.lisp 2011/11/03 18:31:31 1.755 +++ /project/slime/cvsroot/slime/swank.lisp 2011/11/06 17:05:53 1.756 @@ -1095,7 +1095,8 @@ ;; type: ~S~%~ ;; encoding: ~A vs. ~A~%~ ;; style: ~S dedicated: ~S]~%" - (mapcar #'escape-non-ascii (mapcar #'frame-to-string backtrace)) + (loop for (i f) in backtrace collect + (ignore-errors (format nil "~d: ~a" i (escape-non-ascii f)))) (escape-non-ascii (safe-condition-message condition) ) (type-of condition) (connection.coding-system c) From heller at common-lisp.net Sun Nov 6 17:06:09 2011 From: heller at common-lisp.net (CVS User heller) Date: Sun, 06 Nov 2011 09:06:09 -0800 Subject: [slime-cvs] CVS slime Message-ID: 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 + 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 + * swank.lisp (close-connection): Fix thinko. 2011-11-06 Helmut Eller --- /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.") From heller at common-lisp.net Sun Nov 6 17:06:20 2011 From: heller at common-lisp.net (CVS User heller) Date: Sun, 06 Nov 2011 09:06:20 -0800 Subject: [slime-cvs] CVS slime Message-ID: Update of /project/slime/cvsroot/slime In directory tiger.common-lisp.net:/tmp/cvs-serv11367 Modified Files: ChangeLog swank-allegro.lisp Log Message: * swank-allegro.lisp (swank-compile-string): For reader errors return nil not (values nil nil t). --- /project/slime/cvsroot/slime/ChangeLog 2011/11/06 17:06:08 1.2234 +++ /project/slime/cvsroot/slime/ChangeLog 2011/11/06 17:06:19 1.2235 @@ -1,5 +1,10 @@ 2011-11-06 Helmut Eller + * swank-allegro.lisp (swank-compile-string): For reader errors + return nil not (values nil nil t). + +2011-11-06 Helmut Eller + New wire format. Switch from character streams to binary streams. Counting @@ -26,6 +31,7 @@ (slime-unibyte-string, slime-handle-net-read-error): New. (featurep): Require 'un-define for XEmacs. ([test] break): Longer timeouts. + (slime-run-test): Renamed from slime-run-one-test. * swank-sbcl.lisp (input-ready-p): Use sb-sys:wait-until-fd-usable. --- /project/slime/cvsroot/slime/swank-allegro.lisp 2011/11/06 17:04:21 1.146 +++ /project/slime/cvsroot/slime/swank-allegro.lisp 2011/11/06 17:06:20 1.147 @@ -30,10 +30,12 @@ ;;;; UTF8 (defimplementation string-to-utf8 (s) - (excl:string-to-octets s :external-format :utf8)) + (let ((ef (load-time-value (excl:find-external-format :utf-8) t))) + (excl:string-to-octets s :external-format ef))) (defimplementation utf8-to-string (u) - (excl:octets-to-string u :external-format :utf8)) + (let ((ef (load-time-value (excl:find-external-format :utf-8) t))) + (excl:octets-to-string u :external-format ef))) ;;;; TCP Server @@ -471,7 +473,7 @@ (merge-pathnames (pathname filename)) *default-pathname-defaults*))) (compile-from-temp-file string buffer position filename))) - (reader-error () (values nil nil t)))) + (reader-error () nil))) ;;;; Definition Finding From heller at common-lisp.net Sun Nov 6 17:06:31 2011 From: heller at common-lisp.net (CVS User heller) Date: Sun, 06 Nov 2011 09:06:31 -0800 Subject: [slime-cvs] CVS slime Message-ID: Update of /project/slime/cvsroot/slime In directory tiger.common-lisp.net:/tmp/cvs-serv11411 Modified Files: ChangeLog swank-lispworks.lisp Log Message: Add portable versions for string-to-utf8 and utf8-to-string. * swank-backend.lisp (default-string-to-utf8) (default-utf8-to-string): New. (string-to-utf8, utf8-to-string): Use default implementations. * swank-lispworks.lisp (make-flexi-stream): Restored. (utf8-stream): Deleted. The utf8 stuff is now used for the default implementation of utf8-to-string and would cause name clashes. --- /project/slime/cvsroot/slime/ChangeLog 2011/11/06 17:06:19 1.2235 +++ /project/slime/cvsroot/slime/ChangeLog 2011/11/06 17:06:30 1.2236 @@ -1,5 +1,18 @@ 2011-11-06 Helmut Eller + Add portable versions for string-to-utf8 and utf8-to-string. + + * swank-backend.lisp (default-string-to-utf8) + (default-utf8-to-string): New. + (string-to-utf8, utf8-to-string): Use default implementations. + + * swank-lispworks.lisp (make-flexi-stream): Restored. + (utf8-stream): Deleted. The utf8 stuff is now used for the + default implementation of utf8-to-string and would cause name + clashes. + +2011-11-06 Helmut Eller + * swank-allegro.lisp (swank-compile-string): For reader errors return nil not (values nil nil t). --- /project/slime/cvsroot/slime/swank-lispworks.lisp 2011/11/06 17:05:41 1.144 +++ /project/slime/cvsroot/slime/swank-lispworks.lisp 2011/11/06 17:06:30 1.145 @@ -120,226 +120,24 @@ :read-timeout timeout :element-type 'base-char)) (:utf-8 - (make-instance 'utf8-stream :byte-stream - (make-instance - 'comm:socket-stream + (make-flexi-stream + (make-instance 'comm:socket-stream :socket fd :direction :io :read-timeout timeout - :element-type '(unsigned-byte 8))))))))) + :element-type '(unsigned-byte 8)) + external-format))))))) -(defclass utf8-stream (stream:fundamental-character-input-stream - stream:fundamental-character-output-stream) - ((byte-stream :type comm:socket-stream - :initform nil - :initarg :byte-stream - :accessor utf8-stream-byte-stream))) - -;; Helper function. Decode the next N bytes starting from INDEX. -;; Return the decoded char and the new index. -(defun utf8-decode-aux (buffer index limit byte0 n) - (declare (simple-string buffer) (fixnum index limit byte0 n)) - (if (< (- limit index) n) - (values nil index) - (do ((i 0 (1+ i)) - (code byte0 (let ((byte (char-code (schar buffer (+ index i))))) - (cond ((= (ldb (byte 2 6) byte) #b10) - (+ (ash code 6) (ldb (byte 6 0) byte))) - (t - (error "Invalid encoding")))))) - ((= i n) - (values (cond ((<= code #xff) (code-char code)) - ((<= #xdc00 code #xdbff) - (error "Invalid Unicode code point: #x~x" code)) - ((< code char-code-limit) - (code-char code)) - (t - (error - "Can't represent code point: #x~x ~ - (char-code-limit is #x~x)" - code char-code-limit))) - (+ index n)))))) - -;; Decode one character in BUFFER starting at INDEX. -;; Return 2 values: the character and the new index. -;; If there aren't enough bytes between INDEX and LIMIT return nil. -(defun utf8-decode (buffer index limit) - (declare (simple-string buffer) (fixnum index limit)) - (if (= index limit) - (values nil index) - (let ((b (char-code (schar buffer index)))) - (if (<= b #x7f) - (values (code-char b) (1+ index)) - (macrolet ((try (marker else) - (let* ((l (integer-length marker)) - (n (- l 2))) - `(if (= (ldb (byte ,l ,(- 8 l)) b) ,marker) - (utf8-decode-aux buffer (1+ index) limit - (ldb (byte ,(- 8 l) 0) b) - ,n) - ,else)))) - (try #b110 - (try #b1110 - (try #b11110 - (try #b111110 - (try #b1111110 - (error "Invalid encoding"))))))))))) - -;; Decode characters from BUFFER and write them to STRING. -;; Return 2 values: LASTINDEX and LASTSTART where -;; LASTINDEX is the last index in BUFFER that was not decoded -;; and LASTSTART is the last index in STRING not written. -(defun utf8-decode-into (buffer index limit string start end) - (declare (string string) (fixnum index limit start end)) - (loop - (cond ((= start end) - (return (values index start))) - (t - (multiple-value-bind (c i) (utf8-decode buffer index limit) - (cond (c - (setf (aref string start) c) - (setq index i) - (setq start (1+ start))) - (t - (return (values index start))))))))) - -(defmacro utf8-encode-aux (code buffer start end n) - `(cond ((< (- ,end ,start) ,n) - ,start) - (t - (setf (schar ,buffer ,start) - (code-char - (dpb (ldb (byte ,(- 7 n) ,(* 6 (1- n))) ,code) - (byte ,(- 7 n) 0) - ,(dpb 0 (byte 1 (- 7 n)) #xff)))) - ,@(loop for i from 0 upto (- n 2) collect - `(setf (schar ,buffer (+ ,start ,(- n 1 i))) - (code-char - (dpb (ldb (byte 6 ,(* 6 i)) ,code) - (byte 6 0) - #b10111111)))) - (+ ,start ,n)))) - -(defun utf8-encode (char buffer start end) - (declare (fixnum start end)) - (let ((code (char-code char))) - (cond ((<= code #x7f) - (cond ((< start end) - (setf (schar buffer start) char) - (1+ start)) - (t start))) - ((<= code #x7ff) (utf8-encode-aux code buffer start end 2)) - ((<= #xd800 code #xdfff) - (error "Invalid Unicode code point (surrogate): #x~x" code)) - ((<= code #xffff) (utf8-encode-aux code buffer start end 3)) - ((<= code #x1fffff) (utf8-encode-aux code buffer start end 4)) - ((<= code #x3ffffff) (utf8-encode-aux code buffer start end 5)) - ((<= code #x7fffffff) (utf8-encode-aux code buffer start end 6)) - (t (error "Can't encode ~s (~x)" char code))))) - -(defun utf8-encode-into (string start end buffer index limit) - (loop - (cond ((= start end) - (return (values start index))) - ((= index limit) - (return (values start index))) - (t - (let ((i2 (utf8-encode (char string start) buffer index limit))) - (cond ((= i2 index) - (return (values start index))) - (t - (setq index i2) - (incf start)))))))) - -(defun utf8-stream-read-char (stream no-hang) - (with-slots (byte-stream) stream - (loop - (stream:with-stream-input-buffer (b i l) byte-stream - (multiple-value-bind (c i2) (utf8-decode b i l) - (cond (c - (setf i i2) - (return c)) - ((and no-hang - (not (sys:wait-for-input-streams-returning-first - (list byte-stream) :timeout 0))) - (return nil)) - ((stream:stream-fill-buffer byte-stream) - #| next iteration |# ) - (t - (return :eof)))))))) - -(defmethod stream:stream-read-char ((stream utf8-stream)) - (utf8-stream-read-char stream nil)) - -(defmethod stream:stream-read-char-no-hang ((stream utf8-stream)) - (utf8-stream-read-char stream t)) - -(defmethod stream:stream-read-sequence ((stream utf8-stream) (string string) - start end) - (with-slots (byte-stream) stream - (loop - (stream:with-stream-input-buffer (b i l) byte-stream - (multiple-value-bind (i2 s2) (utf8-decode-into b i l string start end) - (setq i i2) - (setq start s2) - (cond ((= start end) - (return start)) - ((stream:stream-fill-buffer byte-stream) - #| next iteration |# ) - (t - (return start)))))))) - -(defmethod stream:stream-unread-char ((stream utf8-stream) (c character)) - (with-slots (byte-stream) stream - (stream:with-stream-input-buffer (b i l) byte-stream - (declare (ignorable l)) - (let* ((bytes (ef:encode-lisp-string (string c) :utf-8)) - (len (length bytes)) - (i2 (- i len))) - (assert (equal (utf8-decode b i2 i) c)) - (setq i i2) - nil)))) - -(defmethod stream:stream-write-char ((stream utf8-stream) (char character)) - (with-slots (byte-stream) stream - (loop - (stream:with-stream-output-buffer (b i l) byte-stream - (let ((i2 (utf8-encode char b i l))) - (cond ((< i i2) - (setf i i2) - (return char)) - ((stream:stream-flush-buffer byte-stream) - ) - (t - (error "Can't flush buffer")))))))) - -(defmethod stream:stream-write-string ((stream utf8-stream) - (string string) - &optional (start 0) - (end (length string))) - (with-slots (byte-stream) stream - (loop - (stream:with-stream-output-buffer (b i l) byte-stream - (multiple-value-bind (s2 i2) (utf8-encode-into string start end - b i l) - (setf i i2) - (setf start s2) - (cond ((= start end) - (return string)) - ((stream:stream-flush-buffer byte-stream) - ) - (t - (error "Can't flush buffer")))))))) - -(defmethod stream:stream-write-sequence ((stream utf8-stream) - seq start end) - (stream:stream-write-string seq start end)) - -(defmethod stream:stream-force-output ((stream utf8-stream)) - (with-slots (byte-stream) stream (force-output byte-stream))) - -(defmethod stream:stream-finish-output ((stream utf8-stream)) - (with-slots (byte-stream) stream (finish-output byte-stream))) +(defun make-flexi-stream (stream external-format) + (unless (member :flexi-streams *features*) + (error "Cannot use external format ~A~ + without having installed flexi-streams in the inferior-lisp." + external-format)) + (funcall (read-from-string "FLEXI-STREAMS:MAKE-FLEXI-STREAM") + stream + :external-format + (apply (read-from-string "FLEXI-STREAMS:MAKE-EXTERNAL-FORMAT") + external-format))) ;;; Coding Systems From heller at common-lisp.net Sun Nov 6 17:06:35 2011 From: heller at common-lisp.net (CVS User heller) Date: Sun, 06 Nov 2011 09:06:35 -0800 Subject: [slime-cvs] CVS slime Message-ID: Update of /project/slime/cvsroot/slime In directory tiger.common-lisp.net:/tmp/cvs-serv11449 Modified Files: swank-backend.lisp Log Message: Forgot this file in last commit. --- /project/slime/cvsroot/slime/swank-backend.lisp 2011/11/06 17:06:09 1.210 +++ /project/slime/cvsroot/slime/swank-backend.lisp 2011/11/06 17:06:35 1.211 @@ -268,11 +268,167 @@ ;;;; UFT8 +(deftype octet () '(unsigned-byte 8)) +(deftype octets () '(simple-array octet (*))) + +;; Helper function. Decode the next N bytes starting from INDEX. +;; Return the decoded char and the new index. +(defun utf8-decode-aux (buffer index limit byte0 n) + (declare (type octets buffer) (fixnum index limit byte0 n)) + (if (< (- limit index) n) + (values nil index) + (do ((i 0 (1+ i)) + (code byte0 (let ((byte (aref buffer (+ index i)))) + (cond ((= (ldb (byte 2 6) byte) #b10) + (+ (ash code 6) (ldb (byte 6 0) byte))) + (t + (error "Invalid encoding")))))) + ((= i n) + (values (cond ((<= code #xff) (code-char code)) + ((<= #xd800 code #xdfff) + (error "Invalid Unicode code point: #x~x" code)) + ((and (< code char-code-limit) + (code-char code))) + (t + (error + "Can't represent code point: #x~x ~ + (char-code-limit is #x~x)" + code char-code-limit))) + (+ index n)))))) + +;; Decode one character in BUFFER starting at INDEX. +;; Return 2 values: the character and the new index. +;; If there aren't enough bytes between INDEX and LIMIT return nil. +(defun utf8-decode (buffer index limit) + (declare (type octets buffer) (fixnum index limit)) + (if (= index limit) + (values nil index) + (let ((b (aref buffer index))) + (if (<= b #x7f) + (values (code-char b) (1+ index)) + (macrolet ((try (marker else) + (let* ((l (integer-length marker)) + (n (- l 2))) + `(if (= (ldb (byte ,l ,(- 8 l)) b) ,marker) + (utf8-decode-aux buffer (1+ index) limit + (ldb (byte ,(- 8 l) 0) b) + ,n) + ,else)))) + (try #b110 + (try #b1110 + (try #b11110 + (try #b111110 + (try #b1111110 + (error "Invalid encoding"))))))))))) + +;; Decode characters from BUFFER and write them to STRING. +;; Return 2 values: LASTINDEX and LASTSTART where +;; LASTINDEX is the last index in BUFFER that was not decoded +;; and LASTSTART is the last index in STRING not written. +(defun utf8-decode-into (buffer index limit string start end) + (declare (string string) (fixnum index limit start end) (type octets buffer)) + (loop + (cond ((= start end) + (return (values index start))) + (t + (multiple-value-bind (c i) (utf8-decode buffer index limit) + (cond (c + (setf (aref string start) c) + (setq index i) + (setq start (1+ start))) + (t + (return (values index start))))))))) + +(defun default-utf8-to-string (octets) + (let* ((limit (length octets)) + (str (make-string limit))) + (multiple-value-bind (i s) (utf8-decode-into octets 0 limit str 0 limit) + (if (= i limit) + (if (= limit s) + str + (adjust-array str s)) + (loop + (let ((end (+ (length str) (- limit i)))) + (setq str (adjust-array str end)) + (multiple-value-bind (i2 s2) + (utf8-decode-into octets i limit str s end) + (cond ((= i2 limit) + (return (adjust-array str s2))) + (t + (setq i i2) + (setq s s2)))))))))) + +(defmacro utf8-encode-aux (code buffer start end n) + `(cond ((< (- ,end ,start) ,n) + ,start) + (t + (setf (aref ,buffer ,start) + (dpb (ldb (byte ,(- 7 n) ,(* 6 (1- n))) ,code) + (byte ,(- 7 n) 0) + ,(dpb 0 (byte 1 (- 7 n)) #xff))) + ,@(loop for i from 0 upto (- n 2) collect + `(setf (aref ,buffer (+ ,start ,(- n 1 i))) + (dpb (ldb (byte 6 ,(* 6 i)) ,code) + (byte 6 0) + #b10111111))) + (+ ,start ,n)))) + +(defun utf8-encode (char buffer start end) + (declare (character char) (type octets buffer) (fixnum start end)) + (let ((code (char-code char))) + (cond ((<= code #x7f) + (cond ((< start end) + (setf (aref buffer start) code) + (1+ start)) + (t start))) + ((<= code #x7ff) (utf8-encode-aux code buffer start end 2)) + ((<= #xd800 code #xdfff) + (error "Invalid Unicode code point (surrogate): #x~x" code)) + ((<= code #xffff) (utf8-encode-aux code buffer start end 3)) + ((<= code #x1fffff) (utf8-encode-aux code buffer start end 4)) + ((<= code #x3ffffff) (utf8-encode-aux code buffer start end 5)) + ((<= code #x7fffffff) (utf8-encode-aux code buffer start end 6)) + (t (error "Can't encode ~s (~x)" char code))))) + +(defun utf8-encode-into (string start end buffer index limit) + (declare (string string) (type octets buffer) (fixnum start end index limit)) + (loop + (cond ((= start end) + (return (values start index))) + ((= index limit) + (return (values start index))) + (t + (let ((i2 (utf8-encode (char string start) buffer index limit))) + (cond ((= i2 index) + (return (values start index))) + (t + (setq index i2) + (incf start)))))))) + +(defun default-string-to-utf8 (string) + (let* ((len (length string)) + (b (make-array len :element-type 'octet))) + (multiple-value-bind (s i) (utf8-encode-into string 0 len b 0 len) + (if (= s len) + b + (loop + (let ((limit (+ (length b) (- len s)))) + (setq b (coerce (adjust-array b limit) 'octets)) + (multiple-value-bind (s2 i2) + (utf8-encode-into string s len b i limit) + (cond ((= s2 len) + (return (coerce (adjust-array b i2) 'octets))) + (t + (setq i i2) + (setq s s2)))))))))) + (definterface string-to-utf8 (string) - "Convert the string STRING to a (simple-array (unsigned-byte 8))") + "Convert the string STRING to a (simple-array (unsigned-byte 8))" + (default-string-to-utf8 string)) (definterface utf8-to-string (octets) - "Convert the (simple-array (unsigned-byte 8)) OCTETS to a string.") + "Convert the (simple-array (unsigned-byte 8)) OCTETS to a string." + (default-utf8-to-string octets)) ;;;; TCP server @@ -1214,13 +1370,6 @@ 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 (when (check-slime-interrupts) (return :interrupt)) From heller at common-lisp.net Sun Nov 6 17:06:50 2011 From: heller at common-lisp.net (CVS User heller) Date: Sun, 06 Nov 2011 09:06:50 -0800 Subject: [slime-cvs] CVS slime Message-ID: Update of /project/slime/cvsroot/slime In directory tiger.common-lisp.net:/tmp/cvs-serv11474 Modified Files: ChangeLog slime.el swank.lisp Log Message: * slime.el (slime-run-test): Renamed from slime-run-one-test. (slime-toggle-test-debug-on-error): New. ([test] break): Longer timeouts. --- /project/slime/cvsroot/slime/ChangeLog 2011/11/06 17:06:30 1.2236 +++ /project/slime/cvsroot/slime/ChangeLog 2011/11/06 17:06:49 1.2237 @@ -1,5 +1,11 @@ 2011-11-06 Helmut Eller + * slime.el (slime-run-test): Renamed from slime-run-one-test. + (slime-toggle-test-debug-on-error): New. + ([test] break): Longer timeouts. + +2011-11-06 Helmut Eller + Add portable versions for string-to-utf8 and utf8-to-string. * swank-backend.lisp (default-string-to-utf8) @@ -43,8 +49,6 @@ (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. - (slime-run-test): Renamed from slime-run-one-test. * swank-sbcl.lisp (input-ready-p): Use sb-sys:wait-until-fd-usable. --- /project/slime/cvsroot/slime/slime.el 2011/11/06 17:06:09 1.1377 +++ /project/slime/cvsroot/slime/slime.el 2011/11/06 17:06:49 1.1378 @@ -7370,7 +7370,7 @@ (goto-char (overlay-start o)) (show-subtree))))) -(defun slime-run-one-test (name) +(defun slime-run-test (name) "Ask for the name of a test and then execute the test." (interactive (list (slime-read-test-name))) (let ((test (find name slime-tests :key #'slime-test.name))) @@ -7378,6 +7378,12 @@ (let ((slime-tests (list test))) (slime-run-tests)))) +(defun slime-toggle-test-debug-on-error () + (interactive) + (setq slime-test-debug-on-error (not slime-test-debug-on-error)) + (message "slime-test-debug-on-error is now %s" + (if slime-test-debug-on-error "enabled" "disabled"))) + (defun slime-read-test-name () (let ((alist (mapcar (lambda (test) (list (symbol-name (slime-test.name test)))) @@ -8272,20 +8278,21 @@ (slime-eval-async `(cl:eval (cl:read-from-string ,(prin1-to-string `(dotimes (i ,times) - ,exp - (swank::sleep-for 0.2)))))) + (unless (= i 0) + (swank::sleep-for 1)) + ,exp))))) (dotimes (i times) (slime-wait-condition "Debugger visible" (lambda () (and (slime-sldb-level= 1) - (get-buffer-window + (get-buffer-window (sldb-get-default-buffer)))) 3) (with-current-buffer (sldb-get-default-buffer) (sldb-continue)) (slime-wait-condition "sldb closed" (lambda () (not (sldb-get-default-buffer))) - 1)) + 0.5)) (slime-sync-to-top-level 1)) (def-slime-test (break2 (:fails-for "cmucl" "allegro" "ccl")) --- /project/slime/cvsroot/slime/swank.lisp 2011/11/06 17:06:09 1.757 +++ /project/slime/cvsroot/slime/swank.lisp 2011/11/06 17:06:49 1.758 @@ -3927,6 +3927,7 @@ (spawn #'perform-it :name "indentation-update-thread") (perform-it))))) +;; FIXME: too complicated (defun update-indentation/delta-for-emacs (cache &optional force) "Update the cache and return the changes in a (SYMBOL INDENT PACKAGES) list. If FORCE is true then check all symbols, otherwise only check symbols From heller at common-lisp.net Sun Nov 6 17:39:29 2011 From: heller at common-lisp.net (CVS User heller) Date: Sun, 06 Nov 2011 09:39:29 -0800 Subject: [slime-cvs] CVS slime Message-ID: Update of /project/slime/cvsroot/slime In directory tiger.common-lisp.net:/tmp/cvs-serv17099 Modified Files: ChangeLog swank-cmucl.lisp Log Message: * swank-cmucl.lisp (accept-connection): Fix buffering arg. --- /project/slime/cvsroot/slime/ChangeLog 2011/11/06 17:06:49 1.2237 +++ /project/slime/cvsroot/slime/ChangeLog 2011/11/06 17:39:29 1.2238 @@ -1,5 +1,9 @@ 2011-11-06 Helmut Eller + * swank-cmucl.lisp (accept-connection): Fix buffering arg. + +2011-11-06 Helmut Eller + * slime.el (slime-run-test): Renamed from slime-run-one-test. (slime-toggle-test-debug-on-error): New. ([test] break): Longer timeouts. --- /project/slime/cvsroot/slime/swank-cmucl.lisp 2011/11/06 17:05:41 1.234 +++ /project/slime/cvsroot/slime/swank-cmucl.lisp 2011/11/06 17:39:29 1.235 @@ -113,9 +113,9 @@ (declare (ignore timeout)) (make-socket-io-stream (ext:accept-tcp-connection socket) (ecase buffering - (:full :full) + ((t) :full) (:line :line) - ((:none nil) :none)) + ((nil) :none)) external-format)) ;;;;; Sockets From heller at common-lisp.net Sun Nov 6 18:34:51 2011 From: heller at common-lisp.net (CVS User heller) Date: Sun, 06 Nov 2011 10:34:51 -0800 Subject: [slime-cvs] CVS slime Message-ID: Update of /project/slime/cvsroot/slime In directory tiger.common-lisp.net:/tmp/cvs-serv25548 Modified Files: ChangeLog swank-ecl.lisp Log Message: * swank-ecl.lisp (accept-connection): Fix buffering arg. * swank-cmucl.lisp (accept-connection): Fix buffering arg. --- /project/slime/cvsroot/slime/ChangeLog 2011/11/06 17:39:29 1.2238 +++ /project/slime/cvsroot/slime/ChangeLog 2011/11/06 18:34:51 1.2239 @@ -1,5 +1,6 @@ 2011-11-06 Helmut Eller + * swank-ecl.lisp (accept-connection): Fix buffering arg. * swank-cmucl.lisp (accept-connection): Fix buffering arg. 2011-11-06 Helmut Eller --- /project/slime/cvsroot/slime/swank-ecl.lisp 2011/06/05 13:29:19 1.69 +++ /project/slime/cvsroot/slime/swank-ecl.lisp 2011/11/06 18:34:51 1.70 @@ -84,7 +84,10 @@ (sb-bsd-sockets:socket-make-stream (accept socket) :output t :input t - :buffering buffering + :buffering (ecase buffering + ((t) :full) + ((nil) :none) + (:line line)) :external-format external-format)) (defun accept (socket) "Like socket-accept, but retry on EAGAIN." From heller at common-lisp.net Tue Nov 8 08:15:34 2011 From: heller at common-lisp.net (CVS User heller) Date: Tue, 08 Nov 2011 00:15:34 -0800 Subject: [slime-cvs] CVS slime Message-ID: Update of /project/slime/cvsroot/slime In directory tiger.common-lisp.net:/tmp/cvs-serv27582 Modified Files: ChangeLog slime.el swank-rpc.lisp Log Message: Restore old header format. * swank-rpc.lisp (parse-header, write-header) * slime.el (slime-net-decode-length, slime-net-encode-length) --- /project/slime/cvsroot/slime/ChangeLog 2011/11/06 18:34:51 1.2239 +++ /project/slime/cvsroot/slime/ChangeLog 2011/11/08 08:15:34 1.2240 @@ -1,3 +1,10 @@ +2011-11-08 Helmut Eller + + Restore old header format. + + * swank-rpc.lisp (parse-header, write-header) + * slime.el (slime-net-decode-length, slime-net-encode-length) + 2011-11-06 Helmut Eller * swank-ecl.lisp (accept-connection): Fix buffering arg. --- /project/slime/cvsroot/slime/slime.el 2011/11/06 17:06:49 1.1378 +++ /project/slime/cvsroot/slime/slime.el 2011/11/08 08:15:34 1.1379 @@ -1476,16 +1476,10 @@ ;;; This section covers the low-level networking: establishing ;;; connections and encoding/decoding protocol messages. ;;; -;;; Each SLIME protocol message beings with a 4-byte header followed +;;; Each SLIME protocol message beings with a 6-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 @@ -1570,8 +1564,7 @@ (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)) + (string (concat (slime-net-encode-length (length payload)) payload))) (slime-log-event sexp) (process-send-string proc string))) @@ -1632,8 +1625,8 @@ (defun slime-net-have-input-p () "Return true if a complete message is available." (goto-char (point-min)) - (and (>= (buffer-size) 4) - (>= (- (buffer-size) 4) (slime-net-decode-length)))) + (and (>= (buffer-size) 6) + (>= (- (buffer-size) 6) (slime-net-decode-length)))) (defun slime-run-when-idle (function &rest args) "Call FUNCTION as soon as Emacs is idle." @@ -1664,7 +1657,7 @@ "Read a message from the network buffer." (goto-char (point-min)) (let* ((length (slime-net-decode-length)) - (start (+ (point) 4)) + (start (+ (point) 6)) (end (+ start length))) (assert (plusp length)) (prog1 (save-restriction @@ -1679,18 +1672,11 @@ (delete-region (point-min) end)))) (defun slime-net-decode-length () - "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))) + (string-to-number (buffer-substring-no-properties (point) (+ (point) 6)) + 16)) (defun slime-net-encode-length (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))) + (format "%06x" n)) (defun slime-prin1-to-string (sexp) "Like `prin1-to-string' but don't octal-escape non-ascii characters. --- /project/slime/cvsroot/slime/swank-rpc.lisp 2011/11/06 17:06:09 1.8 +++ /project/slime/cvsroot/slime/swank-rpc.lisp 2011/11/08 08:15:34 1.9 @@ -36,16 +36,13 @@ :packet packet :cause c)))))) (defun read-packet (stream) - (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))))) + (let* ((length (parse-header stream)) + (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)))))) (defun asciify (packet) (with-output-to-string (*standard-output*) @@ -56,11 +53,9 @@ (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)))) - + (parse-integer (map 'string #'code-char (read-chunk stream 6)) + :radix 16)) + (defun read-chunk (stream length) (let* ((buffer (make-array length :element-type '(unsigned-byte 8))) (count (read-sequence buffer stream))) @@ -115,7 +110,7 @@ (octets (handler-case (swank-backend:string-to-utf8 string) (error (c) (encoding-error c string)))) (length (length octets))) - (write-header stream 0 length) + (write-header stream length) (write-sequence octets stream) (finish-output stream))) @@ -130,14 +125,11 @@ (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 write-header (stream length) + (declare (type (unsigned-byte 24) length)) + ;;(format *trace-output* "length: ~d (#x~x)~%" length length) + (loop for c across (format nil "~6,'0x" length) + do (write-byte (char-code c) stream))) (defun prin1-to-string-for-emacs (object package) (with-standard-io-syntax From nsiivola at common-lisp.net Sat Nov 12 12:01:52 2011 From: nsiivola at common-lisp.net (CVS User nsiivola) Date: Sat, 12 Nov 2011 04:01:52 -0800 Subject: [slime-cvs] CVS slime/contrib Message-ID: Update of /project/slime/cvsroot/slime/contrib In directory tiger.common-lisp.net:/tmp/cvs-serv26473/contrib Modified Files: ChangeLog slime-cl-indent-test.txt slime-cl-indent.el Log Message: slime-indent: DEFMETHOD indentation when the name is a SETF-name and qualifiers are present * slime-cl-indent.el (lisp-beginning-of-defmethod-qualifiers): Renamed from `lisp-beginning-of-defmethod'. Skip the method name as well, since unlike qualifiers it can be list -- eg. (setf foo). (lisp-indent-defmethod): Use the above to get the number of skips right. * slime-cl-indent-test.txt: Tests 64 and 65. --- /project/slime/cvsroot/slime/contrib/ChangeLog 2011/10/31 09:46:16 1.503 +++ /project/slime/cvsroot/slime/contrib/ChangeLog 2011/11/12 12:01:52 1.504 @@ -1,3 +1,15 @@ +2011-11-12 Nikodemus Siivola + + Fix DEFMETHOD indentation when the name is a SETF-name, and qualifiers + are present. + + * slime-cl-indent.el (lisp-beginning-of-defmethod-qualifiers): Renamed + from `lisp-beginning-of-defmethod'. Skip the method name as well, since + unlike qualifiers it can be list -- eg. (setf foo). + (lisp-indent-defmethod): Use the above to get the number of skips right. + + * slime-cl-indent-test.txt: Tests 64 and 65. + 2011-10-31 Nikodemus Siivola * slime-cl-indent.el (common-lisp-run-indentation-tests): Make it --- /project/slime/cvsroot/slime/contrib/slime-cl-indent-test.txt 2011/10/31 09:45:45 1.12 +++ /project/slime/cvsroot/slime/contrib/slime-cl-indent-test.txt 2011/11/12 12:01:52 1.13 @@ -667,3 +667,22 @@ do (foo foo) ;; comment inside clause (bar)) + + +;;; Test: 64 +;; +;; lisp-lambda-list-keyword-parameter-alignment: t +;; lisp-lambda-list-keyword-alignment: t + +(defmethod (setf foo) :around (zot &key x + y) + (list zot)) + +;;; Test: 65 +;; +;; lisp-lambda-list-keyword-parameter-alignment: t +;; lisp-lambda-list-keyword-alignment: t + +(defmethod (setf foo) + :around (zot &key x y) + (list zot)) --- /project/slime/cvsroot/slime/contrib/slime-cl-indent.el 2011/10/31 09:46:16 1.53 +++ /project/slime/cvsroot/slime/contrib/slime-cl-indent.el 2011/11/12 12:01:52 1.54 @@ -1182,23 +1182,30 @@ (t 2))))) (elt state 1))) -(defun lisp-beginning-of-defmethod () - (let ((regexp "(defmethod\\|(DEFMETHOD\\|(:method\\|(:METHOD") - (ok nil)) - (while (and (not (setq ok (looking-at regexp))) +(defun lisp-beginning-of-defmethod-qualifiers () + (let ((regexp-1 "(defmethod\\|(DEFMETHOD") + (regexp-2 "(:method\\|(:METHOD")) + (while (and (not (or (looking-at regexp-1) + (looking-at regexp-2))) (ignore-errors (backward-up-list) t))) - ok)) + (cond ((looking-at regexp-1) + (forward-char) + ;; Skip name. + (forward-sexp 2) + 1) + ((looking-at regexp-2) + (forward-char) + (forward-sexp 1) + 0)))) ;; LISP-INDENT-DEFMETHOD now supports the presence of more than one method ;; qualifier and indents the method's lambda list properly. -- dvl (defun lisp-indent-defmethod (path state indent-point sexp-column normal-indent) (lisp-indent-259 - (let ((nskip 0)) + (let ((nskip nil)) (if (save-excursion - (when (lisp-beginning-of-defmethod) - (forward-char) - (forward-sexp 1) + (when (setq nskip (lisp-beginning-of-defmethod-qualifiers)) (skip-chars-forward " \t\n") (while (looking-at "\\sw\\|\\s_") (incf nskip) From sboukarev at common-lisp.net Sat Nov 12 14:43:02 2011 From: sboukarev at common-lisp.net (CVS User sboukarev) Date: Sat, 12 Nov 2011 06:43:02 -0800 Subject: [slime-cvs] CVS slime Message-ID: Update of /project/slime/cvsroot/slime In directory tiger.common-lisp.net:/tmp/cvs-serv17511 Modified Files: ChangeLog slime.el Log Message: * slime.el (slime-ed): add bytep argument to destructure-case. When it's true, position is interpreted as byte offset. * contrib/swank-fancy-inspector.lisp (make-pathname-ispec): Use :position instead of :charpos, according to slime-ed interface. Add :bytep t, telling slime-ed to interpret it as byte offset. --- /project/slime/cvsroot/slime/ChangeLog 2011/11/08 08:15:34 1.2240 +++ /project/slime/cvsroot/slime/ChangeLog 2011/11/12 14:43:01 1.2241 @@ -1,3 +1,8 @@ +2011-11-11 Anton Kovalenko + + * slime.el (slime-ed): add bytep argument to destructure-case. + When it's true, position is interpreted as byte offset. + 2011-11-08 Helmut Eller Restore old header format. --- /project/slime/cvsroot/slime/slime.el 2011/11/08 08:15:34 1.1379 +++ /project/slime/cvsroot/slime/slime.el 2011/11/12 14:43:01 1.1380 @@ -4117,11 +4117,14 @@ (select-frame slime-ed-frame)) (when what (destructure-case what - ((:filename file &key line column position) + ((:filename file &key line column position bytep) (find-file (slime-from-lisp-filename file)) (when line (slime-goto-line line)) (when column (move-to-column column)) - (when position (goto-char position))) + (when position + (goto-char (if bytep + (byte-to-position position) + position)))) ((:function-name name) (slime-edit-definition name))))) From sboukarev at common-lisp.net Sat Nov 12 14:43:02 2011 From: sboukarev at common-lisp.net (CVS User sboukarev) Date: Sat, 12 Nov 2011 06:43:02 -0800 Subject: [slime-cvs] CVS slime/contrib Message-ID: Update of /project/slime/cvsroot/slime/contrib In directory tiger.common-lisp.net:/tmp/cvs-serv17511/contrib Modified Files: ChangeLog swank-fancy-inspector.lisp Log Message: * slime.el (slime-ed): add bytep argument to destructure-case. When it's true, position is interpreted as byte offset. * contrib/swank-fancy-inspector.lisp (make-pathname-ispec): Use :position instead of :charpos, according to slime-ed interface. Add :bytep t, telling slime-ed to interpret it as byte offset. --- /project/slime/cvsroot/slime/contrib/ChangeLog 2011/11/12 12:01:52 1.504 +++ /project/slime/cvsroot/slime/contrib/ChangeLog 2011/11/12 14:43:02 1.505 @@ -10,6 +10,12 @@ * slime-cl-indent-test.txt: Tests 64 and 65. +2011-11-11 Anton Kovalenko + + * swank-fancy-inspector.lisp (make-pathname-ispec): Use :position + instead of :charpos, according to slime-ed interface. Add :bytep + t, telling slime-ed to interpret it as byte offset. + 2011-10-31 Nikodemus Siivola * slime-cl-indent.el (common-lisp-run-indentation-tests): Make it --- /project/slime/cvsroot/slime/contrib/swank-fancy-inspector.lisp 2010/12/09 19:55:57 1.30 +++ /project/slime/cvsroot/slime/contrib/swank-fancy-inspector.lisp 2011/11/12 14:43:02 1.31 @@ -828,7 +828,7 @@ (:newline) " " ,@(when position `((:action "[visit file and show current position]" - ,(lambda () (ed-in-emacs `(,pathname :charpos ,position))) + ,(lambda () (ed-in-emacs `(,pathname :position ,position :bytep t))) :refreshp nil) (:newline))))) From sboukarev at common-lisp.net Wed Nov 16 10:01:19 2011 From: sboukarev at common-lisp.net (CVS User sboukarev) Date: Wed, 16 Nov 2011 02:01:19 -0800 Subject: [slime-cvs] CVS slime Message-ID: Update of /project/slime/cvsroot/slime In directory tiger.common-lisp.net:/tmp/cvs-serv17495 Modified Files: ChangeLog swank.lisp Log Message: * swank.lisp (open-dedicated-output-stream): Open a stream with the right coding system. Change (:open-dedicated-output-stream port) message to (:open-dedicated-output-stream port coding-system), because Emacs can no longer determine the coding system based on the main network streams since they are binary now. * contrib/slime-repl.el (slime-open-stream-to-lisp): Set the process coding system to the right coding system. --- /project/slime/cvsroot/slime/ChangeLog 2011/11/12 14:43:01 1.2241 +++ /project/slime/cvsroot/slime/ChangeLog 2011/11/16 10:01:18 1.2242 @@ -1,3 +1,12 @@ +2011-11-16 Stas Boukarev + + * swank.lisp (open-dedicated-output-stream): Open a stream with + the right coding system. + Change (:open-dedicated-output-stream port) message to + (:open-dedicated-output-stream port coding-system), because Emacs + can no longer determine the coding system based on the main + network streams since they are binary now. + 2011-11-11 Anton Kovalenko * slime.el (slime-ed): add bytep argument to destructure-case. --- /project/slime/cvsroot/slime/swank.lisp 2011/11/06 17:06:49 1.758 +++ /project/slime/cvsroot/slime/swank.lisp 2011/11/16 10:01:18 1.759 @@ -876,14 +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 nil - :buffering t) - (unless dont-close - (close-socket socket))))) + (let ((client (unwind-protect + (accept-connection socket :external-format nil + :buffering t) + (unless dont-close + (close-socket socket))))) (authenticate-client client) (serve-requests (make-connection socket client style coding-system)))) @@ -931,8 +929,7 @@ "Abort reading input from Emacs.") (read-user-input-from-emacs))))) (dedicated-output (if *use-dedicated-output-stream* - (open-dedicated-output-stream - (connection.socket-io connection)))) + (open-dedicated-output-stream connection))) (in (make-input-stream input-fn)) (out (or dedicated-output (make-output-stream (make-output-function connection)))) @@ -981,7 +978,7 @@ "Create a stream that sends output to a specific TARGET in Emacs." (make-output-stream (make-output-function-for-target connection target))) -(defun open-dedicated-output-stream (socket-io) +(defun open-dedicated-output-stream (connection) "Open a dedicated output connection to the Emacs on SOCKET-IO. Return an output stream suitable for writing program output. @@ -990,12 +987,15 @@ *dedicated-output-stream-port*))) (unwind-protect (let ((port (local-port socket))) - (encode-message `(:open-dedicated-output-stream ,port) socket-io) + (encode-message `(:open-dedicated-output-stream + ,port + ,(connection.coding-system connection)) + (connection.socket-io connection)) (let ((dedicated (accept-connection socket :external-format - (or (ignore-errors - (stream-external-format socket-io)) + (or (find-external-format + (connection.coding-system connection)) :default) :buffering *dedicated-output-stream-buffering* :timeout 30))) From sboukarev at common-lisp.net Wed Nov 16 10:01:19 2011 From: sboukarev at common-lisp.net (CVS User sboukarev) Date: Wed, 16 Nov 2011 02:01:19 -0800 Subject: [slime-cvs] CVS slime/contrib Message-ID: Update of /project/slime/cvsroot/slime/contrib In directory tiger.common-lisp.net:/tmp/cvs-serv17495/contrib Modified Files: ChangeLog slime-repl.el Log Message: * swank.lisp (open-dedicated-output-stream): Open a stream with the right coding system. Change (:open-dedicated-output-stream port) message to (:open-dedicated-output-stream port coding-system), because Emacs can no longer determine the coding system based on the main network streams since they are binary now. * contrib/slime-repl.el (slime-open-stream-to-lisp): Set the process coding system to the right coding system. --- /project/slime/cvsroot/slime/contrib/ChangeLog 2011/11/12 14:43:02 1.505 +++ /project/slime/cvsroot/slime/contrib/ChangeLog 2011/11/16 10:01:19 1.506 @@ -1,3 +1,8 @@ +2011-11-16 Stas Boukarev + + * slime-repl.el (slime-open-stream-to-lisp): Set the process coding system + to the right coding system. + 2011-11-12 Nikodemus Siivola Fix DEFMETHOD indentation when the name is a SETF-name, and qualifiers --- /project/slime/cvsroot/slime/contrib/slime-repl.el 2011/10/07 12:50:20 1.57 +++ /project/slime/cvsroot/slime/contrib/slime-repl.el 2011/11/16 10:01:19 1.58 @@ -180,15 +180,14 @@ (defvar slime-open-stream-hooks) -(defun slime-open-stream-to-lisp (port) +(defun slime-open-stream-to-lisp (port coding-system) (let ((stream (open-network-stream "*lisp-output-stream*" (slime-with-connection-buffer () (current-buffer)) slime-lisp-host port))) (slime-set-query-on-exit-flag stream) (set-process-filter stream 'slime-output-filter) - (let ((pcs (process-coding-system (slime-current-connection)))) - (set-process-coding-system stream (car pcs) (cdr pcs))) + (set-process-coding-system stream coding-system coding-system) (when-let (secret (slime-secret)) (slime-net-send secret stream)) (run-hook-with-args 'slime-open-stream-hooks stream) @@ -1678,8 +1677,8 @@ ((:read-aborted thread tag) (slime-repl-abort-read thread tag) t) - ((:open-dedicated-output-stream port) - (slime-open-stream-to-lisp port) + ((:open-dedicated-output-stream port coding-system) + (slime-open-stream-to-lisp port coding-system) t) ((:new-package package prompt-string) (setf (slime-lisp-package) package) From nsiivola at common-lisp.net Sat Nov 19 16:35:58 2011 From: nsiivola at common-lisp.net (CVS User nsiivola) Date: Sat, 19 Nov 2011 08:35:58 -0800 Subject: [slime-cvs] CVS slime Message-ID: Update of /project/slime/cvsroot/slime In directory tiger.common-lisp.net:/tmp/cvs-serv19433 Modified Files: ChangeLog swank-sbcl.lisp Log Message: sbcl: restart-frame can restart anon and lexical functions now ...at least when the stars and entry points align. --- /project/slime/cvsroot/slime/ChangeLog 2011/11/16 10:01:18 1.2242 +++ /project/slime/cvsroot/slime/ChangeLog 2011/11/19 16:35:58 1.2243 @@ -1,3 +1,8 @@ +2011-11-19 Nikodemus Siivola + + * swank-sbcl.lisp (restart-frame): Make it possible to restart + frames of anonymous functions -- at least some of the time. + 2011-11-16 Stas Boukarev * swank.lisp (open-dedicated-output-stream): Open a stream with --- /project/slime/cvsroot/slime/swank-sbcl.lisp 2011/11/06 17:06:09 1.292 +++ /project/slime/cvsroot/slime/swank-sbcl.lisp 2011/11/19 16:35:58 1.293 @@ -1284,18 +1284,23 @@ (lambda () (values-list values))))) (t (format nil "Cannot return from frame: ~S" frame))))) - + (defimplementation restart-frame (index) - (let* ((frame (nth-frame index))) - (cond ((sb-debug:frame-has-debug-tag-p frame) - (let* ((call-list (sb-debug::frame-call-as-list frame)) - (fun (fdefinition (car call-list))) - (thunk (lambda () - ;; Ensure that the thunk gets tail-call-optimized - (declare (optimize (debug 1))) - (apply fun (cdr call-list))))) - (sb-debug:unwind-to-frame-and-call frame thunk))) - (t (format nil "Cannot restart frame: ~S" frame)))))) + (let ((frame (nth-frame index))) + (when (sb-debug:frame-has-debug-tag-p frame) + (multiple-value-bind (fname args) (sb-debug::frame-call frame) + (multiple-value-bind (fun arglist) + (if (and (sb-int:legal-fun-name-p fname) (fboundp fname)) + (values (fdefinition fname) args) + (values (sb-di:debug-fun-fun (sb-di:frame-debug-fun frame)) + (sb-debug::frame-args-as-list frame))) + (when (functionp fun) + (sb-debug:unwind-to-frame-and-call frame + (lambda () + ;; Ensure TCO. + (declare (optimize (debug 0))) + (apply fun arglist))))))) + (format nil "Cannot restart frame: ~S" frame)))) ;; FIXME: this implementation doesn't unwind the stack before ;; re-invoking the function, but it's better than no implementation at From nsiivola at common-lisp.net Sat Nov 19 16:41:33 2011 From: nsiivola at common-lisp.net (CVS User nsiivola) Date: Sat, 19 Nov 2011 08:41:33 -0800 Subject: [slime-cvs] CVS slime/contrib Message-ID: Update of /project/slime/cvsroot/slime/contrib In directory tiger.common-lisp.net:/tmp/cvs-serv20815/contrib Modified Files: ChangeLog slime-cl-indent.el Log Message: slime-indentation: add !def-debug-command to "sbcl" style --- /project/slime/cvsroot/slime/contrib/ChangeLog 2011/11/16 10:01:19 1.506 +++ /project/slime/cvsroot/slime/contrib/ChangeLog 2011/11/19 16:41:33 1.507 @@ -1,3 +1,7 @@ +2011-11-19 Nikodemus Siivola + + * slime-cl-indent.el ("sbcl"): Add indentation alias for !def-debug-command. + 2011-11-16 Stas Boukarev * slime-repl.el (slime-open-stream-to-lisp): Set the process coding system --- /project/slime/cvsroot/slime/contrib/slime-cl-indent.el 2011/11/12 12:01:52 1.54 +++ /project/slime/cvsroot/slime/contrib/slime-cl-indent.el 2011/11/19 16:41:33 1.55 @@ -482,7 +482,8 @@ (def!type (as deftype)) (defmacro-mundanely (as defmacro)) (define-source-transform (as defun)) - (!def-type-translator (as defun)))) + (!def-type-translator (as defun)) + (!def-debug-command (as defun)))) (defcustom common-lisp-style-default nil "Name of the Common Lisp indentation style to use in lisp-mode buffers if From heller at common-lisp.net Mon Nov 21 16:34:12 2011 From: heller at common-lisp.net (CVS User heller) Date: Mon, 21 Nov 2011 08:34:12 -0800 Subject: [slime-cvs] CVS slime Message-ID: Update of /project/slime/cvsroot/slime In directory tiger.common-lisp.net:/tmp/cvs-serv10973 Modified Files: ChangeLog slime.el swank-backend.lisp swank-cmucl.lisp swank.lisp Log Message: * slime.el (sldb-eval-in-frame): Try to figure the package out. Ask Lisp if the function for frame was defined in a particular package and use it to read the form. (sldb-read-form-for-frame): New helper. * swank-backend (frame-package): New. * swank-cmucl (frame-package): Implement it. * swank.lisp (frame-package-name, eval-in-frame-aux): New. (eval-string-in-frame, pprint-eval-string-in-frame): Use package argument. --- /project/slime/cvsroot/slime/ChangeLog 2011/11/19 16:35:58 1.2243 +++ /project/slime/cvsroot/slime/ChangeLog 2011/11/21 16:34:12 1.2244 @@ -3,6 +3,20 @@ * swank-sbcl.lisp (restart-frame): Make it possible to restart frames of anonymous functions -- at least some of the time. +2011-11-21 Helmut Eller + + * slime.el (sldb-eval-in-frame): Try to figure the package out. + Ask Lisp if the function for frame was defined in a particular + package and use it to read the form. + (sldb-read-form-for-frame): New helper. + + * swank-backend (frame-package): New. + * swank-cmucl (frame-package): Implement it. + + * swank.lisp (frame-package-name, eval-in-frame-aux): New. + (eval-string-in-frame, pprint-eval-string-in-frame): Use package + argument. + 2011-11-16 Stas Boukarev * swank.lisp (open-dedicated-output-stream): Open a stream with --- /project/slime/cvsroot/slime/slime.el 2011/11/12 14:43:01 1.1380 +++ /project/slime/cvsroot/slime/slime.el 2011/11/21 16:34:12 1.1381 @@ -5891,22 +5891,29 @@ ;;;;;; SLDB eval and inspect -(defun sldb-eval-in-frame (string) +(defun sldb-eval-in-frame (frame string package) "Prompt for an expression and evaluate it in the selected frame." - (interactive (list (slime-read-from-minibuffer "Eval in frame: "))) - (let* ((number (sldb-frame-number-at-point))) - (slime-eval-async `(swank:eval-string-in-frame ,string ,number) - (if current-prefix-arg - 'slime-write-string - 'slime-display-eval-result)))) + (interactive (sldb-read-form-for-frame "Eval in frame (%s)> ")) + (slime-eval-async `(swank:eval-string-in-frame ,string ,frame ,package) + (if current-prefix-arg + 'slime-write-string + 'slime-display-eval-result))) -(defun sldb-pprint-eval-in-frame (string) +(defun sldb-pprint-eval-in-frame (frame string package) "Prompt for an expression, evaluate in selected frame, pretty-print result." - (interactive (list (slime-read-from-minibuffer "Eval in frame: "))) - (let* ((number (sldb-frame-number-at-point))) - (slime-eval-async `(swank:pprint-eval-string-in-frame ,string ,number) - (lambda (result) - (slime-show-description result nil))))) + (interactive (sldb-read-form-for-frame "Eval in frame (%s)> ")) + (slime-eval-async + `(swank:pprint-eval-string-in-frame ,string ,frame ,package) + (lambda (result) + (slime-show-description result nil)))) + +(defun sldb-read-form-for-frame (fstring) + (let* ((frame (sldb-frame-number-at-point)) + (pkg (slime-eval `(swank:frame-package-name ,frame)))) + (list frame + (let ((slime-buffer-package pkg)) + (slime-read-from-minibuffer (format fstring pkg))) + pkg))) (defun sldb-inspect-in-frame (string) "Prompt for an expression and inspect it in the selected frame." --- /project/slime/cvsroot/slime/swank-backend.lisp 2011/11/06 17:06:35 1.211 +++ /project/slime/cvsroot/slime/swank-backend.lisp 2011/11/21 16:34:12 1.212 @@ -949,6 +949,12 @@ The return value is the result of evaulating FORM in the appropriate context.") +(definterface frame-package (frame-number) + "Return the package corresponding to the frame at FRAME-NUMBER. +Return nil if the backend can't figure it out." + (declare (ignore frame-number)) + nil) + (definterface frame-call (frame-number) "Return a string representing a call to the entry point of a frame.") --- /project/slime/cvsroot/slime/swank-cmucl.lisp 2011/11/06 17:39:29 1.235 +++ /project/slime/cvsroot/slime/swank-cmucl.lisp 2011/11/21 16:34:12 1.236 @@ -1641,6 +1641,17 @@ (defimplementation frame-catch-tags (index) (mapcar #'car (di:frame-catches (nth-frame index)))) +(defimplementation frame-package (frame-number) + (let* ((frame (nth-frame frame-number)) + (dbg-fun (di:frame-debug-function frame))) + (typecase dbg-fun + (di::compiled-debug-function + (let* ((comp (di::compiled-debug-function-component dbg-fun)) + (dbg-info (kernel:%code-debug-info comp))) + (typecase dbg-info + (c::compiled-debug-info + (find-package (c::compiled-debug-info-package dbg-info))))))))) + (defimplementation return-from-frame (index form) (let ((sym (find-symbol (string 'find-debug-tag-for-frame) :debug-internals))) --- /project/slime/cvsroot/slime/swank.lisp 2011/11/16 10:01:18 1.759 +++ /project/slime/cvsroot/slime/swank.lisp 2011/11/21 16:34:12 1.760 @@ -1919,8 +1919,8 @@ `(call-with-buffer-syntax ,package (lambda () , at body))) (defun call-with-buffer-syntax (package fun) - (let ((*package* (if package - (guess-buffer-package package) + (let ((*package* (if package + (guess-buffer-package package) *buffer-package*))) ;; Don't shadow *readtable* unnecessarily because that prevents ;; the user from assigning to it. @@ -2727,15 +2727,21 @@ `(let ((*sldb-level* ,*sldb-level*)) ,form)) -(defslimefun eval-string-in-frame (string index) - (values-to-string - (eval-in-frame (wrap-sldb-vars (from-string string)) - index))) - -(defslimefun pprint-eval-string-in-frame (string index) - (swank-pprint - (multiple-value-list - (eval-in-frame (wrap-sldb-vars (from-string string)) index)))) +(defun eval-in-frame-aux (frame string package print) + (with-buffer-syntax (package) + (let ((form (wrap-sldb-vars (parse-string string package)))) + (funcall print (multiple-value-list (eval-in-frame form frame)))))) + +(defslimefun eval-string-in-frame (string frame package) + (eval-in-frame-aux frame string package #'format-values-for-echo-area)) + +(defslimefun pprint-eval-string-in-frame (string frame package) + (eval-in-frame-aux frame string package #'swank-pprint)) + +(defslimefun frame-package-name (frame) + (let ((pkg (frame-package frame))) + (cond (pkg (package-name pkg)) + (t (with-buffer-syntax () (package-name *package*)))))) (defslimefun frame-locals-and-catch-tags (index) "Return a list (LOCALS TAGS) for vars and catch tags in the frame INDEX. From heller at common-lisp.net Mon Nov 21 19:46:11 2011 From: heller at common-lisp.net (CVS User heller) Date: Mon, 21 Nov 2011 11:46:11 -0800 Subject: [slime-cvs] CVS slime Message-ID: Update of /project/slime/cvsroot/slime In directory tiger.common-lisp.net:/tmp/cvs-serv16855 Modified Files: ChangeLog swank.lisp Log Message: * swank.lisp (*sldb-printer-bindings*): Removed. Rather useless since the change from 2009-02-26. It could at best have some influence on the way conditions are printed. *sldb-string-length* and *sldb-bitvector-length* where both nil so *sldb-pprint-dispatch-table* was also not used by default. In summary, spending 3 pages for something that's not used by default was pretty silly. One variable less where we can get the defaults wrong. --- /project/slime/cvsroot/slime/ChangeLog 2011/11/21 16:34:12 1.2244 +++ /project/slime/cvsroot/slime/ChangeLog 2011/11/21 19:46:11 1.2245 @@ -1,7 +1,13 @@ -2011-11-19 Nikodemus Siivola +2011-11-21 Helmut Eller - * swank-sbcl.lisp (restart-frame): Make it possible to restart - frames of anonymous functions -- at least some of the time. + * swank.lisp (*sldb-printer-bindings*): Removed. Rather useless + since the change from 2009-02-26. It could at best have some + influence on the way conditions are printed. *sldb-string-length* + and *sldb-bitvector-length* where both nil so + *sldb-pprint-dispatch-table* was also not used by default. In + summary, spending 3 pages for something that's not used by default + was pretty silly. One variable less where we can get the defaults + wrong. 2011-11-21 Helmut Eller @@ -17,6 +23,11 @@ (eval-string-in-frame, pprint-eval-string-in-frame): Use package argument. +2011-11-19 Nikodemus Siivola + + * swank-sbcl.lisp (restart-frame): Make it possible to restart + frames of anonymous functions -- at least some of the time. + 2011-11-16 Stas Boukarev * swank.lisp (open-dedicated-output-stream): Open a stream with --- /project/slime/cvsroot/slime/swank.lisp 2011/11/21 16:34:12 1.760 +++ /project/slime/cvsroot/slime/swank.lisp 2011/11/21 19:46:11 1.761 @@ -42,7 +42,6 @@ #:*backtrace-printer-bindings* #:*default-worker-thread-bindings* #:*macroexpand-printer-bindings* - #:*sldb-printer-bindings* #:*swank-pprint-bindings* #:*record-repl-results* #:*inspector-verbose* @@ -92,62 +91,6 @@ (defvar *swank-debug-p* t "When true, print extra debugging information.") -;;;;; SLDB customized pprint dispatch table -;;; -;;; CLHS 22.1.3.4, and CLHS 22.1.3.6 do not specify *PRINT-LENGTH* to -;;; affect the printing of strings and bit-vectors. -;;; -;;; We use a customized pprint dispatch table to do it for us. - -(defvar *sldb-string-length* nil) -(defvar *sldb-bitvector-length* nil) - -(defvar *sldb-pprint-dispatch-table* - (let ((initial-table (copy-pprint-dispatch nil)) - (result-table (copy-pprint-dispatch nil))) - (flet ((sldb-bitvector-pprint (stream bitvector) - ;;; Truncate bit-vectors according to *SLDB-BITVECTOR-LENGTH*. - (if (not *sldb-bitvector-length*) - (write bitvector :stream stream :circle nil - :pprint-dispatch initial-table) - (loop initially (write-string "#*" stream) - for i from 0 and bit across bitvector do - (when (= i *sldb-bitvector-length*) - (write-string "..." stream) - (loop-finish)) - (write-char (if (= bit 0) #\0 #\1) stream)))) - (sldb-string-pprint (stream string) - ;;; Truncate strings according to *SLDB-STRING-LENGTH*. - (cond ((not *print-escape*) - (write-string string stream)) - ((not *sldb-string-length*) - (write string :stream stream :circle nil - :pprint-dispatch initial-table)) - (t - (escape-string string stream - :length *sldb-string-length*))))) - (set-pprint-dispatch 'bit-vector #'sldb-bitvector-pprint 0 result-table) - (set-pprint-dispatch 'string #'sldb-string-pprint 0 result-table) - result-table))) - -(defvar *sldb-printer-bindings* - `((*print-pretty* . t) - (*print-level* . 4) - (*print-length* . 10) - (*print-circle* . t) - (*print-readably* . nil) - (*print-pprint-dispatch* . ,*sldb-pprint-dispatch-table*) - (*print-gensym* . t) - (*print-base* . 10) - (*print-radix* . nil) - (*print-array* . t) - (*print-lines* . nil) - (*print-escape* . t) - (*print-right-margin* . 65) - (*sldb-bitvector-length* . 25) - (*sldb-string-length* . 50)) - "A set of printer variables used in the debugger.") - (defvar *backtrace-pprint-dispatch-table* (let ((table (copy-pprint-dispatch nil))) (flet ((print-string (stream string) @@ -2545,18 +2488,15 @@ (force-user-output) (call-with-debugging-environment (lambda () - ;; We used to have (WITH-BINDING *SLDB-PRINTER-BINDINGS* ...) - ;; here, but that truncated the result of an eval-in-frame. (sldb-loop *sldb-level*))))) (defun sldb-loop (level) (unwind-protect (loop (with-simple-restart (abort "Return to sldb level ~D." level) - (send-to-emacs + (send-to-emacs (list* :debug (current-thread-id) level - (with-bindings *sldb-printer-bindings* - (debugger-info-for-emacs 0 *sldb-initial-frames*)))) + (debugger-info-for-emacs 0 *sldb-initial-frames*))) (send-to-emacs (list :debug-activate (current-thread-id) level nil)) (loop From heller at common-lisp.net Mon Nov 21 19:52:25 2011 From: heller at common-lisp.net (CVS User heller) Date: Mon, 21 Nov 2011 11:52:25 -0800 Subject: [slime-cvs] CVS slime Message-ID: Update of /project/slime/cvsroot/slime In directory tiger.common-lisp.net:/tmp/cvs-serv17458 Modified Files: ChangeLog swank-cmucl.lisp Log Message: * swank-cmucl.lisp: Trigger compilation of utf8 stuff before first real use. --- /project/slime/cvsroot/slime/ChangeLog 2011/11/21 19:46:11 1.2245 +++ /project/slime/cvsroot/slime/ChangeLog 2011/11/21 19:52:25 1.2246 @@ -1,5 +1,10 @@ 2011-11-21 Helmut Eller + * swank-cmucl.lisp: Trigger compilation of utf8 stuff before first + real use. + +2011-11-21 Helmut Eller + * swank.lisp (*sldb-printer-bindings*): Removed. Rather useless since the change from 2009-02-26. It could at best have some influence on the way conditions are printed. *sldb-string-length* --- /project/slime/cvsroot/slime/swank-cmucl.lisp 2011/11/21 16:34:12 1.236 +++ /project/slime/cvsroot/slime/swank-cmucl.lisp 2011/11/21 19:52:25 1.237 @@ -66,6 +66,11 @@ ;;; UTF8 +(locally (declare (ext:inhibit-warnings 3)) + (stream:octets-to-string + (stream:string-to-octets "compile utf8 transcoder" :external-format :utf-8) + :external-format :utf-8)) + (defimplementation string-to-utf8 (string) (let ((ef (load-time-value (stream::find-external-format :utf-8) t))) (stream:string-to-octets string :external-format ef))) From sboukarev at common-lisp.net Wed Nov 23 00:56:01 2011 From: sboukarev at common-lisp.net (CVS User sboukarev) Date: Tue, 22 Nov 2011 16:56:01 -0800 Subject: [slime-cvs] CVS slime/contrib Message-ID: Update of /project/slime/cvsroot/slime/contrib In directory tiger.common-lisp.net:/tmp/cvs-serv19020 Modified Files: ChangeLog slime-repl.el Log Message: * slime-repl.el (slime-open-stream-to-lisp): Convert "utf-8-unix" to 'utf-8-unix. --- /project/slime/cvsroot/slime/contrib/ChangeLog 2011/11/19 16:41:33 1.507 +++ /project/slime/cvsroot/slime/contrib/ChangeLog 2011/11/23 00:56:01 1.508 @@ -1,3 +1,8 @@ +2011-11-23 Stas Boukarev + + * slime-repl.el (slime-open-stream-to-lisp): Convert "utf-8-unix" + to 'utf-8-unix. + 2011-11-19 Nikodemus Siivola * slime-cl-indent.el ("sbcl"): Add indentation alias for !def-debug-command. --- /project/slime/cvsroot/slime/contrib/slime-repl.el 2011/11/16 10:01:19 1.58 +++ /project/slime/cvsroot/slime/contrib/slime-repl.el 2011/11/23 00:56:01 1.59 @@ -184,10 +184,13 @@ (let ((stream (open-network-stream "*lisp-output-stream*" (slime-with-connection-buffer () (current-buffer)) - slime-lisp-host port))) + slime-lisp-host port)) + (emacs-coding-system (car (find coding-system + slime-net-valid-coding-systems + :key #'third)))) (slime-set-query-on-exit-flag stream) (set-process-filter stream 'slime-output-filter) - (set-process-coding-system stream coding-system coding-system) + (set-process-coding-system stream emacs-coding-system emacs-coding-system) (when-let (secret (slime-secret)) (slime-net-send secret stream)) (run-hook-with-args 'slime-open-stream-hooks stream) From heller at common-lisp.net Sun Nov 27 17:57:41 2011 From: heller at common-lisp.net (CVS User heller) Date: Sun, 27 Nov 2011 09:57:41 -0800 Subject: [slime-cvs] CVS slime Message-ID: Update of /project/slime/cvsroot/slime In directory tiger.common-lisp.net:/tmp/cvs-serv10868 Modified Files: ChangeLog swank.lisp Log Message: * swank.lisp (eval-in-frame-aux): Don't bind *package* during eval. --- /project/slime/cvsroot/slime/ChangeLog 2011/11/21 19:52:25 1.2246 +++ /project/slime/cvsroot/slime/ChangeLog 2011/11/27 17:57:41 1.2247 @@ -1,3 +1,8 @@ +2011-11-27 Helmut Eller + + * swank.lisp (eval-in-frame-aux): Don't bind *package* during + eval. + 2011-11-21 Helmut Eller * swank-cmucl.lisp: Trigger compilation of utf8 stuff before first --- /project/slime/cvsroot/slime/swank.lisp 2011/11/21 19:46:11 1.761 +++ /project/slime/cvsroot/slime/swank.lisp 2011/11/27 17:57:41 1.762 @@ -2668,9 +2668,10 @@ ,form)) (defun eval-in-frame-aux (frame string package print) - (with-buffer-syntax (package) - (let ((form (wrap-sldb-vars (parse-string string package)))) - (funcall print (multiple-value-list (eval-in-frame form frame)))))) + (let* ((form (wrap-sldb-vars (parse-string string package))) + (values (multiple-value-list (eval-in-frame form frame)))) + (with-buffer-syntax (package) + (funcall print values)))) (defslimefun eval-string-in-frame (string frame package) (eval-in-frame-aux frame string package #'format-values-for-echo-area)) From heller at common-lisp.net Sun Nov 27 19:24:33 2011 From: heller at common-lisp.net (CVS User heller) Date: Sun, 27 Nov 2011 11:24:33 -0800 Subject: [slime-cvs] CVS slime Message-ID: Update of /project/slime/cvsroot/slime In directory tiger.common-lisp.net:/tmp/cvs-serv17076 Modified Files: ChangeLog slime.el swank.lisp Log Message: * swank.lisp (create-server): Remove coding-system argument. ([defstruct] connection): Remove coding-system slot. (connection.external-format, *coding-system*): Deleted. (make-connection, start-server, create-server, setup-server) (accept-connections): Drop coding-system arg. (connection-info): Return supported coding systems. (create-repl, open-dedicated-output-stream) (open-streams, initialize-streams-for-connection): Add coding-system arg. * slime.el (slime-init-command): Ignore the coding-system arg. (slime-connection-coding-systems): New connection variable. (slime-set-connection-info): Set it. --- /project/slime/cvsroot/slime/ChangeLog 2011/11/27 17:57:41 1.2247 +++ /project/slime/cvsroot/slime/ChangeLog 2011/11/27 19:24:33 1.2248 @@ -1,5 +1,22 @@ 2011-11-27 Helmut Eller + * swank.lisp (create-server): Remove coding-system argument. + ([defstruct] connection): Remove coding-system slot. + (connection.external-format, *coding-system*): Deleted. + (make-connection, start-server, create-server, setup-server) + (accept-connections): Drop coding-system arg. + + (connection-info): Return supported coding systems. + (create-repl, open-dedicated-output-stream) + (open-streams, initialize-streams-for-connection): Add + coding-system arg. + + * slime.el (slime-init-command): Ignore the coding-system arg. + (slime-connection-coding-systems): New connection variable. + (slime-set-connection-info): Set it. + +2011-11-27 Helmut Eller + * swank.lisp (eval-in-frame-aux): Don't bind *package* during eval. --- /project/slime/cvsroot/slime/slime.el 2011/11/21 16:34:12 1.1381 +++ /project/slime/cvsroot/slime/slime.el 2011/11/27 19:24:33 1.1382 @@ -1343,8 +1343,7 @@ "Return a string to initialize Lisp." (let ((loader (if (file-name-absolute-p slime-backend) slime-backend - (concat slime-path slime-backend))) - (encoding (slime-coding-system-cl-name coding-system))) + (concat slime-path slime-backend)))) ;; Return a single form to avoid problems with buffered input. (format "%S\n\n" `(progn @@ -1352,8 +1351,7 @@ :verbose t) (funcall (read-from-string "swank-loader:init")) (funcall (read-from-string "swank:start-server") - ,(slime-to-lisp-filename port-filename) - :coding-system ,encoding))))) + ,(slime-to-lisp-filename port-filename)))))) (defun slime-swank-port-file () "Filename where the SWANK server writes its TCP port number." @@ -1904,6 +1902,9 @@ (slime-def-connection-var slime-machine-instance nil "The name of the (remote) machine running the Lisp process.") +(slime-def-connection-var slime-connection-coding-systems nil + "Coding systems supported by the Lisp process.") + ;;;;; Connection setup (defvar slime-connection-counter 0 @@ -1939,7 +1940,8 @@ (let ((slime-dispatching-connection connection) (slime-current-thread t)) (destructuring-bind (&key pid style lisp-implementation machine - features version modules &allow-other-keys) info + features version modules encoding + &allow-other-keys) info (slime-check-version version connection) (setf (slime-pid) pid (slime-communication-style) style @@ -1952,7 +1954,9 @@ (slime-lisp-implementation-program) program (slime-connection-name) (slime-generate-connection-name name))) (destructuring-bind (&key instance ((:type _)) ((:version _))) machine - (setf (slime-machine-instance) instance))) + (setf (slime-machine-instance) instance)) + (destructuring-bind (&key coding-systems) encoding + (setf (slime-connection-coding-systems) coding-systems))) (let ((args (when-let (p (slime-inferior-process)) (slime-inferior-lisp-args p)))) (when-let (name (plist-get args ':name)) --- /project/slime/cvsroot/slime/swank.lisp 2011/11/27 17:57:41 1.762 +++ /project/slime/cvsroot/slime/swank.lisp 2011/11/27 19:24:33 1.763 @@ -244,8 +244,6 @@ (indentation-cache-packages '()) ;; The communication style used. (communication-style nil :type (member nil :spawn :sigio :fd-handler)) - ;; The coding system for network streams. - coding-system ;; The SIGINT handler we should restore when the connection is ;; closed. saved-sigint-handler) @@ -269,7 +267,7 @@ recently established one." (first *connections*)) -(defun make-connection (socket stream style coding-system) +(defun make-connection (socket stream style) (multiple-value-bind (serve cleanup) (ecase style (:spawn @@ -283,17 +281,12 @@ (let ((conn (%make-connection :socket socket :socket-io stream :communication-style style - :coding-system coding-system :serve-requests serve :cleanup cleanup))) (run-hook *new-connection-hook* conn) (push conn *connections*) conn))) -(defun connection.external-format (connection) - (ignore-errors - (stream-external-format (connection.socket-io connection)))) - (defslimefun ping (tag) tag) @@ -725,11 +718,9 @@ create-server.") (defvar *dedicated-output-stream-buffering* - (if (eq *communication-style* :spawn) :full :none) + (if (eq *communication-style* :spawn) t nil) "The buffering scheme that should be used for the output stream. -Valid values are :none, :line, and :full.") - -(defvar *coding-system* "iso-latin-1-unix") +Valid values are nil, t, :line") (defvar *listener-sockets* nil "A property list of lists containing style, socket pairs used @@ -737,23 +728,21 @@ are used to close sockets on server shutdown or restart.") (defun start-server (port-file &key (style *communication-style*) - (dont-close *dont-close*) - (coding-system *coding-system*)) + (dont-close *dont-close*)) "Start the server and write the listen port number to PORT-FILE. This is the entry point for Emacs." (setup-server 0 (lambda (port) (announce-server-port port-file port)) - style dont-close coding-system)) + style dont-close)) (defun create-server (&key (port default-server-port) - (style *communication-style*) - (dont-close *dont-close*) - (coding-system *coding-system*)) + (style *communication-style*) + (dont-close *dont-close*)) "Start a SWANK server on PORT running in STYLE. If DONT-CLOSE is true then the listen socket will accept multiple connections, otherwise it will be closed after the first." (setup-server port #'simple-announce-function - style dont-close coding-system)) + style dont-close)) (defun find-external-format-or-lose (coding-system) (or (find-external-format coding-system) @@ -761,15 +750,14 @@ (defparameter *loopback-interface* "127.0.0.1") -(defun setup-server (port announce-fn style dont-close coding-system) +(defun setup-server (port announce-fn style dont-close) (declare (type function announce-fn)) (init-log-output) - (find-external-format-or-lose coding-system) (let* ((socket (create-socket *loopback-interface* port)) (local-port (local-port socket))) (funcall announce-fn local-port) (flet ((serve () - (accept-connections socket style coding-system dont-close))) + (accept-connections socket style dont-close))) (ecase style (:spawn (initialize-multiprocessing @@ -808,25 +796,23 @@ (defun restart-server (&key (port default-server-port) (style *communication-style*) - (dont-close *dont-close*) - (coding-system *coding-system*)) + (dont-close *dont-close*)) "Stop the server listening on PORT, then start a new SWANK server on PORT running in STYLE. If DONT-CLOSE is true then the listen socket will accept multiple connections, otherwise it will be closed after the first." (stop-server port) (sleep 5) - (create-server :port port :style style :dont-close dont-close - :coding-system coding-system)) + (create-server :port port :style style :dont-close dont-close)) -(defun accept-connections (socket style coding-system dont-close) +(defun accept-connections (socket style dont-close) (let ((client (unwind-protect (accept-connection socket :external-format nil :buffering t) (unless dont-close (close-socket socket))))) (authenticate-client client) - (serve-requests (make-connection socket client style coding-system)))) + (serve-requests (make-connection socket client style)))) (defun authenticate-client (stream) (let ((secret (slime-secret))) @@ -862,7 +848,7 @@ (format *log-output* "~&;; Swank started at port: ~D.~%" port) (force-output *log-output*))) -(defun open-streams (connection) +(defun open-streams (connection properties) "Return the 5 streams for IO redirection: DEDICATED-OUTPUT INPUT OUTPUT IO REPL-RESULTS" (let* ((input-fn @@ -872,7 +858,9 @@ "Abort reading input from Emacs.") (read-user-input-from-emacs))))) (dedicated-output (if *use-dedicated-output-stream* - (open-dedicated-output-stream connection))) + (open-dedicated-output-stream + connection + (getf properties :coding-system)))) (in (make-input-stream input-fn)) (out (or dedicated-output (make-output-stream (make-output-function connection)))) @@ -921,25 +909,22 @@ "Create a stream that sends output to a specific TARGET in Emacs." (make-output-stream (make-output-function-for-target connection target))) -(defun open-dedicated-output-stream (connection) +(defun open-dedicated-output-stream (connection coding-system) "Open a dedicated output connection to the Emacs on SOCKET-IO. Return an output stream suitable for writing program output. This is an optimized way for Lisp to deliver output to Emacs." - (let ((socket (create-socket *loopback-interface* - *dedicated-output-stream-port*))) + (let ((socket (create-socket *loopback-interface* + *dedicated-output-stream-port*)) + (ef (find-external-format-or-lose coding-system))) (unwind-protect (let ((port (local-port socket))) - (encode-message `(:open-dedicated-output-stream - ,port - ,(connection.coding-system connection)) + (encode-message `(:open-dedicated-output-stream ,port + ,coding-system) (connection.socket-io connection)) - (let ((dedicated (accept-connection + (let ((dedicated (accept-connection socket - :external-format - (or (find-external-format - (connection.coding-system connection)) - :default) + :external-format ef :buffering *dedicated-output-stream-buffering* :timeout 30))) (authenticate-client dedicated) @@ -1038,14 +1023,11 @@ ;; Connection to Emacs lost. [~%~ ;; condition: ~A~%~ ;; type: ~S~%~ - ;; encoding: ~A vs. ~A~%~ ;; style: ~S dedicated: ~S]~%" (loop for (i f) in backtrace collect (ignore-errors (format nil "~d: ~a" i (escape-non-ascii f)))) (escape-non-ascii (safe-condition-message condition) ) (type-of condition) - (connection.coding-system c) - (connection.external-format c) (connection.communication-style c) *use-dedicated-output-stream*)) (finish-output *log-output*) @@ -1545,10 +1527,10 @@ ;;; We always redirect the standard streams to Emacs while evaluating ;;; an RPC. This is done with simple dynamic bindings. -(defslimefun create-repl (target) +(defslimefun create-repl (target &key coding-system) (assert (eq target nil)) (let ((conn *emacs-connection*)) - (initialize-streams-for-connection conn) + (initialize-streams-for-connection conn `(:coding-system ,coding-system)) (with-struct* (connection. @ conn) (setf (@ env) `((*standard-output* . ,(@ user-output)) @@ -1564,9 +1546,9 @@ (list (package-name *package*) (package-string-for-prompt *package*))))) -(defun initialize-streams-for-connection (connection) +(defun initialize-streams-for-connection (connection properties) (multiple-value-bind (dedicated in out io repl-results) - (open-streams connection) + (open-streams connection properties) (setf (connection.dedicated-output connection) dedicated (connection.user-io connection) io (connection.user-output connection) out @@ -1798,11 +1780,9 @@ (let ((c *emacs-connection*)) (setq *slime-features* *features*) `(:pid ,(getpid) :style ,(connection.communication-style c) - :encoding (:coding-system ,(connection.coding-system c) - ;; external-formats are totally implementation-dependent, - ;; so better play safe. - :external-format ,(princ-to-string - (connection.external-format c))) + :encoding (:coding-systems + ,(loop for cs in '("utf-8-unix" "iso-latin-1-unix") + when (find-external-format cs) collect cs)) :lisp-implementation (:type ,(lisp-implementation-type) :name ,(lisp-implementation-type-name) :version ,(lisp-implementation-version) From heller at common-lisp.net Sun Nov 27 19:24:34 2011 From: heller at common-lisp.net (CVS User heller) Date: Sun, 27 Nov 2011 11:24:34 -0800 Subject: [slime-cvs] CVS slime/contrib Message-ID: Update of /project/slime/cvsroot/slime/contrib In directory tiger.common-lisp.net:/tmp/cvs-serv17076/contrib Modified Files: ChangeLog slime-repl.el Log Message: * swank.lisp (create-server): Remove coding-system argument. ([defstruct] connection): Remove coding-system slot. (connection.external-format, *coding-system*): Deleted. (make-connection, start-server, create-server, setup-server) (accept-connections): Drop coding-system arg. (connection-info): Return supported coding systems. (create-repl, open-dedicated-output-stream) (open-streams, initialize-streams-for-connection): Add coding-system arg. * slime.el (slime-init-command): Ignore the coding-system arg. (slime-connection-coding-systems): New connection variable. (slime-set-connection-info): Set it. --- /project/slime/cvsroot/slime/contrib/ChangeLog 2011/11/23 00:56:01 1.508 +++ /project/slime/cvsroot/slime/contrib/ChangeLog 2011/11/27 19:24:33 1.509 @@ -1,3 +1,8 @@ +2011-11-27 Helmut Eller + + * slime-repl.el (slime-repl-choose-coding-system): New. + (slime-repl-connected-hook-function): Use it. + 2011-11-23 Stas Boukarev * slime-repl.el (slime-open-stream-to-lisp): Convert "utf-8-unix" --- /project/slime/cvsroot/slime/contrib/slime-repl.el 2011/11/23 00:56:01 1.59 +++ /project/slime/cvsroot/slime/contrib/slime-repl.el 2011/11/27 19:24:34 1.60 @@ -1659,10 +1659,21 @@ (pop-to-buffer repl-buffer) (goto-char (point-max)))))) +(defun slime-repl-choose-coding-system () + (let ((candidates (slime-connection-coding-systems))) + (or (find (symbol-name (car default-process-coding-system)) + candidates + :test (lambda (s1 s2) + (if (fboundp 'coding-system-equal) + (coding-system-equal (intern s1) (intern s2))))) + (car candidates) + (error "Can't find suitable coding-system")))) + (defun slime-repl-connected-hook-function () (destructuring-bind (package prompt) - (let ((slime-current-thread t)) - (slime-eval '(swank:create-repl nil))) + (let ((slime-current-thread t) + (cs (slime-repl-choose-coding-system))) + (slime-eval `(swank:create-repl nil :coding-system ,cs))) (setf (slime-lisp-package) package) (setf (slime-lisp-package-prompt-string) prompt)) (slime-hide-inferior-lisp-buffer) From heller at common-lisp.net Sun Nov 27 19:24:53 2011 From: heller at common-lisp.net (CVS User heller) Date: Sun, 27 Nov 2011 11:24:53 -0800 Subject: [slime-cvs] CVS slime Message-ID: Update of /project/slime/cvsroot/slime In directory tiger.common-lisp.net:/tmp/cvs-serv17424 Modified Files: ChangeLog swank-cmucl.lisp Log Message: * swank-cmucl.lisp (make-socket-io-stream): Create a character stream if external-format is non-nil. --- /project/slime/cvsroot/slime/ChangeLog 2011/11/27 19:24:33 1.2248 +++ /project/slime/cvsroot/slime/ChangeLog 2011/11/27 19:24:53 1.2249 @@ -1,5 +1,9 @@ 2011-11-27 Helmut Eller + * swank-cmucl.lisp (make-socket-io-stream): Create character + stream if external-format is non-nil. + +2011-11-27 Helmut Eller * swank.lisp (create-server): Remove coding-system argument. ([defstruct] connection): Remove coding-system slot. (connection.external-format, *coding-system*): Deleted. --- /project/slime/cvsroot/slime/swank-cmucl.lisp 2011/11/21 19:52:25 1.237 +++ /project/slime/cvsroot/slime/swank-cmucl.lisp 2011/11/27 19:24:53 1.238 @@ -137,11 +137,9 @@ (car (ext:host-entry-addr-list hostent)))) (defvar *external-format-to-coding-system* - '((:iso-8859-1 - "latin-1" "latin-1-unix" "iso-latin-1-unix" - "iso-8859-1" "iso-8859-1-unix") + '((:iso-8859-1 "iso-latin-1-unix") #+unicode - (:utf-8 "utf-8" "utf-8-unix"))) + (:utf-8 "utf-8-unix"))) (defimplementation find-external-format (coding-system) (car (rassoc-if (lambda (x) (member coding-system x :test #'equal)) @@ -149,9 +147,9 @@ (defun make-socket-io-stream (fd buffering external-format) "Create a new input/output fd-stream for FD." - (cond ((and external-format (ext:featurep :unicode)) + (cond (external-format (sys:make-fd-stream fd :input t :output t - :element-type '(unsigned-byte 8) + :element-type 'character :buffering buffering :external-format external-format)) (t From heller at common-lisp.net Sun Nov 27 21:47:15 2011 From: heller at common-lisp.net (CVS User heller) Date: Sun, 27 Nov 2011 13:47:15 -0800 Subject: [slime-cvs] CVS slime Message-ID: Update of /project/slime/cvsroot/slime In directory tiger.common-lisp.net:/tmp/cvs-serv21065 Modified Files: ChangeLog swank-abcl.lisp swank-allegro.lisp swank-backend.lisp swank-ccl.lisp swank-clisp.lisp swank-cmucl.lisp swank-corman.lisp swank-ecl.lisp swank-lispworks.lisp swank-sbcl.lisp swank-scl.lisp swank.lisp Log Message: * swank.lisp (create-server): Add a :backlog argument. (setup-server): Pass it along. * swank-backend.lisp (create-socket): Backlog argument. * swank-abcl.lisp: Implement it. * swank-allegro.lisp: * swank-ccl.lisp: * swank-clisp.lisp: * swank-cmucl.lisp: * swank-corman.lisp: * swank-ecl.lisp: * swank-lispworks.lisp: * swank-sbcl.lisp: * swank-scl.lisp: --- /project/slime/cvsroot/slime/ChangeLog 2011/11/27 19:24:53 1.2249 +++ /project/slime/cvsroot/slime/ChangeLog 2011/11/27 21:47:14 1.2250 @@ -1,5 +1,22 @@ 2011-11-27 Helmut Eller + * swank.lisp (create-server): Add a :backlog argument. + (setup-server): Pass it along. + + * swank-backend.lisp (create-socket): Backlog argument. + * swank-abcl.lisp: Implement it. + * swank-allegro.lisp: + * swank-ccl.lisp: + * swank-clisp.lisp: + * swank-cmucl.lisp: + * swank-corman.lisp: + * swank-ecl.lisp: + * swank-lispworks.lisp: + * swank-sbcl.lisp: + * swank-scl.lisp: + +2011-11-27 Helmut Eller + * swank-cmucl.lisp (make-socket-io-stream): Create character stream if external-format is non-nil. --- /project/slime/cvsroot/slime/swank-abcl.lisp 2011/11/06 17:05:41 1.89 +++ /project/slime/cvsroot/slime/swank-abcl.lisp 2011/11/27 21:47:15 1.90 @@ -131,7 +131,7 @@ (defimplementation preferred-communication-style () :spawn) -(defimplementation create-socket (host port) +(defimplementation create-socket (host port &key backlog) (ext:make-server-socket port)) (defimplementation local-port (socket) --- /project/slime/cvsroot/slime/swank-allegro.lisp 2011/11/06 17:06:20 1.147 +++ /project/slime/cvsroot/slime/swank-allegro.lisp 2011/11/27 21:47:15 1.148 @@ -43,9 +43,10 @@ (defimplementation preferred-communication-style () :spawn) -(defimplementation create-socket (host port) +(defimplementation create-socket (host port &key backlog) (socket:make-socket :connect :passive :local-port port - :local-host host :reuse-address t)) + :local-host host :reuse-address t + :backlog (or backlog 5))) (defimplementation local-port (socket) (socket:local-port socket)) --- /project/slime/cvsroot/slime/swank-backend.lisp 2011/11/21 16:34:12 1.212 +++ /project/slime/cvsroot/slime/swank-backend.lisp 2011/11/27 21:47:15 1.213 @@ -433,8 +433,9 @@ ;;;; TCP server -(definterface create-socket (host port) - "Create a listening TCP socket on interface HOST and port PORT .") +(definterface create-socket (host port &key backlog) + "Create a listening TCP socket on interface HOST and port PORT. +BACKLOG queue length for incoming connections.") (definterface local-port (socket) "Return the local port number of SOCKET.") --- /project/slime/cvsroot/slime/swank-ccl.lisp 2011/11/06 17:04:32 1.23 +++ /project/slime/cvsroot/slime/swank-ccl.lisp 2011/11/27 21:47:15 1.24 @@ -95,9 +95,10 @@ (defimplementation preferred-communication-style () :spawn) -(defimplementation create-socket (host port) +(defimplementation create-socket (host port &key backlog) (ccl:make-socket :connect :passive :local-port port - :local-host host :reuse-address t)) + :local-host host :reuse-address t + :backlog (or backlog 5))) (defimplementation local-port (socket) (ccl:local-port socket)) --- /project/slime/cvsroot/slime/swank-clisp.lisp 2011/11/06 17:05:41 1.97 +++ /project/slime/cvsroot/slime/swank-clisp.lisp 2011/11/27 21:47:15 1.98 @@ -151,9 +151,8 @@ ;;;; TCP Server -(defimplementation create-socket (host port) - (declare (ignore host)) - (socket:socket-server port)) +(defimplementation create-socket (host port &key backlog) + (socket:socket-server port :interface host :backlog (or backlog 5))) (defimplementation local-port (socket) (socket:socket-server-port socket)) --- /project/slime/cvsroot/slime/swank-cmucl.lisp 2011/11/27 19:24:53 1.238 +++ /project/slime/cvsroot/slime/swank-cmucl.lisp 2011/11/27 21:47:15 1.239 @@ -92,16 +92,17 @@ :sigio) #-(or darwin mips) -(defimplementation create-socket (host port) +(defimplementation create-socket (host port &key backlog) (let* ((addr (resolve-hostname host)) (addr (if (not (find-symbol "SOCKET-ERROR" :ext)) (ext:htonl addr) addr))) - (ext:create-inet-listener port :stream :reuse-address t :host addr))) + (ext:create-inet-listener port :stream :reuse-address t :host addr + :backlog (or backlog 5)))) ;; There seems to be a bug in create-inet-listener on Mac/OSX and Irix. #+(or darwin mips) -(defimplementation create-socket (host port) +(defimplementation create-socket (host port &key backlog) (declare (ignore host)) (ext:create-inet-listener port :stream :reuse-address t)) --- /project/slime/cvsroot/slime/swank-corman.lisp 2010/03/02 12:38:07 1.25 +++ /project/slime/cvsroot/slime/swank-corman.lisp 2011/11/27 21:47:15 1.26 @@ -224,7 +224,7 @@ ;;; Socket communication -(defimplementation create-socket (host port) +(defimplementation create-socket (host port &key backlog) (sockets:start-sockets) (sockets:make-server-socket :host host :port port)) --- /project/slime/cvsroot/slime/swank-ecl.lisp 2011/11/06 18:34:51 1.70 +++ /project/slime/cvsroot/slime/swank-ecl.lisp 2011/11/27 21:47:15 1.71 @@ -62,13 +62,13 @@ (car (sb-bsd-sockets:host-ent-addresses (sb-bsd-sockets:get-host-by-name name)))) -(defimplementation create-socket (host port) +(defimplementation create-socket (host port &key backlog) (let ((socket (make-instance 'sb-bsd-sockets:inet-socket :type :stream :protocol :tcp))) (setf (sb-bsd-sockets:sockopt-reuse-address socket) t) (sb-bsd-sockets:socket-bind socket (resolve-hostname host) port) - (sb-bsd-sockets:socket-listen socket 5) + (sb-bsd-sockets:socket-listen socket (or backlog 5)) socket)) (defimplementation local-port (socket) --- /project/slime/cvsroot/slime/swank-lispworks.lisp 2011/11/06 17:06:30 1.145 +++ /project/slime/cvsroot/slime/swank-lispworks.lisp 2011/11/27 21:47:15 1.146 @@ -80,10 +80,11 @@ (fixnum socket) (comm:socket-stream (comm:socket-stream-socket socket)))) -(defimplementation create-socket (host port) +(defimplementation create-socket (host port &key backlog) (multiple-value-bind (socket where errno) #-(or lispworks4.1 (and macosx lispworks4.3)) - (comm::create-tcp-socket-for-service port :address host) + (comm::create-tcp-socket-for-service port :address host + :backlog (or backlog 5)) #+(or lispworks4.1 (and macosx lispworks4.3)) (comm::create-tcp-socket-for-service port) (cond (socket socket) --- /project/slime/cvsroot/slime/swank-sbcl.lisp 2011/11/19 16:35:58 1.293 +++ /project/slime/cvsroot/slime/swank-sbcl.lisp 2011/11/27 21:47:15 1.294 @@ -83,13 +83,13 @@ (car (sb-bsd-sockets:host-ent-addresses (sb-bsd-sockets:get-host-by-name name)))) -(defimplementation create-socket (host port) +(defimplementation create-socket (host port &key backlog) (let ((socket (make-instance 'sb-bsd-sockets:inet-socket :type :stream :protocol :tcp))) (setf (sb-bsd-sockets:sockopt-reuse-address socket) t) (sb-bsd-sockets:socket-bind socket (resolve-hostname host) port) - (sb-bsd-sockets:socket-listen socket 5) + (sb-bsd-sockets:socket-listen socket (or backlog 5)) socket)) (defimplementation local-port (socket) --- /project/slime/cvsroot/slime/swank-scl.lisp 2011/11/06 17:05:41 1.38 +++ /project/slime/cvsroot/slime/swank-scl.lisp 2011/11/27 21:47:15 1.39 @@ -26,9 +26,10 @@ (defimplementation preferred-communication-style () :spawn) -(defimplementation create-socket (host port) +(defimplementation create-socket (host port &key backlog) (let ((addr (resolve-hostname host))) - (ext:create-inet-listener port :stream :host addr :reuse-address t))) + (ext:create-inet-listener port :stream :host addr :reuse-address t + :backlog (or backend 5)))) (defimplementation local-port (socket) (nth-value 1 (ext::get-socket-host-and-port (socket-fd socket)))) --- /project/slime/cvsroot/slime/swank.lisp 2011/11/27 19:24:33 1.763 +++ /project/slime/cvsroot/slime/swank.lisp 2011/11/27 21:47:15 1.764 @@ -733,16 +733,17 @@ This is the entry point for Emacs." (setup-server 0 (lambda (port) (announce-server-port port-file port)) - style dont-close)) + style dont-close nil)) (defun create-server (&key (port default-server-port) (style *communication-style*) - (dont-close *dont-close*)) + (dont-close *dont-close*) + backlog) "Start a SWANK server on PORT running in STYLE. If DONT-CLOSE is true then the listen socket will accept multiple connections, otherwise it will be closed after the first." (setup-server port #'simple-announce-function - style dont-close)) + style dont-close backlog)) (defun find-external-format-or-lose (coding-system) (or (find-external-format coding-system) @@ -750,10 +751,10 @@ (defparameter *loopback-interface* "127.0.0.1") -(defun setup-server (port announce-fn style dont-close) +(defun setup-server (port announce-fn style dont-close backlog) (declare (type function announce-fn)) (init-log-output) - (let* ((socket (create-socket *loopback-interface* port)) + (let* ((socket (create-socket *loopback-interface* port :backlog backlog)) (local-port (local-port socket))) (funcall announce-fn local-port) (flet ((serve () From nsiivola at common-lisp.net Mon Nov 28 12:46:56 2011 From: nsiivola at common-lisp.net (CVS User nsiivola) Date: Mon, 28 Nov 2011 04:46:56 -0800 Subject: [slime-cvs] CVS slime/contrib Message-ID: Update of /project/slime/cvsroot/slime/contrib In directory tiger.common-lisp.net:/tmp/cvs-serv16756/contrib Modified Files: ChangeLog slime-cl-indent-test.txt slime-cl-indent.el Log Message: slime-indentation: better DEFCLASS and DEFINE-CONDITION superclass indentation --- /project/slime/cvsroot/slime/contrib/ChangeLog 2011/11/27 19:24:33 1.509 +++ /project/slime/cvsroot/slime/contrib/ChangeLog 2011/11/28 12:46:56 1.510 @@ -1,3 +1,10 @@ +2011-11-28 Nikodemus Siivola + + * slime-cl-indent.el: fix DEFCLASS and DEFINE-CONDITION superclass-list + indentation. + + * slime-cl-indent-test.txt: Add tests 66 and 67. + 2011-11-27 Helmut Eller * slime-repl.el (slime-repl-choose-coding-system): New. --- /project/slime/cvsroot/slime/contrib/slime-cl-indent-test.txt 2011/11/12 12:01:52 1.13 +++ /project/slime/cvsroot/slime/contrib/slime-cl-indent-test.txt 2011/11/28 12:46:56 1.14 @@ -686,3 +686,23 @@ (defmethod (setf foo) :around (zot &key x y) (list zot)) + +;;; Test: 66 +;; + +(define-condition + foo + (bar quux + zot) + () + (:report "foo")) + +;;; Test: 67 +;; + +(defclass + foo + (bar quxx + xoo) + () + (:metaclass foo-class)) --- /project/slime/cvsroot/slime/contrib/slime-cl-indent.el 2011/11/19 16:41:33 1.55 +++ /project/slime/cvsroot/slime/contrib/slime-cl-indent.el 2011/11/28 12:46:56 1.56 @@ -1502,7 +1502,7 @@ ;; for DEFSTRUCT (:constructor (4 &lambda)) (defvar (4 2 2)) - (defclass (6 4 (&whole 2 &rest 1) (&whole 2 &rest 1))) + (defclass (6 (&whole 4 &rest 1) (&whole 2 &rest 1) (&whole 2 &rest 1))) (defconstant (as defvar)) (defcustom (4 2 2 2)) (defparameter (as defvar)) From nsiivola at common-lisp.net Mon Nov 28 18:38:34 2011 From: nsiivola at common-lisp.net (CVS User nsiivola) Date: Mon, 28 Nov 2011 10:38:34 -0800 Subject: [slime-cvs] CVS slime/contrib Message-ID: Update of /project/slime/cvsroot/slime/contrib In directory tiger.common-lisp.net:/tmp/cvs-serv20011/contrib Modified Files: ChangeLog slime-cl-indent-test.txt slime-cl-indent.el Log Message: slime-indentation: still more work on loop indentation (loop repeat 1000 do ;; This is the ;; beginning (foo)) (loop repeat 100 ;; This too ;; is a beginning do (foo)) --- /project/slime/cvsroot/slime/contrib/ChangeLog 2011/11/28 12:46:56 1.510 +++ /project/slime/cvsroot/slime/contrib/ChangeLog 2011/11/28 18:38:34 1.511 @@ -1,5 +1,16 @@ 2011-11-28 Nikodemus Siivola + * slime-cl-indent.el (common-lisp-trailing-comment): New function. + Returns the column of a trailing comment. + (common-lisp-loop-part-indentation) + (common-lisp-indent-loop-macro-1): fix indentation of multiline + comments starting from a trailing position. + + + * slime-cl-indent-test.txt: Add tests 68 and 69. + +2011-11-28 Nikodemus Siivola + * slime-cl-indent.el: fix DEFCLASS and DEFINE-CONDITION superclass-list indentation. --- /project/slime/cvsroot/slime/contrib/slime-cl-indent-test.txt 2011/11/28 12:46:56 1.14 +++ /project/slime/cvsroot/slime/contrib/slime-cl-indent-test.txt 2011/11/28 18:38:34 1.15 @@ -706,3 +706,33 @@ xoo) () (:metaclass foo-class)) + + +;;; Test: 68 +;; +;; lisp-loop-indent-subclauses: nil + +(progn + (loop + repeat 1000 + do ;; This is the + ;; beginning + (foo)) + (loop repeat 100 ;; This too + ;; is a beginning + do (foo))) + +;;; Test: 69 +;; +;; lisp-loop-indent-subclauses: t + +(progn + (loop + repeat 1000 + do ;; This is the + ;; beginning + (foo)) + (loop repeat 100 ;; This too + ;; is a beginning + do (foo))) + --- /project/slime/cvsroot/slime/contrib/slime-cl-indent.el 2011/11/28 12:46:56 1.56 +++ /project/slime/cvsroot/slime/contrib/slime-cl-indent.el 2011/11/28 18:38:34 1.57 @@ -611,6 +611,16 @@ 'simple/split 'simple))))) +(defun common-lisp-trailing-comment () + (ignore-errors + ;; If we had a trailing comment just before this, find it. + (save-excursion + (backward-sexp) + (forward-sexp) + (when (looking-at "\\s-*;") + (search-forward ";") + (1- (current-column)))))) + (defun common-lisp-loop-part-indentation (indent-point state type) "Compute the indentation of loop form constituents." (let* ((loop-start (elt state 1)) @@ -639,7 +649,12 @@ (list indent loop-start)) ;; Keyword-style or comment outside body ((or lisp-loop-indent-forms-like-keywords (looking-at re) (looking-at ";")) - (list (+ loop-indentation 6) loop-start)) + (if (and (looking-at ";") + (let ((p (common-lisp-trailing-comment))) + (when p + (setq loop-indentation p)))) + (list loop-indentation loop-start) + (list (+ loop-indentation 6) loop-start))) ;; Form-style (t (list (+ loop-indentation 9) loop-start))))) @@ -1378,7 +1393,8 @@ ;; vanilla clause. (if loop-body-p loop-body-indentation - default-value)) + (or (and (looking-at ";") (common-lisp-trailing-comment)) + default-value))) ((looking-at common-lisp-indent-indented-loop-macro-keyword) indented-clause-indentation) ((looking-at common-lisp-indent-clause-joining-loop-macro-keyword) @@ -1681,6 +1697,6 @@ ;;; (common-lisp-run-indentation-tests t) ;;; ;;; Run specific test: -;;; (common-lisp-run-indentation-tests 17) +;;; (common-lisp-run-indentation-tests 69) ;;; cl-indent.el ends here From heller at common-lisp.net Tue Nov 29 19:50:16 2011 From: heller at common-lisp.net (CVS User heller) Date: Tue, 29 Nov 2011 11:50:16 -0800 Subject: [slime-cvs] CVS slime Message-ID: Update of /project/slime/cvsroot/slime In directory tiger.common-lisp.net:/tmp/cvs-serv25102 Modified Files: ChangeLog swank.lisp Log Message: * swank.lisp (to-line): Increase default limit to 512. (frame-locals-for-emacs): Let *print-right-margin* override default line width. --- /project/slime/cvsroot/slime/ChangeLog 2011/11/27 21:47:14 1.2250 +++ /project/slime/cvsroot/slime/ChangeLog 2011/11/29 19:50:15 1.2251 @@ -1,3 +1,9 @@ +2011-11-29 Helmut Eller + + * swank.lisp (to-line): Increase default limit to 512. + (frame-locals-for-emacs): Let *print-right-margin* override + default line width. + 2011-11-27 Helmut Eller * swank.lisp (create-server): Add a :backlog argument. @@ -21,6 +27,7 @@ stream if external-format is non-nil. 2011-11-27 Helmut Eller + * swank.lisp (create-server): Remove coding-system argument. ([defstruct] connection): Remove coding-system slot. (connection.external-format, *coding-system*): Deleted. --- /project/slime/cvsroot/slime/swank.lisp 2011/11/27 21:47:15 1.764 +++ /project/slime/cvsroot/slime/swank.lisp 2011/11/29 19:50:16 1.765 @@ -2252,11 +2252,12 @@ (with-string-stream (,var :length ,length) . ,body))))) -(defun to-line (object &optional (width 75)) +(defun to-line (object &optional width) "Print OBJECT to a single line. Return the string." - (without-printing-errors (:object object :stream nil) - (with-string-stream (stream :length width) - (write object :stream stream :right-margin width :lines 1)))) + (let ((width (or width 512))) + (without-printing-errors (:object object :stream nil) + (with-string-stream (stream :length width) + (write object :stream stream :right-margin width :lines 1))))) (defun escape-string (string stream &key length (map '((#\" . "\\\"") (#\\ . "\\\\")))) @@ -2674,11 +2675,11 @@ (defun frame-locals-for-emacs (index) (with-bindings *backtrace-printer-bindings* - (loop for var in (frame-locals index) - collect (destructuring-bind (&key name id value) var - (list :name (prin1-to-string name) - :id id - :value (to-line value)))))) + (loop for var in (frame-locals index) collect + (destructuring-bind (&key name id value) var + (list :name (prin1-to-string name) + :id id + :value (to-line value *print-right-margin*)))))) (defslimefun sldb-disassemble (index) (with-output-to-string (*standard-output*)