[slime-cvs] CVS slime
CVS User heller
heller at common-lisp.net
Wed Apr 14 17:51:30 UTC 2010
Update of /project/slime/cvsroot/slime
In directory cl-net:/tmp/cvs-serv9765
Modified Files:
ChangeLog swank-rpc.lisp swank.lisp
Log Message:
Move error handling and logging from swank-rpc.lisp to swank.lisp
* swank.lisp (log-event, destructure-case, decode-message)
(encode-message, decode-message, swank-protocol-error): Moved back
to swank.lisp from swank-rpc.lisp. It never belonged there
anyway.
* swank-rpc.lisp (read-message, write-message): New functions.
(swank-reader-error): New condition.
--- /project/slime/cvsroot/slime/ChangeLog 2010/04/12 18:51:10 1.2061
+++ /project/slime/cvsroot/slime/ChangeLog 2010/04/14 17:51:30 1.2062
@@ -1,3 +1,15 @@
+2010-04-14 Helmut Eller <heller at common-lisp.net>
+
+ Move error handling and logging from swank-rpc.lisp to swank.lisp
+
+ * swank.lisp (log-event, destructure-case, decode-message)
+ (encode-message, decode-message, swank-protocol-error): Moved back
+ to swank.lisp from swank-rpc.lisp. It never belonged there
+ anyway.
+
+ * swank-rpc.lisp (read-message, write-message): New functions.
+ (swank-reader-error): New condition.
+
2010-04-12 Helmut Eller <heller at common-lisp.net>
* slime.el (slime-doc-bindings): Restore key for slime-apropos.
--- /project/slime/cvsroot/slime/swank-rpc.lisp 2010/01/27 06:38:27 1.5
+++ /project/slime/cvsroot/slime/swank-rpc.lisp 2010/04/14 17:51:30 1.6
@@ -8,44 +8,62 @@
;;; are disclaimed.
;;;
-(defpackage :swank-rpc
+(defpackage #:swank-rpc
(:use :cl)
(:export
- ; export everything for compatibility, need to be trimmed down!
- #:decode-message
- #:read-packet
- #:read-chunk
- #:*swank-io-package*
- #:read-form
- #:encode-message
- #:prin1-to-string-for-emacs
- #:destructure-case
- #:swank-protocol-error
- #:swank-protocol-error.condition
- #:make-swank-protocol-error
- #:*log-events*
- #:*log-output*
- #:init-log-output
- #:real-input-stream
- #:real-output-stream
- #:*event-history*
- #:*event-history-index*
- #:*enable-event-history*
- #:log-event
- #:event-history-to-list
- #:clear-event-history
- #:dump-event-history
- #:dump-event
- #:escape-non-ascii
- #:ascii-string-p
- #:ascii-char-p))
+ #:read-message
+ #:swank-reader-error
+ #:swank-reader-error.packet
+ #:swank-reader-error.cause
+ #:write-message))
(in-package :swank-rpc)
+
;;;;; 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)))
+
+(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))))))
+
+;; 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))
+
+(defun read-chunk (stream length)
+ (let* ((buffer (make-string length))
+ (count (read-sequence buffer stream)))
+ (assert (= count length) () "Short read: length=~D count=~D" length count)
+ buffer))
+
+;; FIXME: no one ever tested this and will probably not work.
+(defparameter *validate-input* nil
+ "Set to true to require input that strictly conforms to the protocol")
+
+(defun read-form (string package)
+ (with-standard-io-syntax
+ (let ((*package* package))
+ (if *validate-input*
+ (validating-read string)
+ (read-from-string string)))))
+
+(defun validating-read (string)
+ (with-input-from-string (*standard-input* string)
+ (simple-read)))
+
(defun simple-read ()
- "Reads a form that conforms to the protocol, otherwise signalling an error."
+ "Read a form that conforms to the protocol, otherwise signal an error."
(let ((c (read-char)))
(case c
(#\" (with-output-to-string (*standard-output*)
@@ -69,204 +87,38 @@
(cond ((digit-char-p c) (parse-integer string))
((intern string))))))))
-(defun decode-message (stream)
- "Read an S-expression from STREAM using the SLIME protocol."
- ;;(log-event "decode-message~%")
- (handler-bind ((error (lambda (c) (error (make-swank-protocol-error c)))))
- (let ((packet (read-packet stream)))
- (handler-case (values (read-form packet) nil)
- (reader-error (c)
- `(:reader-error ,packet ,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)))
- (log-event "READ: ~S~%" payload)
- payload))
-
-(defun read-chunk (stream length)
- (let* ((buffer (make-string length))
- (count (read-sequence buffer stream)))
- (assert (= count length) () "Short read: length=~D count=~D" length count)
- buffer))
-
-(defvar *swank-io-package*
- (let ((package (make-package :swank-io-package :use '())))
- (import '(nil t quote) package)
- package))
-
-(defparameter *validate-input* nil
- "Set to true to require input that strictly conforms to the protocol")
-
-(defun read-form (string)
- (with-standard-io-syntax
- (let ((*package* *swank-io-package*))
- (if *validate-input*
- (with-input-from-string (*standard-input* string)
- (simple-read))
- (read-from-string string)))))
-
+
;;;;; Output
-(defun encode-message (message stream)
- (handler-bind ((error (lambda (c) (error (make-swank-protocol-error c)))))
- (let* ((string (prin1-to-string-for-emacs message))
- (length (length string)))
- (log-event "WRITE: ~A~%" string)
- (let ((*print-pretty* nil))
- (format stream "~6,'0x" length))
- (write-string string stream)
- (finish-output stream))))
+(defun write-message (message package stream)
+ (let* ((string (prin1-to-string-for-emacs message package))
+ (length (length string)))
+ (let ((*print-pretty* nil))
+ (format stream "~6,'0x" length))
+ (write-string string stream)
+ (finish-output stream)))
-(defun prin1-to-string-for-emacs (object)
+(defun prin1-to-string-for-emacs (object package)
(with-standard-io-syntax
(let ((*print-case* :downcase)
(*print-readably* nil)
(*print-pretty* nil)
- (*package* *swank-io-package*))
+ (*package* package))
(prin1-to-string object))))
-;;;;; message decomposition
-
-(defmacro destructure-case (value &rest patterns)
- "Dispatch VALUE to one of PATTERNS.
-A cross between `case' and `destructuring-bind'.
-The pattern syntax is:
- ((HEAD . ARGS) . BODY)
-The list of patterns is searched for a HEAD `eq' to the car of
-VALUE. If one is found, the BODY is executed with ARGS bound to the
-corresponding values in the CDR of VALUE."
- (let ((operator (gensym "op-"))
- (operands (gensym "rand-"))
- (tmp (gensym "tmp-")))
- `(let* ((,tmp ,value)
- (,operator (car ,tmp))
- (,operands (cdr ,tmp)))
- (case ,operator
- ,@(loop for (pattern . body) in patterns collect
- (if (eq pattern t)
- `(t , at body)
- (destructuring-bind (op &rest rands) pattern
- `(,op (destructuring-bind ,rands ,operands
- , at body)))))
- ,@(if (eq (caar (last patterns)) t)
- '()
- `((t (error "destructure-case failed: ~S" ,tmp))))))))
-
-;;;;; Error handling
-
-(define-condition swank-protocol-error (error)
- ((condition :initarg :condition :reader swank-protocol-error.condition))
- (:report (lambda (condition stream)
- (princ (swank-protocol-error.condition condition) stream))))
-
-(defun make-swank-protocol-error (condition)
- (make-condition 'swank-protocol-error :condition condition))
-
-;;;;; Logging
-
-(defvar *log-events* nil)
-(defvar *log-output* nil) ; should be nil for image dumpers
-
-(defun init-log-output ()
- (unless *log-output*
- (setq *log-output* (real-output-stream *error-output*))))
-
-(defun real-input-stream (stream)
- (typecase stream
- (synonym-stream
- (real-input-stream (symbol-value (synonym-stream-symbol stream))))
- (two-way-stream
- (real-input-stream (two-way-stream-input-stream stream)))
- (t stream)))
-
-(defun real-output-stream (stream)
- (typecase stream
- (synonym-stream
- (real-output-stream (symbol-value (synonym-stream-symbol stream))))
- (two-way-stream
- (real-output-stream (two-way-stream-output-stream stream)))
- (t stream)))
-
-(defvar *event-history* (make-array 40 :initial-element nil)
- "A ring buffer to record events for better error messages.")
-(defvar *event-history-index* 0)
-(defvar *enable-event-history* t)
-
-(defun log-event (format-string &rest args)
- "Write a message to *terminal-io* when *log-events* is non-nil.
-Useful for low level debugging."
- (with-standard-io-syntax
- (let ((*print-readably* nil)
- (*print-pretty* nil)
- (*package* *swank-io-package*))
- (when *enable-event-history*
- (setf (aref *event-history* *event-history-index*)
- (format nil "~?" format-string args))
- (setf *event-history-index*
- (mod (1+ *event-history-index*) (length *event-history*))))
- (when *log-events*
- (write-string (escape-non-ascii (format nil "~?" format-string args))
- *log-output*)
- (force-output *log-output*)))))
-
-(defun event-history-to-list ()
- "Return the list of events (older events first)."
- (let ((arr *event-history*)
- (idx *event-history-index*))
- (concatenate 'list (subseq arr idx) (subseq arr 0 idx))))
-
-(defun clear-event-history ()
- (fill *event-history* nil)
- (setq *event-history-index* 0))
-
-(defun dump-event-history (stream)
- (dolist (e (event-history-to-list))
- (dump-event e stream)))
-
-(defun dump-event (event stream)
- (cond ((stringp event)
- (write-string (escape-non-ascii event) stream))
- ((null event))
- (t
- (write-string
- (escape-non-ascii (format nil "Unexpected event: ~A~%" event))
- stream))))
-
-(defun escape-non-ascii (string)
- "Return a string like STRING but with non-ascii chars escaped."
- (cond ((ascii-string-p string) string)
- (t (with-output-to-string (out)
- (loop for c across string do
- (cond ((ascii-char-p c) (write-char c out))
- (t (format out "\\x~4,'0X" (char-code c)))))))))
-
-(defun ascii-string-p (o)
- (and (stringp o)
- (every #'ascii-char-p o)))
-
-(defun ascii-char-p (c)
- (<= (char-code c) 127))
-
-
+
#| TEST/DEMO:
-(setf *log-events* T)
-
(defparameter *transport*
(with-output-to-string (out)
- (encode-message '(:message (hello "world")) out)
- (encode-message '(:return 5) out)
- (encode-message '(:emacs-rex NIL) out)))
+ (write-message '(:message (hello "world")) *package* out)
+ (write-message '(:return 5) *package* out)
+ (write-message '(:emacs-rex NIL) *package* out)))
*transport*
(with-input-from-string (in *transport*)
(loop while (peek-char T in NIL)
- collect (decode-message in)))
+ collect (read-message in *package*)))
|#
--- /project/slime/cvsroot/slime/swank.lisp 2010/03/29 15:57:28 1.707
+++ /project/slime/cvsroot/slime/swank.lisp 2010/04/14 17:51:30 1.708
@@ -354,6 +354,14 @@
(call-with-debugging-environment
(lambda () (backtrace 0 nil)))))
+(define-condition swank-protocol-error (error)
+ ((condition :initarg :condition :reader swank-protocol-error.condition))
+ (:report (lambda (condition stream)
+ (princ (swank-protocol-error.condition condition) stream))))
+
+(defun make-swank-protocol-error (condition)
+ (make-condition 'swank-protocol-error :condition condition))
+
(defvar *debug-on-swank-protocol-error* nil
"When non-nil invoke the system debugger on errors that were
signalled during decoding/encoding the wire protocol. Do not set this
@@ -392,8 +400,125 @@
;;;; Utilities
+
+;;;;; Logging
+
+(defvar *swank-io-package*
+ (let ((package (make-package :swank-io-package :use '())))
+ (import '(nil t quote) package)
+ package))
+
+(defvar *log-events* nil)
+(defvar *log-output* nil) ; should be nil for image dumpers
+
+(defun init-log-output ()
+ (unless *log-output*
+ (setq *log-output* (real-output-stream *error-output*))))
+
+(defun real-input-stream (stream)
+ (typecase stream
+ (synonym-stream
+ (real-input-stream (symbol-value (synonym-stream-symbol stream))))
+ (two-way-stream
+ (real-input-stream (two-way-stream-input-stream stream)))
+ (t stream)))
+
+(defun real-output-stream (stream)
+ (typecase stream
+ (synonym-stream
+ (real-output-stream (symbol-value (synonym-stream-symbol stream))))
+ (two-way-stream
+ (real-output-stream (two-way-stream-output-stream stream)))
+ (t stream)))
+
+(defvar *event-history* (make-array 40 :initial-element nil)
+ "A ring buffer to record events for better error messages.")
+(defvar *event-history-index* 0)
+(defvar *enable-event-history* t)
+
+(defun log-event (format-string &rest args)
+ "Write a message to *terminal-io* when *log-events* is non-nil.
+Useful for low level debugging."
+ (with-standard-io-syntax
+ (let ((*print-readably* nil)
+ (*print-pretty* nil)
+ (*package* *swank-io-package*))
+ (when *enable-event-history*
+ (setf (aref *event-history* *event-history-index*)
+ (format nil "~?" format-string args))
+ (setf *event-history-index*
+ (mod (1+ *event-history-index*) (length *event-history*))))
+ (when *log-events*
+ (write-string (escape-non-ascii (format nil "~?" format-string args))
+ *log-output*)
+ (force-output *log-output*)))))
+
+(defun event-history-to-list ()
+ "Return the list of events (older events first)."
+ (let ((arr *event-history*)
+ (idx *event-history-index*))
+ (concatenate 'list (subseq arr idx) (subseq arr 0 idx))))
+
+(defun clear-event-history ()
+ (fill *event-history* nil)
+ (setq *event-history-index* 0))
+
+(defun dump-event-history (stream)
+ (dolist (e (event-history-to-list))
+ (dump-event e stream)))
+
+(defun dump-event (event stream)
+ (cond ((stringp event)
+ (write-string (escape-non-ascii event) stream))
+ ((null event))
+ (t
+ (write-string
+ (escape-non-ascii (format nil "Unexpected event: ~A~%" event))
+ stream))))
+
+(defun escape-non-ascii (string)
+ "Return a string like STRING but with non-ascii chars escaped."
+ (cond ((ascii-string-p string) string)
+ (t (with-output-to-string (out)
+ (loop for c across string do
+ (cond ((ascii-char-p c) (write-char c out))
+ (t (format out "\\x~4,'0X" (char-code c)))))))))
+
+(defun ascii-string-p (o)
+ (and (stringp o)
+ (every #'ascii-char-p o)))
+
+(defun ascii-char-p (c)
+ (<= (char-code c) 127))
+
+
;;;;; Helper macros
+(defmacro destructure-case (value &rest patterns)
+ "Dispatch VALUE to one of PATTERNS.
+A cross between `case' and `destructuring-bind'.
+The pattern syntax is:
+ ((HEAD . ARGS) . BODY)
+The list of patterns is searched for a HEAD `eq' to the car of
+VALUE. If one is found, the BODY is executed with ARGS bound to the
+corresponding values in the CDR of VALUE."
+ (let ((operator (gensym "op-"))
+ (operands (gensym "rand-"))
+ (tmp (gensym "tmp-")))
+ `(let* ((,tmp ,value)
+ (,operator (car ,tmp))
+ (,operands (cdr ,tmp)))
+ (case ,operator
+ ,@(loop for (pattern . body) in patterns collect
+ (if (eq pattern t)
+ `(t , at body)
+ (destructuring-bind (op &rest rands) pattern
+ `(,op (destructuring-bind ,rands ,operands
+ , at body)))))
+ ,@(if (eq (caar (last patterns)) t)
+ '()
+ `((t (error "destructure-case failed: ~S" ,tmp))))))))
+
;; If true execute interrupts, otherwise queue them.
;; Note: `with-connection' binds *pending-slime-interrupts*.
(defvar *slime-interrupts-enabled*)
@@ -872,6 +997,28 @@
(when socket
(close-socket socket)))))
+
+;;;;; Event Decoding/Encoding
+
+(defun decode-message (stream)
+ "Read an S-expression from STREAM using the SLIME protocol."
+ (log-event "decode-message~%")
+ (without-slime-interrupts
+ (handler-bind ((error (lambda (c) (error (make-swank-protocol-error c)))))
+ (handler-case (read-message stream *swank-io-package*)
+ (swank-reader-error (c)
+ `(:reader-error ,(swank-reader-error.packet c)
+ ,(swank-reader-error.cause c)))))))
+
+(defun encode-message (message stream)
+ "Write an S-expression to STREAM using the SLIME protocol."
+ (log-event "encode-message~%")
+ (without-slime-interrupts
+ (handler-bind ((error (lambda (c) (error (make-swank-protocol-error c)))))
+ (write-message message *swank-io-package* stream))))
+
+
+;;;;; Event Processing
;; By default, this restart will be named "abort" because many people
;; press "a" instead of "q" in the debugger.
(define-special *sldb-quit-restart*
More information about the slime-cvs
mailing list