/[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.171 by heller, Sun Nov 19 21:33:03 2006 UTC revision 1.172 by jsnellman, Tue Dec 5 04:46:06 2006 UTC
# Line 35  Line 35 
35    (defun sbcl-with-weak-hash-tables ()    (defun sbcl-with-weak-hash-tables ()
36      (if (find-symbol "HASH-TABLE-WEAKNESS" "SB-EXT")      (if (find-symbol "HASH-TABLE-WEAKNESS" "SB-EXT")
37          '(and)          '(and)
38            '(or)))
39      ;; And for xref support (1.0.1)
40      (defun sbcl-with-xref-p ()
41        (if (find-symbol "WHO-CALLS" "SB-INTROSPECT")
42            '(and)
43          '(or))))          '(or))))
44    
45  ;;; swank-mop  ;;; swank-mop
# Line 485  This is useful when debugging the defini Line 490  This is useful when debugging the defini
490          plist          plist
491        (cond        (cond
492          (emacs-buffer          (emacs-buffer
493           (let ((pos (if form-path           (let* ((pos (if form-path
494                          (with-debootstrapping                           (with-debootstrapping
495                            (source-path-string-position                             (source-path-string-position form-path emacs-string))
496                             form-path emacs-string))                           character-offset))
497                          character-offset)))                  (snippet (string-path-snippet emacs-string form-path pos)))
498             (make-location `(:buffer ,emacs-buffer)             (make-location `(:buffer ,emacs-buffer)
499                            `(:position ,(+ pos emacs-position))                            `(:position ,(+ pos emacs-position))
500                            `(:snippet ,emacs-string))))                            `(:snippet ,snippet))))
501          ((not pathname)          ((not pathname)
502           `(:error ,(format nil "Source of ~A ~A not found"           `(:error ,(format nil "Source of ~A ~A not found"
503                             (string-downcase type) name)))                             (string-downcase type) name)))
504          (t          (t
505           (let* ((namestring (namestring (translate-logical-pathname pathname)))           (let* ((namestring (namestring (translate-logical-pathname pathname)))
506                  (*readtable* (guess-readtable-for-filename namestring))                  (pos (source-file-position namestring file-write-date form-path
507                  (pos (1+ (with-debootstrapping                                             character-offset))
508                             ;; Some internal functions have no source path                  (snippet (source-hint-snippet namestring file-write-date pos)))
                            ;; or offset available, just the file (why?).  
                            ;; In these cases we can at least try to open  
                            ;; the right file.  
                            (if form-path  
                                (source-path-file-position form-path  
                                                           pathname)  
                                0))))  
                 (snippet (source-hint-snippet namestring  
                                               file-write-date pos)))  
509             (make-location `(:file ,namestring)             (make-location `(:file ,namestring)
510                            `(:position ,pos)                            `(:position ,pos)
511                            `(:snippet ,snippet))))))))                            `(:snippet ,snippet))))))))
512    
513    (defun string-path-snippet (string form-path position)
514      (if form-path
515          ;; If we have a form-path, use it to derive a more accurate
516          ;; snippet, so that we can point to the individual form rather
517          ;; than just the toplevel form.
518          (multiple-value-bind (data end)
519              (let ((*read-suppress* t))
520                (read-from-string string nil nil :start position))
521            (declare (ignore data))
522            (subseq string position end))
523          string))
524    
525    (defun source-file-position (filename write-date form-path character-offset)
526      (let ((source (get-source-code filename write-date))
527            (*readtable* (guess-readtable-for-filename filename)))
528        (1+ (with-debootstrapping
529              (if form-path
530                  (source-path-string-position form-path source)
531                  (or character-offset 0))))))
532    
533  (defun source-hint-snippet (filename write-date position)  (defun source-hint-snippet (filename write-date position)
534    (let ((source (get-source-code filename write-date)))    (let ((source (get-source-code filename write-date)))
535      (with-input-from-string (s source)      (with-input-from-string (s source)
# Line 576  Return NIL if the symbol is unbound." Line 592  Return NIL if the symbol is unbound."
592       (describe (find-class symbol)))       (describe (find-class symbol)))
593      (:type      (:type
594       (describe (sb-kernel:values-specifier-type symbol)))))       (describe (sb-kernel:values-specifier-type symbol)))))
595    
596    #+#.(swank-backend::sbcl-with-xref-p)
597    (progn
598      (defmacro defxref (name)
599        `(defimplementation ,name (what)
600           (sanitize-xrefs
601            (mapcar #'source-location-for-xref-data
602                    (,(find-symbol (symbol-name name) "SB-INTROSPECT")
603                      what)))))
604      (defxref who-calls)
605      (defxref who-binds)
606      (defxref who-sets)
607      (defxref who-references)
608      (defxref who-macroexpands))
609    
610    (defun source-location-for-xref-data (xref-data)
611      (let ((name (car xref-data))
612            (source-location (cdr xref-data)))
613        (list name
614              (handler-case (make-definition-source-location source-location
615                                                             'function
616                                                             name)
617                (error (e)
618                  (list :error (format nil "Error: ~A" e)))))))
619    
620  (defimplementation list-callers (symbol)  (defimplementation list-callers (symbol)
621    (let ((fn (fdefinition symbol)))    (let ((fn (fdefinition symbol)))
# Line 587  Return NIL if the symbol is unbound." Line 627  Return NIL if the symbol is unbound."
627      (sanitize-xrefs      (sanitize-xrefs
628       (mapcar #'function-dspec (sb-introspect:find-function-callees fn)))))       (mapcar #'function-dspec (sb-introspect:find-function-callees fn)))))
629    
630  (defun sanitize-xrefs (x)  (defun sanitize-xrefs (xrefs)
631    (remove-duplicates    (remove-duplicates
632     (remove-if (lambda (f)     (remove-if (lambda (f)
633                  (member f (ignored-xref-function-names)))                  (member f (ignored-xref-function-names)))
634                x                (loop for entry in xrefs
635                        for name = (car entry)
636                        collect (if (and (consp name)
637                                         (member (car name)
638                                                 '(sb-pcl::fast-method
639                                                   sb-pcl::slow-method
640                                                   sb-pcl::method)))
641                                    (cons (cons 'defmethod (cdr name))
642                                          (cdr entry))
643                                    entry))
644                :key #'car)                :key #'car)
645     :test (lambda (a b)     :test (lambda (a b)
646             (and (eq (first a) (first b))             (and (eq (first a) (first b))

Legend:
Removed from v.1.171  
changed lines
  Added in v.1.172

  ViewVC Help
Powered by ViewVC 1.1.5