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

Diff of /slime/swank-ccl.lisp

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

revision 1.4 by heller, Sat Aug 15 08:34:56 2009 UTC revision 1.8 by trittweiler, Sat Oct 24 11:32:18 2009 UTC
# Line 303  Line 303 
303     :test 'equal))     :test 'equal))
304    
305  (defimplementation who-specializes (class)  (defimplementation who-specializes (class)
306    (delete-duplicates    (when (symbolp class)
307     (mapcar (lambda (m)      (setq class (find-class class nil)))
308               (car (find-definitions m)))    (when class
309             (ccl:specializer-direct-methods (if (symbolp class) (find-class class) class)))      (delete-duplicates
310     :test 'equal))       (mapcar (lambda (m)
311                   (car (find-definitions m)))
312                 (ccl:specializer-direct-methods class))
313         :test 'equal)))
314    
315  (defimplementation list-callees (name)  (defimplementation list-callees (name)
316    (remove-duplicates    (remove-duplicates
# Line 384  Line 387 
387    (setq ccl:*select-interactive-process-hook* 'find-repl-thread)    (setq ccl:*select-interactive-process-hook* 'find-repl-thread)
388    )    )
389    
 (let ((ccl::*warn-if-redefine-kernel* nil))  
   ;; Everybody (error, cerror, break, invoke-debugger, and async interrupts) ends up  
   ;; in CCL::BREAK-LOOP, which implements the default debugger. Regardless of how it  
   ;; was entered, make sure it runs with the swank connection state established so  
   ;; that i/o happens via emacs and there is no contention for the terminal (stdin).  
   (ccl:advise  
    ccl::break-loop  
    (if (symbol-value (swank-sym *emacs-connection*))  
      (:do-it)  
      (let ((conn (funcall (swank-sym default-connection))))  
        (if conn  
          (funcall (swank-sym call-with-connection) conn  
                   (lambda () (:do-it)))  
          (:do-it))))  
    :when :around  
    :name swank-default-debugger-context))  
   
390  (defun map-backtrace (function &optional  (defun map-backtrace (function &optional
391                                 (start-frame-number 0)                        (start-frame-number 0)
392                                 (end-frame-number most-positive-fixnum))                        end-frame-number)
393    "Call FUNCTION passing information about each stack frame    "Call FUNCTION passing information about each stack frame
394   from frames START-FRAME-NUMBER to END-FRAME-NUMBER."   from frames START-FRAME-NUMBER to END-FRAME-NUMBER."
395    (ccl:map-call-frames function    (let ((end-frame-number (or end-frame-number most-positive-fixnum)))
396                         :origin ccl:*top-error-frame*      (ccl:map-call-frames function
397                         :start-frame-number start-frame-number                           :origin ccl:*top-error-frame*
398                         :count (- end-frame-number start-frame-number)                           :start-frame-number start-frame-number
399                         :test (and (not t) ;(not (symbol-value (swank-sym *sldb-show-internal-frames*)))                           :count (- end-frame-number start-frame-number)
400                                    'interesting-frame-p)))                           :test (and (not t) ;(not (symbol-value (swank-sym *sldb-show-internal-frames*)))
401                                        'interesting-frame-p))))
402    
403  ;; Exceptions  ;; Exceptions
404  (defvar *interesting-internal-frames* ())  (defvar *interesting-internal-frames* ())
# Line 598  Line 585 
585                (t `(:error ,(funcall if-nil-thunk))))                (t `(:error ,(funcall if-nil-thunk))))
586        (error (c) `(:error ,(princ-to-string c))))))        (error (c) `(:error ,(princ-to-string c))))))
587    
588  (defimplementation find-definitions (obj)  (defimplementation find-definitions (name)
589    (loop for ((type . name) . sources) in (ccl:find-definition-sources obj)    (let ((defs (or (ccl:find-definition-sources name)
590          collect (list (definition-name type name)                    (and (symbolp name)
591                        (source-note-to-source-location                         (fboundp name)
592                         (find-if-not #'null sources)                         (ccl:find-definition-sources (symbol-function name))))))
593                         (lambda () "No source-note available")      (loop for ((type . name) . sources) in defs
594                         name))))            collect (list (definition-name type name)
595                            (source-note-to-source-location
596                             (find-if-not #'null sources)
597                             (lambda () "No source-note available")
598                             name)))))
599    
600  (defimplementation find-source-location (obj)  (defimplementation find-source-location (obj)
601    (let* ((defs (ccl:find-definition-sources obj))    (let* ((defs (ccl:find-definition-sources obj))

Legend:
Removed from v.1.4  
changed lines
  Added in v.1.8

  ViewVC Help
Powered by ViewVC 1.1.5