[slime-cvs] CVS slime/contrib
CVS User sboukarev
sboukarev at common-lisp.net
Tue Nov 13 15:44:40 UTC 2012
Update of /project/slime/cvsroot/slime/contrib
In directory tiger.common-lisp.net:/tmp/cvs-serv25282/contrib
Modified Files:
ChangeLog swank-asdf.lisp
Log Message:
* swank-asdf.lisp: Better ASDF support.
* swank.lisp (*compile-file-for-emacs-hook*): A hook for
compile-file-for-emacs, so that ASDF can hook its compilation
functions.
--- /project/slime/cvsroot/slime/contrib/ChangeLog 2012/10/19 05:18:05 1.552
+++ /project/slime/cvsroot/slime/contrib/ChangeLog 2012/11/13 15:44:40 1.553
@@ -1,3 +1,7 @@
+2012-11-13 Francois-Rene Rideau <tunes at google.com>
+
+ * swank-asdf.lisp: Better ASDF support.
+
2012-10-19 Stas Boukarev <stassats at gmail.com>
* slime-fuzzy.el (slime-fuzzy-choices-buffer): Don't move position
--- /project/slime/cvsroot/slime/contrib/swank-asdf.lisp 2011/10/05 11:22:21 1.32
+++ /project/slime/cvsroot/slime/contrib/swank-asdf.lisp 2012/11/13 15:44:40 1.33
@@ -1,40 +1,369 @@
-;;; swank-asdf.el -- ASDF support
+;;; swank-asdf.lisp -- ASDF support
;;
-;; Authors: Daniel Barlow <dan at telent.net>
+;; Authors: Daniel Barlow <dan at telent.net>
;; Marco Baringer <mb at bese.it>
;; Edi Weitz <edi at agharta.de>
-;; and others
+;; Francois-Rene Rideau <tunes at google.com>
+;; and others
;; License: Public Domain
;;
(in-package :swank)
-#-asdf
(eval-when (:compile-toplevel :load-toplevel :execute)
- (require :asdf))
+ (defvar *asdf-directory*
+ (merge-pathnames #p"cl/asdf/" (user-homedir-pathname))
+ "Directory in which your favorite and/or latest version
+ of the ASDF source code is located"))
+
+;;; Doing our best to load ASDF
+;; First, try loading asdf from your implementation
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (unless (member :asdf *features*)
+ (ignore-errors (require "asdf"))))
+
+;; If not found, load asdf from wherever the user specified it
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (unless (member :asdf *features*)
+ (handler-bind ((warning #'muffle-warning))
+ (ignore-errors (load (make-pathname :name "asdf" :type "lisp"
+ :defaults *asdf-directory*))))))
+;; If still not found, error out.
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (unless (member :asdf *features*)
+ (error "Could not load ASDF.
+Please install ASDF2 and in your ~~/.swank.lisp specify:
+ (defparameter swank::*asdf-directory* #p\"/path/containing/asdf/\")")))
+
+;;; If ASDF is found, try to upgrade it to the latest installed version.
+;; (eval-when (:compile-toplevel :load-toplevel :execute)
+;; (handler-bind ((warning #'muffle-warning))
+;; (pushnew *asdf-directory* asdf:*central-registry*)
+;; (asdf:oos 'asdf:load-op :asdf)))
+
+;;; If ASDF is too old, punt.
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (unless (or #+asdf2 (asdf:version-satisfies (asdf:asdf-version) "2.000"))
+ (error "Your ASDF version is too old.
+Please upgrade to ASDF2 and in your ~~/.swank.lisp specify:
+ (defparameter swank::*asdf-directory* #p\"/path/containing/asdf/\")")))
+
+;;; Import functionality from ASDF that isn't available in all ASDF versions.
+;;; Please do NOT depend on any of the below as reference:
+;;; they are sometimes stripped down versions, for compatibility only.
+;;;
+;;; The way I got these is usually by looking at the current definition,
+;;; using git blame in one screen to locate which commit last modified it,
+;;; and git log in another to determine which release that made it in.
+;;; It is OK for some of the below definitions to be or become obsolete,
+;;; as long as it will make do with versions older than the tagged version:
+;;; if ASDF is more recent, its more recent version will win.
+;;;
+;;; If your software is hacking ASDF, use its internals.
+;;; If you want ASDF utilities in user software, please use ASDF-UTILS.
+
+(defun asdf-at-least (version)
+ (or #+asdf2 (asdf:version-satisfies
+ (asdf:asdf-version) version)))
+
+(defmacro asdefs (version &rest defs)
+ (flet ((defun* (version name aname rest)
+ `(progn
+ (defun ,name , at rest)
+ (declaim (notinline ,name))
+ (when (asdf-at-least ,version)
+ (setf (fdefinition ',name) (fdefinition ',aname)))))
+ (defvar* (name aname rest)
+ `(progn
+ (define-symbol-macro ,name ,aname)
+ (defvar ,aname , at rest))))
+ `(progn
+ ,@(loop :for (def name . args) :in defs
+ :for aname = (intern (string name) :asdf)
+ :collect
+ (ecase def
+ ((defun) (defun* version name aname args))
+ ((defvar) (defvar* name aname args)))))))
+
+(asdefs "2.015"
+ (defvar *wild* #-cormanlisp :wild #+cormanlisp "*"))
+
+(asdefs "2.010"
+ (defun collect-sub*directories (directory collectp recursep collector)
+ (when (funcall collectp directory)
+ (funcall collector directory))
+ (dolist (subdir (subdirectories directory))
+ (when (funcall recursep subdir)
+ (collect-sub*directories subdir collectp recursep collector)))))
+
+(asdefs "2.011"
+ (defun find-symbol* (s p)
+ (find-symbol (string s) p)))
+
+(asdefs "2.012"
+ (defvar *wild-file*
+ (make-pathname :name *wild* :type *wild*
+ :version (or #-(or abcl xcl) *wild*) :directory nil))
+ (defvar *wild-directory*
+ (make-pathname :directory `(:relative ,*wild*)
+ :name nil :type nil :version nil)))
+
+(asdefs "2.014"
+ (defun ensure-directory-pathname (pathspec)
+ (cond
+ ((stringp pathspec)
+ (ensure-directory-pathname (pathname pathspec)))
+ ((not (pathnamep pathspec))
+ (error "Invalid pathname designator ~S" pathspec))
+ ((wild-pathname-p pathspec)
+ (error "Can't reliably convert wild pathname ~S" pathspec))
+ ((asdf::directory-pathname-p pathspec)
+ pathspec)
+ (t
+ (make-pathname :directory (append (or (pathname-directory pathspec)
+ (list :relative))
+ (list (file-namestring pathspec)))
+ :name nil :type nil :version nil
+ :defaults pathspec)))))
+
+(asdefs "2.015"
+ (defun collect-asds-in-directory (directory collect)
+ (map () collect (directory-asd-files directory)))
+
+ (defun register-asd-directory (directory &key recurse exclude collect)
+ (if (not recurse)
+ (collect-asds-in-directory directory collect)
+ (collect-sub*directories-asd-files
+ directory :exclude exclude :collect collect))))
+
+(asdefs "2.016"
+ (defun load-sysdef (name pathname)
+ (declare (ignore name))
+ (let ((package (asdf::make-temporary-package)))
+ (unwind-protect
+ (let ((*package* package)
+ (*default-pathname-defaults*
+ (asdf::pathname-directory-pathname
+ (translate-logical-pathname pathname))))
+ (asdf::asdf-message
+ "~&; Loading system definition from ~A into ~A~%"
+ pathname package)
+ (load pathname))
+ (delete-package package))))
+
+ (defun directory* (pathname-spec &rest keys &key &allow-other-keys)
+ (apply 'directory pathname-spec
+ (append keys
+ '#.(or #+allegro
+ '(:directories-are-files nil
+ :follow-symbolic-links nil)
+ #+clozure
+ '(:follow-links nil)
+ #+clisp
+ '(:circle t :if-does-not-exist :ignore)
+ #+(or cmu scl)
+ '(:follow-links nil :truenamep nil)
+ #+sbcl
+ (when (find-symbol "RESOLVE-SYMLINKS" '#:sb-impl)
+ '(:resolve-symlinks nil)))))))
+(asdefs "2.017"
+ (defun collect-sub*directories-asd-files
+ (directory &key
+ (exclude asdf::*default-source-registry-exclusions*)
+ collect)
+ (collect-sub*directories
+ directory
+ (constantly t)
+ (lambda (x) (not (member (car (last (pathname-directory x)))
+ exclude :test #'equal)))
+ (lambda (dir) (collect-asds-in-directory dir collect))))
+
+ (defun system-source-directory (system-designator)
+ (pathname-directory-pathname (asdf::system-source-file system-designator)))
+
+ (defun filter-logical-directory-results (directory entries merger)
+ (if (typep directory 'logical-pathname)
+ (loop for f in entries
+ when
+ (if (typep f 'logical-pathname)
+ f
+ (let ((u (ignore-errors (funcall merger f))))
+ (and u
+ (equal (ignore-errors (truename u))
+ (truename f))
+ u)))
+ collect it)
+ entries))
+
+ (defun directory-asd-files (directory)
+ (directory-files directory asdf::*wild-asd*)))
+
+(asdefs "2.019"
+ (defun subdirectories (directory)
+ (let* ((directory (ensure-directory-pathname directory))
+ #-(or abcl cormanlisp genera xcl)
+ (wild (asdf::merge-pathnames*
+ #-(or abcl allegro cmu lispworks sbcl scl xcl)
+ *wild-directory*
+ #+(or abcl allegro cmu lispworks sbcl scl xcl) "*.*"
+ directory))
+ (dirs
+ #-(or abcl cormanlisp genera xcl)
+ (ignore-errors
+ (directory* wild . #.(or #+clozure '(:directories t :files nil)
+ #+mcl '(:directories t))))
+ #+(or abcl xcl) (system:list-directory directory)
+ #+cormanlisp (cl::directory-subdirs directory)
+ #+genera (fs:directory-list directory))
+ #+(or abcl allegro cmu genera lispworks sbcl scl xcl)
+ (dirs (loop for x in dirs
+ for d = #+(or abcl xcl) (extensions:probe-directory x)
+ #+allegro (excl:probe-directory x)
+ #+(or cmu sbcl scl) (asdf::directory-pathname-p x)
+ #+genera (getf (cdr x) :directory)
+ #+lispworks (lw:file-directory-p x)
+ when d collect #+(or abcl allegro xcl) d
+ #+genera (ensure-directory-pathname (first x))
+ #+(or cmu lispworks sbcl scl) x)))
+ (filter-logical-directory-results
+ directory dirs
+ (let ((prefix (or (normalize-pathname-directory-component
+ (pathname-directory directory))
+ ;; because allegro returns NIL for #p"FOO:"
+ '(:absolute))))
+ (lambda (d)
+ (let ((dir (normalize-pathname-directory-component
+ (pathname-directory d))))
+ (and (consp dir) (consp (cdr dir))
+ (make-pathname
+ :defaults directory :name nil :type nil :version nil
+ :directory
+ (append prefix
+ (make-pathname-component-logical
+ (last dir))))))))))))
+
+(asdefs "2.21"
+ (defun normalize-pathname-directory-component (directory)
+ (cond
+ #-(or cmu sbcl scl)
+ ((stringp directory) `(:absolute ,directory) directory)
+ #+gcl
+ ((and (consp directory) (stringp (first directory)))
+ `(:absolute , at directory))
+ ((or (null directory)
+ (and (consp directory)
+ (member (first directory) '(:absolute :relative))))
+ directory)
+ (t
+ (error "Unrecognized pathname directory component ~S" directory))))
+
+ (defun make-pathname-component-logical (x)
+ (typecase x
+ ((eql :unspecific) nil)
+ #+clisp (string (string-upcase x))
+ #+clisp (cons (mapcar 'make-pathname-component-logical x))
+ (t x)))
+
+ (defun make-pathname-logical (pathname host)
+ (make-pathname
+ :host host
+ :directory (make-pathname-component-logical (pathname-directory pathname))
+ :name (make-pathname-component-logical (pathname-name pathname))
+ :type (make-pathname-component-logical (pathname-type pathname))
+ :version (make-pathname-component-logical (pathname-version pathname)))))
+
+(asdefs "2.022"
+ (defun directory-files (directory &optional (pattern *wild-file*))
+ (let ((dir (pathname directory)))
+ (when (typep dir 'logical-pathname)
+ (when (wild-pathname-p dir)
+ (error "Invalid wild pattern in logical directory ~S" directory))
+ (unless (member (pathname-directory pattern)
+ '(() (:relative)) :test 'equal)
+ (error "Invalid file pattern ~S for logical directory ~S"
+ pattern directory))
+ (setf pattern (make-pathname-logical pattern (pathname-host dir))))
+ (let ((entries (ignore-errors
+ (directory* (asdf::merge-pathnames* pattern dir)))))
+ (filter-logical-directory-results
+ directory entries
+ (lambda (f)
+ (make-pathname :defaults dir
+ :name (make-pathname-component-logical
+ (pathname-name f))
+ :type (make-pathname-component-logical
+ (pathname-type f))
+ :version (make-pathname-component-logical
+ (pathname-version f)))))))))
+
+;;; Taken from ASDF 1.628
+(defmacro while-collecting ((&rest collectors) &body body)
+ (let ((vars (mapcar (lambda (x) (gensym (symbol-name x))) collectors))
+ (initial-values (mapcar (constantly nil) collectors)))
+ `(let ,(mapcar #'list vars initial-values)
+ (flet ,(mapcar (lambda (c v) `(,c (x) (push x ,v) (values)))
+ collectors vars)
+ , at body
+ (values ,@(mapcar (lambda (v) `(reverse ,v)) vars))))))
+
+
+;;; Now for SLIME-specific stuff
(defun find-operation (operation)
- (or (find-symbol (symbol-name operation) :asdf)
+ (or (find-symbol* operation :asdf)
(error "Couldn't find ASDF operation ~S" operation)))
-(defun map-defined-systems (fn)
- (loop for (nil . system) being the hash-values in asdf::*defined-systems*
- do (funcall fn system)))
+(defun map-system-components (fn system)
+ (map-component-subcomponents fn (asdf:find-system system)))
+
+(defun map-component-subcomponents (fn component)
+ (when component
+ (funcall fn component)
+ (when (typep component 'asdf:module)
+ (dolist (c (asdf:module-components component))
+ (map-component-subcomponents fn c)))))
+
+;;; Maintaining a pathname to component table
+
+(defvar *pathname-component* (make-hash-table :test 'equal))
+
+(defun clear-pathname-component-table ()
+ (clrhash *pathname-component*))
-;;; This is probably a crude hack, see ASDF's LP #481187.
+(defun register-system-pathnames (system)
+ (map-system-components 'register-component-pathname system))
+
+(defun recompute-pathname-component-table ()
+ (clear-pathname-component-table)
+ (asdf::map-systems 'register-system-pathnames))
+
+(defun pathname-component (x)
+ (gethash (pathname x) *pathname-component*))
+
+(defmethod asdf:component-pathname :around ((component asdf:component))
+ (let ((p (call-next-method)))
+ (setf (gethash p *pathname-component*) component)
+ p))
+
+(defun register-component-pathname (component)
+ (asdf:component-pathname component))
+
+(recompute-pathname-component-table)
+
+;;; This is a crude hack, see ASDF's LP #481187.
(defslimefun who-depends-on (system)
(flet ((system-dependencies (op system)
- (mapcar #'(lambda (dep)
- (asdf::coerce-name (if (consp dep) (second dep) dep)))
+ (mapcar (lambda (dep)
+ (asdf::coerce-name (if (consp dep) (second dep) dep)))
(cdr (assoc op (asdf:component-depends-on op system))))))
(let ((system-name (asdf::coerce-name system))
(result))
- (map-defined-systems
- #'(lambda (system)
- (when (member system-name
- (system-dependencies 'asdf:load-op system)
- :test #'string=)
- (push (asdf:component-name system) result))))
+ (asdf::map-systems
+ (lambda (system)
+ (when (member system-name
+ (system-dependencies 'asdf:load-op system)
+ :test #'string=)
+ (push (asdf:component-name system) result))))
result)))
(defmethod xref-doit ((type (eql :depends-on)) thing)
@@ -49,7 +378,6 @@
`(:snippet ,(format nil "(defsystem :~A" dependency)
:align t))))))
-
(defslimefun operate-on-system-for-emacs (system-name operation &rest keywords)
"Compile and load SYSTEM using ASDF.
Record compiler notes signalled as `compiler-condition's."
@@ -69,65 +397,68 @@
t)
[226 lines skipped]
More information about the slime-cvs
mailing list