/[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.257 by trittweiler, Thu Dec 10 20:51:33 2009 UTC revision 1.258 by trittweiler, Thu Dec 10 22:21:09 2009 UTC
# Line 642  compiler state." Line 642  compiler state."
642    
643  ;;;; Definitions  ;;;; Definitions
644    
645  (defvar *debug-definition-finding* nil  (defmacro converting-errors-to-location (&body body)
646    "When true don't handle errors while looking for definitions.    "Catches error and converts them to an error location."
647  This is useful when debugging the definition-finding code.")    (let ((gblock (gensym "CONVERTING-ERRORS+")))
648        `(block ,gblock
649           (handler-bind ((error
650                           #'(lambda (e)
651                                (if *debug-swank-backend*
652                                    nil     ;decline
653                                    (return-from ,gblock
654                                      (make-error-location e))))))
655             ,@body))))
656    
657  (defparameter *definition-types*  (defparameter *definition-types*
658    '(:variable defvar    '(:variable defvar
# Line 676  This is useful when debugging the defini Line 684  This is useful when debugging the defini
684        :def-ir1-translator        :def-ir1-translator
685        (getf *definition-types* type)))        (getf *definition-types* type)))
686    
687    (defun make-dspec (type name source-location)
688      (list* (definition-specifier type name)
689             name
690             (sb-introspect::definition-source-description source-location)))
691    
692  (defimplementation find-definitions (name)  (defimplementation find-definitions (name)
693    (loop for type in *definition-types* by #'cddr    (loop for type in *definition-types* by #'cddr
694          for locations = (sb-introspect:find-definition-sources-by-name          for locations = (sb-introspect:find-definition-sources-by-name
695                           name type)                           name type)
696          append (loop for source-location in locations collect          append (loop for source-location in locations collect
697                       (make-source-location-specification type name                         (list (make-dspec type name source-location)
698                                                           source-location))))                               (converting-errors-to-location
699                                   (make-definition-source-location source-location
700                                                                    type
701                                                                    name))))))
702    
703  (defimplementation find-source-location (obj)  (defimplementation find-source-location (obj)
704    (flet ((general-type-of (obj)    (flet ((general-type-of (obj)
# Line 706  This is useful when debugging the defini Line 721  This is useful when debugging the defini
721                (with-output-to-string (s)                (with-output-to-string (s)
722                  (print-unreadable-object (obj s :type t :identity t))))                  (print-unreadable-object (obj s :type t :identity t))))
723               (t (princ-to-string obj)))))               (t (princ-to-string obj)))))
724      (handler-case      (converting-errors-to-location
725          (make-definition-source-location        (make-definition-source-location (sb-introspect:find-definition-source obj)
726           (sb-introspect:find-definition-source obj) (general-type-of obj) (to-string obj))                                         (general-type-of obj)
727        (error (e)                                         (to-string obj)))))
         (list :error (format nil "Error: ~A" e))))))  
   
   
 (defun make-source-location-specification (type name source-location)  
   (list (make-dspec type name source-location)  
         (if *debug-definition-finding*  
             (make-definition-source-location source-location type name)  
             (handler-case  
                 (make-definition-source-location source-location type name)  
               (error (e)  
                 (list :error (format nil "Error: ~A" e)))))))  
728    
 (defun make-dspec (type name source-location)  
   (list* (definition-specifier type name)  
          name  
          (sb-introspect::definition-source-description source-location)))  
729    
730  (defun make-definition-source-location (definition-source type name)  (defun make-definition-source-location (definition-source type name)
731    (with-struct (sb-introspect::definition-source-    (with-struct (sb-introspect::definition-source-
# Line 779  This is useful when debugging the defini Line 779  This is useful when debugging the defini
779    (let ((location (sb-introspect:find-definition-source function)))    (let ((location (sb-introspect:find-definition-source function)))
780      (make-definition-source-location location :function name)))      (make-definition-source-location location :function name)))
781    
 (defun safe-function-source-location (fun name)  
   (if *debug-definition-finding*  
       (function-source-location fun name)  
       (handler-case (function-source-location fun name)  
         (error (e)  
           (list :error (format nil "Error: ~A" e))))))  
   
782  (defimplementation describe-symbol-for-emacs (symbol)  (defimplementation describe-symbol-for-emacs (symbol)
783    "Return a plist describing SYMBOL.    "Return a plist describing SYMBOL.
784  Return NIL if the symbol is unbound."  Return NIL if the symbol is unbound."
# Line 854  Return NIL if the symbol is unbound." Line 847  Return NIL if the symbol is unbound."
847  (defun source-location-for-xref-data (xref-data)  (defun source-location-for-xref-data (xref-data)
848    (let ((name (car xref-data))    (let ((name (car xref-data))
849          (source-location (cdr xref-data)))          (source-location (cdr xref-data)))
850      (list name      (list name (make-definition-source-location source-location
851            (handler-case (make-definition-source-location source-location                                                  'function
852                                                           'function                                                  name))))
                                                          name)  
             (error (e)  
               (list :error (format nil "Error: ~A" e)))))))  
853    
854  (defimplementation list-callers (symbol)  (defimplementation list-callers (symbol)
855    (let ((fn (fdefinition symbol)))    (let ((fn (fdefinition symbol)))
# Line 900  Return NIL if the symbol is unbound." Line 890  Return NIL if the symbol is unbound."
890    "Describe where the function FN was defined.    "Describe where the function FN was defined.
891  Return a list of the form (NAME LOCATION)."  Return a list of the form (NAME LOCATION)."
892    (let ((name (sb-kernel:%fun-name fn)))    (let ((name (sb-kernel:%fun-name fn)))
893      (list name (safe-function-source-location fn name))))      (list name (converting-errors-to-location
894                     (function-source-location fn name)))))
895    
896  ;;; macroexpansion  ;;; macroexpansion
897    
# Line 959  Return a list of the form (NAME LOCATION Line 950  Return a list of the form (NAME LOCATION
950    
951  (defimplementation call-with-debugging-environment (debugger-loop-fn)  (defimplementation call-with-debugging-environment (debugger-loop-fn)
952    (declare (type function debugger-loop-fn))    (declare (type function debugger-loop-fn))
953    (let* ((*sldb-stack-top* (or sb-debug:*stack-top-hint* (sb-di:top-frame)))    (let* ((*sldb-stack-top* (if *debug-swank-backend*
954                                   (sb-di:top-frame)
955                                   (or sb-debug:*stack-top-hint* (sb-di:top-frame))))
956           (sb-debug:*stack-top-hint* nil))           (sb-debug:*stack-top-hint* nil))
957      (handler-bind ((sb-di:debug-condition      (handler-bind ((sb-di:debug-condition
958                      (lambda (condition)                      (lambda (condition)
# Line 1128  stack." Line 1121  stack."
1121    
1122  ;;; source-path-file-position and friends are in swank-source-path-parser  ;;; source-path-file-position and friends are in swank-source-path-parser
1123    
 (defun safe-source-location-for-emacs (code-location)  
   (if *debug-definition-finding*  
       (code-location-source-location code-location)  
       (handler-case (code-location-source-location code-location)  
         (error (c) (list :error (format nil "~A" c))))))  
   
1124  (defimplementation frame-source-location (index)  (defimplementation frame-source-location (index)
1125    (safe-source-location-for-emacs    (converting-errors-to-location
1126     (sb-di:frame-code-location (nth-frame index))))      (code-location-source-location
1127         (sb-di:frame-code-location (nth-frame index)))))
1128    
1129  (defun frame-debug-vars (frame)  (defun frame-debug-vars (frame)
1130    "Return a vector of debug-variables in frame."    "Return a vector of debug-variables in frame."

Legend:
Removed from v.1.257  
changed lines
  Added in v.1.258

  ViewVC Help
Powered by ViewVC 1.1.5