[slime-cvs] CVS update: slime/swank-cmucl.lisp slime/swank-sbcl.lisp slime/swank-clisp.lisp slime/swank-openmcl.lisp slime/swank-lispworks.lisp slime/swank-allegro.lisp
Helmut Eller
heller at common-lisp.net
Fri Jan 2 18:23:14 UTC 2004
Update of /project/slime/cvsroot/slime
In directory common-lisp.net:/tmp/cvs-serv17536
Modified Files:
swank-cmucl.lisp swank-sbcl.lisp swank-clisp.lisp
swank-openmcl.lisp swank-lispworks.lisp swank-allegro.lisp
Log Message:
(format-condition-for-emacs): Replaced with debugger-condition-for-emacs.
(backtrace): Use print-with-frame-label.
(frame-locals): Rename the :symbol property to :name.
Date: Fri Jan 2 13:23:14 2004
Author: heller
Index: slime/swank-cmucl.lisp
diff -u slime/swank-cmucl.lisp:1.42 slime/swank-cmucl.lisp:1.43
--- slime/swank-cmucl.lisp:1.42 Mon Dec 15 00:28:21 2003
+++ slime/swank-cmucl.lisp Fri Jan 2 13:23:14 2004
@@ -47,8 +47,9 @@
(system:add-fd-handler fd :input fn))
(defun accept-loop (fd background close)
- "Accept clients on the the server socket FD.
-Use fd-handlers if BACKGROUND is non-nil. Close the server socket after the first client if CLOSE is non-nil, "
+ "Accept clients on the the server socket FD. Use fd-handlers if
+BACKGROUND is non-nil. Close the server socket after the first client
+if CLOSE is non-nil, "
(cond (background
(add-input-handler
fd (lambda (fd) (accept-one-client fd background close))))
@@ -415,29 +416,6 @@
xrefs)))
(group-xrefs xrefs)))
-
-(defun location-buffer= (location1 location2)
- (equalp location1 location2))
-
-(defun file-xrefs-for-emacs (unix-filename contexts)
- "Return a summary of the references from a particular file.
-The result is a list of the form (FILENAME ((REFERRER SOURCE-PATH) ...))"
- (list unix-filename
- (loop for context in (sort-contexts-by-source-path contexts)
- collect (list (let ((*print-pretty* nil))
- (to-string (xref:xref-context-name context)))
- (xref:xref-context-source-path context)))))
-
-(defun sort-contexts-by-source-path (contexts)
- "Sort xref contexts by lexical position of source-paths.
-It is assumed that all contexts belong to the same file."
- (sort contexts #'source-path< :key #'xref:xref-context-source-path))
-
-(defun source-path< (path1 path2)
- "Return true if PATH1 is lexically before PATH2."
- (and (every #'< path1 path2)
- (< (length path1) (length path2))))
-
(defun clear-xref-info (namestring)
"Clear XREF notes pertaining to FILENAME.
This is a workaround for a CMUCL bug: XREF records are cumulative."
@@ -594,9 +572,9 @@
This is useful when debugging the definition-finding code.")
(defmacro safe-definition-finding (&body body)
- "Execute BODY ignoring errors. Return a the source location
-returned by BODY or if an error occurs a description of the error.
-The second return value is the condition or nil."
+ "Execute BODY ignoring errors. Return the source location returned
+by BODY or if an error occurs a description of the error. The second
+return value is the condition or nil."
`(flet ((body () , at body))
(if *debug-definition-finding*
(body)
@@ -974,11 +952,6 @@
collect (list (princ-to-string (restart-name restart))
(princ-to-string restart))))
-(defun format-condition-for-emacs ()
- (format nil "~A~% [Condition of type ~S]"
- (debug::safe-condition-message *swank-debugger-condition*)
- (type-of *swank-debugger-condition*)))
-
(defun nth-frame (index)
(do ((frame *sldb-stack-top* (di:frame-down frame))
(i index (1- i)))
@@ -987,10 +960,10 @@
(defun nth-restart (index)
(nth index *sldb-restarts*))
-(defun format-frame-for-emacs (frame)
- (with-output-to-string (*standard-output*)
- (let ((*print-pretty* *sldb-pprint-frames*))
- (debug::print-frame-call frame :verbosity 1 :number t))))
+(defun format-frame-for-emacs (number frame)
+ (print-with-frame-label
+ number (lambda (*standard-output*)
+ (debug::print-frame-call frame :verbosity 1 :number nil))))
(defun compute-backtrace (start end)
"Return a list of frames starting with frame number START and
@@ -1004,10 +977,10 @@
(defmethod backtrace (start end)
(loop for (n . frame) in (compute-backtrace start end)
- collect (list n (format-frame-for-emacs frame))))
+ collect (list n (format-frame-for-emacs n frame))))
(defmethod debugger-info-for-emacs (start end)
- (list (format-condition-for-emacs)
+ (list (debugger-condition-for-emacs)
(format-restarts-for-emacs)
(backtrace start end)))
@@ -1031,15 +1004,14 @@
(location (di:frame-code-location frame))
(debug-function (di:frame-debug-function frame))
(debug-variables (di::debug-function-debug-variables debug-function)))
- (loop for v across debug-variables
- for symbol = (di:debug-variable-symbol v)
- for id = (di:debug-variable-id v)
- for validy = (di:debug-variable-validity v location)
- collect (list :symbol symbol :id id
- :value-string
- (ecase validy
- (:valid (to-string (di:debug-variable-value v frame)))
- ((:invalid :unknown) "<not-available>"))))))
+ (loop for v across debug-variables collect
+ (list :name (to-string (di:debug-variable-symbol v))
+ :id (di:debug-variable-id v)
+ :value-string (ecase (di:debug-variable-validity v location)
+ (:valid
+ (to-string (di:debug-variable-value v frame)))
+ ((:invalid :unknown)
+ "<not-available>"))))))
(defmethod frame-catch-tags (index)
(loop for (tag . code-location) in (di:frame-catches (nth-frame index))
Index: slime/swank-sbcl.lisp
diff -u slime/swank-sbcl.lisp:1.44 slime/swank-sbcl.lisp:1.45
--- slime/swank-sbcl.lisp:1.44 Thu Dec 11 22:22:36 2003
+++ slime/swank-sbcl.lisp Fri Jan 2 13:23:14 2004
@@ -240,7 +240,7 @@
When Emacs presents the message it already has the source popped up
and the source form highlighted. This makes much of the information in
the error-context redundant."
- (declare (type (or sb-c::compiler-error-context error-context null)))
+ (declare (type (or sb-c::compiler-error-context null) error-context))
(let ((enclosing
(and error-context
(sb-c::compiler-error-context-enclosing-source error-context))))
@@ -407,18 +407,6 @@
;;;
-(defun tracedp (fname)
- (gethash (sb-debug::trace-fdefinition fname)
- sb-debug::*traced-funs*))
-
-(defslimefun toggle-trace-fdefinition (fname-string)
- (let ((fname (from-string fname-string)))
- (cond ((tracedp fname)
- (sb-debug::untrace-1 fname)
- (format nil "~S is now untraced." fname))
- (t
- (sb-debug::trace-1 fname (sb-debug::make-trace-info))
- (format nil "~S is now traced." fname)))))
(defslimefun getpid ()
(sb-unix:unix-getpid))
@@ -452,11 +440,6 @@
collect (list (princ-to-string (restart-name restart))
(princ-to-string restart))))
-(defun format-condition-for-emacs ()
- (format nil "~A~% [Condition of type ~S]"
- (ignore-errors *swank-debugger-condition*)
- (type-of *swank-debugger-condition*)))
-
(defun nth-frame (index)
(do ((frame *sldb-stack-top* (sb-di:frame-down frame))
(i index (1- i)))
@@ -465,30 +448,27 @@
(defun nth-restart (index)
(nth index *sldb-restarts*))
-(defun format-frame-for-emacs (frame)
- (list (sb-di:frame-number frame)
- (with-output-to-string (*standard-output*)
- (let ((*print-pretty* *sldb-pprint-frames*))
- (sb-debug::print-frame-call frame :verbosity 1 :number t)))))
+(defun format-frame-for-emacs (number frame)
+ (print-with-frame-label
+ number (lambda (*standard-output*)
+ (sb-debug::print-frame-call frame :verbosity 1 :number nil))))
(defun compute-backtrace (start end)
"Return a list of frames starting with frame number START and
continuing to frame number END or, if END is nil, the last frame on the
stack."
(let ((end (or end most-positive-fixnum)))
- (do ((frame *sldb-stack-top* (sb-di:frame-down frame))
- (i 0 (1+ i)))
- ((= i start)
- (loop for f = frame then (sb-di:frame-down f)
- for i from start below end
- while f
- collect f)))))
+ (loop for f = (nth-frame start) then (sb-di:frame-down f)
+ for i from start below end
+ while f
+ collect (cons i f))))
(defmethod backtrace (start end)
- (mapcar #'format-frame-for-emacs (compute-backtrace start end)))
+ (loop for (n . frame) in (compute-backtrace start end)
+ collect (list n (format-frame-for-emacs n frame))))
(defmethod debugger-info-for-emacs (start end)
- (list (format-condition-for-emacs)
+ (list (debugger-condition-for-emacs)
(format-restarts-for-emacs)
(backtrace start end)))
@@ -563,9 +543,8 @@
(debug-variables (sb-di::debug-fun-debug-vars debug-function)))
(loop for v across debug-variables
collect (list
- :symbol (sb-di:debug-var-symbol v)
+ :name (to-string (sb-di:debug-var-symbol v))
:id (sb-di:debug-var-id v)
- :validity (sb-di:debug-var-validity v location)
:value-string
(if (eq (sb-di:debug-var-validity v location)
:valid)
Index: slime/swank-clisp.lisp
diff -u slime/swank-clisp.lisp:1.1 slime/swank-clisp.lisp:1.2
--- slime/swank-clisp.lisp:1.1 Fri Jan 2 03:01:48 2004
+++ slime/swank-clisp.lisp Fri Jan 2 13:23:14 2004
@@ -222,10 +222,6 @@
;;; (*print-length* 10))
(funcall debugger-loop-fn)))
-(defun format-condition-for-emacs ()
- (format nil "~A~% [Condition of type ~S]"
- *swank-debugger-condition* (type-of *swank-debugger-condition*)))
-
(defun format-restarts-for-emacs ()
(loop for restart in *sldb-restarts*
collect (list (princ-to-string (restart-name restart))
@@ -248,12 +244,13 @@
(defmethod backtrace (start-frame-number end-frame-number)
(flet ((format-frame (f i)
- (format nil "~d: ~a" i
- (string-left-trim
- '(#\Newline)
- (with-output-to-string (stream)
- (let ((*print-pretty* *sldb-pprint-frames*))
- (sys::describe-frame stream f)))))))
+ (print-with-frame-label
+ i (lambda (s)
+ (princ (string-left-trim
+ '(#\Newline)
+ (with-output-to-string (stream)
+ (sys::describe-frame stream f)))
+ s)))))
(loop for i from start-frame-number
for f in (compute-backtrace start-frame-number end-frame-number)
collect (list i (format-frame f i)))))
@@ -275,18 +272,16 @@
;; NIL or #(v1 val1 ... vn valn NEXT-ENV).
(defun frame-do-venv (frame venv)
- (loop
- for i from 1 below (length venv) by 2
- as symbol = (svref venv (1- i))
- and value = (svref venv i)
- collect (list :symbol symbol :id 0
- :value-string
- (to-string
- (if (eq sys::specdecl value)
- ;; special variable
- (sys::eval-at frame symbol)
- ;; lexical variable or symbol macro
- value)))))
+ (loop for i from 1 below (length venv) by 2
+ as symbol = (svref venv (1- i))
+ and value = (svref venv i)
+ collect (list :name (to-string symbol) :id 0
+ :value-string (to-string
+ (if (eq sys::specdecl value)
+ ;; special variable
+ (sys::eval-at frame symbol)
+ ;; lexical variable or symbol macro
+ value)))))
(defun frame-do-fenv (frame fenv)
(declare (ignore frame fenv))
@@ -313,7 +308,7 @@
(nth-frame index))))
(defmethod debugger-info-for-emacs (start end)
- (list (format-condition-for-emacs)
+ (list (debugger-condition-for-emacs)
(format-restarts-for-emacs)
(backtrace start end)))
Index: slime/swank-openmcl.lisp
diff -u slime/swank-openmcl.lisp:1.42 slime/swank-openmcl.lisp:1.43
--- slime/swank-openmcl.lisp:1.42 Fri Dec 19 00:50:18 2003
+++ slime/swank-openmcl.lisp Fri Jan 2 13:23:14 2004
@@ -13,7 +13,7 @@
;;; The LLGPL is also available online at
;;; http://opensource.franz.com/preamble.html
;;;
-;;; $Id: swank-openmcl.lisp,v 1.42 2003/12/19 05:50:18 aruttenberg Exp $
+;;; $Id: swank-openmcl.lisp,v 1.43 2004/01/02 18:23:14 heller Exp $
;;;
;;;
@@ -281,10 +281,6 @@
collect (list (princ-to-string (restart-name restart))
(princ-to-string restart))))
-(defun format-condition-for-emacs ()
- (format nil "~A~% [Condition of type ~S]"
- *swank-debugger-condition* (type-of *swank-debugger-condition*)))
-
(defun map-backtrace (function &optional
(start-frame-number 0)
(end-frame-number most-positive-fixnum))
@@ -351,15 +347,18 @@
(let (result)
(map-backtrace (lambda (frame-number p tcr lfun pc)
(push (list frame-number
- (format nil "~D: (~A~A)" frame-number
- (ccl::%lfun-name-string lfun)
- (frame-arguments p tcr lfun pc)))
+ (print-with-frame-label
+ frame-number
+ (lambda (s)
+ (format s "(~A~A)"
+ (ccl::%lfun-name-string lfun)
+ (frame-arguments p tcr lfun pc)))))
result))
start-frame-number end-frame-number)
(nreverse result)))
(defmethod debugger-info-for-emacs (start end)
- (list (format-condition-for-emacs)
+ (list (debugger-condition-for-emacs)
(format-restarts-for-emacs)
(backtrace start end)))
@@ -376,9 +375,8 @@
(declare (ignore type))
(when name
(push (list
- :symbol (to-string name)
+ :name (to-string name)
:id 0
- :validity :valid
:value-string (to-string var))
result))))
(return-from frame-locals (nreverse result))))))))
Index: slime/swank-lispworks.lisp
diff -u slime/swank-lispworks.lisp:1.9 slime/swank-lispworks.lisp:1.10
--- slime/swank-lispworks.lisp:1.9 Sun Dec 14 02:59:36 2003
+++ slime/swank-lispworks.lisp Fri Jan 2 13:23:14 2004
@@ -7,7 +7,7 @@
;;; This code has been placed in the Public Domain. All warranties
;;; are disclaimed.
;;;
-;;; $Id: swank-lispworks.lisp,v 1.9 2003/12/14 07:59:36 heller Exp $
+;;; $Id: swank-lispworks.lisp,v 1.10 2004/01/02 18:23:14 heller Exp $
;;;
(in-package :swank)
@@ -169,12 +169,6 @@
(let ((*sldb-restarts* (compute-restarts *swank-debugger-condition*)))
(funcall fn))))
-(defun format-condition-for-emacs ()
- (let ((*print-right-margin* 75)
- (*print-pretty* t))
- (format nil "~A~% [Condition of type ~S]"
- *swank-debugger-condition* (type-of *swank-debugger-condition*))))
-
(defun format-restarts-for-emacs ()
(loop for restart in *sldb-restarts*
collect (list (princ-to-string (restart-name restart))
@@ -203,22 +197,21 @@
(defmethod backtrace (start end)
(flet ((format-frame (f i)
- (with-output-to-string (*standard-output*)
- (let ((*print-pretty* *sldb-pprint-frames*))
- (format t "~D: ~A" i
- (cond ((dbg::call-frame-p f)
- (format nil "~A ~A"
- (dbg::call-frame-function-name f)
- (dbg::call-frame-arglist f)))
- (t f)))))))
+ (print-with-frame-label
+ i (lambda (s)
+ (cond ((dbg::call-frame-p f)
+ (format s "~A ~A"
+ (dbg::call-frame-function-name f)
+ (dbg::call-frame-arglist f)))
+ (t (princ f s)))))))
(loop for i from start
for f in (compute-backtrace start end)
collect (list i (format-frame f i)))))
(defmethod debugger-info-for-emacs (start end)
- (list (format-condition-for-emacs)
+ (list (debugger-condition-for-emacs)
(format-restarts-for-emacs)
- (backtrace start end)))
+ (backtrace start end)))
(defun nth-restart (index)
(nth index *sldb-restarts*))
@@ -233,7 +226,7 @@
(dbg::frame-locals-format-list frame #'list 75 0)
(declare (ignore with))
(loop for (name value symbol location) in vars
- collect (list :symbol symbol :id 0
+ collect (list :name (to-string symbol) :id 0
:value-string (princ-to-string value)))))))
(defmethod frame-catch-tags (index)
Index: slime/swank-allegro.lisp
diff -u slime/swank-allegro.lisp:1.4 slime/swank-allegro.lisp:1.5
--- slime/swank-allegro.lisp:1.4 Sun Dec 14 02:58:12 2003
+++ slime/swank-allegro.lisp Fri Jan 2 13:23:14 2004
@@ -7,7 +7,7 @@
;;; This code has been placed in the Public Domain. All warranties
;;; are disclaimed.
;;;
-;;; $Id: swank-allegro.lisp,v 1.4 2003/12/14 07:58:12 heller Exp $
+;;; $Id: swank-allegro.lisp,v 1.5 2004/01/02 18:23:14 heller Exp $
;;;
;;; This code was written for
;;; Allegro CL Trial Edition "5.0 [Linux/X86] (8/29/98 10:57)"
@@ -36,6 +36,8 @@
;;; TCP Server
+(setq *start-swank-in-background* nil)
+
(defun create-swank-server (port &key (reuse-address t)
(announce #'simple-announce-function)
(background *start-swank-in-background*)
@@ -145,10 +147,6 @@
(*print-length* 10))
(funcall debugger-loop-fn)))
-(defun format-condition-for-emacs ()
- (format nil "~A~% [Condition of type ~S]"
- *swank-debugger-condition* (type-of *swank-debugger-condition*)))
-
(defun format-restarts-for-emacs ()
(loop for restart in *sldb-restarts*
collect (list (princ-to-string (restart-name restart))
@@ -168,16 +166,14 @@
(defmethod backtrace (start-frame-number end-frame-number)
(flet ((format-frame (f i)
- (with-output-to-string (stream)
- (let ((*print-pretty* *sldb-pprint-frames*))
- (format stream "~D: " i)
- (debugger:output-frame stream f :moderate)))))
+ (print-with-frame-label
+ i (lambda (s) (debugger:output-frame s f :moderate)))))
(loop for i from start-frame-number
for f in (compute-backtrace start-frame-number end-frame-number)
collect (list i (format-frame f i)))))
(defmethod debugger-info-for-emacs (start end)
- (list (format-condition-for-emacs)
+ (list (debugger-condition-for-emacs)
(format-restarts-for-emacs)
(backtrace start end)))
@@ -193,7 +189,7 @@
(defmethod frame-locals (index)
(let ((frame (nth-frame index)))
(loop for i from 0 below (debugger:frame-number-vars frame)
- collect (list :symbol (debugger:frame-var-name frame i)
+ collect (list :name (to-string (debugger:frame-var-name frame i))
:id 0
:value-string
(to-string (debugger:frame-var-value frame i))))))
More information about the slime-cvs
mailing list