[slime-cvs] CVS update: slime/swank-openmcl.lisp

[Alan Ruttenberg]

Update of /project/slime/cvsroot/slime
In directory common-lisp.net:/tmp/cvs-serv23272/slime

Modified Files:
	swank-openmcl.lisp 
Log Message:

Implement frame-catch-tags. Added debugger functions
sldb-restart-frame, sldb-return-from-frame. Should probably be added
to backend.lisp but let's discuss first. Do other lisps support this?

Date: Sun Jan 18 11:17:37 2004
Author: aruttenberg

Index: slime/swank-openmcl.lisp
diff -u slime/swank-openmcl.lisp:1.50 slime/swank-openmcl.lisp:1.51
--- slime/swank-openmcl.lisp:1.50	Sun Jan 18 02:15:49 2004
+++ slime/swank-openmcl.lisp	Sun Jan 18 11:17:37 2004
@@ -330,9 +330,27 @@
                        result))))
            (return-from frame-locals (nreverse result))))))))
 
-(defmethod frame-catch-tags (index)
-  (declare (ignore index))
-  nil)
+(defmethod frame-catch-tags (index &aux my-frame)
+   (map-backtrace 
+   (lambda (frame-number p tcr lfun pc)
+      (declare (ignore pc lfun))
+      (if (= frame-number index) 
+          (setq my-frame p)
+          (when my-frame
+            (return-from frame-catch-tags
+              (loop for catch = (ccl::%catch-top tcr) then (ccl::next-catch catch)
+                    while catch
+                    for csp = (ccl::uvref catch ppc32::catch-frame.csp-cell)
+                    for tag = (ccl::uvref catch ppc32::catch-frame.catch-tag-cell)
+                    until (ccl::%stack< p csp tcr)
+                    do (print "-") (print catch) (terpri) (describe tag)
+                    when (ccl::%stack< my-frame csp tcr)
+                    collect (cond 
+                              ((symbolp tag)
+                               (list tag))
+                              ((and (listp tag)
+                                    (typep (car tag) 'restart)
+                                    (list `(:restart ,(restart-name (car tag))))))))))))))
                        
 (defslimefun sldb-disassemble (the-frame-number)
   "Return a string with the disassembly of frames code."
@@ -447,6 +465,20 @@
                                ,@(mapcar 'car bindings)))
                      ,form)))
            ))))))
+
+(defslimefun sldb-return-from-frame (form index)
+  (let ((values (multiple-value-list (eval-in-frame (from-string form) index))))
+    (map-backtrace
+     (lambda (frame-number p tcr lfun pc)
+       (declare (ignore tcr lfun pc))
+       (when (= frame-number index)
+         (ccl::apply-in-frame p #'values  values))))))
+ 
+(defslimefun sldb-restart-frame (index)
+  (map-backtrace
+   (lambda (frame-number p tcr lfun pc)
+     (when (= frame-number index)
+       (ccl::apply-in-frame p lfun (ccl::frame-supplied-args p lfun pc nil tcr))))))
 
 ;;; Utilities