/[slime]/slime/swank-sbcl.lisp
ViewVC logotype

Diff of /slime/swank-sbcl.lisp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.120 by lgorrie, Wed Mar 2 23:50:29 2005 UTC revision 1.121 by lgorrie, Thu Mar 3 00:11:58 2005 UTC
# Line 503  stack." Line 503  stack."
503            collect f)))            collect f)))
504    
505  (defimplementation print-frame (frame stream)  (defimplementation print-frame (frame stream)
506    (let ((*standard-output* stream))    (macrolet ((printer-form ()
507      (sb-debug::print-frame-call frame stream :verbosity 1 :number nil)))                 ;; MEGAKLUDGE: As SBCL 0.8.20.1 fixed its debug IO style
508                   ;; our usage of unexported interfaces came back to haunt
509                   ;; us. And since we still use the same interfaces it will
510                   ;; haunt us again.
511                   (let ((print-sym (find-symbol "PRINT-FRAME-CALL" :sb-debug)))
512                     (if (fboundp print-sym)
513                         (let* ((args (sb-introspect:function-arglist print-sym))
514                              (key-pos (position '&key args)))
515                           (cond ((eql 2 key-pos)
516                                  `(,print-sym frame stream))
517                                 ((eql 1 key-pos)
518                                  `(let ((*standard-output* stream))
519                                     (,print-sym frame)))
520                                 (t
521                                  (error "*THWAP* SBCL changes internals ~
522                                           again!"))))
523                         (error "You're in a twisty little maze of unsupported
524                                  SBCL interfaces, all different.")))))
525        (printer-form)))
526    
527  (defun code-location-source-path (code-location)  (defun code-location-source-path (code-location)
528    (let* ((location (sb-debug::maybe-block-start-location code-location))    (let* ((location (sb-debug::maybe-block-start-location code-location))
# Line 528  stack." Line 546  stack."
546           (consp info)           (consp info)
547           (eq :emacs-buffer (car info)))))           (eq :emacs-buffer (car info)))))
548    
549    (defun print-code-location-source-form (code-location context)
550      (macrolet ((printer-form ()
551                   ;; KLUDGE: These are both unexported interfaces, used
552                   ;; by different versions of SBCL. ...sooner or later
553                   ;; this will change again: hopefully by then we have
554                   ;; figured out the interface we want to drive the
555                   ;; debugger with and requested it from the SBCL
556                   ;; folks.
557                   (let ((print-code-sym
558                          (find-symbol "PRINT-CODE-LOCATION-SOURCE-FORM"
559                                       :sb-debug))
560                         (code-sym
561                          (find-symbol "CODE-LOCATION-SOURCE-FORM"
562                                       :sb-debug)))
563                     (cond ((fboundp print-code-sym)
564                            `(,print-code-sym code-location context))
565                           ((fboundp code-sym)
566                            `(prin1 (,code-sym code-location context)))
567                           (t
568                            (error
569                             "*THWAP* SBCL changes its debugger interface ~
570                              again!"))))))
571        (printer-form)))
572    
573  (defun source-location-for-emacs (code-location)  (defun source-location-for-emacs (code-location)
574    (let* ((debug-source (sb-di:code-location-debug-source code-location))    (let* ((debug-source (sb-di:code-location-debug-source code-location))
575           (from (sb-di:debug-source-from debug-source))           (from (sb-di:debug-source-from debug-source))
# Line 554  stack." Line 596  stack."
596        (:lisp        (:lisp
597         (make-location         (make-location
598          (list :source-form (with-output-to-string (*standard-output*)          (list :source-form (with-output-to-string (*standard-output*)
599                               (print (sb-debug::code-location-source-form                               (print-code-location-source-form code-location 100)))
                                      code-location 100))))  
600          (list :position 0))))))          (list :position 0))))))
601    
602  (defun safe-source-location-for-emacs (code-location)  (defun safe-source-location-for-emacs (code-location)

Legend:
Removed from v.1.120  
changed lines
  Added in v.1.121

  ViewVC Help
Powered by ViewVC 1.1.5