[nongnu] externals/sly c41b298 36/47: clasp.lisp changes to use new clasp-debug pkg

[ELPA Syncer]

branch: externals/sly
commit c41b2980773521af90f8e62a39040b4c0b3f96bb
Author: Chris Schafmeister <meister@temple.edu>
Commit: João Távora <joaotavora@gmail.com>

    clasp.lisp changes to use new clasp-debug pkg
    
    Clasp added a clasp-debug package for debugging.
    Here we upgrade clasp.lisp to use it in slynk.
    
    * slynk/backend/clasp.lisp: rework.
    
    Cherry-picked-from: SLIME commit 221518f0d3d224403743e6690f6bb66c42d9dec9
    Co-authored-by: João Távora <joaotavora@gmail.com>
---
 slynk/backend/clasp.lisp | 147 +++++++++--------------------------------------
 1 file changed, 27 insertions(+), 120 deletions(-)

diff --git a/slynk/backend/clasp.lisp b/slynk/backend/clasp.lisp
index f0f8a8b..415f830 100644
--- a/slynk/backend/clasp.lisp
+++ b/slynk/backend/clasp.lisp
@@ -381,25 +381,6 @@
 
 ;;; Debugging
 
-(eval-when (:compile-toplevel :load-toplevel :execute)
-  (import
-   '(si::*break-env*
-     si::*ihs-top*
-     si::*ihs-current*
-     si::*ihs-base*
-#+frs     si::*frs-base*
-#+frs     si::*frs-top*
-     si::*tpl-commands*
-     si::*tpl-level*
-#+frs     si::frs-top
-     si::ihs-top
-     si::ihs-fun
-     si::ihs-env
-#+frs     si::sch-frs-base
-     si::set-break-env
-     si::set-current-ihs
-     si::tpl-commands)))
-
 (defun make-invoke-debugger-hook (hook)
   (when hook
     #'(lambda (condition old-hook)
@@ -410,14 +391,12 @@
 
 (defimplementation install-debugger-globally (function)
   (setq *debugger-hook* function)
-  (setq ext:*invoke-debugger-hook* (make-invoke-debugger-hook function))
-  )
+  (setq ext:*invoke-debugger-hook* (make-invoke-debugger-hook function)))
 
 (defimplementation call-with-debugger-hook (hook fun)
   (let ((*debugger-hook* hook)
         (ext:*invoke-debugger-hook* (make-invoke-debugger-hook hook)))
-    (funcall fun))
-  )
+    (funcall fun)))
 
 (defvar *backtrace* '())
 
@@ -455,122 +434,50 @@
 
 (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*)))
-    (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)))))))
+  (clasp-debug:with-stack (stack)
+    (let ((*backtrace* (clasp-debug:list-stack stack)))
+      (funcall debugger-loop-fn))))
 
 (defimplementation compute-backtrace (start end)
   (subseq *backtrace* start
           (and (numberp end)
                (min end (length *backtrace*)))))
 
