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

Diff of /slime/swank.lisp

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

revision 1.15 by ellerh, Sun Sep 21 20:15:52 2003 UTC revision 1.16 by lukeg, Mon Sep 22 05:50:08 2003 UTC
# Line 1  Line 1 
1    (declaim (optimize debug))
2    
3  (defpackage :swank  (defpackage :swank
4    (:use :common-lisp)    (:use :common-lisp)
# Line 16  Line 17 
17             #:completions             #:completions
18             #:find-fdefinition             #:find-fdefinition
19             #:apropos-list-for-emacs             #:apropos-list-for-emacs
20               #:who-calls
21               #:who-references
22               #:who-sets
23               #:who-binds
24               #:who-macroexpands
25             #:list-all-package-names             #:list-all-package-names
26             #:function-source-location-for-emacs             #:function-source-location-for-emacs
27             #:swank-macroexpand-1             #:swank-macroexpand-1
# Line 413  compiler state." Line 419  compiler state."
419  (defslimefun swank-compile-file (filename load)  (defslimefun swank-compile-file (filename load)
420    (clear-note-database filename)    (clear-note-database filename)
421    (clear-compiler-notes)    (clear-compiler-notes)
422      (clear-xref-info filename)
423    (let ((*buffername* nil)    (let ((*buffername* nil)
424          (*buffer-offset* nil))          (*buffer-offset* nil))
425      (multiple-value-bind (pathname errorsp notesp)      (multiple-value-bind (pathname errorsp notesp)
# Line 432  compiler state." Line 439  compiler state."
439            :source-info `(:emacs-buffer ,buffer            :source-info `(:emacs-buffer ,buffer
440                           :emacs-buffer-offset ,start)))))))                           :emacs-buffer-offset ,start)))))))
441    
442  ;;;; ARGLIST-STRING -- interface  (defun clear-xref-info (namestring)
443      "Clear XREF notes pertaining to FILENAME.
444    This is a workaround for a CMUCL bug: XREF records are cumulative."
445      (let ((filename (parse-namestring namestring)))
446        (when c:*record-xref-info*
447          (dolist (db (list xref::*who-calls*
448                            xref::*who-macroexpands*
449                            xref::*who-references*
450                            xref::*who-binds*
451                            xref::*who-sets*))
452            (maphash (lambda (target contexts)
453                       (setf (gethash target db)
454                             (delete-if (lambda (ctx)
455                                          (xref-context-derived-from-p ctx filename))
456                                        contexts)))
457                     db)))))
458    
459    (defun xref-context-derived-from-p (context filename)
460      (let ((xref-file (xref:xref-context-file context)))
461        (and xref-file (pathname= filename xref-file))))
462    
463    (defun pathname= (&rest pathnames)
464      "True if PATHNAMES refer to the same file."
465      (apply #'string= (mapcar #'unix-truename pathnames)))
466    
467    (defun unix-truename (pathname)
468      (ext:unix-namestring (truename pathname)))
469    
470  (defslimefun arglist-string (fname)  (defslimefun arglist-string (fname)
471    "Return a string describing the argument list for FNAME.    "Return a string describing the argument list for FNAME.
472  The result has the format \"(...)\"."  The result has the format \"(...)\"."
# Line 466  The result has the format \"(...)\"." Line 500  The result has the format \"(...)\"."
500            arglist            arglist
501            (to-string arglist)))))            (to-string arglist)))))
502    
503  ;;;; COMPLETIONS -- interface  (defslimefun who-calls (function-name)
504      "Return a the callers of FUNCTION-NAME.
505    The result is a list of files-referrer:
506    file-referrer ::= (FILENAME ({reference}+))
507    reference     ::= (FUNCTION-SPECIFIER SOURCE-PATH)"
508      (xref-results-for-emacs (xref:who-calls function-name)))
509    
510    (defslimefun who-references (symbol)
511      (xref-results-for-emacs (xref:who-references symbol)))
512    
513    (defslimefun who-binds (variable)
514      (xref-results-for-emacs (xref:who-binds variable)))
515    
516    (defslimefun who-sets (variable)
517      (xref-results-for-emacs (xref:who-sets variable)))
518    
519    (defslimefun who-macroexpands (variable)
520      (xref-results-for-emacs (xref:who-macroexpands variable)))
521    
522    (defun xref-results-for-emacs (contexts)
523      (let ((hash (make-hash-table :test 'equal))
524            (files '()))
525        (dolist (context contexts)
526          (let ((unix-path (unix-truename (xref:xref-context-file context))))
527            (push context (gethash unix-path hash))
528            (pushnew unix-path files :test #'string=)))
529        (mapcar (lambda (unix-path)
530                  (xref-contexts-to-plist unix-path (gethash unix-path hash)))
531                (sort files #'string<))))
532    
533    (defun xref-contexts-to-plist (unix-filename contexts)
534      "Translate an xref CONTEXT into a property list."
535      (list unix-filename
536            (loop for context in contexts
537                  collect (list (let ((*print-pretty* nil))
538                                  (princ-to-string (xref:xref-context-name context)))
539                                (xref:xref-context-source-path context)))))
540    
541  (defun completions (prefix package-name &optional only-external-p)  (defslimefun completions (prefix package-name &optional only-external-p)
542    "Return a list of completions for a symbol's PREFIX and PACKAGE-NAME.    "Return a list of completions for a symbol's PREFIX and PACKAGE-NAME.
543  The result is a list of symbol-name strings. All symbols accessible in  The result is a list of symbol-name strings. All symbols accessible in
544  the package are considered."  the package are considered."
# Line 670  Return NIL if the symbol is unbound." Line 740  Return NIL if the symbol is unbound."
740  The result is a list of property lists."  The result is a list of property lists."
741    (mapcan (listify #'briefly-describe-symbol-for-emacs)    (mapcan (listify #'briefly-describe-symbol-for-emacs)
742            (sort (apropos-symbols name external-only package)            (sort (apropos-symbols name external-only package)
743                  #'belongs-before-in-apropos-p)))                  #'present-symbol-before-p)))
744    
745  (defun listify (f)  (defun listify (f)
746    "Return a function like F, but which returns any non-null value    "Return a function like F, but which returns any non-null value
# Line 688  wrapped in a list." Line 758  wrapped in a list."
758                       string package external-only)                       string package external-only)
759      symbols))      symbols))
760    
761  (defun belongs-before-in-apropos-p (a b)  (defun present-symbol-before-p (a b)
762    "Return true if A belongs before B in an apropos listing.    "Return true if A belongs before B in a printed summary of symbols.
763  Sorted alphabetically by package name and then symbol name, except  Sorted alphabetically by package name and then symbol name, except
764  that symbols accessible in the current package go first."  that symbols accessible in the current package go first."
765    (flet ((accessible (s)    (flet ((accessible (s)
766             (find-symbol (symbol-name s) *package*)))             (find-symbol (symbol-name s) *buffer-package*)))
767      (let ((pa (symbol-package a))      (let ((pa (symbol-package a))
768            (pb (symbol-package b)))            (pb (symbol-package b)))
769        (cond ((or (eq pa pb)        (cond ((or (eq pa pb)

Legend:
Removed from v.1.15  
changed lines
  Added in v.1.16

  ViewVC Help
Powered by ViewVC 1.1.5