[slime-cvs] CVS slime
CVS User tnorderhaug
tnorderhaug at common-lisp.net
Tue Jan 19 21:14:23 UTC 2010
Update of /project/slime/cvsroot/slime
In directory cl-net:/tmp/cvs-serv528
Modified Files:
swank.lisp
Log Message:
Deleted redundant definitions covered by swank-rpc.
--- /project/slime/cvsroot/slime/swank.lisp 2010/01/19 19:41:01 1.684
+++ /project/slime/cvsroot/slime/swank.lisp 2010/01/19 21:14:23 1.685
@@ -82,11 +82,6 @@
(defvar *auto-abbreviate-dotted-packages* t
"Abbreviate dotted package names to their last component if T.")
-(defvar *swank-io-package*
- (let ((package (make-package :swank-io-package :use '())))
- (import '(nil t quote) package)
- package))
-
(defconstant default-server-port 4005
"The default TCP port for the server (when started manually).")
@@ -324,17 +319,6 @@
(defslimefun ping (tag)
tag)
-;; A condition to include backtrace information
-(define-condition swank-protocol-error (error)
- ((condition :initarg :condition :reader swank-protocol-error.condition)
- (backtrace :initarg :backtrace :reader swank-protocol-error.backtrace))
- (:report (lambda (condition stream)
- (princ (swank-protocol-error.condition condition) stream))))
-
-(defun make-swank-protocol-error (condition)
- (make-condition 'swank-protocol-error :condition condition
- :backtrace (safe-backtrace)))
-
(defun safe-backtrace ()
(ignore-errors
(call-with-debugging-environment
@@ -452,31 +436,6 @@
(check-type msg string)
`(call-with-retry-restart ,msg #'(lambda () , at body)))
-(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))))))))
-
(defmacro with-struct* ((conc-name get obj) &body body)
(let ((var (gensym)))
`(let ((,var ,obj))
@@ -520,91 +479,8 @@
;;;;; 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)))
-
(add-hook *after-init-hook* 'init-log-output)
-(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))
-
;;;;; Symbols
@@ -1727,36 +1603,6 @@
-(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))
-
-(defun read-form (string)
- (with-standard-io-syntax
- (let ((*package* *swank-io-package*))
- (read-from-string string))))
-
(defun input-available-p (stream)
;; return true iff we can read from STREAM without waiting or if we
;; hit EOF
@@ -1773,24 +1619,6 @@
(defun send-oob-to-emacs (object)
(send-to-emacs object))
-(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 prin1-to-string-for-emacs (object)
- (with-standard-io-syntax
- (let ((*print-case* :downcase)
- (*print-readably* nil)
- (*print-pretty* nil)
- (*package* *swank-io-package*))
- (prin1-to-string object))))
-
(defun force-user-output ()
(force-output (connection.user-io *emacs-connection*)))
More information about the slime-cvs
mailing list