-(defun frame-name (frame)
-  (let ((x (core::backtrace-frame-function-name frame)))
-    (if (symbolp x)
-      x
-      (function-name x))))
-
-(defun frame-function (frame-number)
-  (let ((x (core::backtrace-frame-function-name (elt *backtrace* 
frame-number))))
-    (etypecase x
-      (symbol
-       (and (fboundp x)
-            (fdefinition x)))
-      (cons
-       (if (eq (car x) 'cl:setf)
-           (fdefinition x)
-           nil))
-      (function
-       x))))
+(defun frame-from-number (frame-number)
+  (elt *backtrace* frame-number))
 
 (defimplementation print-frame (frame stream)
-  (if (core::backtrace-frame-arguments frame)
-      (format stream "(~a~{ ~s~})" (core::backtrace-frame-print-name frame)
-              (coerce (core::backtrace-frame-arguments frame) 'list))
-      (format stream "~a" (core::backtrace-frame-print-name frame))))
+  (clasp-debug:prin1-frame-call frame stream))
 
 (defimplementation frame-source-location (frame-number)
-  (let* ((address (core::backtrace-frame-return-address (elt *backtrace* 
frame-number)))
-         (code-source-location (ext::code-source-position address)))
-    (format t "address: ~a   code-source-location ~s~%" address 
code-source-location)
-    ;; (core::source-info-backtrace *backtrace*)
-    (if (ext::code-source-line-source-pathname code-source-location)
-        (make-location (list :file (namestring 
(ext::code-source-line-source-pathname code-source-location)))
-                       (list :line (ext::code-source-line-line-number 
code-source-location))
+  (let ((csl (clasp-debug:frame-source-position (frame-from-number 
frame-number))))
+    (if (clasp-debug:code-source-line-pathname csl)
+        (make-location (list :file (namestring 
(clasp-debug:code-source-line-pathname csl)))
+                       (list :line (clasp-debug:code-source-line-line-number 
csl))
                        '(:align t))
         `(:error ,(format nil "No source for frame: ~a" frame-number)))))
 
-#+clasp-working
-(defimplementation frame-catch-tags (frame-number)
-  (third (elt *backtrace* frame-number)))
-
-(defun ihs-frame-id (frame-number)
-  (- (core:ihs-top) frame-number))
-
 (defimplementation frame-locals (frame-number)
-  (let* ((frame (elt *backtrace* frame-number))
-         (env nil) ; no env yet
-         (locals (loop for x = env then (core:get-parent-environment x)
-                       while x
-                       nconc (loop for name across 
(core:environment-debug-names x)
-                                   for value across 
(core:environment-debug-values x)
-                                   collect (list :name name :id 0 :value 
value)))))
-    (nconc
-     (loop for arg across (core::backtrace-frame-arguments frame)
-           for i from 0
-           collect (list :name (intern (format nil "ARG~d" i) :cl-user)
-                         :id 0
-                         :value arg))
-     locals)))
+  (loop for (var . value)
+          in (clasp-debug:frame-locals (frame-from-number frame-number))
+        for i from 0
+        collect (list :name var :id i :value value)))
 
 (defimplementation frame-var-value (frame-number var-number)
-  (let* ((frame (elt *backtrace* frame-number))
-         (env nil)
-         (args (core::backtrace-frame-arguments frame)))
-    (if (< var-number (length args))
-        (svref args var-number)
-        (elt (frame-locals frame-number) var-number))))
+  (let* ((frame (frame-from-number frame-number))
+         (locals (clasp-debug:frame-locals frame)))
+    (cdr (nth var-number locals))))
 
 (defimplementation disassemble-frame (frame-number)
-  (let ((fun (frame-function frame-number)))
-    (disassemble fun)))
+  (clasp-debug:disassemble-frame (frame-from-number frame-number)))
 
 (defimplementation eval-in-frame (form frame-number)
-  (let* ((frame (elt *backtrace* frame-number))
-         (raw-arg-values (coerce (core::backtrace-frame-arguments frame) 
'list)))
-    (if (and (= (length raw-arg-values) 2) (core:vaslistp (car 
raw-arg-values)))
-        (let* ((arg-values (core:list-from-va-list (car raw-arg-values)))
-               (bindings (append (loop for i from 0 for value in arg-values 
collect `(,(intern (core:bformat nil "ARG%d" i) :cl-user) ',value))
-                                 (list (list (intern "NEXT-METHODS" :cl-user) 
(cadr raw-arg-values))))))
-          (eval
-           `(let (,@bindings) ,form)))
-        (let* ((arg-values raw-arg-values)
-               (bindings (loop for i from 0 for value in arg-values collect 
`(,(intern (core:bformat nil "ARG%d" i) :cl-user) ',value))))
-          (eval
-           `(let (,@bindings) ,form))))))
-
+  (let* ((frame (frame-from-number frame-number)))
+    (eval
+     `(let (,@(loop for (var . value)
+                      in (clasp-debug:frame-locals frame)
+                    collect `(,var ',value)))
+        (progn ,form)))))
 
 #+clasp-working
 (defimplementation gdb-initial-commands ()
@@ -712,7 +619,7 @@
         "STOPPED"))
 
   (defimplementation make-lock (&key name)
-    (mp:make-lock :name name))
+    (mp:make-recursive-mutex name))
 
   (defimplementation call-with-lock-held (lock function)
     (declare (type function function))