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

Diff of /slime/swank.lisp

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

revision 1.574 by heller, Fri Aug 22 21:15:13 2008 UTC revision 1.575 by heller, Fri Aug 22 21:15:19 2008 UTC
# Line 1485  NIL if streams are not globally redirect Line 1485  NIL if streams are not globally redirect
1485  (defun encode-message (message stream)  (defun encode-message (message stream)
1486    (let* ((string (prin1-to-string-for-emacs message))    (let* ((string (prin1-to-string-for-emacs message))
1487           (length (length string)))           (length (length string)))
1488        (assert (<= length #xffffff))
1489      (log-event "WRITE: ~A~%" string)      (log-event "WRITE: ~A~%" string)
1490      (without-interrupts      (let ((*print-pretty* nil))
1491        (let ((*print-pretty* nil))        (format stream "~6,'0x" length))
1492          (format stream "~6,'0x" length))      (write-string string stream)
       (write-string string stream))  
1493      ;;(terpri stream)      ;;(terpri stream)
1494      (finish-output stream)))      (finish-output stream)))
1495    
# Line 1958  Return the full package-name and the str Line 1958  Return the full package-name and the str
1958            (ellipsis (cat (subseq string 0 width) ellipsis))            (ellipsis (cat (subseq string 0 width) ellipsis))
1959            (t (subseq string 0 width)))))            (t (subseq string 0 width)))))
1960    
1961    (defun call/truncated-output-to-string (length function
1962                                            &optional (ellipsis ".."))
1963      "Call FUNCTION with a new stream, return the output written to the stream.
1964    If FUNCTION tries to write more than LENGTH characters, it will be
1965    aborted and return immediately with the output written so far."
1966      (let ((buffer (make-string (+ length (length ellipsis))))
1967            (fill-pointer 0))
1968        (block buffer-full
1969          (flet ((write-output (string)
1970                   (let* ((free (- length fill-pointer))
1971                          (count (min free (length string))))
1972                     (replace buffer string :start1 fill-pointer :end2 count)
1973                     (incf fill-pointer count)
1974                     (when (> (length string) free)
1975                       (replace buffer ellipsis :start1 fill-pointer)
1976                       (return-from buffer-full buffer)))))
1977            (let ((stream (make-output-stream #'write-output)))
1978              (funcall function stream)
1979              (finish-output stream)
1980              (subseq buffer 0 fill-pointer))))))
1981    
1982  (defun package-string-for-prompt (package)  (defun package-string-for-prompt (package)
1983    "Return the shortest nickname (or canonical name) of PACKAGE."    "Return the shortest nickname (or canonical name) of PACKAGE."
1984    (unparse-name    (unparse-name
# Line 2191  format suitable for Emacs." Line 2212  format suitable for Emacs."
2212    "Return a list ((I FRAME) ...) of frames from START to END.    "Return a list ((I FRAME) ...) of frames from START to END.
2213  I is an integer describing and FRAME a string."  I is an integer describing and FRAME a string."
2214    (loop for frame in (compute-backtrace start end)    (loop for frame in (compute-backtrace start end)
2215          for i from start          for i from start collect
2216          collect (list i (with-output-to-string (stream)          (list i
2217                            (handler-case                (call/truncated-output-to-string
2218                                (with-bindings *backtrace-printer-bindings*                 100
2219                                  (print-frame frame stream))                 (lambda (stream)
2220                              (t ()                   (handler-case
2221                                (format stream "[error printing frame]")))))))                       (with-bindings *backtrace-printer-bindings*
2222                           (print-frame frame stream))
2223                       (t ()
2224                         (format stream "[error printing frame]"))))))))
2225    
2226  (defslimefun debugger-info-for-emacs (start end)  (defslimefun debugger-info-for-emacs (start end)
2227    "Return debugger state, with stack frames from START to END.    "Return debugger state, with stack frames from START to END.
# Line 2283  the local variables in the frame INDEX." Line 2307  the local variables in the frame INDEX."
2307      (mapcar (lambda (frame-locals)      (mapcar (lambda (frame-locals)
2308                (destructuring-bind (&key name id value) frame-locals                (destructuring-bind (&key name id value) frame-locals
2309                  (list :name (prin1-to-string name) :id id                  (list :name (prin1-to-string name) :id id
2310                        :value (to-string value))))                        :value (to-line value))))
2311              (frame-locals index))))              (frame-locals index))))
2312    
2313  (defslimefun frame-catch-tags-for-emacs (frame-index)  (defslimefun frame-catch-tags-for-emacs (frame-index)
# Line 2848  DSPEC is a string and LOCATION a source Line 2872  DSPEC is a string and LOCATION a source
2872      (emacs-inspect object)))      (emacs-inspect object)))
2873    
2874  (defun istate>elisp (istate)  (defun istate>elisp (istate)
2875    (list :title (with-output-to-string (s)    (list :title (call/truncated-output-to-string
2876                   (print-unreadable-object ((istate.object istate)                  200
2877                                             s :type t :identity t)))                  (lambda (s)
2878                      (print-unreadable-object ((istate.object istate)
2879                                               s :type t :identity t))))
2880          :id (assign-index (istate.object istate) (istate.parts istate))          :id (assign-index (istate.object istate) (istate.parts istate))
2881          :content (content-range (inspector-content istate) 0 500)))          :content (content-range (inspector-content istate) 0 500)))
2882    
# Line 2889  DSPEC is a string and LOCATION a source Line 2915  DSPEC is a string and LOCATION a source
2915    
2916  ;; Print OBJECT to a single line. Return the string.  ;; Print OBJECT to a single line. Return the string.
2917  (defun to-line  (object &optional (width 75))  (defun to-line  (object &optional (width 75))
2918    (truncate-string    (call/truncated-output-to-string
2919     (with-output-to-string (*standard-output*)     width
2920       (lambda (*standard-output*)
2921       (write object :right-margin width :lines 1))       (write object :right-margin width :lines 1))
2922     80 ".."))     ".."))
2923    
2924  (defun content-range (list start end)  (defun content-range (list start end)
2925    (let* ((len (length list)) (end (min len end)))    (let* ((len (length list)) (end (min len end)))

Legend:
Removed from v.1.574  
changed lines
  Added in v.1.575

  ViewVC Help
Powered by ViewVC 1.1.5