[slime-cvs] CVS slime
heller
heller at common-lisp.net
Sat Sep 20 21:46:16 UTC 2008
Update of /project/slime/cvsroot/slime
In directory clnet:/tmp/cvs-serv19258
Modified Files:
ChangeLog swank-openmcl.lisp
Log Message:
Fix some of the bugs that I introduced with the last commits.
* swank-openmcl.lisp (call-with-debugging-environment): Fix typo.
(call-with-debugger-hook): Bind *break-in-sldb*.
(backtrace-context): Return nil, not tcr!
(map-backtrace): Remove the stack< test. Only test for nil.
(lisp-implementation-type-name): Return "ccl".
(emacs-inspect (t)): Fix typo.
(kill-thread): Use join-process. Otherwise we get strange
"process-reset" errors when disconnecting.
(thread-alive-p): Implemented with ccl::process-exhausted-p.
(source-locations): Use labels for helper functions.
(function-source-location): No implemented on top of
source-locations.
--- /project/slime/cvsroot/slime/ChangeLog 2008/09/20 16:34:08 1.1530
+++ /project/slime/cvsroot/slime/ChangeLog 2008/09/20 21:46:16 1.1531
@@ -1,5 +1,32 @@
2008-09-20 Helmut Eller <heller at common-lisp.net>
+ Fix some of the bugs that I introduced with the last commits.
+
+ * swank-openmcl.lisp (call-with-debugging-environment): Fix typo.
+ (call-with-debugger-hook): Bind *break-in-sldb*.
+ (backtrace-context): Return nil, not tcr!
+ (map-backtrace): Remove the stack< test. Only test for nil.
+ (lisp-implementation-type-name): Return "ccl".
+
+ (emacs-inspect (t)): Fix typo.
+
+ (kill-thread): Use join-process. Otherwise we get strange
+ "process-reset" errors when disconnecting.
+ (thread-alive-p): Implemented with ccl::process-exhausted-p.
+
+ (source-locations): Use labels for helper functions.
+ (function-source-location): No implemented on top of
+ source-locations.
+
+2008-09-20 Helmut Eller <heller at common-lisp.net>
+
+ Fix frame-source-location-for-emacs for CCL.
+
+ * swank-openmcl.lisp (source-locations): New function.
+ (create-source-location): New function.
+ (frame-source-location-for-emacs): Use it.
+
+2008-09-20 Helmut Eller <heller at common-lisp.net>
Fix inspecting of arrays.
* swank-openmcl.lisp (emacs-inspect :around (t)): call-next-method
--- /project/slime/cvsroot/slime/swank-openmcl.lisp 2008/09/20 16:34:08 1.137
+++ /project/slime/cvsroot/slime/swank-openmcl.lisp 2008/09/20 21:46:16 1.138
@@ -202,7 +202,7 @@
(ccl::getpid))
(defimplementation lisp-implementation-type-name ()
- "openmcl")
+ "ccl")
;;; Evaluation
@@ -430,21 +430,27 @@
(*sldb-stack-top-hint* nil)
;; don't let error while printing error take us down
(ccl::*signal-printing-errors* nil))
- (funcall debugger-loop-xfn)))
+ (funcall debugger-loop-fn)))
+
+(defimplementation call-with-debugger-hook (hook fun)
+ (let ((*debugger-hook* hook)
+ (*break-in-sldb* t))
+ (funcall fun)))
+
+(defun backtrace-context ()
+ nil)
(defun map-backtrace (function &optional
(start-frame-number 0)
(end-frame-number most-positive-fixnum))
"Call FUNCTION passing information about each stack frame
from frames START-FRAME-NUMBER to END-FRAME-NUMBER."
- (let ((context (ccl::%current-tcr))
+ (let ((context (backtrace-context))
(frame-number 0)
(top-stack-frame (or *sldb-stack-top*
(ccl::%get-frame-ptr))))
- (do* ((p top-stack-frame (ccl::parent-frame p context))
- (q (ccl::last-frame-ptr context)))
- ((or (null p) (eq p q) (ccl::%stack< q p context))
- (values))
+ (do ((p top-stack-frame (ccl::parent-frame p context)))
+ ((null p))
(multiple-value-bind (lfun pc) (ccl::cfp-lfun p)
(when lfun
(if (and (>= frame-number start-frame-number)
@@ -595,19 +601,44 @@
(canonicalize-location file symbol))))))
(defun function-source-location (function)
- (multiple-value-bind (info name)
- (ccl::edit-definition-p function)
- (cond ((not info) (list :error (format nil "No source info available for ~A" function)))
- ((typep (caar info) 'ccl::method)
- `(:location
- (:file ,(remove-filename-quoting (namestring (translate-logical-pathname (cdr (car info))) )))
- (:method ,(princ-to-string (ccl::method-name (caar info)))
- ,(mapcar 'princ-to-string
- (mapcar #'specializer-name
- (ccl::method-specializers (caar info))))
- ,@(mapcar 'princ-to-string (ccl::method-qualifiers (caar info))))
- nil))
- (t (canonicalize-location (second (first info)) name (third (first info)))))))
+ (or (car (source-locations function))
+ (list :error (format nil "No source info available for ~A" function))))
+
+;; source-locations THING => LOCATIONS NAMES
+;; LOCATIONS ... a list of source-locations. Most "specific" first.
+;; NAMES ... a list of names.
+(labels ((str (obj) (princ-to-string obj))
+ (str* (list) (mapcar #'princ-to-string list))
+ (filename (file) (namestring (truename file)))
+ (src-loc (file pos)
+ (assert (or (null file) (stringp file) (pathnamep file)))
+ (etypecase file
+ (null `(:error "No source-file info available"))
+ ((or string pathname)
+ (handler-case (make-location `(:file ,(filename file)) pos)
+ (error (c) `(:error ,(princ-to-string c))))))))
+
+ (defun source-locations (thing)
+ (multiple-value-bind (files name) (ccl::edit-definition-p thing)
+ (let ((locs '()) (names '()))
+ (loop for (type . file) in files do
+ (etypecase type
+ ((member function macro variable compiler-macro
+ ccl:defcallback ccl::x8664-vinsn)
+ (push (src-loc file (list :function-name (str name)))
+ locs)
+ (push (list type name) names))
+ (method
+ (let* ((m type)
+ (name (ccl::method-name m))
+ (specs (ccl::method-specializers m))
+ (specs (mapcar #'specializer-name specs))
+ (quals (ccl::method-qualifiers m)))
+ (push (src-loc file (list :method (str name) (str* specs)
+ (str* quals)))
+ locs)
+ (push `(method ,name ,quals ,specs) names)))))
+ (values (nreverse locs) (nreverse names))))))
(defimplementation frame-source-location-for-emacs (index)
"Return to Emacs the location of the source code for the
@@ -764,7 +795,7 @@
for l below count
for (value label) = (multiple-value-list
(inspector::line-n i l))
- collect (if label (format nil "~(~a~)" label) i)
+ collect (format nil "~(~a~)" (or label l))
collect " = "
collect `(:value ,value)
collect '(:newline))))
@@ -868,8 +899,14 @@
(defimplementation all-threads ()
(ccl:all-processes))
+;; our thread-alive-p implementation will not work well if we don't
+;; wait. join-process should have a timeout argument.
(defimplementation kill-thread (thread)
- (ccl:process-kill thread))
+ (ccl:process-kill thread)
+ (ccl:join-process thread))
+
+(defimplementation thread-alive-p (thread)
+ (not (ccl::process-exhausted-p thread)))
(defimplementation interrupt-thread (thread function)
(ccl:process-interrupt
@@ -887,13 +924,10 @@
(setq *known-processes*
(acons (ccl::process-serial-number thread)
(list thread mailbox)
- (remove-if
- (lambda(entry)
- (string= (ccl::process-whostate (second entry)) "Exhausted"))
- *known-processes*)
- ))
+ (remove-if #'ccl::process-exhausted-p
+ *known-processes*)))
mailbox))))))
-
+
(defimplementation send (thread message)
(assert message)
(let* ((mbox (mailbox thread))
More information about the slime-cvs
mailing list