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

[Luke Gorrie]

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

Modified Files:
	swank-sbcl.lisp 
Log Message:
Fixed for latest SBCL HEAD revision and temporarily
backwards-compatible with the current release.

Date: Thu Mar  3 01:12:02 2005
Author: lgorrie

Index: slime/swank-sbcl.lisp
diff -u slime/swank-sbcl.lisp:1.120 slime/swank-sbcl.lisp:1.121
--- slime/swank-sbcl.lisp:1.120	Thu Mar  3 00:50:29 2005
+++ slime/swank-sbcl.lisp	Thu Mar  3 01:11:58 2005
@@ -503,8 +503,26 @@
 	  collect f)))
 
 (defimplementation print-frame (frame stream)
-  (let ((*standard-output* stream))
-    (sb-debug::print-frame-call frame stream :verbosity 1 :number nil)))
+  (macrolet ((printer-form ()
+               ;; MEGAKLUDGE: As SBCL 0.8.20.1 fixed its debug IO style
+               ;; our usage of unexported interfaces came back to haunt
+               ;; us. And since we still use the same interfaces it will
+               ;; haunt us again.
+               (let ((print-sym (find-symbol "PRINT-FRAME-CALL" :sb-debug)))
+                 (if (fboundp print-sym)
+                     (let* ((args (sb-introspect:function-arglist print-sym))
+                          (key-pos (position '&key args)))
+                       (cond ((eql 2 key-pos)
+                              `(,print-sym frame stream))
+                             ((eql 1 key-pos)
+                              `(let ((*standard-output* stream))
+                                 (,print-sym frame)))
+                             (t
+                              (error "*THWAP* SBCL changes internals ~
+                                       again!"))))
+                     (error "You're in a twisty little maze of unsupported
+                              SBCL interfaces, all different.")))))
+    (printer-form)))
 
 (defun code-location-source-path (code-location)
   (let* ((location (sb-debug::maybe-block-start-location code-location))
@@ -528,6 +546,30 @@
 	 (consp info)
 	 (eq :emacs-buffer (car info)))))
 
+(defun print-code-location-source-form (code-location context)
+  (macrolet ((printer-form ()
+               ;; KLUDGE: These are both unexported interfaces, used
+               ;; by different versions of SBCL. ...sooner or later
+               ;; this will change again: hopefully by then we have
+               ;; figured out the interface we want to drive the
+               ;; debugger with and requested it from the SBCL
+               ;; folks.
+               (let ((print-code-sym
+                      (find-symbol "PRINT-CODE-LOCATION-SOURCE-FORM"
+                                   :sb-debug))
+                     (code-sym
+                      (find-symbol "CODE-LOCATION-SOURCE-FORM"
+                                   :sb-debug)))
+                 (cond ((fboundp print-code-sym)
+                        `(,print-code-sym code-location context))
+                       ((fboundp code-sym)
+                        `(prin1 (,code-sym code-location context)))
+                       (t
+                        (error 
+                         "*THWAP* SBCL changes its debugger interface ~
+                          again!"))))))
+    (printer-form)))
+
 (defun source-location-for-emacs (code-location)
   (let* ((debug-source (sb-di:code-location-debug-source code-location))
 	 (from (sb-di:debug-source-from debug-source))
@@ -554,8 +596,7 @@
       (:lisp
        (make-location
         (list :source-form (with-output-to-string (*standard-output*)
-                             (print (sb-debug::code-location-source-form
-                                     code-location 100))))
+                             (print-code-location-source-form code-location 100)))
         (list :position 0))))))
 
 (defun safe-source-location-for-emacs (code-location)