You can not select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
541 lines
21 KiB
541 lines
21 KiB
;;; swank-asdf.lisp -- ASDF support
|
|
;;
|
|
;; Authors: Daniel Barlow <dan@telent.net>
|
|
;; Marco Baringer <mb@bese.it>
|
|
;; Edi Weitz <edi@agharta.de>
|
|
;; Francois-Rene Rideau <tunes@google.com>
|
|
;; and others
|
|
;; License: Public Domain
|
|
;;
|
|
|
|
(in-package :swank)
|
|
|
|
(eval-when (:compile-toplevel :load-toplevel :execute)
|
|
;;; The best way to load ASDF is from an init file of an
|
|
;;; implementation. If ASDF is not loaded at the time swank-asdf is
|
|
;;; loaded, it will be tried first with (require "asdf"), if that
|
|
;;; doesn't help and *asdf-path* is set, it will be loaded from that
|
|
;;; file.
|
|
;;; To set *asdf-path* put the following into ~/.swank.lisp:
|
|
;;; (defparameter swank::*asdf-path* #p"/path/to/asdf/asdf.lisp")
|
|
(defvar *asdf-path* nil
|
|
"Path to asdf.lisp file, to be loaded in case (require \"asdf\") fails."))
|
|
|
|
(eval-when (:compile-toplevel :load-toplevel :execute)
|
|
(unless (member :asdf *features*)
|
|
(ignore-errors (funcall 'require "asdf"))))
|
|
|
|
(eval-when (:compile-toplevel :load-toplevel :execute)
|
|
(unless (member :asdf *features*)
|
|
(handler-bind ((warning #'muffle-warning))
|
|
(when *asdf-path*
|
|
(load *asdf-path* :if-does-not-exist nil)))))
|
|
|
|
;; If still not found, error out.
|
|
(eval-when (:compile-toplevel :load-toplevel :execute)
|
|
(unless (member :asdf *features*)
|
|
(error "Could not load ASDF.
|
|
Please update your implementation or
|
|
install a recent release of ASDF and in your ~~/.swank.lisp specify:
|
|
(defparameter swank::*asdf-path* #p\"/path/containing/asdf/asdf.lisp\")")))
|
|
|
|
;;; If ASDF is too old, punt.
|
|
;; As of January 2014, Quicklisp has been providing 2.26 for a year
|
|
;; (and previously had 2.014.6 for over a year), whereas
|
|
;; all SLIME-supported implementations provide ASDF3 (i.e. 2.27 or later)
|
|
;; except LispWorks (stuck with 2.019) and SCL (which hasn't been released
|
|
;; in years and doesn't provide ASDF at all, but is fully supported by ASDF).
|
|
;; If your implementation doesn't provide ASDF, or provides an old one,
|
|
;; install an upgrade yourself and configure *asdf-path*.
|
|
;; It's just not worth the hassle supporting something
|
|
;; that doesn't even have COERCE-PATHNAME.
|
|
;;
|
|
;; NB: this version check is duplicated in swank-loader.lisp so that we don't
|
|
;; try to load this contrib when ASDF is too old since that will abort the SLIME
|
|
;; connection.
|
|
#-asdf3
|
|
(eval-when (:compile-toplevel :load-toplevel :execute)
|
|
(unless (and #+asdf2 (asdf:version-satisfies (asdf:asdf-version) "2.14.6"))
|
|
(error "Your ASDF is too old. ~
|
|
The oldest version supported by swank-asdf is 2.014.6.")))
|
|
;;; 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.
|
|
;;; Indeed, they are supposed to work on *OLDER*, not *NEWER* versions of ASDF.
|
|
;;;
|
|
;;; 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)
|
|
(asdf:version-satisfies (asdf:asdf-version) version))
|
|
|
|
(defmacro asdefs (version &rest defs)
|
|
(flet ((defun* (version name aname rest)
|
|
`(progn
|
|
(defun ,name ,@rest)
|
|
(declaim (notinline ,name))
|
|
(when (asdf-at-least ,version)
|
|
(setf (fdefinition ',name) (fdefinition ',aname)))))
|
|
(defmethod* (version aname rest)
|
|
`(unless (asdf-at-least ,version)
|
|
(defmethod ,aname ,@rest)))
|
|
(defvar* (name aname rest)
|
|
`(progn
|
|
(define-symbol-macro ,name ,aname)
|
|
(defvar ,aname ,@rest))))
|
|
`(progn
|
|
,@(loop :for (def name . args) :in defs
|
|
:for aname = (intern (string name) :asdf)
|
|
:collect
|
|
(ecase def
|
|
((defun) (defun* version name aname args))
|
|
((defmethod) (defmethod* version aname args))
|
|
((defvar) (defvar* name aname args)))))))
|
|
|
|
(asdefs "2.15"
|
|
(defvar *wild* #-cormanlisp :wild #+cormanlisp "*")
|
|
|
|
(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.16"
|
|
(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.17"
|
|
(defun collect-sub*directories-asd-files
|
|
(directory &key
|
|
(exclude asdf::*default-source-registry-exclusions*)
|
|
collect)
|
|
(asdf::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)
|
|
(asdf::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.19"
|
|
(defun subdirectories (directory)
|
|
(let* ((directory (asdf::ensure-directory-pathname directory))
|
|
#-(or abcl cormanlisp xcl)
|
|
(wild (asdf::merge-pathnames*
|
|
#-(or abcl allegro cmu lispworks sbcl scl xcl)
|
|
asdf::*wild-directory*
|
|
#+(or abcl allegro cmu lispworks sbcl scl xcl) "*.*"
|
|
directory))
|
|
(dirs
|
|
#-(or abcl cormanlisp 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))
|
|
#+(or abcl allegro cmu 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)
|
|
#+lispworks (lw:file-directory-p x)
|
|
when d collect #+(or abcl allegro xcl) d
|
|
#+(or cmu lispworks sbcl scl) x)))
|
|
(filter-logical-directory-results
|
|
directory dirs
|
|
(let ((prefix (or (normalize-pathname-directory-component
|
|
(pathname-directory directory))
|
|
;; because allegro 8.x 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 component-loaded-p (c)
|
|
(and (gethash 'load-op (asdf::component-operation-times
|
|
(asdf::find-component c nil))) t))
|
|
|
|
(defun normalize-pathname-directory-component (directory)
|
|
(cond
|
|
#-(or cmu sbcl scl)
|
|
((stringp directory) `(:absolute ,directory) 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.22"
|
|
(defun directory-files (directory &optional (pattern asdf::*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)))))))))
|
|
|
|
(asdefs "2.26.149"
|
|
(defmethod component-relative-pathname ((system asdf:system))
|
|
(asdf::coerce-pathname
|
|
(and (slot-boundp system 'asdf::relative-pathname)
|
|
(slot-value system 'asdf::relative-pathname))
|
|
:type :directory
|
|
:defaults (system-source-directory system)))
|
|
(defun load-asd (pathname &key name &allow-other-keys)
|
|
(asdf::load-sysdef (or name (string-downcase (pathname-name pathname)))
|
|
pathname)))
|
|
|
|
|
|
;;; Taken from ASDF 1.628
|
|
(defmacro while-collecting ((&rest collectors) &body body)
|
|
`(asdf::while-collecting ,collectors ,@body))
|
|
|
|
;;; Now for SLIME-specific stuff
|
|
|
|
(defun asdf-operation (operation)
|
|
(or (asdf::find-symbol* operation :asdf)
|
|
(error "Couldn't find ASDF operation ~S" operation)))
|
|
|
|
(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*))
|
|
|
|
(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)))
|
|
(when (pathnamep p)
|
|
(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)))
|
|
(cdr (assoc op (asdf:component-depends-on op system))))))
|
|
(let ((system-name (asdf::coerce-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)
|
|
(when (typep thing '(or string symbol))
|
|
(loop for dependency in (who-depends-on thing)
|
|
for asd-file = (asdf:system-definition-pathname dependency)
|
|
when asd-file
|
|
collect (list dependency
|
|
(swank/backend:make-location
|
|
`(:file ,(namestring asd-file))
|
|
`(:position 1)
|
|
`(: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."
|
|
(collect-notes
|
|
(lambda ()
|
|
(apply #'operate-on-system system-name operation keywords))))
|
|
|
|
(defun operate-on-system (system-name operation-name &rest keyword-args)
|
|
"Perform OPERATION-NAME on SYSTEM-NAME using ASDF.
|
|
The KEYWORD-ARGS are passed on to the operation.
|
|
Example:
|
|
\(operate-on-system \"cl-ppcre\" 'compile-op :force t)"
|
|
(handler-case
|
|
(with-compilation-hooks ()
|
|
(apply #'asdf:operate (asdf-operation operation-name)
|
|
system-name keyword-args)
|
|
t)
|
|
((or asdf:compile-error #+asdf3 asdf/lisp-build:compile-file-error)
|
|
() nil)))
|
|
|
|
(defun unique-string-list (&rest lists)
|
|
(sort (delete-duplicates (apply #'append lists) :test #'string=) #'string<))
|
|
|
|
(defslimefun list-all-systems-in-central-registry ()
|
|
"Returns a list of all systems in ASDF's central registry
|
|
AND in its source-registry. (legacy name)"
|
|
(unique-string-list
|
|
(mapcar
|
|
#'pathname-name
|
|
(while-collecting (c)
|
|
(loop for dir in asdf:*central-registry*
|
|
for defaults = (eval dir)
|
|
when defaults
|
|
do (collect-asds-in-directory defaults #'c))
|
|
(asdf:ensure-source-registry)
|
|
(if (or #+asdf3 t
|
|
#-asdf3 (asdf:version-satisfies (asdf:asdf-version) "2.15"))
|
|
(loop :for k :being :the :hash-keys :of asdf::*source-registry*
|
|
:do (c k))
|
|
#-asdf3
|
|
(dolist (entry (asdf::flatten-source-registry))
|
|
(destructuring-bind (directory &key recurse exclude) entry
|
|
(register-asd-directory
|
|
directory
|
|
:recurse recurse :exclude exclude :collect #'c))))))))
|
|
|
|
(defslimefun list-all-systems-known-to-asdf ()
|
|
"Returns a list of all systems ASDF knows already."
|
|
(while-collecting (c)
|
|
(asdf::map-systems (lambda (system) (c (asdf:component-name system))))))
|
|
|
|
(defslimefun list-asdf-systems ()
|
|
"Returns the systems in ASDF's central registry and those which ASDF
|
|
already knows."
|
|
(unique-string-list
|
|
(list-all-systems-known-to-asdf)
|
|
(list-all-systems-in-central-registry)))
|
|
|
|
(defun asdf-component-source-files (component)
|
|
(while-collecting (c)
|
|
(labels ((f (x)
|
|
(typecase x
|
|
(asdf:source-file (c (asdf:component-pathname x)))
|
|
(asdf:module (map () #'f (asdf:module-components x))))))
|
|
(f component))))
|
|
|
|
(defun make-operation (x)
|
|
#+#.(swank/backend:with-symbol 'make-operation 'asdf)
|
|
(asdf:make-operation x)
|
|
#-#.(swank/backend:with-symbol 'make-operation 'asdf)
|
|
(make-instance x))
|
|
|
|
(defun asdf-component-output-files (component)
|
|
(while-collecting (c)
|
|
(labels ((f (x)
|
|
(typecase x
|
|
(asdf:source-file
|
|
(map () #'c
|
|
(asdf:output-files (make-operation 'asdf:compile-op) x)))
|
|
(asdf:module (map () #'f (asdf:module-components x))))))
|
|
(f component))))
|
|
|
|
(defslimefun asdf-system-files (name)
|
|
(let* ((system (asdf:find-system name))
|
|
(files (mapcar #'namestring
|
|
(cons
|
|
(asdf:system-definition-pathname system)
|
|
(asdf-component-source-files system))))
|
|
(main-file (find name files
|
|
:test #'equalp :key #'pathname-name :start 1)))
|
|
(if main-file
|
|
(cons main-file (remove main-file files
|
|
:test #'equal :count 1))
|
|
files)))
|
|
|
|
(defslimefun asdf-system-loaded-p (name)
|
|
(component-loaded-p name))
|
|
|
|
(defslimefun asdf-system-directory (name)
|
|
(namestring (translate-logical-pathname (asdf:system-source-directory name))))
|
|
|
|
(defun pathname-system (pathname)
|
|
(let ((component (pathname-component pathname)))
|
|
(when component
|
|
(asdf:component-name (asdf:component-system component)))))
|
|
|
|
(defslimefun asdf-determine-system (file buffer-package-name)
|
|
(or
|
|
(and file
|
|
(pathname-system file))
|
|
(and file
|
|
(progn
|
|
;; If not found, let's rebuild the table first
|
|
(recompute-pathname-component-table)
|
|
(pathname-system file)))
|
|
;; If we couldn't find an already defined system,
|
|
;; try finding a system that's named like BUFFER-PACKAGE-NAME.
|
|
(loop with package = (guess-buffer-package buffer-package-name)
|
|
for name in (package-names package)
|
|
for system = (asdf:find-system (asdf::coerce-name name) nil)
|
|
when (and system
|
|
(or (not file)
|
|
(pathname-system file)))
|
|
return (asdf:component-name system))))
|
|
|
|
(defslimefun delete-system-fasls (name)
|
|
(let ((removed-count
|
|
(loop for file in (asdf-component-output-files
|
|
(asdf:find-system name))
|
|
when (probe-file file)
|
|
count it
|
|
and
|
|
do (delete-file file))))
|
|
(format nil "~d file~:p ~:*~[were~;was~:;were~] removed" removed-count)))
|
|
|
|
(defvar *recompile-system* nil)
|
|
|
|
(defmethod asdf:operation-done-p :around
|
|
((operation asdf:compile-op)
|
|
component)
|
|
(unless (eql *recompile-system*
|
|
(asdf:component-system component))
|
|
(call-next-method)))
|
|
|
|
(defslimefun reload-system (name)
|
|
(let ((*recompile-system* (asdf:find-system name)))
|
|
(operate-on-system-for-emacs name 'asdf:load-op)))
|
|
|
|
;; Doing list-all-systems-in-central-registry might be quite slow
|
|
;; since it accesses a file-system, so run it once at the background
|
|
;; to initialize caches.
|
|
(when (eql *communication-style* :spawn)
|
|
(spawn (lambda ()
|
|
(ignore-errors (list-all-systems-in-central-registry)))
|
|
:name "init-asdf-fs-caches"))
|
|
|
|
;;; Hook for compile-file-for-emacs
|
|
|
|
(defun try-compile-file-with-asdf (pathname load-p &rest options)
|
|
(declare (ignore options))
|
|
(let ((component (pathname-component pathname)))
|
|
(when component
|
|
;;(format t "~&Compiling ASDF component ~S~%" component)
|
|
(let ((op (make-operation 'asdf:compile-op)))
|
|
(with-compilation-hooks ()
|
|
(asdf:perform op component))
|
|
(when load-p
|
|
(asdf:perform (make-operation 'asdf:load-op) component))
|
|
(values t t nil (first (asdf:output-files op component)))))))
|
|
|
|
(defun try-compile-asd-file (pathname load-p &rest options)
|
|
(declare (ignore load-p options))
|
|
(when (equalp (pathname-type pathname) "asd")
|
|
(load-asd pathname)
|
|
(values t t nil pathname)))
|
|
|
|
(pushnew 'try-compile-asd-file *compile-file-for-emacs-hook*)
|
|
|
|
;;; (pushnew 'try-compile-file-with-asdf *compile-file-for-emacs-hook*)
|
|
|
|
(provide :swank-asdf)
|