/[slime]/slime/swank.lisp
ViewVC logotype

Diff of /slime/swank.lisp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.355 by mbaringer, Tue Dec 20 00:26:25 2005 UTC revision 1.356 by heller, Tue Dec 27 15:12:22 2005 UTC
# Line 323  The package is deleted before returning. Line 323  The package is deleted before returning.
323    
324  (defvar *log-events* nil)  (defvar *log-events* nil)
325  (defvar *log-output* *error-output*)  (defvar *log-output* *error-output*)
326    (defvar *event-history* (make-array 40 :initial-element nil)
327      "A ring buffer to record events for better error messages.")
328    (defvar *event-history-index* 0)
329    (defvar *enable-event-history* t)
330    
331  (defun log-event (format-string &rest args)  (defun log-event (format-string &rest args)
332    "Write a message to *terminal-io* when *log-events* is non-nil.    "Write a message to *terminal-io* when *log-events* is non-nil.
333  Useful for low level debugging."  Useful for low level debugging."
334      (when *enable-event-history*
335        (setf (aref *event-history* *event-history-index*)
336              (apply #'format nil format-string args))
337        (setf *event-history-index*
338              (mod (1+ *event-history-index*) (length *event-history*))))
339    (when *log-events*    (when *log-events*
340      (apply #'format *log-output* format-string args)      (apply #'format *log-output* format-string args)
341      (force-output *log-output*)))      (force-output *log-output*)))
342    
343    (defun event-history-to-list ()
344      "Return the list of events (older events first)."
345      (let ((arr *event-history*)
346            (idx *event-history-index*))
347        (concatenate 'list (subseq arr idx) (subseq arr 0 idx))))
348    
349    (defun dump-event-history (stream)
350      (dolist (e (event-history-to-list))
351        (dump-event e stream)))
352    
353    (defun dump-event (event stream)
354      (cond ((stringp event)
355             (write-string (escape-non-ascii event) stream))
356            ((null event))
357            (t (format stream "Unexpected event: ~A~%" event))))
358    
359    (defun escape-non-ascii (string)
360      "Return a string like STRING but with non-ascii chars escaped."
361      (cond ((ascii-string-p string) string)
362            (t (with-output-to-string (out)
363                 (loop for c across string do
364                   (cond ((ascii-char-p c) (write-char c out))
365                         (t (format out "\\x~4,'0X" (char-code c)))))))))
366    
367    (defun ascii-string-p (o)
368      (and (stringp o)
369           (every #'ascii-char-p o)))
370    
371    (defun ascii-char-p (c)
372      (<= (char-code c) 127))
373    
374    
375  ;;;; TCP Server  ;;;; TCP Server
376    
# Line 510  of the toplevel restart." Line 550  of the toplevel restart."
550    (setf *connections* (remove c *connections*))    (setf *connections* (remove c *connections*))
551    (run-hook *connection-closed-hook* c)    (run-hook *connection-closed-hook* c)
552    (when condition    (when condition
553      (format *debug-io* "~&;; Connection to Emacs lost.~%;; [~A]~%" condition)      (finish-output *debug-io*)
554        (format *debug-io* "~&;; Event history start:~%")
555        (dump-event-history *debug-io*)
556        (format *debug-io* ";; Event history end.~%~
557                            ;; Connection to Emacs lost. [~%~
558                            ;;  condition: ~A~%~
559                            ;;  type: ~S~%~
560                            ;;  encoding: ~S style: ~S dedicated: ~S]~%"
561                (escape-non-ascii (safe-condition-message condition) )
562                (type-of condition)
563                (connection.external-format c)
564                (connection.communication-style c)
565                *use-dedicated-output-stream*)
566      (finish-output *debug-io*)))      (finish-output *debug-io*)))
567    
568  (defmacro with-reader-error-handler ((connection) &body body)  (defmacro with-reader-error-handler ((connection) &body body)
# Line 962  If a protocol error occurs then a SLIME- Line 1014  If a protocol error occurs then a SLIME-
1014                 (pos (read-sequence string stream)))                 (pos (read-sequence string stream)))
1015            (assert (= pos length) ()            (assert (= pos length) ()
1016                    "Short read: length=~D  pos=~D" length pos)                    "Short read: length=~D  pos=~D" length pos)
1017            (let ((form (read-form string)))            (log-event "READ: ~S~%" string)
1018              (log-event "READ: ~A~%" string)            (read-form string))
             form))  
1019        (serious-condition (c)        (serious-condition (c)
1020          (error (make-condition 'slime-protocol-error :condition c))))))          (error (make-condition 'slime-protocol-error :condition c))))))
1021    

Legend:
Removed from v.1.355  
changed lines
  Added in v.1.356

  ViewVC Help
Powered by ViewVC 1.1.5