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

Diff of /slime/swank.lisp

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

revision 1.407 by heller, Thu Oct 19 12:12:58 2006 UTC revision 1.408 by heller, Thu Oct 19 12:29:09 2006 UTC
# Line 3868  Include the nicknames if INCLUDE-NICKNAM Line 3868  Include the nicknames if INCLUDE-NICKNAM
3868             (format nil "~S is now unprofiled." fname))             (format nil "~S is now unprofiled." fname))
3869            (t            (t
3870             (profile fname)             (profile fname)
3871             (format nil "~S is now profiled." fname)))))             (format nil "~S is now profiled." fname)))))
3872    
3873    
3874  ;;;; Source Locations  ;;;; Source Locations
# Line 3880  DSPEC is a string and LOCATION a source Line 3880  DSPEC is a string and LOCATION a source
3880        (ignore-errors (values (from-string name)))        (ignore-errors (values (from-string name)))
3881      (cond (error '())      (cond (error '())
3882            (t (loop for (dspec loc) in (find-definitions sexp)            (t (loop for (dspec loc) in (find-definitions sexp)
3883                     unless (eql :error (first loc))                     collect (list (to-string dspec) loc))))))
                      collect (list (to-string dspec) loc))))))  
3884    
3885  (defun alistify (list key test)  (defun alistify (list key test)
3886    "Partition the elements of LIST into an alist.  KEY extracts the key    "Partition the elements of LIST into an alist.  KEY extracts the key
# Line 3895  from an element and TEST is used to comp Line 3894  from an element and TEST is used to comp
3894              (push e (cdr probe))              (push e (cdr probe))
3895              (push (cons k (list e)) alist))))              (push (cons k (list e)) alist))))
3896      alist))      alist))
3897    
3898  (defun location-position< (pos1 pos2)  (defun location-position< (pos1 pos2)
3899    (cond ((and (position-p pos1) (position-p pos2))    (cond ((and (position-p pos1) (position-p pos2))
3900           (< (position-pos pos1)           (< (position-pos pos1)
# Line 3904  from an element and TEST is used to comp Line 3903  from an element and TEST is used to comp
3903    
3904  (defun partition (list test key)  (defun partition (list test key)
3905    (declare (type function test key))    (declare (type function test key))
3906    (loop for e in list    (loop for e in list
3907          if (funcall test (funcall key e)) collect e into yes          if (funcall test (funcall key e)) collect e into yes
3908          else collect e into no          else collect e into no
3909          finally (return (values yes no))))          finally (return (values yes no))))
# Line 3925  from an element and TEST is used to comp Line 3924  from an element and TEST is used to comp
3924  (defun group-xrefs (xrefs)  (defun group-xrefs (xrefs)
3925    "Group XREFS, a list of the form ((DSPEC LOCATION) ...) by location.    "Group XREFS, a list of the form ((DSPEC LOCATION) ...) by location.
3926  The result is a list of the form ((LOCATION . ((DSPEC . LOCATION) ...)) ...)."  The result is a list of the form ((LOCATION . ((DSPEC . LOCATION) ...)) ...)."
3927    (multiple-value-bind (resolved errors)    (multiple-value-bind (resolved errors)
3928        (partition xrefs #'location-valid-p #'xref.location)        (partition xrefs #'location-valid-p #'xref.location)
3929      (let ((alist (alistify resolved #'xref-buffer #'equal)))      (let ((alist (alistify resolved #'xref-buffer #'equal)))
3930        (append        (append
3931         (loop for (buffer . list) in alist         (loop for (buffer . list) in alist
3932               collect (cons (second buffer)               collect (cons (second buffer)
3933                             (mapcar (lambda (xref)                             (mapcar (lambda (xref)
# Line 3936  The result is a list of the form ((LOCAT Line 3935  The result is a list of the form ((LOCAT
3935                                             (xref.location xref)))                                             (xref.location xref)))
3936                                     (sort list #'location-position<                                     (sort list #'location-position<
3937                                           :key #'xref-position))))                                           :key #'xref-position))))
3938         (if errors         (if errors
3939             (list (cons "Unresolved"             (list (cons "Unresolved"
3940                         (mapcar (lambda (xref)                         (mapcar (lambda (xref)
3941                                   (cons (to-string (xref.dspec xref))                                   (cons (to-string (xref.dspec xref))
3942                                         (xref.location xref)))                                         (xref.location xref)))
# Line 3946  The result is a list of the form ((LOCAT Line 3945  The result is a list of the form ((LOCAT
3945  (defslimefun xref (type symbol-name)  (defslimefun xref (type symbol-name)
3946    (let ((symbol (parse-symbol-or-lose symbol-name *buffer-package*)))    (let ((symbol (parse-symbol-or-lose symbol-name *buffer-package*)))
3947      (group-xrefs      (group-xrefs
3948       (sanitize-xrefs       (ecase type
3949        (ecase type         (:calls (who-calls symbol))
3950          (:calls (who-calls symbol))         (:calls-who (calls-who symbol))
3951          (:calls-who (calls-who symbol))         (:references (who-references symbol))
3952          (:references (who-references symbol))         (:binds (who-binds symbol))
3953          (:binds (who-binds symbol))         (:sets (who-sets symbol))
3954          (:sets (who-sets symbol))         (:macroexpands (who-macroexpands symbol))
3955          (:macroexpands (who-macroexpands symbol))         (:specializes (who-specializes symbol))
3956          (:specializes (who-specializes symbol))         (:callers (list-callers symbol))
3957          (:callers (list-callers symbol))         (:callees (list-callees symbol))))))
         (:callees (list-callees symbol)))))))  
   
 (defun sanitize-xrefs (x)  
   (remove-duplicates  
    (remove-if (lambda (f)  
                 (member f (ignored-xref-function-names)))  
               x  
               :key #'car)  
    :test (lambda (a b)  
            (and (eq (first a) (first b))  
                 (equal (second a) (second b))))))  
3958    
3959    
3960  ;;;; Inspecting  ;;;; Inspecting

Legend:
Removed from v.1.407  
changed lines
  Added in v.1.408

  ViewVC Help
Powered by ViewVC 1.1.5