[nongnu] externals/sly dcfe556 02/47: Fixed sldb and backtraces in clasp

[ELPA Syncer]

branch: externals/sly
commit dcfe5562f4e1ac204a5720e870be360b2ac202f4
Author: Chris Schafmeister <meister@temple.edu>
Commit: João Távora <joaotavora@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 <manfred@nnamgreb.de>
    Co-authored-by: João Távora <joaotavora@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