branch: externals/sly
commit dcfe5562f4e1ac204a5720e870be360b2ac202f4
Author: Chris Schafmeister <meis...@temple.edu>
Commit: João Távora <joaotav...@gmail.com>
Fixed sldb and backtraces in clasp
Use the core:call-with-backtrace and pass it a closure
that runs within an environment where the backtrace is valid.
* slynk/backend/clasp.lisp (call-with-debugging-environment): Rework.
(*saved-backtrace*): Remove.
Cherry-picked-from: SLIME commit 06f6d9829d9d1eace93efb4d00c724ceab667079
Co-authored-by: Manfred Bergmann <manf...@nnamgreb.de>
Co-authored-by: João Távora <joaotav...@gmail.com>
---
slynk/backend/clasp.lisp | 50 ++++++++++++++++++++----------------------------
1 file changed, 21 insertions(+), 29 deletions(-)
diff --git a/slynk/backend/clasp.lisp b/slynk/backend/clasp.lisp
index acc4ccb..7db7796 100644
--- a/slynk/backend/clasp.lisp
+++ b/slynk/backend/clasp.lisp
@@ -464,41 +464,33 @@
;; (declare (ignore position))
;; (if file (is-slynk-source-p file)))))
-(defparameter *saved-backtrace* nil)
(defimplementation call-with-debugging-environment (debugger-loop-fn)
(declare (type function debugger-loop-fn))
(let* ((*ihs-top* 0)
(*ihs-current* *ihs-top*)
#+frs (*frs-base* (or (sch-frs-base *frs-top* *ihs-base*) (1+
(frs-top))))
#+frs (*frs-top* (frs-top))
- (*tpl-level* (1+ *tpl-level*))
- (*backtrace* (let ((backtrace (core::common-lisp-backtrace-frames
- :gather-start-trigger
- (lambda (frame)
- (let ((function-name
(core::backtrace-frame-function-name frame)))
- (and (symbolp function-name)
- (eq function-name
'core::universal-error-handler))))
- :gather-all-frames nil)))
- (unless backtrace
- (setq backtrace (core::common-lisp-backtrace-frames
- :gather-all-frames nil)))
- backtrace)))
- (declare (special *ihs-current*))
- (setq *saved-backtrace* *backtrace*)
- #+(or)
- (progn
- (format ext:+process-standard-output+ "---------------
call-with-debugging-environment -----------~%")
- (format ext:+process-standard-output+ "(length *backtrace*) -> ~a ~%"
(length *backtrace*))
- (format ext:+process-standard-output+ "Raw backtrace length: ~a ~%"
(length (core:clib-backtrace-as-list)))
- (format ext:+process-standard-output+ "Common Lisp backtrace frames
length: ~a ~%" (length (core::common-lisp-backtrace-frames)))
- (loop for f in (core::common-lisp-backtrace-frames)
- for id from 0
- do (progn
- (format ext:+process-standard-output+ "Frame ~a: (~a ~a)~%"
id (core::backtrace-frame-print-name f) (core::backtrace-frame-arguments f)))))
- (set-break-env)
- (set-current-ihs)
- (let ((*ihs-base* *ihs-top*))
- (funcall debugger-loop-fn))))
+ (*tpl-level* (1+ *tpl-level*)))
+ (core:call-with-backtrace
+ (lambda (raw-backtrace)
+ (let ((*backtrace*
+ (let ((backtrace (core::common-lisp-backtrace-frames
+ raw-backtrace
+ :gather-start-trigger
+ (lambda (frame)
+ (let ((function-name
(core::backtrace-frame-function-name frame)))
+ (and (symbolp function-name)
+ (eq function-name
'core::universal-error-handler))))
+ :gather-all-frames nil)))
+ (unless backtrace
+ (setq backtrace (core::common-lisp-backtrace-frames
+ :gather-all-frames nil)))
+ backtrace)))
+ (declare (special *ihs-current*))
+ (set-break-env)
+ (set-current-ihs)
+ (let ((*ihs-base* *ihs-top*))
+ (funcall debugger-loop-fn)))))))
(defimplementation compute-backtrace (start end)
(subseq *backtrace* start
