+++ /dev/null
-;;; -*- mode: Common-Lisp; Base: 10 ; Syntax: ANSI-Common-Lisp -*-
-;;; This is ASDF 2.20: Another System Definition Facility.
-;;;
-;;; Feedback, bug reports, and patches are all welcome:
-;;; please mail to <asdf-devel@common-lisp.net>.
-;;; Note first that the canonical source for ASDF is presently
-;;; <URL:http://common-lisp.net/project/asdf/>.
-;;;
-;;; If you obtained this copy from anywhere else, and you experience
-;;; trouble using it, or find bugs, you may want to check at the
-;;; location above for a more recent version (and for documentation
-;;; and test files, if your copy came without them) before reporting
-;;; bugs. There are usually two "supported" revisions - the git master
-;;; branch is the latest development version, whereas the git release
-;;; branch may be slightly older but is considered `stable'
-
-;;; -- LICENSE START
-;;; (This is the MIT / X Consortium license as taken from
-;;; http://www.opensource.org/licenses/mit-license.html on or about
-;;; Monday; July 13, 2009)
-;;;
-;;; Copyright (c) 2001-2011 Daniel Barlow and contributors
-;;;
-;;; Permission is hereby granted, free of charge, to any person obtaining
-;;; a copy of this software and associated documentation files (the
-;;; "Software"), to deal in the Software without restriction, including
-;;; without limitation the rights to use, copy, modify, merge, publish,
-;;; distribute, sublicense, and/or sell copies of the Software, and to
-;;; permit persons to whom the Software is furnished to do so, subject to
-;;; the following conditions:
-;;;
-;;; The above copyright notice and this permission notice shall be
-;;; included in all copies or substantial portions of the Software.
-;;;
-;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
-;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
-;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
-;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
-;;; LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
-;;; OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
-;;; WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
-;;;
-;;; -- LICENSE END
-
-;;; The problem with writing a defsystem replacement is bootstrapping:
-;;; we can't use defsystem to compile it. Hence, all in one file.
-
-#+xcvb (module ())
-
-(cl:in-package #-genera :common-lisp-user #+genera :future-common-lisp-user)
-
-#-(or abcl allegro clisp clozure cmu cormanlisp ecl gcl genera lispworks mcl sbcl scl xcl)
-(error "ASDF is not supported on your implementation. Please help us port it.")
-
-#+gcl (defpackage :asdf (:use :cl)) ;; GCL treats defpackage magically and needs this
-
-(eval-when (:compile-toplevel :load-toplevel :execute)
- ;;; Implementation-dependent tweaks
- ;; (declaim (optimize (speed 1) (debug 3) (safety 3))) ; NO: trust implementation defaults.
- #+allegro
- (setf excl::*autoload-package-name-alist*
- (remove "asdf" excl::*autoload-package-name-alist*
- :test 'equalp :key 'car)) ; need that BEFORE any mention of package ASDF as below
- #+ecl (defun use-ecl-byte-compiler-p () (and (member :ecl-bytecmp *features*) t))
- #+ecl (unless (use-ecl-byte-compiler-p) (require :cmp))
- #+gcl ;; Debian's GCL 2.7 has bugs with compiling multiple-value stuff, but can run ASDF 2.011
- (when (or (< system::*gcl-major-version* 2) ;; GCL 2.6 fails to fully compile ASDF at all
- (and (= system::*gcl-major-version* 2)
- (< system::*gcl-minor-version* 7)))
- (pushnew :gcl-pre2.7 *features*))
- ;;; make package if it doesn't exist yet.
- ;;; DEFPACKAGE may cause errors on discrepancies, so we avoid it.
- (unless (find-package :asdf)
- (make-package :asdf :use '(:common-lisp))))
-
-(in-package :asdf)
-
-;;;; Create packages in a way that is compatible with hot-upgrade.
-;;;; See https://bugs.launchpad.net/asdf/+bug/485687
-;;;; See more near the end of the file.
-
-(eval-when (:load-toplevel :compile-toplevel :execute)
- (defvar *asdf-version* nil)
- (defvar *upgraded-p* nil)
- (defvar *asdf-verbose* nil) ; was t from 2.000 to 2.014.12.
- (defun find-symbol* (s p)
- (find-symbol (string s) p))
- ;; Strip out formatting that is not supported on Genera.
- ;; Has to be inside the eval-when to make Lispworks happy (!)
- (defun strcat (&rest strings)
- (apply 'concatenate 'string strings))
- (defmacro compatfmt (format)
- #-(or gcl genera) format
- #+(or gcl genera)
- (loop :for (unsupported . replacement) :in
- (append
- '(("~3i~_" . ""))
- #+genera '(("~@<" . "") ("; ~@;" . "; ") ("~@:>" . "") ("~:>" . ""))) :do
- (loop :for found = (search unsupported format) :while found :do
- (setf format (strcat (subseq format 0 found) replacement
- (subseq format (+ found (length unsupported)))))))
- format)
- (let* (;; For bug reporting sanity, please always bump this version when you modify this file.
- ;; Please also modify asdf.asd to reflect this change. The script bin/bump-version
- ;; can help you do these changes in synch (look at the source for documentation).
- ;; Relying on its automation, the version is now redundantly present on top of this file.
- ;; "2.345" would be an official release
- ;; "2.345.6" would be a development version in the official upstream
- ;; "2.345.0.7" would be your seventh local modification of official release 2.345
- ;; "2.345.6.7" would be your seventh local modification of development version 2.345.6
- (asdf-version "2.20")
- (existing-asdf (find-class 'component nil))
- (existing-version *asdf-version*)
- (already-there (equal asdf-version existing-version)))
- (unless (and existing-asdf already-there)
- (when (and existing-asdf *asdf-verbose*)
- (format *trace-output*
- (compatfmt "~&~@<; ~@;Upgrading ASDF ~@[from version ~A ~]to version ~A~@:>~%")
- existing-version asdf-version))
- (labels
- ((present-symbol-p (symbol package)
- (member (nth-value 1 (find-symbol* symbol package)) '(:internal :external)))
- (present-symbols (package)
- ;; #-genera (loop :for s :being :the :present-symbols :in package :collect s) #+genera
- (let (l)
- (do-symbols (s package)
- (when (present-symbol-p s package) (push s l)))
- (reverse l)))
- (unlink-package (package)
- (let ((u (find-package package)))
- (when u
- (ensure-unintern u (present-symbols u))
- (loop :for p :in (package-used-by-list u) :do
- (unuse-package u p))
- (delete-package u))))
- (ensure-exists (name nicknames use)
- (let ((previous
- (remove-duplicates
- (mapcar #'find-package (cons name nicknames))
- :from-end t)))
- ;; do away with packages with conflicting (nick)names
- (map () #'unlink-package (cdr previous))
- ;; reuse previous package with same name
- (let ((p (car previous)))
- (cond
- (p
- (rename-package p name nicknames)
- (ensure-use p use)
- p)
- (t
- (make-package name :nicknames nicknames :use use))))))
- (intern* (symbol package)
- (intern (string symbol) package))
- (remove-symbol (symbol package)
- (let ((sym (find-symbol* symbol package)))
- (when sym
- #-cormanlisp (unexport sym package)
- (unintern sym package)
- sym)))
- (ensure-unintern (package symbols)
- (loop :with packages = (list-all-packages)
- :for sym :in symbols
- :for removed = (remove-symbol sym package)
- :when removed :do
- (loop :for p :in packages :do
- (when (eq removed (find-symbol* sym p))
- (unintern removed p)))))
- (ensure-shadow (package symbols)
- (shadow symbols package))
- (ensure-use (package use)
- (dolist (used (reverse use))
- (do-external-symbols (sym used)
- (unless (eq sym (find-symbol* sym package))
- (remove-symbol sym package)))
- (use-package used package)))
- (ensure-fmakunbound (package symbols)
- (loop :for name :in symbols
- :for sym = (find-symbol* name package)
- :when sym :do (fmakunbound sym)))
- (ensure-export (package export)
- (let ((formerly-exported-symbols nil)
- (bothly-exported-symbols nil)
- (newly-exported-symbols nil))
- (do-external-symbols (sym package)
- (if (member sym export :test 'string-equal)
- (push sym bothly-exported-symbols)
- (push sym formerly-exported-symbols)))
- (loop :for sym :in export :do
- (unless (member sym bothly-exported-symbols :test 'equal)
- (push sym newly-exported-symbols)))
- (loop :for user :in (package-used-by-list package)
- :for shadowing = (package-shadowing-symbols user) :do
- (loop :for new :in newly-exported-symbols
- :for old = (find-symbol* new user)
- :when (and old (not (member old shadowing)))
- :do (unintern old user)))
- (loop :for x :in newly-exported-symbols :do
- (export (intern* x package)))))
- (ensure-package (name &key nicknames use unintern
- shadow export redefined-functions)
- (let* ((p (ensure-exists name nicknames use)))
- (ensure-unintern p unintern)
- (ensure-shadow p shadow)
- (ensure-export p export)
- (ensure-fmakunbound p redefined-functions)
- p)))
- (macrolet
- ((pkgdcl (name &key nicknames use export
- redefined-functions unintern shadow)
- `(ensure-package
- ',name :nicknames ',nicknames :use ',use :export ',export
- :shadow ',shadow
- :unintern ',unintern
- :redefined-functions ',redefined-functions)))
- (pkgdcl
- :asdf
- :nicknames (:asdf-utilities) ;; DEPRECATED! Do not use, for backward compatibility only.
- :use (:common-lisp)
- :redefined-functions
- (#:perform #:explain #:output-files #:operation-done-p
- #:perform-with-restarts #:component-relative-pathname
- #:system-source-file #:operate #:find-component #:find-system
- #:apply-output-translations #:translate-pathname* #:resolve-location
- #:system-relative-pathname
- #:inherit-source-registry #:process-source-registry
- #:process-source-registry-directive
- #:compile-file* #:source-file-type)
- :unintern
- (#:*asdf-revision* #:around #:asdf-method-combination
- #:split #:make-collector #:do-dep #:do-one-dep
- #:resolve-relative-location-component #:resolve-absolute-location-component
- #:output-files-for-system-and-operation) ; obsolete ASDF-BINARY-LOCATION function
- :export
- (#:defsystem #:oos #:operate #:find-system #:locate-system #:run-shell-command
- #:system-definition-pathname #:with-system-definitions
- #:search-for-system-definition #:find-component #:component-find-path
- #:compile-system #:load-system #:load-systems #:test-system #:clear-system
- #:operation #:compile-op #:load-op #:load-source-op #:test-op
- #:feature #:version #:version-satisfies
- #:upgrade-asdf
- #:implementation-identifier #:implementation-type
- #:input-files #:output-files #:output-file #:perform
- #:operation-done-p #:explain
-
- #:component #:source-file
- #:c-source-file #:cl-source-file #:java-source-file
- #:cl-source-file.cl #:cl-source-file.lsp
- #:static-file
- #:doc-file
- #:html-file
- #:text-file
- #:source-file-type
- #:module ; components
- #:system
- #:unix-dso
-
- #:module-components ; component accessors
- #:module-components-by-name ; component accessors
- #:component-pathname
- #:component-relative-pathname
- #:component-name
- #:component-version
- #:component-parent
- #:component-property
- #:component-system
-
- #:component-depends-on
-
- #:system-description
- #:system-long-description
- #:system-author
- #:system-maintainer
- #:system-license
- #:system-licence
- #:system-source-file
- #:system-source-directory
- #:system-relative-pathname
- #:map-systems
-
- #:operation-description
- #:operation-on-warnings
- #:operation-on-failure
- #:component-visited-p
- ;;#:*component-parent-pathname*
- #:*system-definition-search-functions*
- #:*central-registry* ; variables
- #:*compile-file-warnings-behaviour*
- #:*compile-file-failure-behaviour*
- #:*resolve-symlinks*
- #:*require-asdf-operator*
- #:*asdf-verbose*
- #:*verbose-out*
-
- #:asdf-version
-
- #:operation-error #:compile-failed #:compile-warned #:compile-error
- #:error-name
- #:error-pathname
- #:load-system-definition-error
- #:error-component #:error-operation
- #:system-definition-error
- #:missing-component
- #:missing-component-of-version
- #:missing-dependency
- #:missing-dependency-of-version
- #:circular-dependency ; errors
- #:duplicate-names
-
- #:try-recompiling
- #:retry
- #:accept ; restarts
- #:coerce-entry-to-directory
- #:remove-entry-from-registry
-
- #:clear-configuration
- #:*output-translations-parameter*
- #:initialize-output-translations
- #:disable-output-translations
- #:clear-output-translations
- #:ensure-output-translations
- #:apply-output-translations
- #:compile-file*
- #:compile-file-pathname*
- #:enable-asdf-binary-locations-compatibility
- #:*default-source-registries*
- #:*source-registry-parameter*
- #:initialize-source-registry
- #:compute-source-registry
- #:clear-source-registry
- #:ensure-source-registry
- #:process-source-registry
- #:system-registered-p
- #:asdf-message
- #:user-output-translations-pathname
- #:system-output-translations-pathname
- #:user-output-translations-directory-pathname
- #:system-output-translations-directory-pathname
- #:user-source-registry
- #:system-source-registry
- #:user-source-registry-directory
- #:system-source-registry-directory
-
- ;; Utilities
- #:absolute-pathname-p
- ;; #:aif #:it
- ;; #:appendf #:orf
- #:coerce-name
- #:directory-pathname-p
- ;; #:ends-with
- #:ensure-directory-pathname
- #:getenv
- ;; #:length=n-p
- ;; #:find-symbol*
- #:merge-pathnames* #:coerce-pathname #:subpathname
- #:pathname-directory-pathname
- #:read-file-forms
- ;; #:remove-keys
- ;; #:remove-keyword
- #:resolve-symlinks
- #:split-string
- #:component-name-to-pathname-components
- #:split-name-type
- #:subdirectories
- #:truenamize
- #:while-collecting)))
- #+genera (import 'scl:boolean :asdf)
- (setf *asdf-version* asdf-version
- *upgraded-p* (if existing-version
- (cons existing-version *upgraded-p*)
- *upgraded-p*))))))
-
-;;;; -------------------------------------------------------------------------
-;;;; User-visible parameters
-;;;;
-(defvar *resolve-symlinks* t
- "Determine whether or not ASDF resolves symlinks when defining systems.
-
-Defaults to T.")
-
-(defvar *compile-file-warnings-behaviour*
- (or #+clisp :ignore :warn)
- "How should ASDF react if it encounters a warning when compiling a file?
-Valid values are :error, :warn, and :ignore.")
-
-(defvar *compile-file-failure-behaviour*
- (or #+sbcl :error #+clisp :ignore :warn)
- "How should ASDF react if it encounters a failure (per the ANSI spec of COMPILE-FILE)
-when compiling a file? Valid values are :error, :warn, and :ignore.
-Note that ASDF ALWAYS raises an error if it fails to create an output file when compiling.")
-
-(defvar *verbose-out* nil)
-
-(defparameter +asdf-methods+
- '(perform-with-restarts perform explain output-files operation-done-p))
-
-#+allegro
-(eval-when (:compile-toplevel :execute)
- (defparameter *acl-warn-save*
- (when (boundp 'excl:*warn-on-nested-reader-conditionals*)
- excl:*warn-on-nested-reader-conditionals*))
- (when (boundp 'excl:*warn-on-nested-reader-conditionals*)
- (setf excl:*warn-on-nested-reader-conditionals* nil)))
-
-;;;; -------------------------------------------------------------------------
-;;;; Resolve forward references
-
-(declaim (ftype (function (t) t)
- format-arguments format-control
- error-name error-pathname error-condition
- duplicate-names-name
- error-component error-operation
- module-components module-components-by-name
- circular-dependency-components
- condition-arguments condition-form
- condition-format condition-location
- coerce-name)
- (ftype (function (&optional t) (values)) initialize-source-registry)
- #-(or cormanlisp gcl-pre2.7)
- (ftype (function (t t) t) (setf module-components-by-name)))
-
-;;;; -------------------------------------------------------------------------
-;;;; Compatibility various implementations
-#+cormanlisp
-(progn
- (deftype logical-pathname () nil)
- (defun make-broadcast-stream () *error-output*)
- (defun file-namestring (p)
- (setf p (pathname p))
- (format nil "~@[~A~]~@[.~A~]" (pathname-name p) (pathname-type p))))
-
-#.(or #+mcl ;; the #$ doesn't work on other lisps, even protected by #+mcl
- (read-from-string
- "(eval-when (:compile-toplevel :load-toplevel :execute)
- (ccl:define-entry-point (_getenv \"getenv\") ((name :string)) :string)
- (ccl:define-entry-point (_system \"system\") ((name :string)) :int)
- ;; Note: ASDF may expect user-homedir-pathname to provide
- ;; the pathname of the current user's home directory, whereas
- ;; MCL by default provides the directory from which MCL was started.
- ;; See http://code.google.com/p/mcl/wiki/Portability
- (defun current-user-homedir-pathname ()
- (ccl::findfolder #$kuserdomain #$kCurrentUserFolderType))
- (defun probe-posix (posix-namestring)
- \"If a file exists for the posix namestring, return the pathname\"
- (ccl::with-cstrs ((cpath posix-namestring))
- (ccl::rlet ((is-dir :boolean)
- (fsref :fsref))
- (when (eq #$noerr (#_fspathmakeref cpath fsref is-dir))
- (ccl::%path-from-fsref fsref is-dir))))))"))
-
-;;;; -------------------------------------------------------------------------
-;;;; General Purpose Utilities
-
-(macrolet
- ((defdef (def* def)
- `(defmacro ,def* (name formals &rest rest)
- `(progn
- #+(or ecl (and gcl (not gcl-pre2.7))) (fmakunbound ',name)
- #-gcl ; gcl 2.7.0 notinline functions lose secondary return values :-(
- ,(when (and #+ecl (symbolp name)) ; fails for setf functions on ecl
- `(declaim (notinline ,name)))
- (,',def ,name ,formals ,@rest)))))
- (defdef defgeneric* defgeneric)
- (defdef defun* defun))
-
-(defmacro while-collecting ((&rest collectors) &body body)
- "COLLECTORS should be a list of names for collections. A collector
-defines a function that, when applied to an argument inside BODY, will
-add its argument to the corresponding collection. Returns multiple values,
-a list for each collection, in order.
- E.g.,
-\(while-collecting \(foo bar\)
- \(dolist \(x '\(\(a 1\) \(b 2\) \(c 3\)\)\)
- \(foo \(first x\)\)
- \(bar \(second x\)\)\)\)
-Returns two values: \(A B C\) and \(1 2 3\)."
- (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)
- ,@body
- (values ,@(mapcar #'(lambda (v) `(reverse ,v)) vars))))))
-
-(defmacro aif (test then &optional else)
- `(let ((it ,test)) (if it ,then ,else)))
-
-(defun* pathname-directory-pathname (pathname)
- "Returns a new pathname with same HOST, DEVICE, DIRECTORY as PATHNAME,
-and NIL NAME, TYPE and VERSION components"
- (when pathname
- (make-pathname :name nil :type nil :version nil :defaults pathname)))
-
-(defun* normalize-pathname-directory-component (directory)
- (cond
- #-(or cmu sbcl scl)
- ((stringp directory) `(:absolute ,directory) directory)
- #+gcl
- ((and (consp directory) (stringp (first directory)))
- `(:absolute ,@directory))
- ((or (null directory)
- (and (consp directory) (member (first directory) '(:absolute :relative))))
- directory)
- (t
- (error (compatfmt "~@<Unrecognized pathname directory component ~S~@:>") directory))))
-
-(defun* merge-pathname-directory-components (specified defaults)
- (let ((directory (normalize-pathname-directory-component specified)))
- (ecase (first directory)
- ((nil) defaults)
- (:absolute specified)
- (:relative
- (let ((defdir (normalize-pathname-directory-component defaults))
- (reldir (cdr directory)))
- (cond
- ((null defdir)
- directory)
- ((not (eq :back (first reldir)))
- (append defdir reldir))
- (t
- (loop :with defabs = (first defdir)
- :with defrev = (reverse (rest defdir))
- :while (and (eq :back (car reldir))
- (or (and (eq :absolute defabs) (null defrev))
- (stringp (car defrev))))
- :do (pop reldir) (pop defrev)
- :finally (return (cons defabs (append (reverse defrev) reldir)))))))))))
-
-(defun* ununspecific (x)
- (if (eq x :unspecific) nil x))
-
-(defun* merge-pathnames* (specified &optional (defaults *default-pathname-defaults*))
- "MERGE-PATHNAMES* is like MERGE-PATHNAMES except that
-if the SPECIFIED pathname does not have an absolute directory,
-then the HOST and DEVICE both come from the DEFAULTS, whereas
-if the SPECIFIED pathname does have an absolute directory,
-then the HOST and DEVICE both come from the SPECIFIED.
-Also, if either argument is NIL, then the other argument is returned unmodified."
- (when (null specified) (return-from merge-pathnames* defaults))
- (when (null defaults) (return-from merge-pathnames* specified))
- #+scl
- (ext:resolve-pathname specified defaults)
- #-scl
- (let* ((specified (pathname specified))
- (defaults (pathname defaults))
- (directory (normalize-pathname-directory-component (pathname-directory specified)))
- (name (or (pathname-name specified) (pathname-name defaults)))
- (type (or (pathname-type specified) (pathname-type defaults)))
- (version (or (pathname-version specified) (pathname-version defaults))))
- (labels ((unspecific-handler (p)
- (if (typep p 'logical-pathname) #'ununspecific #'identity)))
- (multiple-value-bind (host device directory unspecific-handler)
- (ecase (first directory)
- ((:absolute)
- (values (pathname-host specified)
- (pathname-device specified)
- directory
- (unspecific-handler specified)))
- ((nil :relative)
- (values (pathname-host defaults)
- (pathname-device defaults)
- (merge-pathname-directory-components directory (pathname-directory defaults))
- (unspecific-handler defaults))))
- (make-pathname :host host :device device :directory directory
- :name (funcall unspecific-handler name)
- :type (funcall unspecific-handler type)
- :version (funcall unspecific-handler version))))))
-
-(defun* pathname-parent-directory-pathname (pathname)
- "Returns a new pathname with same HOST, DEVICE, DIRECTORY as PATHNAME,
-and NIL NAME, TYPE and VERSION components"
- (when pathname
- (make-pathname :name nil :type nil :version nil
- :directory (merge-pathname-directory-components
- '(:relative :back) (pathname-directory pathname))
- :defaults pathname)))
-
-(define-modify-macro appendf (&rest args)
- append "Append onto list") ;; only to be used on short lists.
-
-(define-modify-macro orf (&rest args)
- or "or a flag")
-
-(defun* first-char (s)
- (and (stringp s) (plusp (length s)) (char s 0)))
-
-(defun* last-char (s)
- (and (stringp s) (plusp (length s)) (char s (1- (length s)))))
-
-
-(defun* asdf-message (format-string &rest format-args)
- (declare (dynamic-extent format-args))
- (apply 'format *verbose-out* format-string format-args))
-
-(defun* split-string (string &key max (separator '(#\Space #\Tab)))
- "Split STRING into a list of components separated by
-any of the characters in the sequence SEPARATOR.
-If MAX is specified, then no more than max(1,MAX) components will be returned,
-starting the separation from the end, e.g. when called with arguments
- \"a.b.c.d.e\" :max 3 :separator \".\" it will return (\"a.b.c\" \"d\" \"e\")."
- (catch nil
- (let ((list nil) (words 0) (end (length string)))
- (flet ((separatorp (char) (find char separator))
- (done () (throw nil (cons (subseq string 0 end) list))))
- (loop
- :for start = (if (and max (>= words (1- max)))
- (done)
- (position-if #'separatorp string :end end :from-end t)) :do
- (when (null start)
- (done))
- (push (subseq string (1+ start) end) list)
- (incf words)
- (setf end start))))))
-
-(defun* split-name-type (filename)
- (let ((unspecific
- ;; Giving :unspecific as argument to make-pathname is not portable.
- ;; See CLHS make-pathname and 19.2.2.2.3.
- ;; We only use it on implementations that support it.
- (or #+(or clozure gcl lispworks sbcl) :unspecific)))
- (destructuring-bind (name &optional (type unspecific))
- (split-string filename :max 2 :separator ".")
- (if (equal name "")
- (values filename unspecific)
- (values name type)))))
-
-(defun* component-name-to-pathname-components (s &key force-directory force-relative)
- "Splits the path string S, returning three values:
-A flag that is either :absolute or :relative, indicating
- how the rest of the values are to be interpreted.
-A directory path --- a list of strings, suitable for
- use with MAKE-PATHNAME when prepended with the flag
- value.
-A filename with type extension, possibly NIL in the
- case of a directory pathname.
-FORCE-DIRECTORY forces S to be interpreted as a directory
-pathname \(third return value will be NIL, final component
-of S will be treated as part of the directory path.
-
-The intention of this function is to support structured component names,
-e.g., \(:file \"foo/bar\"\), which will be unpacked to relative
-pathnames."
- (check-type s string)
- (when (find #\: s)
- (error (compatfmt "~@<A portable ASDF pathname designator cannot include a #\: character: ~3i~_~S~@:>") s))
- (let* ((components (split-string s :separator "/"))
- (last-comp (car (last components))))
- (multiple-value-bind (relative components)
- (if (equal (first components) "")
- (if (equal (first-char s) #\/)
- (progn
- (when force-relative
- (error (compatfmt "~@<Absolute pathname designator not allowed: ~3i~_~S~@:>") s))
- (values :absolute (cdr components)))
- (values :relative nil))
- (values :relative components))
- (setf components (remove-if #'(lambda (x) (member x '("" ".") :test #'equal)) components))
- (setf components (substitute :back ".." components :test #'equal))
- (cond
- ((equal last-comp "")
- (values relative components nil)) ; "" already removed
- (force-directory
- (values relative components nil))
- (t
- (values relative (butlast components) last-comp))))))
-
-(defun* remove-keys (key-names args)
- (loop :for (name val) :on args :by #'cddr
- :unless (member (symbol-name name) key-names
- :key #'symbol-name :test 'equal)
- :append (list name val)))
-
-(defun* remove-keyword (key args)
- (loop :for (k v) :on args :by #'cddr
- :unless (eq k key)
- :append (list k v)))
-
-(defun* getenv (x)
- (declare (ignorable x))
- #+(or abcl clisp ecl xcl) (ext:getenv x)
- #+allegro (sys:getenv x)
- #+clozure (ccl:getenv x)
- #+(or cmu scl) (cdr (assoc x ext:*environment-list* :test #'string=))
- #+cormanlisp
- (let* ((buffer (ct:malloc 1))
- (cname (ct:lisp-string-to-c-string x))
- (needed-size (win:getenvironmentvariable cname buffer 0))
- (buffer1 (ct:malloc (1+ needed-size))))
- (prog1 (if (zerop (win:getenvironmentvariable cname buffer1 needed-size))
- nil
- (ct:c-string-to-lisp-string buffer1))
- (ct:free buffer)
- (ct:free buffer1)))
- #+gcl (system:getenv x)
- #+genera nil
- #+lispworks (lispworks:environment-variable x)
- #+mcl (ccl:with-cstrs ((name x))
- (let ((value (_getenv name)))
- (unless (ccl:%null-ptr-p value)
- (ccl:%get-cstring value))))
- #+sbcl (sb-ext:posix-getenv x)
- #-(or abcl allegro clisp clozure cmu cormanlisp ecl gcl genera lispworks mcl sbcl scl xcl)
- (error "~S is not supported on your implementation" 'getenv))
-
-(defun* directory-pathname-p (pathname)
- "Does PATHNAME represent a directory?
-
-A directory-pathname is a pathname _without_ a filename. The three
-ways that the filename components can be missing are for it to be NIL,
-:UNSPECIFIC or the empty string.
-
-Note that this does _not_ check to see that PATHNAME points to an
-actually-existing directory."
- (when pathname
- (let ((pathname (pathname pathname)))
- (flet ((check-one (x)
- (member x '(nil :unspecific "") :test 'equal)))
- (and (not (wild-pathname-p pathname))
- (check-one (pathname-name pathname))
- (check-one (pathname-type pathname))
- t)))))
-
-(defun* ensure-directory-pathname (pathspec)
- "Converts the non-wild pathname designator PATHSPEC to directory form."
- (cond
- ((stringp pathspec)
- (ensure-directory-pathname (pathname pathspec)))
- ((not (pathnamep pathspec))
- (error (compatfmt "~@<Invalid pathname designator ~S~@:>") pathspec))
- ((wild-pathname-p pathspec)
- (error (compatfmt "~@<Can't reliably convert wild pathname ~3i~_~S~@:>") pathspec))
- ((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))))
-
-#+genera
-(unless (fboundp 'ensure-directories-exist)
- (defun* ensure-directories-exist (path)
- (fs:create-directories-recursively (pathname path))))
-
-(defun* absolute-pathname-p (pathspec)
- (and (typep pathspec '(or pathname string))
- (eq :absolute (car (pathname-directory (pathname pathspec))))))
-
-(defun* length=n-p (x n) ;is it that (= (length x) n) ?
- (check-type n (integer 0 *))
- (loop
- :for l = x :then (cdr l)
- :for i :downfrom n :do
- (cond
- ((zerop i) (return (null l)))
- ((not (consp l)) (return nil)))))
-
-(defun* ends-with (s suffix)
- (check-type s string)
- (check-type suffix string)
- (let ((start (- (length s) (length suffix))))
- (and (<= 0 start)
- (string-equal s suffix :start1 start))))
-
-(defun* read-file-forms (file)
- (with-open-file (in file)
- (loop :with eof = (list nil)
- :for form = (read in nil eof)
- :until (eq form eof)
- :collect form)))
-
-(defun* pathname-root (pathname)
- (make-pathname :directory '(:absolute)
- :name nil :type nil :version nil
- :defaults pathname ;; host device, and on scl, *some*
- ;; scheme-specific parts: port username password, not others:
- . #.(or #+scl '(:parameters nil :query nil :fragment nil))))
-
-(defun* probe-file* (p)
- "when given a pathname P, probes the filesystem for a file or directory
-with given pathname and if it exists return its truename."
- (etypecase p
- (null nil)
- (string (probe-file* (parse-namestring p)))
- (pathname (unless (wild-pathname-p p)
- #.(or #+(or allegro clozure cmu cormanlisp ecl lispworks sbcl scl)
- '(probe-file p)
- #+clisp (aif (find-symbol* '#:probe-pathname :ext)
- `(ignore-errors (,it p)))
- '(ignore-errors (truename p)))))))
-
-(defun* truenamize (pathname &optional (defaults *default-pathname-defaults*))
- "Resolve as much of a pathname as possible"
- (block nil
- (when (typep pathname '(or null logical-pathname)) (return pathname))
- (let ((p (merge-pathnames* pathname defaults)))
- (when (typep p 'logical-pathname) (return p))
- (let ((found (probe-file* p)))
- (when found (return found)))
- (unless (absolute-pathname-p p)
- (let ((true-defaults (ignore-errors (truename defaults))))
- (when true-defaults
- (setf p (merge-pathnames pathname true-defaults)))))
- (unless (absolute-pathname-p p) (return p))
- (let ((sofar (probe-file* (pathname-root p))))
- (unless sofar (return p))
- (flet ((solution (directories)
- (merge-pathnames*
- (make-pathname :host nil :device nil
- :directory `(:relative ,@directories)
- :name (pathname-name p)
- :type (pathname-type p)
- :version (pathname-version p))
- sofar)))
- (loop :with directory = (normalize-pathname-directory-component
- (pathname-directory p))
- :for component :in (cdr directory)
- :for rest :on (cdr directory)
- :for more = (probe-file*
- (merge-pathnames*
- (make-pathname :directory `(:relative ,component))
- sofar)) :do
- (if more
- (setf sofar more)
- (return (solution rest)))
- :finally
- (return (solution nil))))))))
-
-(defun* resolve-symlinks (path)
- #-allegro (truenamize path)
- #+allegro (if (typep path 'logical-pathname)
- path
- (excl:pathname-resolve-symbolic-links path)))
-
-(defun* resolve-symlinks* (path)
- (if *resolve-symlinks*
- (and path (resolve-symlinks path))
- path))
-
-(defun* ensure-pathname-absolute (path)
- (cond
- ((absolute-pathname-p path) path)
- ((stringp path) (ensure-pathname-absolute (pathname path)))
- ((not (pathnamep path)) (error "not a valid pathname designator ~S" path))
- (t (let ((resolved (resolve-symlinks path)))
- (assert (absolute-pathname-p resolved))
- resolved))))
-
-(defun* default-directory ()
- (truenamize (pathname-directory-pathname *default-pathname-defaults*)))
-
-(defun* lispize-pathname (input-file)
- (make-pathname :type "lisp" :defaults input-file))
-
-(defparameter *wild* #-cormanlisp :wild #+cormanlisp "*")
-(defparameter *wild-file*
- (make-pathname :name *wild* :type *wild*
- :version (or #-(or abcl xcl) *wild*) :directory nil))
-(defparameter *wild-directory*
- (make-pathname :directory `(:relative ,*wild*) :name nil :type nil :version nil))
-(defparameter *wild-inferiors*
- (make-pathname :directory '(:relative :wild-inferiors) :name nil :type nil :version nil))
-(defparameter *wild-path*
- (merge-pathnames *wild-file* *wild-inferiors*))
-
-(defun* wilden (path)
- (merge-pathnames* *wild-path* path))
-
-#-scl
-(defun* directory-separator-for-host (&optional (pathname *default-pathname-defaults*))
- (let ((foo (make-pathname :directory '(:absolute "FOO") :defaults pathname)))
- (last-char (namestring foo))))
-
-#-scl
-(defun* directorize-pathname-host-device (pathname)
- (let* ((root (pathname-root pathname))
- (wild-root (wilden root))
- (absolute-pathname (merge-pathnames* pathname root))
- (separator (directory-separator-for-host root))
- (root-namestring (namestring root))
- (root-string
- (substitute-if #\/
- #'(lambda (x) (or (eql x #\:)
- (eql x separator)))
- root-namestring)))
- (multiple-value-bind (relative path filename)
- (component-name-to-pathname-components root-string :force-directory t)
- (declare (ignore relative filename))
- (let ((new-base
- (make-pathname :defaults root
- :directory `(:absolute ,@path))))
- (translate-pathname absolute-pathname wild-root (wilden new-base))))))
-
-#+scl
-(defun* directorize-pathname-host-device (pathname)
- (let ((scheme (ext:pathname-scheme pathname))
- (host (pathname-host pathname))
- (port (ext:pathname-port pathname))
- (directory (pathname-directory pathname)))
- (if (or (ununspecific port)
- (and (ununspecific host) (plusp (length host)))
- (ununspecific scheme))
- (let ((prefix ""))
- (when (ununspecific port)
- (setf prefix (format nil ":~D" port)))
- (when (and (ununspecific host) (plusp (length host)))
- (setf prefix (strcat host prefix)))
- (setf prefix (strcat ":" prefix))
- (when (ununspecific scheme)
- (setf prefix (strcat scheme prefix)))
- (assert (and directory (eq (first directory) :absolute)))
- (make-pathname :directory `(:absolute ,prefix ,@(rest directory))
- :defaults pathname)))
- pathname))
-
-;;;; -------------------------------------------------------------------------
-;;;; ASDF Interface, in terms of generic functions.
-(defgeneric* find-system (system &optional error-p))
-(defgeneric* perform-with-restarts (operation component))
-(defgeneric* perform (operation component))
-(defgeneric* operation-done-p (operation component))
-(defgeneric* mark-operation-done (operation component))
-(defgeneric* explain (operation component))
-(defgeneric* output-files (operation component))
-(defgeneric* input-files (operation component))
-(defgeneric* component-operation-time (operation component))
-(defgeneric* operation-description (operation component)
- (:documentation "returns a phrase that describes performing this operation
-on this component, e.g. \"loading /a/b/c\".
-You can put together sentences using this phrase."))
-
-(defgeneric* system-source-file (system)
- (:documentation "Return the source file in which system is defined."))
-
-(defgeneric* component-system (component)
- (:documentation "Find the top-level system containing COMPONENT"))
-
-(defgeneric* component-pathname (component)
- (:documentation "Extracts the pathname applicable for a particular component."))
-
-(defgeneric* component-relative-pathname (component)
- (:documentation "Returns a pathname for the component argument intended to be
-interpreted relative to the pathname of that component's parent.
-Despite the function's name, the return value may be an absolute
-pathname, because an absolute pathname may be interpreted relative to
-another pathname in a degenerate way."))
-
-(defgeneric* component-property (component property))
-
-(defgeneric* (setf component-property) (new-value component property))
-
-(eval-when (#-gcl :compile-toplevel :load-toplevel :execute)
- (defgeneric* (setf module-components-by-name) (new-value module)))
-
-(defgeneric* version-satisfies (component version))
-
-(defgeneric* find-component (base path)
- (:documentation "Finds the component with PATH starting from BASE module;
-if BASE is nil, then the component is assumed to be a system."))
-
-(defgeneric* source-file-type (component system))
-
-(defgeneric* operation-ancestor (operation)
- (:documentation
- "Recursively chase the operation's parent pointer until we get to
-the head of the tree"))
-
-(defgeneric* component-visited-p (operation component)
- (:documentation "Returns the value stored by a call to
-VISIT-COMPONENT, if that has been called, otherwise NIL.
-This value stored will be a cons cell, the first element
-of which is a computed key, so not interesting. The
-CDR wil be the DATA value stored by VISIT-COMPONENT; recover
-it as (cdr (component-visited-p op c)).
- In the current form of ASDF, the DATA value retrieved is
-effectively a boolean, indicating whether some operations are
-to be performed in order to do OPERATION X COMPONENT. If the
-data value is NIL, the combination had been explored, but no
-operations needed to be performed."))
-
-(defgeneric* visit-component (operation component data)
- (:documentation "Record DATA as being associated with OPERATION
-and COMPONENT. This is a side-effecting function: the association
-will be recorded on the ROOT OPERATION \(OPERATION-ANCESTOR of the
-OPERATION\).
- No evidence that DATA is ever interesting, beyond just being
-non-NIL. Using the data field is probably very risky; if there is
-already a record for OPERATION X COMPONENT, DATA will be quietly
-discarded instead of recorded.
- Starting with 2.006, TRAVERSE will store an integer in data,
-so that nodes can be sorted in decreasing order of traversal."))
-
-
-(defgeneric* (setf visiting-component) (new-value operation component))
-
-(defgeneric* component-visiting-p (operation component))
-
-(defgeneric* component-depends-on (operation component)
- (:documentation
- "Returns a list of dependencies needed by the component to perform
- the operation. A dependency has one of the following forms:
-
- (<operation> <component>*), where <operation> is a class
- designator and each <component> is a component
- designator, which means that the component depends on
- <operation> having been performed on each <component>; or
-
- (FEATURE <feature>), which means that the component depends
- on <feature>'s presence in *FEATURES*.
-
- Methods specialized on subclasses of existing component types
- should usually append the results of CALL-NEXT-METHOD to the
- list."))
-
-(defgeneric* component-self-dependencies (operation component))
-
-(defgeneric* traverse (operation component)
- (:documentation
-"Generate and return a plan for performing OPERATION on COMPONENT.
-
-The plan returned is a list of dotted-pairs. Each pair is the CONS
-of ASDF operation object and a COMPONENT object. The pairs will be
-processed in order by OPERATE."))
-
-
-;;;; -------------------------------------------------------------------------
-;;; Methods in case of hot-upgrade. See https://bugs.launchpad.net/asdf/+bug/485687
-(when *upgraded-p*
- (when (find-class 'module nil)
- (eval
- '(defmethod update-instance-for-redefined-class :after
- ((m module) added deleted plist &key)
- (declare (ignorable deleted plist))
- (when *asdf-verbose*
- (asdf-message (compatfmt "~&~@<; ~@;Updating ~A for ASDF ~A~@:>~%")
- m (asdf-version)))
- (when (member 'components-by-name added)
- (compute-module-components-by-name m))
- (when (typep m 'system)
- (when (member 'source-file added)
- (%set-system-source-file
- (probe-asd (component-name m) (component-pathname m)) m)
- (when (equal (component-name m) "asdf")
- (setf (component-version m) *asdf-version*))))))))
-
-;;;; -------------------------------------------------------------------------
-;;;; Classes, Conditions
-
-(define-condition system-definition-error (error) ()
- ;; [this use of :report should be redundant, but unfortunately it's not.
- ;; cmucl's lisp::output-instance prefers the kernel:slot-class-print-function
- ;; over print-object; this is always conditions::%print-condition for
- ;; condition objects, which in turn does inheritance of :report options at
- ;; run-time. fortunately, inheritance means we only need this kludge here in
- ;; order to fix all conditions that build on it. -- rgr, 28-Jul-02.]
- #+cmu (:report print-object))
-
-(define-condition formatted-system-definition-error (system-definition-error)
- ((format-control :initarg :format-control :reader format-control)
- (format-arguments :initarg :format-arguments :reader format-arguments))
- (:report (lambda (c s)
- (apply 'format s (format-control c) (format-arguments c)))))
-
-(define-condition load-system-definition-error (system-definition-error)
- ((name :initarg :name :reader error-name)
- (pathname :initarg :pathname :reader error-pathname)
- (condition :initarg :condition :reader error-condition))
- (:report (lambda (c s)
- (format s (compatfmt "~@<Error while trying to load definition for system ~A from pathname ~A: ~3i~_~A~@:>")
- (error-name c) (error-pathname c) (error-condition c)))))
-
-(define-condition circular-dependency (system-definition-error)
- ((components :initarg :components :reader circular-dependency-components))
- (:report (lambda (c s)
- (format s (compatfmt "~@<Circular dependency: ~3i~_~S~@:>")
- (circular-dependency-components c)))))
-
-(define-condition duplicate-names (system-definition-error)
- ((name :initarg :name :reader duplicate-names-name))
- (:report (lambda (c s)
- (format s (compatfmt "~@<Error while defining system: multiple components are given same name ~A~@:>")
- (duplicate-names-name c)))))
-
-(define-condition missing-component (system-definition-error)
- ((requires :initform "(unnamed)" :reader missing-requires :initarg :requires)
- (parent :initform nil :reader missing-parent :initarg :parent)))
-
-(define-condition missing-component-of-version (missing-component)
- ((version :initform nil :reader missing-version :initarg :version)))
-
-(define-condition missing-dependency (missing-component)
- ((required-by :initarg :required-by :reader missing-required-by)))
-
-(define-condition missing-dependency-of-version (missing-dependency
- missing-component-of-version)
- ())
-
-(define-condition operation-error (error)
- ((component :reader error-component :initarg :component)
- (operation :reader error-operation :initarg :operation))
- (:report (lambda (c s)
- (format s (compatfmt "~@<Error while invoking ~A on ~A~@:>")
- (error-operation c) (error-component c)))))
-(define-condition compile-error (operation-error) ())
-(define-condition compile-failed (compile-error) ())
-(define-condition compile-warned (compile-error) ())
-
-(define-condition invalid-configuration ()
- ((form :reader condition-form :initarg :form)
- (location :reader condition-location :initarg :location)
- (format :reader condition-format :initarg :format)
- (arguments :reader condition-arguments :initarg :arguments :initform nil))
- (:report (lambda (c s)
- (format s (compatfmt "~@<~? (will be skipped)~@:>")
- (condition-format c)
- (list* (condition-form c) (condition-location c)
- (condition-arguments c))))))
-(define-condition invalid-source-registry (invalid-configuration warning)
- ((format :initform (compatfmt "~@<Invalid source registry ~S~@[ in ~S~]~@{ ~@?~}~@:>"))))
-(define-condition invalid-output-translation (invalid-configuration warning)
- ((format :initform (compatfmt "~@<Invalid asdf output-translation ~S~@[ in ~S~]~@{ ~@?~}~@:>"))))
-
-(defclass component ()
- ((name :accessor component-name :initarg :name :type string :documentation
- "Component name: designator for a string composed of portable pathname characters")
- ;; We might want to constrain version with
- ;; :type (and string (satisfies parse-version))
- ;; but we cannot until we fix all systems that don't use it correctly!
- (version :accessor component-version :initarg :version)
- (description :accessor component-description :initarg :description)
- (long-description :accessor component-long-description :initarg :long-description)
- ;; This one below is used by POIU - http://www.cliki.net/poiu
- ;; a parallelizing extension of ASDF that compiles in multiple parallel
- ;; slave processes (forked on demand) and loads in the master process.
- ;; Maybe in the future ASDF may use it internally instead of in-order-to.
- (load-dependencies :accessor component-load-dependencies :initform nil)
- ;; In the ASDF object model, dependencies exist between *actions*
- ;; (an action is a pair of operation and component). They are represented
- ;; alists of operations to dependencies (other actions) in each component.
- ;; There are two kinds of dependencies, each stored in its own slot:
- ;; in-order-to and do-first dependencies. These two kinds are related to
- ;; the fact that some actions modify the filesystem,
- ;; whereas other actions modify the current image, and
- ;; this implies a difference in how to interpret timestamps.
- ;; in-order-to dependencies will trigger re-performing the action
- ;; when the timestamp of some dependency
- ;; makes the timestamp of current action out-of-date;
- ;; do-first dependencies do not trigger such re-performing.
- ;; Therefore, a FASL must be recompiled if it is obsoleted
- ;; by any of its FASL dependencies (in-order-to); but
- ;; it needn't be recompiled just because one of these dependencies
- ;; hasn't yet been loaded in the current image (do-first).
- ;; The names are crap, but they have been the official API since Dan Barlow's ASDF 1.52!
- ;; See our ASDF 2 paper for more complete explanations.
- (in-order-to :initform nil :initarg :in-order-to
- :accessor component-in-order-to)
- (do-first :initform nil :initarg :do-first
- :accessor component-do-first)
- ;; methods defined using the "inline" style inside a defsystem form:
- ;; need to store them somewhere so we can delete them when the system
- ;; is re-evaluated
- (inline-methods :accessor component-inline-methods :initform nil)
- (parent :initarg :parent :initform nil :reader component-parent)
- ;; no direct accessor for pathname, we do this as a method to allow
- ;; it to default in funky ways if not supplied
- (relative-pathname :initarg :pathname)
- ;; the absolute-pathname is computed based on relative-pathname...
- (absolute-pathname)
- (operation-times :initform (make-hash-table)
- :accessor component-operation-times)
- (around-compile :initarg :around-compile)
- ;; XXX we should provide some atomic interface for updating the
- ;; component properties
- (properties :accessor component-properties :initarg :properties
- :initform nil)))
-
-(defun* component-find-path (component)
- (reverse
- (loop :for c = component :then (component-parent c)
- :while c :collect (component-name c))))
-
-(defmethod print-object ((c component) stream)
- (print-unreadable-object (c stream :type t :identity nil)
- (format stream "~{~S~^ ~}" (component-find-path c))))
-
-
-;;;; methods: conditions
-
-(defmethod print-object ((c missing-dependency) s)
- (format s (compatfmt "~@<~A, required by ~A~@:>")
- (call-next-method c nil) (missing-required-by c)))
-
-(defun* sysdef-error (format &rest arguments)
- (error 'formatted-system-definition-error :format-control
- format :format-arguments arguments))
-
-;;;; methods: components
-
-(defmethod print-object ((c missing-component) s)
- (format s (compatfmt "~@<Component ~S not found~@[ in ~A~]~@:>")
- (missing-requires c)
- (when (missing-parent c)
- (coerce-name (missing-parent c)))))
-
-(defmethod print-object ((c missing-component-of-version) s)
- (format s (compatfmt "~@<Component ~S does not match version ~A~@[ in ~A~]~@:>")
- (missing-requires c)
- (missing-version c)
- (when (missing-parent c)
- (coerce-name (missing-parent c)))))
-
-(defmethod component-system ((component component))
- (aif (component-parent component)
- (component-system it)
- component))
-
-(defvar *default-component-class* 'cl-source-file)
-
-(defun* compute-module-components-by-name (module)
- (let ((hash (make-hash-table :test 'equal)))
- (setf (module-components-by-name module) hash)
- (loop :for c :in (module-components module)
- :for name = (component-name c)
- :for previous = (gethash name (module-components-by-name module))
- :do
- (when previous
- (error 'duplicate-names :name name))
- :do (setf (gethash name (module-components-by-name module)) c))
- hash))
-
-(defclass module (component)
- ((components
- :initform nil
- :initarg :components
- :accessor module-components)
- (components-by-name
- :accessor module-components-by-name)
- ;; What to do if we can't satisfy a dependency of one of this module's
- ;; components. This allows a limited form of conditional processing.
- (if-component-dep-fails
- :initform :fail
- :initarg :if-component-dep-fails
- :accessor module-if-component-dep-fails)
- (default-component-class
- :initform *default-component-class*
- :initarg :default-component-class
- :accessor module-default-component-class)))
-
-(defun* component-parent-pathname (component)
- ;; No default anymore (in particular, no *default-pathname-defaults*).
- ;; If you force component to have a NULL pathname, you better arrange
- ;; for any of its children to explicitly provide a proper absolute pathname
- ;; wherever a pathname is actually wanted.
- (let ((parent (component-parent component)))
- (when parent
- (component-pathname parent))))
-
-(defmethod component-pathname ((component component))
- (if (slot-boundp component 'absolute-pathname)
- (slot-value component 'absolute-pathname)
- (let ((pathname
- (merge-pathnames*
- (component-relative-pathname component)
- (pathname-directory-pathname (component-parent-pathname component)))))
- (unless (or (null pathname) (absolute-pathname-p pathname))
- (error (compatfmt "~@<Invalid relative pathname ~S for component ~S~@:>")
- pathname (component-find-path component)))
- (setf (slot-value component 'absolute-pathname) pathname)
- pathname)))
-
-(defmethod component-property ((c component) property)
- (cdr (assoc property (slot-value c 'properties) :test #'equal)))
-
-(defmethod (setf component-property) (new-value (c component) property)
- (let ((a (assoc property (slot-value c 'properties) :test #'equal)))
- (if a
- (setf (cdr a) new-value)
- (setf (slot-value c 'properties)
- (acons property new-value (slot-value c 'properties)))))
- new-value)
-
-(defclass proto-system () ; slots to keep when resetting a system
- ;; To preserve identity for all objects, we'd need keep the components slots
- ;; but also to modify parse-component-form to reset the recycled objects.
- ((name) #|(components) (components-by-names)|#))
-
-(defclass system (module proto-system)
- (;; description and long-description are now available for all component's,
- ;; but now also inherited from component, but we add the legacy accessor
- (description :accessor system-description :initarg :description)
- (long-description :accessor system-long-description :initarg :long-description)
- (author :accessor system-author :initarg :author)
- (maintainer :accessor system-maintainer :initarg :maintainer)
- (licence :accessor system-licence :initarg :licence
- :accessor system-license :initarg :license)
- (source-file :reader %system-source-file :initarg :source-file ; for CLISP upgrade
- :writer %set-system-source-file)
- (defsystem-depends-on :reader system-defsystem-depends-on :initarg :defsystem-depends-on)))
-
-;;;; -------------------------------------------------------------------------
-;;;; version-satisfies
-
-(defmethod version-satisfies ((c component) version)
- (unless (and version (slot-boundp c 'version))
- (when version
- (warn "Requested version ~S but component ~S has no version" version c))
- (return-from version-satisfies t))
- (version-satisfies (component-version c) version))
-
-(defun* asdf-version ()
- "Exported interface to the version of ASDF currently installed. A string.
-You can compare this string with e.g.:
-(ASDF:VERSION-SATISFIES (ASDF:ASDF-VERSION) \"2.345.67\")."
- *asdf-version*)
-
-(defun* parse-version (string &optional on-error)
- "Parse a version string as a series of natural integers separated by dots.
-Return a (non-null) list of integers if the string is valid, NIL otherwise.
-If on-error is error, warn, or designates a function of compatible signature,
-the function is called with an explanation of what is wrong with the argument.
-NB: ignores leading zeroes, and so doesn't distinguish between 2.003 and 2.3"
- (and
- (or (stringp string)
- (when on-error
- (funcall on-error "~S: ~S is not a string"
- 'parse-version string)) nil)
- (or (loop :for prev = nil :then c :for c :across string
- :always (or (digit-char-p c)
- (and (eql c #\.) prev (not (eql prev #\.))))
- :finally (return (and c (digit-char-p c))))
- (when on-error
- (funcall on-error "~S: ~S doesn't follow asdf version numbering convention"
- 'parse-version string)) nil)
- (mapcar #'parse-integer (split-string string :separator "."))))
-
-(defmethod version-satisfies ((cver string) version)
- (let ((x (parse-version cver 'warn))
- (y (parse-version version 'warn)))
- (labels ((bigger (x y)
- (cond ((not y) t)
- ((not x) nil)
- ((> (car x) (car y)) t)
- ((= (car x) (car y))
- (bigger (cdr x) (cdr y))))))
- (and x y (= (car x) (car y))
- (or (not (cdr y)) (bigger (cdr x) (cdr y)))))))
-
-;;;; -----------------------------------------------------------------
-;;;; Windows shortcut support. Based on:
-;;;;
-;;;; Jesse Hager: The Windows Shortcut File Format.
-;;;; http://www.wotsit.org/list.asp?fc=13
-
-#-(or clisp genera) ; CLISP doesn't need it, and READ-SEQUENCE annoys old Genera.
-(progn
-(defparameter *link-initial-dword* 76)
-(defparameter *link-guid* #(1 20 2 0 0 0 0 0 192 0 0 0 0 0 0 70))
-
-(defun* read-null-terminated-string (s)
- (with-output-to-string (out)
- (loop :for code = (read-byte s)
- :until (zerop code)
- :do (write-char (code-char code) out))))
-
-(defun* read-little-endian (s &optional (bytes 4))
- (loop :for i :from 0 :below bytes
- :sum (ash (read-byte s) (* 8 i))))
-
-(defun* parse-file-location-info (s)
- (let ((start (file-position s))
- (total-length (read-little-endian s))
- (end-of-header (read-little-endian s))
- (fli-flags (read-little-endian s))
- (local-volume-offset (read-little-endian s))
- (local-offset (read-little-endian s))
- (network-volume-offset (read-little-endian s))
- (remaining-offset (read-little-endian s)))
- (declare (ignore total-length end-of-header local-volume-offset))
- (unless (zerop fli-flags)
- (cond
- ((logbitp 0 fli-flags)
- (file-position s (+ start local-offset)))
- ((logbitp 1 fli-flags)
- (file-position s (+ start
- network-volume-offset
- #x14))))
- (strcat (read-null-terminated-string s)
- (progn
- (file-position s (+ start remaining-offset))
- (read-null-terminated-string s))))))
-
-(defun* parse-windows-shortcut (pathname)
- (with-open-file (s pathname :element-type '(unsigned-byte 8))
- (handler-case
- (when (and (= (read-little-endian s) *link-initial-dword*)
- (let ((header (make-array (length *link-guid*))))
- (read-sequence header s)
- (equalp header *link-guid*)))
- (let ((flags (read-little-endian s)))
- (file-position s 76) ;skip rest of header
- (when (logbitp 0 flags)
- ;; skip shell item id list
- (let ((length (read-little-endian s 2)))
- (file-position s (+ length (file-position s)))))
- (cond
- ((logbitp 1 flags)
- (parse-file-location-info s))
- (t
- (when (logbitp 2 flags)
- ;; skip description string
- (let ((length (read-little-endian s 2)))
- (file-position s (+ length (file-position s)))))
- (when (logbitp 3 flags)
- ;; finally, our pathname
- (let* ((length (read-little-endian s 2))
- (buffer (make-array length)))
- (read-sequence buffer s)
- (map 'string #'code-char buffer)))))))
- (end-of-file ()
- nil)))))
-
-;;;; -------------------------------------------------------------------------
-;;;; Finding systems
-
-(defun* make-defined-systems-table ()
- (make-hash-table :test 'equal))
-
-(defvar *defined-systems* (make-defined-systems-table)
- "This is a hash table whose keys are strings, being the
-names of the systems, and whose values are pairs, the first
-element of which is a universal-time indicating when the
-system definition was last updated, and the second element
-of which is a system object.")
-
-(defun* coerce-name (name)
- (typecase name
- (component (component-name name))
- (symbol (string-downcase (symbol-name name)))
- (string name)
- (t (sysdef-error (compatfmt "~@<Invalid component designator: ~3i~_~A~@:>") name))))
-
-(defun* system-registered-p (name)
- (gethash (coerce-name name) *defined-systems*))
-
-(defun* register-system (system)
- (check-type system system)
- (let ((name (component-name system)))
- (check-type name string)
- (asdf-message (compatfmt "~&~@<; ~@;Registering ~3i~_~A~@:>~%") system)
- (unless (eq system (cdr (gethash name *defined-systems*)))
- (setf (gethash name *defined-systems*)
- (cons (get-universal-time) system)))))
-
-(defun* clear-system (name)
- "Clear the entry for a system in the database of systems previously loaded.
-Note that this does NOT in any way cause the code of the system to be unloaded."
- ;; There is no "unload" operation in Common Lisp, and
- ;; a general such operation cannot be portably written,
- ;; considering how much CL relies on side-effects to global data structures.
- (remhash (coerce-name name) *defined-systems*))
-
-(defun* map-systems (fn)
- "Apply FN to each defined system.
-
-FN should be a function of one argument. It will be
-called with an object of type asdf:system."
- (maphash #'(lambda (_ datum)
- (declare (ignore _))
- (destructuring-bind (_ . def) datum
- (declare (ignore _))
- (funcall fn def)))
- *defined-systems*))
-
-;;; for the sake of keeping things reasonably neat, we adopt a
-;;; convention that functions in this list are prefixed SYSDEF-
-
-(defvar *system-definition-search-functions* '())
-
-(setf *system-definition-search-functions*
- (append
- ;; Remove known-incompatible sysdef functions from ancient sbcl asdf.
- (remove 'contrib-sysdef-search *system-definition-search-functions*)
- ;; Tuck our defaults at the end of the list if they were absent.
- ;; This is imperfect, in case they were removed on purpose,
- ;; but then it will be the responsibility of whoever does that
- ;; to upgrade asdf before he does such a thing rather than after.
- (remove-if #'(lambda (x) (member x *system-definition-search-functions*))
- '(sysdef-central-registry-search
- sysdef-source-registry-search
- sysdef-find-asdf))))
-
-(defun* search-for-system-definition (system)
- (some (let ((name (coerce-name system))) #'(lambda (x) (funcall x name)))
- (cons 'find-system-if-being-defined
- *system-definition-search-functions*)))
-
-(defvar *central-registry* nil
-"A list of 'system directory designators' ASDF uses to find systems.
-
-A 'system directory designator' is a pathname or an expression
-which evaluates to a pathname. For example:
-
- (setf asdf:*central-registry*
- (list '*default-pathname-defaults*
- #p\"/home/me/cl/systems/\"
- #p\"/usr/share/common-lisp/systems/\"))
-
-This is for backward compatibilily.
-Going forward, we recommend new users should be using the source-registry.
-")
-
-(defun* featurep (x &optional (features *features*))
- (cond
- ((atom x)
- (and (member x features) t))
- ((eq :not (car x))
- (assert (null (cddr x)))
- (not (featurep (cadr x) features)))
- ((eq :or (car x))
- (some #'(lambda (x) (featurep x features)) (cdr x)))
- ((eq :and (car x))
- (every #'(lambda (x) (featurep x features)) (cdr x)))
- (t
- (error "Malformed feature specification ~S" x))))
-
-(defun* os-unix-p ()
- (featurep '(:or :unix :cygwin :darwin)))
-
-(defun* os-windows-p ()
- (and (not (os-unix-p)) (featurep '(:or :win32 :windows :mswindows :mingw32))))
-
-(defun* probe-asd (name defaults)
- (block nil
- (when (directory-pathname-p defaults)
- (let ((file (make-pathname
- :defaults defaults :name name
- :version :newest :case :local :type "asd")))
- (when (probe-file* file)
- (return file)))
- #-(or clisp genera) ; clisp doesn't need it, plain genera doesn't have read-sequence(!)
- (when (os-windows-p)
- (let ((shortcut
- (make-pathname
- :defaults defaults :version :newest :case :local
- :name (strcat name ".asd")
- :type "lnk")))
- (when (probe-file* shortcut)
- (let ((target (parse-windows-shortcut shortcut)))
- (when target
- (return (pathname target))))))))))
-
-(defun* sysdef-central-registry-search (system)
- (let ((name (coerce-name system))
- (to-remove nil)
- (to-replace nil))
- (block nil
- (unwind-protect
- (dolist (dir *central-registry*)
- (let ((defaults (eval dir)))
- (when defaults
- (cond ((directory-pathname-p defaults)
- (let ((file (probe-asd name defaults)))
- (when file
- (return file))))
- (t
- (restart-case
- (let* ((*print-circle* nil)
- (message
- (format nil
- (compatfmt "~@<While searching for system ~S: ~3i~_~S evaluated to ~S which is not a directory.~@:>")
- system dir defaults)))
- (error message))
- (remove-entry-from-registry ()
- :report "Remove entry from *central-registry* and continue"
- (push dir to-remove))
- (coerce-entry-to-directory ()
- :report (lambda (s)
- (format s (compatfmt "~@<Coerce entry to ~a, replace ~a and continue.~@:>")
- (ensure-directory-pathname defaults) dir))
- (push (cons dir (ensure-directory-pathname defaults)) to-replace))))))))
- ;; cleanup
- (dolist (dir to-remove)
- (setf *central-registry* (remove dir *central-registry*)))
- (dolist (pair to-replace)
- (let* ((current (car pair))
- (new (cdr pair))
- (position (position current *central-registry*)))
- (setf *central-registry*
- (append (subseq *central-registry* 0 position)
- (list new)
- (subseq *central-registry* (1+ position))))))))))
-
-(defun* make-temporary-package ()
- (flet ((try (counter)
- (ignore-errors
- (make-package (format nil "~A~D" :asdf counter)
- :use '(:cl :asdf)))))
- (do* ((counter 0 (+ counter 1))
- (package (try counter) (try counter)))
- (package package))))
-
-(defun* safe-file-write-date (pathname)
- ;; If FILE-WRITE-DATE returns NIL, it's possible that
- ;; the user or some other agent has deleted an input file.
- ;; Also, generated files will not exist at the time planning is done
- ;; and calls operation-done-p which calls safe-file-write-date.
- ;; So it is very possible that we can't get a valid file-write-date,
- ;; and we can survive and we will continue the planning
- ;; as if the file were very old.
- ;; (or should we treat the case in a different, special way?)
- (or (and pathname (probe-file* pathname) (ignore-errors (file-write-date pathname)))
- (progn
- (when (and pathname *asdf-verbose*)
- (warn (compatfmt "~@<Missing FILE-WRITE-DATE for ~S, treating it as zero.~@:>")
- pathname))
- 0)))
-
-(defmethod find-system ((name null) &optional (error-p t))
- (declare (ignorable name))
- (when error-p
- (sysdef-error (compatfmt "~@<NIL is not a valid system name~@:>"))))
-
-(defmethod find-system (name &optional (error-p t))
- (find-system (coerce-name name) error-p))
-
-(defvar *systems-being-defined* nil
- "A hash-table of systems currently being defined keyed by name, or NIL")
-
-(defun* find-system-if-being-defined (name)
- (when *systems-being-defined*
- (gethash (coerce-name name) *systems-being-defined*)))
-
-(defun* call-with-system-definitions (thunk)
- (if *systems-being-defined*
- (funcall thunk)
- (let ((*systems-being-defined* (make-hash-table :test 'equal)))
- (funcall thunk))))
-
-(defmacro with-system-definitions ((&optional) &body body)
- `(call-with-system-definitions #'(lambda () ,@body)))
-
-(defun* load-sysdef (name pathname)
- ;; Tries to load system definition with canonical NAME from PATHNAME.
- (with-system-definitions ()
- (let ((package (make-temporary-package)))
- (unwind-protect
- (handler-bind
- ((error #'(lambda (condition)
- (error 'load-system-definition-error
- :name name :pathname pathname
- :condition condition))))
- (let ((*package* package)
- (*default-pathname-defaults*
- (pathname-directory-pathname pathname)))
- (asdf-message (compatfmt "~&~@<; ~@;Loading system definition from ~A into ~A~@:>~%")
- pathname package)
- (load pathname)))
- (delete-package package)))))
-
-(defun* locate-system (name)
- "Given a system NAME designator, try to locate where to load the system from.
-Returns four values: FOUND-SYSTEM PATHNAME PREVIOUS PREVIOUS-TIME
-FOUNDP is true when a new was found, either a new unregistered one or a previously registered one.
-FOUND-SYSTEM when not null is a SYSTEM object that may be REGISTER-SYSTEM'ed as is
-PATHNAME when not null is a path from where to load the system, associated with FOUND-SYSTEM, or with the PREVIOUS system.
-PREVIOUS when not null is a previously loaded SYSTEM object of same name.
-PREVIOUS-TIME when not null is the time at which the PREVIOUS system was loaded."
- (let* ((name (coerce-name name))
- (in-memory (system-registered-p name)) ; load from disk if absent or newer on disk
- (previous (cdr in-memory))
- (previous (and (typep previous 'system) previous))
- (previous-time (car in-memory))
- (found (search-for-system-definition name))
- (found-system (and (typep found 'system) found))
- (pathname (or (and (typep found '(or pathname string)) (pathname found))
- (and found-system (system-source-file found-system))
- (and previous (system-source-file previous))))
- (foundp (and (or found-system pathname previous) t)))
- (check-type found (or null pathname system))
- (when foundp
- (setf pathname (resolve-symlinks* pathname))
- (when (and pathname (not (absolute-pathname-p pathname)))
- (setf pathname (ensure-pathname-absolute pathname))
- (when found-system
- (%set-system-source-file pathname found-system)))
- (when (and previous (not (#-cormanlisp equal #+cormanlisp equalp
- (system-source-file previous) pathname)))
- (%set-system-source-file pathname previous)
- (setf previous-time nil))
- (values foundp found-system pathname previous previous-time))))
-
-(defmethod find-system ((name string) &optional (error-p t))
- (with-system-definitions ()
- (loop
- (restart-case
- (multiple-value-bind (foundp found-system pathname previous previous-time)
- (locate-system name)
- (declare (ignore foundp))
- (when (and found-system (not previous))
- (register-system found-system))
- (when (and pathname
- (or (not previous-time)
- ;; don't reload if it's already been loaded,
- ;; or its filestamp is in the future which means some clock is skewed
- ;; and trying to load might cause an infinite loop.
- (< previous-time (safe-file-write-date pathname) (get-universal-time))))
- (load-sysdef name pathname))
- (let ((in-memory (system-registered-p name))) ; try again after loading from disk if needed
- (return
- (cond
- (in-memory
- (when pathname
- (setf (car in-memory) (safe-file-write-date pathname)))
- (cdr in-memory))
- (error-p
- (error 'missing-component :requires name))))))
- (reinitialize-source-registry-and-retry ()
- :report (lambda (s)
- (format s "~@<Retry finding system ~A after reinitializing the source-registry.~@:>" name))
- (initialize-source-registry))))))
-
-(defun* find-system-fallback (requested fallback &rest keys &key source-file &allow-other-keys)
- (setf fallback (coerce-name fallback)
- requested (coerce-name requested))
- (when (equal requested fallback)
- (let ((registered (cdr (gethash fallback *defined-systems*))))
- (or registered
- (apply 'make-instance 'system
- :name fallback :source-file source-file keys)))))
-
-(defun* sysdef-find-asdf (name)
- ;; Bug: :version *asdf-version* won't be updated when ASDF is updated.
- (find-system-fallback name "asdf" :version *asdf-version*))
-
-
-;;;; -------------------------------------------------------------------------
-;;;; Finding components
-
-(defmethod find-component ((base string) path)
- (let ((s (find-system base nil)))
- (and s (find-component s path))))
-
-(defmethod find-component ((base symbol) path)
- (cond
- (base (find-component (coerce-name base) path))
- (path (find-component path nil))
- (t nil)))
-
-(defmethod find-component ((base cons) path)
- (find-component (car base) (cons (cdr base) path)))
-
-(defmethod find-component ((module module) (name string))
- (unless (slot-boundp module 'components-by-name) ;; SBCL may miss the u-i-f-r-c method!!!
- (compute-module-components-by-name module))
- (values (gethash name (module-components-by-name module))))
-
-(defmethod find-component ((component component) (name symbol))
- (if name
- (find-component component (coerce-name name))
- component))
-
-(defmethod find-component ((module module) (name cons))
- (find-component (find-component module (car name)) (cdr name)))
-
-
-;;; component subclasses
-
-(defclass source-file (component)
- ((type :accessor source-file-explicit-type :initarg :type :initform nil)))
-
-(defclass cl-source-file (source-file)
- ((type :initform "lisp")))
-(defclass cl-source-file.cl (cl-source-file)
- ((type :initform "cl")))
-(defclass cl-source-file.lsp (cl-source-file)
- ((type :initform "lsp")))
-(defclass c-source-file (source-file)
- ((type :initform "c")))
-(defclass java-source-file (source-file)
- ((type :initform "java")))
-(defclass static-file (source-file) ())
-(defclass doc-file (static-file) ())
-(defclass html-file (doc-file)
- ((type :initform "html")))
-
-(defmethod source-file-type ((component module) (s module))
- (declare (ignorable component s))
- :directory)
-(defmethod source-file-type ((component source-file) (s module))
- (declare (ignorable s))
- (source-file-explicit-type component))
-
-(defun* coerce-pathname (name &key type defaults)
- "coerce NAME into a PATHNAME.
-When given a string, portably decompose it into a relative pathname:
-#\\/ separates subdirectories. The last #\\/-separated string is as follows:
-if TYPE is NIL, its last #\\. if any separates name and type from from type;
-if TYPE is a string, it is the type, and the whole string is the name;
-if TYPE is :DIRECTORY, the string is a directory component;
-if the string is empty, it's a directory.
-Any directory named .. is read as :BACK.
-Host, device and version components are taken from DEFAULTS."
- ;; The defaults are required notably because they provide the default host
- ;; to the below make-pathname, which may crucially matter to people using
- ;; merge-pathnames with non-default hosts, e.g. for logical-pathnames.
- ;; NOTE that the host and device slots will be taken from the defaults,
- ;; but that should only matter if you later merge relative pathnames with
- ;; CL:MERGE-PATHNAMES instead of ASDF:MERGE-PATHNAMES*
- (etypecase name
- ((or null pathname)
- name)
- (symbol
- (coerce-pathname (string-downcase name) :type type :defaults defaults))
- (string
- (multiple-value-bind (relative path filename)
- (component-name-to-pathname-components name :force-directory (eq type :directory)
- :force-relative t)
- (multiple-value-bind (name type)
- (cond
- ((or (eq type :directory) (null filename))
- (values nil nil))
- (type
- (values filename type))
- (t
- (split-name-type filename)))
- (apply 'make-pathname :directory (cons relative path) :name name :type type
- (when defaults `(:defaults ,defaults))))))))
-
-(defun* merge-component-name-type (name &key type defaults)
- ;; For backwards compatibility only, for people using internals.
- ;; Will be removed in a future release, e.g. 2.016.
- (warn "Please don't use ASDF::MERGE-COMPONENT-NAME-TYPE. Use ASDF:COERCE-PATHNAME.")
- (coerce-pathname name :type type :defaults defaults))
-
-(defmethod component-relative-pathname ((component component))
- (coerce-pathname
- (or (slot-value component 'relative-pathname)
- (component-name component))
- :type (source-file-type component (component-system component))
- :defaults (component-parent-pathname component)))
-
-(defun* subpathname (pathname subpath &key type)
- (and pathname (merge-pathnames* (coerce-pathname subpath :type type)
- (pathname-directory-pathname pathname))))
-
-(defun subpathname* (pathname subpath &key type)
- (and pathname
- (subpathname (ensure-directory-pathname pathname) subpath :type type)))
-
-;;;; -------------------------------------------------------------------------
-;;;; Operations
-
-;;; one of these is instantiated whenever #'operate is called
-
-(defclass operation ()
- (;; as of danb's 2003-03-16 commit e0d02781, :force can be:
- ;; T to force the inside of the specified system,
- ;; but not recurse to other systems we depend on.
- ;; :ALL (or any other atom) to force all systems
- ;; including other systems we depend on.
- ;; (SYSTEM1 SYSTEM2 ... SYSTEMN)
- ;; to force systems named in a given list
- ;; However, but this feature has only ever worked but starting with ASDF 2.014.5
- (forced :initform nil :initarg :force :accessor operation-forced)
- (original-initargs :initform nil :initarg :original-initargs
- :accessor operation-original-initargs)
- (visited-nodes :initform (make-hash-table :test 'equal) :accessor operation-visited-nodes)
- (visiting-nodes :initform (make-hash-table :test 'equal) :accessor operation-visiting-nodes)
- (parent :initform nil :initarg :parent :accessor operation-parent)))
-
-(defmethod print-object ((o operation) stream)
- (print-unreadable-object (o stream :type t :identity t)
- (ignore-errors
- (prin1 (operation-original-initargs o) stream))))
-
-(defmethod shared-initialize :after ((operation operation) slot-names
- &key force
- &allow-other-keys)
- (declare (ignorable operation slot-names force))
- ;; empty method to disable initarg validity checking
- (values))
-
-(defun* node-for (o c)
- (cons (class-name (class-of o)) c))
-
-(defmethod operation-ancestor ((operation operation))
- (aif (operation-parent operation)
- (operation-ancestor it)
- operation))
-
-
-(defun* make-sub-operation (c o dep-c dep-o)
- "C is a component, O is an operation, DEP-C is another
-component, and DEP-O, confusingly enough, is an operation
-class specifier, not an operation."
- (let* ((args (copy-list (operation-original-initargs o)))
- (force-p (getf args :force)))
- ;; note explicit comparison with T: any other non-NIL force value
- ;; (e.g. :recursive) will pass through
- (cond ((and (null (component-parent c))
- (null (component-parent dep-c))
- (not (eql c dep-c)))
- (when (eql force-p t)
- (setf (getf args :force) nil))
- (apply 'make-instance dep-o
- :parent o
- :original-initargs args args))
- ((subtypep (type-of o) dep-o)
- o)
- (t
- (apply 'make-instance dep-o
- :parent o :original-initargs args args)))))
-
-
-(defmethod visit-component ((o operation) (c component) data)
- (unless (component-visited-p o c)
- (setf (gethash (node-for o c)
- (operation-visited-nodes (operation-ancestor o)))
- (cons t data))))
-
-(defmethod component-visited-p ((o operation) (c component))
- (gethash (node-for o c)
- (operation-visited-nodes (operation-ancestor o))))
-
-(defmethod (setf visiting-component) (new-value operation component)
- ;; MCL complains about unused lexical variables
- (declare (ignorable operation component))
- new-value)
-
-(defmethod (setf visiting-component) (new-value (o operation) (c component))
- (let ((node (node-for o c))
- (a (operation-ancestor o)))
- (if new-value
- (setf (gethash node (operation-visiting-nodes a)) t)
- (remhash node (operation-visiting-nodes a)))
- new-value))
-
-(defmethod component-visiting-p ((o operation) (c component))
- (let ((node (node-for o c)))
- (gethash node (operation-visiting-nodes (operation-ancestor o)))))
-
-(defmethod component-depends-on ((op-spec symbol) (c component))
- ;; Note: we go from op-spec to operation via make-instance
- ;; to allow for specialization through defmethod's, even though
- ;; it's a detour in the default case below.
- (component-depends-on (make-instance op-spec) c))
-
-(defmethod component-depends-on ((o operation) (c component))
- (cdr (assoc (type-of o) (component-in-order-to c))))
-
-(defmethod component-self-dependencies ((o operation) (c component))
- (remove-if-not
- #'(lambda (x) (member (component-name c) (cdr x) :test #'string=))
- (component-depends-on o c)))
-
-(defmethod input-files ((operation operation) (c component))
- (let ((parent (component-parent c))
- (self-deps (component-self-dependencies operation c)))
- (if self-deps
- (mapcan #'(lambda (dep)
- (destructuring-bind (op name) dep
- (output-files (make-instance op)
- (find-component parent name))))
- self-deps)
- ;; no previous operations needed? I guess we work with the
- ;; original source file, then
- (list (component-pathname c)))))
-
-(defmethod input-files ((operation operation) (c module))
- (declare (ignorable operation c))
- nil)
-
-(defmethod component-operation-time (o c)
- (gethash (type-of o) (component-operation-times c)))
-
-(defmethod operation-done-p ((o operation) (c component))
- (let ((out-files (output-files o c))
- (in-files (input-files o c))
- (op-time (component-operation-time o c)))
- (flet ((earliest-out ()
- (reduce #'min (mapcar #'safe-file-write-date out-files)))
- (latest-in ()
- (reduce #'max (mapcar #'safe-file-write-date in-files))))
- (cond
- ((and (not in-files) (not out-files))
- ;; arbitrary decision: an operation that uses nothing to
- ;; produce nothing probably isn't doing much.
- ;; e.g. operations on systems, modules that have no immediate action,
- ;; but are only meaningful through traversed dependencies
- t)
- ((not out-files)
- ;; an operation without output-files is probably meant
- ;; for its side-effects in the current image,
- ;; assumed to be idem-potent,
- ;; e.g. LOAD-OP or LOAD-SOURCE-OP of some CL-SOURCE-FILE.
- (and op-time (>= op-time (latest-in))))
- ((not in-files)
- ;; an operation with output-files and no input-files
- ;; is probably meant for its side-effects on the file-system,
- ;; assumed to have to be done everytime.
- ;; (I don't think there is any such case in ASDF unless extended)
- nil)
- (t
- ;; an operation with both input and output files is assumed
- ;; as computing the latter from the former,
- ;; assumed to have been done if the latter are all older
- ;; than the former.
- ;; e.g. COMPILE-OP of some CL-SOURCE-FILE.
- ;; We use >= instead of > to play nice with generated files.
- ;; This opens a race condition if an input file is changed
- ;; after the output is created but within the same second
- ;; of filesystem time; but the same race condition exists
- ;; whenever the computation from input to output takes more
- ;; than one second of filesystem time (or just crosses the
- ;; second). So that's cool.
- (and
- (every #'probe-file* in-files)
- (every #'probe-file* out-files)
- (>= (earliest-out) (latest-in))))))))
-
-
-
-;;; For 1.700 I've done my best to refactor TRAVERSE
-;;; by splitting it up in a bunch of functions,
-;;; so as to improve the collection and use-detection algorithm. --fare
-;;; The protocol is as follows: we pass around operation, dependency,
-;;; bunch of other stuff, and a force argument. Return a force flag.
-;;; The returned flag is T if anything has changed that requires a rebuild.
-;;; The force argument is a list of components that will require a rebuild
-;;; if the flag is T, at which point whoever returns the flag has to
-;;; mark them all as forced, and whoever recurses again can use a NIL list
-;;; as a further argument.
-
-(defvar *forcing* nil
- "This dynamically-bound variable is used to force operations in
-recursive calls to traverse.")
-
-(defgeneric* do-traverse (operation component collect))
-
-(defun* resolve-dependency-name (component name &optional version)
- (loop
- (restart-case
- (return
- (let ((comp (find-component (component-parent component) name)))
- (unless comp
- (error 'missing-dependency
- :required-by component
- :requires name))
- (when version
- (unless (version-satisfies comp version)
- (error 'missing-dependency-of-version
- :required-by component
- :version version
- :requires name)))
- comp))
- (retry ()
- :report (lambda (s)
- (format s "~@<Retry loading ~3i~_~A.~@:>" name))
- :test
- (lambda (c)
- (or (null c)
- (and (typep c 'missing-dependency)
- (eq (missing-required-by c) component)
- (equal (missing-requires c) name))))))))
-
-(defun* resolve-dependency-spec (component dep-spec)
- (cond
- ((atom dep-spec)
- (resolve-dependency-name component dep-spec))
- ;; Structured dependencies --- this parses keywords.
- ;; The keywords could conceivably be broken out and cleanly (extensibly)
- ;; processed by EQL methods. But for now, here's what we've got.
- ((eq :version (first dep-spec))
- ;; https://bugs.launchpad.net/asdf/+bug/527788
- (resolve-dependency-name component (second dep-spec) (third dep-spec)))
- ((eq :feature (first dep-spec))
- ;; This particular subform is not documented and
- ;; has always been broken in the past.
- ;; Therefore no one uses it, and I'm cerroring it out,
- ;; after fixing it
- ;; See https://bugs.launchpad.net/asdf/+bug/518467
- (cerror "Continue nonetheless."
- "Congratulations, you're the first ever user of FEATURE dependencies! Please contact the asdf-devel mailing-list.")
- (when (find (second dep-spec) *features* :test 'string-equal)
- (resolve-dependency-name component (third dep-spec))))
- (t
- (error (compatfmt "~@<Bad dependency ~s. Dependencies must be (:version <name> <version>), (:feature <feature> <name>), or <name>.~@:>") dep-spec))))
-
-(defun* do-one-dep (op c collect dep-op dep-c)
- ;; Collects a partial plan for performing dep-op on dep-c
- ;; as dependencies of a larger plan involving op and c.
- ;; Returns t if this should force recompilation of those who depend on us.
- ;; dep-op is an operation class name (not an operation object),
- ;; whereas dep-c is a component object.n
- (do-traverse (make-sub-operation c op dep-c dep-op) dep-c collect))
-
-(defun* do-dep (op c collect dep-op-spec dep-c-specs)
- ;; Collects a partial plan for performing dep-op-spec on each of dep-c-specs
- ;; as dependencies of a larger plan involving op and c.
- ;; Returns t if this should force recompilation of those who depend on us.
- ;; dep-op-spec is either an operation class name (not an operation object),
- ;; or the magic symbol asdf:feature.
- ;; If dep-op-spec is asdf:feature, then the first dep-c-specs is a keyword,
- ;; and the plan will succeed if that keyword is present in *feature*,
- ;; or fail if it isn't
- ;; (at which point c's :if-component-dep-fails will kick in).
- ;; If dep-op-spec is an operation class name,
- ;; then dep-c-specs specifies a list of sibling component of c,
- ;; as per resolve-dependency-spec, such that operating op on c
- ;; depends on operating dep-op-spec on each of them.
- (cond ((eq dep-op-spec 'feature)
- (if (member (car dep-c-specs) *features*)
- nil
- (error 'missing-dependency
- :required-by c
- :requires (list :feature (car dep-c-specs)))))
- (t
- (let ((flag nil))
- (dolist (d dep-c-specs)
- (when (do-one-dep op c collect dep-op-spec
- (resolve-dependency-spec c d))
- (setf flag t)))
- flag))))
-
-(defvar *visit-count* 0) ; counter that allows to sort nodes from operation-visited-nodes
-
-(defun* do-collect (collect x)
- (funcall collect x))
-
-(defmethod do-traverse ((operation operation) (c component) collect)
- (let ((*forcing* *forcing*)
- (flag nil)) ;; return value: must we rebuild this and its dependencies?
- (labels
- ((update-flag (x)
- (orf flag x))
- (dep (op comp)
- (update-flag (do-dep operation c collect op comp))))
- ;; Have we been visited yet? If so, just process the result.
- (aif (component-visited-p operation c)
- (progn
- (update-flag (cdr it))
- (return-from do-traverse flag)))
- ;; dependencies
- (when (component-visiting-p operation c)
- (error 'circular-dependency :components (list c)))
- (setf (visiting-component operation c) t)
- (unwind-protect
- (progn
- (let ((f (operation-forced
- (operation-ancestor operation))))
- (when (and f (or (not (consp f)) ;; T or :ALL
- (and (typep c 'system) ;; list of names of systems to force
- (member (component-name c) f
- :test #'string=))))
- (setf *forcing* t)))
- ;; first we check and do all the dependencies for the module.
- ;; Operations planned in this loop will show up
- ;; in the results, and are consumed below.
- (let ((*forcing* nil))
- ;; upstream dependencies are never forced to happen just because
- ;; the things that depend on them are....
- (loop
- :for (required-op . deps) :in (component-depends-on operation c)
- :do (dep required-op deps)))
- ;; constituent bits
- (let ((module-ops
- (when (typep c 'module)
- (let ((at-least-one nil)
- ;; This is set based on the results of the
- ;; dependencies and whether we are in the
- ;; context of a *forcing* call...
- ;; inter-system dependencies do NOT trigger
- ;; building components
- (*forcing*
- (or *forcing*
- (and flag (not (typep c 'system)))))
- (error nil))
- (while-collecting (internal-collect)
- (dolist (kid (module-components c))
- (handler-case
- (update-flag
- (do-traverse operation kid #'internal-collect))
- #-genera
- (missing-dependency (condition)
- (when (eq (module-if-component-dep-fails c)
- :fail)
- (error condition))
- (setf error condition))
- (:no-error (c)
- (declare (ignore c))
- (setf at-least-one t))))
- (when (and (eq (module-if-component-dep-fails c)
- :try-next)
- (not at-least-one))
- (error error)))))))
- (update-flag (or *forcing* (not (operation-done-p operation c))))
- ;; For sub-operations, check whether
- ;; the original ancestor operation was forced,
- ;; or names us amongst an explicit list of things to force...
- ;; except that this check doesn't distinguish
- ;; between all the things with a given name. Sigh.
- ;; BROKEN!
- (when flag
- (let ((do-first (cdr (assoc (class-name (class-of operation))
- (component-do-first c)))))
- (loop :for (required-op . deps) :in do-first
- :do (do-dep operation c collect required-op deps)))
- (do-collect collect (vector module-ops))
- (do-collect collect (cons operation c)))))
- (setf (visiting-component operation c) nil)))
- (visit-component operation c (when flag (incf *visit-count*)))
- flag))
-
-(defun* flatten-tree (l)
- ;; You collected things into a list.
- ;; Most elements are just things to collect again.
- ;; A (simple-vector 1) indicate that you should recurse into its contents.
- ;; This way, in two passes (rather than N being the depth of the tree),
- ;; you can collect things with marginally constant-time append,
- ;; achieving linear time collection instead of quadratic time.
- (while-collecting (c)
- (labels ((r (x)
- (if (typep x '(simple-vector 1))
- (r* (svref x 0))
- (c x)))
- (r* (l)
- (dolist (x l) (r x))))
- (r* l))))
-
-(defmethod traverse ((operation operation) (c component))
- (when (consp (operation-forced operation))
- (setf (operation-forced operation)
- (mapcar #'coerce-name (operation-forced operation))))
- (flatten-tree
- (while-collecting (collect)
- (let ((*visit-count* 0))
- (do-traverse operation c #'collect)))))
-
-(defmethod perform ((operation operation) (c source-file))
- (sysdef-error
- (compatfmt "~@<Required method PERFORM not implemented for operation ~A, component ~A~@:>")
- (class-of operation) (class-of c)))
-
-(defmethod perform ((operation operation) (c module))
- (declare (ignorable operation c))
- nil)
-
-(defmethod mark-operation-done ((operation operation) (c component))
- (setf (gethash (type-of operation) (component-operation-times c))
- (reduce #'max
- (cons (get-universal-time)
- (mapcar #'safe-file-write-date (input-files operation c))))))
-
-(defmethod perform-with-restarts (operation component)
- ;; TOO verbose, especially as the default. Add your own :before method
- ;; to perform-with-restart or perform if you want that:
- #|(when *asdf-verbose* (explain operation component))|#
- (perform operation component))
-
-(defmethod perform-with-restarts :around (operation component)
- (loop
- (restart-case
- (return (call-next-method))
- (retry ()
- :report
- (lambda (s)
- (format s (compatfmt "~@<Retry ~A.~@:>")
- (operation-description operation component))))
- (accept ()
- :report
- (lambda (s)
- (format s (compatfmt "~@<Continue, treating ~A as having been successful.~@:>")
- (operation-description operation component)))
- (mark-operation-done operation component)
- (return)))))
-
-(defmethod explain ((operation operation) (component component))
- (asdf-message (compatfmt "~&~@<; ~@;~A~:>~%")
- (operation-description operation component)))
-
-(defmethod operation-description (operation component)
- (format nil (compatfmt "~@<~A on ~A~@:>")
- (class-of operation) component))
-
-;;;; -------------------------------------------------------------------------
-;;;; compile-op
-
-(defclass compile-op (operation)
- ((proclamations :initarg :proclamations :accessor compile-op-proclamations :initform nil)
- (on-warnings :initarg :on-warnings :accessor operation-on-warnings
- :initform *compile-file-warnings-behaviour*)
- (on-failure :initarg :on-failure :accessor operation-on-failure
- :initform *compile-file-failure-behaviour*)
- (flags :initarg :flags :accessor compile-op-flags
- :initform nil)))
-
-(defun* output-file (operation component)
- "The unique output file of performing OPERATION on COMPONENT"
- (let ((files (output-files operation component)))
- (assert (length=n-p files 1))
- (first files)))
-
-(defun* ensure-all-directories-exist (pathnames)
- (loop :for pn :in pathnames
- :for pathname = (if (typep pn 'logical-pathname)
- (translate-logical-pathname pn)
- pn)
- :do (ensure-directories-exist pathname)))
-
-(defmethod perform :before ((operation compile-op) (c source-file))
- (ensure-all-directories-exist (asdf:output-files operation c)))
-
-(defmethod perform :after ((operation operation) (c component))
- (mark-operation-done operation c))
-
-(defgeneric* around-compile-hook (component))
-(defgeneric* call-with-around-compile-hook (component thunk))
-
-(defmethod around-compile-hook ((c component))
- (cond
- ((slot-boundp c 'around-compile)
- (slot-value c 'around-compile))
- ((component-parent c)
- (around-compile-hook (component-parent c)))))
-
-(defun ensure-function (fun &key (package :asdf))
- (etypecase fun
- ((or symbol function) fun)
- (cons (eval `(function ,fun)))
- (string (eval `(function ,(with-standard-io-syntax
- (let ((*package* (find-package package)))
- (read-from-string fun))))))))
-
-(defmethod call-with-around-compile-hook ((c component) thunk)
- (let ((hook (around-compile-hook c)))
- (if hook
- (funcall (ensure-function hook) thunk)
- (funcall thunk))))
-
-(defvar *compile-op-compile-file-function* 'compile-file*
- "Function used to compile lisp files.")
-
-;;; perform is required to check output-files to find out where to put
-;;; its answers, in case it has been overridden for site policy
-(defmethod perform ((operation compile-op) (c cl-source-file))
- #-:broken-fasl-loader
- (let ((source-file (component-pathname c))
- ;; on some implementations, there are more than one output-file,
- ;; but the first one should always be the primary fasl that gets loaded.
- (output-file (first (output-files operation c)))
- (*compile-file-warnings-behaviour* (operation-on-warnings operation))
- (*compile-file-failure-behaviour* (operation-on-failure operation)))
- (multiple-value-bind (output warnings-p failure-p)
- (call-with-around-compile-hook
- c #'(lambda ()
- (apply *compile-op-compile-file-function* source-file
- :output-file output-file (compile-op-flags operation))))
- (unless output
- (error 'compile-error :component c :operation operation))
- (when failure-p
- (case (operation-on-failure operation)
- (:warn (warn
- (compatfmt "~@<COMPILE-FILE failed while performing ~A on ~A.~@:>")
- operation c))
- (:error (error 'compile-failed :component c :operation operation))
- (:ignore nil)))
- (when warnings-p
- (case (operation-on-warnings operation)
- (:warn (warn
- (compatfmt "~@<COMPILE-FILE warned while performing ~A on ~A.~@:>")
- operation c))
- (:error (error 'compile-warned :component c :operation operation))
- (:ignore nil))))))
-
-(defmethod output-files ((operation compile-op) (c cl-source-file))
- (declare (ignorable operation))
- (let ((p (lispize-pathname (component-pathname c))))
- #-broken-fasl-loader (list (compile-file-pathname p))
- #+broken-fasl-loader (list p)))
-
-(defmethod perform ((operation compile-op) (c static-file))
- (declare (ignorable operation c))
- nil)
-
-(defmethod output-files ((operation compile-op) (c static-file))
- (declare (ignorable operation c))
- nil)
-
-(defmethod input-files ((operation compile-op) (c static-file))
- (declare (ignorable operation c))
- nil)
-
-(defmethod operation-description ((operation compile-op) component)
- (declare (ignorable operation))
- (format nil (compatfmt "~@<compiling ~3i~_~A~@:>") component))
-
-(defmethod operation-description ((operation compile-op) (component module))
- (declare (ignorable operation))
- (format nil (compatfmt "~@<compiled ~3i~_~A~@:>") component))
-
-
-;;;; -------------------------------------------------------------------------
-;;;; load-op
-
-(defclass basic-load-op (operation) ())
-
-(defclass load-op (basic-load-op) ())
-
-(defmethod perform-with-restarts ((o load-op) (c cl-source-file))
- (loop
- (restart-case
- (return (call-next-method))
- (try-recompiling ()
- :report (lambda (s)
- (format s "Recompile ~a and try loading it again"
- (component-name c)))
- (perform (make-sub-operation c o c 'compile-op) c)))))
-
-(defmethod perform ((o load-op) (c cl-source-file))
- (map () #'load (input-files o c)))
-
-(defmethod perform ((operation load-op) (c static-file))
- (declare (ignorable operation c))
- nil)
-
-(defmethod operation-done-p ((operation load-op) (c static-file))
- (declare (ignorable operation c))
- t)
-
-(defmethod output-files ((operation operation) (c component))
- (declare (ignorable operation c))
- nil)
-
-(defmethod component-depends-on ((operation load-op) (c component))
- (declare (ignorable operation))
- (cons (list 'compile-op (component-name c))
- (call-next-method)))
-
-(defmethod operation-description ((operation load-op) component)
- (declare (ignorable operation))
- (format nil (compatfmt "~@<loading ~3i~_~A~@:>")
- component))
-
-(defmethod operation-description ((operation load-op) (component cl-source-file))
- (declare (ignorable operation))
- (format nil (compatfmt "~@<loading FASL for ~3i~_~A~@:>")
- component))
-
-(defmethod operation-description ((operation load-op) (component module))
- (declare (ignorable operation))
- (format nil (compatfmt "~@<loaded ~3i~_~A~@:>")
- component))
-
-;;;; -------------------------------------------------------------------------
-;;;; load-source-op
-
-(defclass load-source-op (basic-load-op) ())
-
-(defmethod perform ((o load-source-op) (c cl-source-file))
- (declare (ignorable o))
- (let ((source (component-pathname c)))
- (setf (component-property c 'last-loaded-as-source)
- (and (call-with-around-compile-hook c #'(lambda () (load source)))
- (get-universal-time)))))
-
-(defmethod perform ((operation load-source-op) (c static-file))
- (declare (ignorable operation c))
- nil)
-
-(defmethod output-files ((operation load-source-op) (c component))
- (declare (ignorable operation c))
- nil)
-
-;;; FIXME: We simply copy load-op's dependencies. This is Just Not Right.
-(defmethod component-depends-on ((o load-source-op) (c component))
- (declare (ignorable o))
- (loop :with what-would-load-op-do = (component-depends-on 'load-op c)
- :for (op . co) :in what-would-load-op-do
- :when (eq op 'load-op) :collect (cons 'load-source-op co)))
-
-(defmethod operation-done-p ((o load-source-op) (c source-file))
- (declare (ignorable o))
- (if (or (not (component-property c 'last-loaded-as-source))
- (> (safe-file-write-date (component-pathname c))
- (component-property c 'last-loaded-as-source)))
- nil t))
-
-(defmethod operation-description ((operation load-source-op) component)
- (declare (ignorable operation))
- (format nil (compatfmt "~@<Loading source of ~3i~_~A~@:>")
- component))
-
-(defmethod operation-description ((operation load-source-op) (component module))
- (declare (ignorable operation))
- (format nil (compatfmt "~@<Loaded source of ~3i~_~A~@:>") component))
-
-
-;;;; -------------------------------------------------------------------------
-;;;; test-op
-
-(defclass test-op (operation) ())
-
-(defmethod perform ((operation test-op) (c component))
- (declare (ignorable operation c))
- nil)
-
-(defmethod operation-done-p ((operation test-op) (c system))
- "Testing a system is _never_ done."
- (declare (ignorable operation c))
- nil)
-
-(defmethod component-depends-on :around ((o test-op) (c system))
- (declare (ignorable o))
- (cons `(load-op ,(component-name c)) (call-next-method)))
-
-
-;;;; -------------------------------------------------------------------------
-;;;; Invoking Operations
-
-(defgeneric* operate (operation-class system &key &allow-other-keys))
-(defgeneric* perform-plan (plan &key))
-
-;;;; Separating this into a different function makes it more forward-compatible
-(defun* cleanup-upgraded-asdf (old-version)
- (let ((new-version (asdf:asdf-version)))
- (unless (equal old-version new-version)
- (cond
- ((version-satisfies new-version old-version)
- (asdf-message (compatfmt "~&~@<; ~@;Upgraded ASDF from version ~A to version ~A~@:>~%")
- old-version new-version))
- ((version-satisfies old-version new-version)
- (warn (compatfmt "~&~@<; ~@;Downgraded ASDF from version ~A to version ~A~@:>~%")
- old-version new-version))
- (t
- (asdf-message (compatfmt "~&~@<; ~@;Changed ASDF from version ~A to incompatible version ~A~@:>~%")
- old-version new-version)))
- (let ((asdf (funcall (find-symbol* 'find-system :asdf) :asdf)))
- ;; Invalidate all systems but ASDF itself.
- (setf *defined-systems* (make-defined-systems-table))
- (register-system asdf)
- ;; If we're in the middle of something, restart it.
- (when *systems-being-defined*
- (let ((l (loop :for name :being :the :hash-keys :of *systems-being-defined* :collect name)))
- (clrhash *systems-being-defined*)
- (dolist (s l) (find-system s nil))))
- t))))
-
-;;;; Try to upgrade of ASDF. If a different version was used, return T.
-;;;; We need do that before we operate on anything that depends on ASDF.
-(defun* upgrade-asdf ()
- (let ((version (asdf:asdf-version)))
- (handler-bind (((or style-warning warning) #'muffle-warning))
- (operate 'load-op :asdf :verbose nil))
- (cleanup-upgraded-asdf version)))
-
-(defmethod perform-plan ((steps list) &key)
- (let ((*package* *package*)
- (*readtable* *readtable*))
- (with-compilation-unit ()
- (loop :for (op . component) :in steps :do
- (perform-with-restarts op component)))))
-
-(defmethod operate (operation-class system &rest args
- &key ((:verbose *asdf-verbose*) *asdf-verbose*) version force
- &allow-other-keys)
- (declare (ignore force))
- (with-system-definitions ()
- (let* ((op (apply 'make-instance operation-class
- :original-initargs args
- args))
- (*verbose-out* (if *asdf-verbose* *standard-output* (make-broadcast-stream)))
- (system (etypecase system
- (system system)
- ((or string symbol) (find-system system)))))
- (unless (version-satisfies system version)
- (error 'missing-component-of-version :requires system :version version))
- (let ((steps (traverse op system)))
- (when (and (not (equal '("asdf") (component-find-path system)))
- (find '("asdf") (mapcar 'cdr steps)
- :test 'equal :key 'component-find-path)
- (upgrade-asdf))
- ;; If we needed to upgrade ASDF to achieve our goal,
- ;; then do it specially as the first thing, then
- ;; invalidate all existing system
- ;; retry the whole thing with the new OPERATE function,
- ;; which on some implementations
- ;; has a new symbol shadowing the current one.
- (return-from operate
- (apply (find-symbol* 'operate :asdf) operation-class system args)))
- (perform-plan steps)
- (values op steps)))))
-
-(defun* oos (operation-class system &rest args &key force verbose version
- &allow-other-keys)
- (declare (ignore force verbose version))
- (apply 'operate operation-class system args))
-
-(let ((operate-docstring
- "Operate does three things:
-
-1. It creates an instance of OPERATION-CLASS using any keyword parameters
-as initargs.
-2. It finds the asdf-system specified by SYSTEM (possibly loading
-it from disk).
-3. It then calls TRAVERSE with the operation and system as arguments
-
-The traverse operation is wrapped in WITH-COMPILATION-UNIT and error
-handling code. If a VERSION argument is supplied, then operate also
-ensures that the system found satisfies it using the VERSION-SATISFIES
-method.
-
-Note that dependencies may cause the operation to invoke other
-operations on the system or its components: the new operations will be
-created with the same initargs as the original one.
-"))
- (setf (documentation 'oos 'function)
- (format nil
- "Short for _operate on system_ and an alias for the OPERATE function.~%~%~a"
- operate-docstring))
- (setf (documentation 'operate 'function)
- operate-docstring))
-
-(defun* load-system (system &rest args &key force verbose version &allow-other-keys)
- "Shorthand for `(operate 'asdf:load-op system)`.
-See OPERATE for details."
- (declare (ignore force verbose version))
- (apply 'operate 'load-op system args)
- t)
-
-(defun* load-systems (&rest systems)
- (map () 'load-system systems))
-
-(defun* compile-system (system &rest args &key force verbose version
- &allow-other-keys)
- "Shorthand for `(operate 'asdf:compile-op system)`. See OPERATE
-for details."
- (declare (ignore force verbose version))
- (apply 'operate 'compile-op system args)
- t)
-
-(defun* test-system (system &rest args &key force verbose version
- &allow-other-keys)
- "Shorthand for `(operate 'asdf:test-op system)`. See OPERATE for
-details."
- (declare (ignore force verbose version))
- (apply 'operate 'test-op system args)
- t)
-
-;;;; -------------------------------------------------------------------------
-;;;; Defsystem
-
-(defun* load-pathname ()
- (resolve-symlinks* (or *load-pathname* *compile-file-pathname*)))
-
-(defun* determine-system-pathname (pathname)
- ;; The defsystem macro calls us to determine
- ;; the pathname of a system as follows:
- ;; 1. the one supplied,
- ;; 2. derived from *load-pathname* via load-pathname
- ;; 3. taken from the *default-pathname-defaults* via default-directory
- (let* ((file-pathname (load-pathname))
- (directory-pathname (and file-pathname (pathname-directory-pathname file-pathname))))
- (or (and pathname (subpathname directory-pathname pathname :type :directory))
- directory-pathname
- (default-directory))))
-
-(defun* class-for-type (parent type)
- (or (loop :for symbol :in (list
- type
- (find-symbol* type *package*)
- (find-symbol* type :asdf))
- :for class = (and symbol (find-class symbol nil))
- :when (and class
- (#-cormanlisp subtypep #+cormanlisp cl::subclassp
- class (find-class 'component)))
- :return class)
- (and (eq type :file)
- (or (and parent (module-default-component-class parent))
- (find-class *default-component-class*)))
- (sysdef-error "don't recognize component type ~A" type)))
-
-(defun* maybe-add-tree (tree op1 op2 c)
- "Add the node C at /OP1/OP2 in TREE, unless it's there already.
-Returns the new tree (which probably shares structure with the old one)"
- (let ((first-op-tree (assoc op1 tree)))
- (if first-op-tree
- (progn
- (aif (assoc op2 (cdr first-op-tree))
- (if (find c (cdr it) :test #'equal)
- nil
- (setf (cdr it) (cons c (cdr it))))
- (setf (cdr first-op-tree)
- (acons op2 (list c) (cdr first-op-tree))))
- tree)
- (acons op1 (list (list op2 c)) tree))))
-
-(defun* union-of-dependencies (&rest deps)
- (let ((new-tree nil))
- (dolist (dep deps)
- (dolist (op-tree dep)
- (dolist (op (cdr op-tree))
- (dolist (c (cdr op))
- (setf new-tree
- (maybe-add-tree new-tree (car op-tree) (car op) c))))))
- new-tree))
-
-
-(defvar *serial-depends-on* nil)
-
-(defun* sysdef-error-component (msg type name value)
- (sysdef-error (strcat msg (compatfmt "~&~@<The value specified for ~(~A~) ~A is ~S~@:>"))
- type name value))
-
-(defun* check-component-input (type name weakly-depends-on
- depends-on components in-order-to)
- "A partial test of the values of a component."
- (unless (listp depends-on)
- (sysdef-error-component ":depends-on must be a list."
- type name depends-on))
- (unless (listp weakly-depends-on)
- (sysdef-error-component ":weakly-depends-on must be a list."
- type name weakly-depends-on))
- (unless (listp components)
- (sysdef-error-component ":components must be NIL or a list of components."
- type name components))
- (unless (and (listp in-order-to) (listp (car in-order-to)))
- (sysdef-error-component ":in-order-to must be NIL or a list of components."
- type name in-order-to)))
-
-(defun* %remove-component-inline-methods (component)
- (dolist (name +asdf-methods+)
- (map ()
- ;; this is inefficient as most of the stored
- ;; methods will not be for this particular gf
- ;; But this is hardly performance-critical
- #'(lambda (m)
- (remove-method (symbol-function name) m))
- (component-inline-methods component)))
- ;; clear methods, then add the new ones
- (setf (component-inline-methods component) nil))
-
-(defun* %define-component-inline-methods (ret rest)
- (dolist (name +asdf-methods+)
- (let ((keyword (intern (symbol-name name) :keyword)))
- (loop :for data = rest :then (cddr data)
- :for key = (first data)
- :for value = (second data)
- :while data
- :when (eq key keyword) :do
- (destructuring-bind (op qual (o c) &body body) value
- (pushnew
- (eval `(defmethod ,name ,qual ((,o ,op) (,c (eql ,ret)))
- ,@body))
- (component-inline-methods ret)))))))
-
-(defun* %refresh-component-inline-methods (component rest)
- (%remove-component-inline-methods component)
- (%define-component-inline-methods component rest))
-
-(defun* parse-component-form (parent options)
- (destructuring-bind
- (type name &rest rest &key
- ;; the following list of keywords is reproduced below in the
- ;; remove-keys form. important to keep them in sync
- components pathname default-component-class
- perform explain output-files operation-done-p
- weakly-depends-on
- depends-on serial in-order-to do-first
- (version nil versionp)
- ;; list ends
- &allow-other-keys) options
- (declare (ignorable perform explain output-files operation-done-p))
- (check-component-input type name weakly-depends-on depends-on components in-order-to)
-
- (when (and parent
- (find-component parent name)
- ;; ignore the same object when rereading the defsystem
- (not
- (typep (find-component parent name)
- (class-for-type parent type))))
- (error 'duplicate-names :name name))
-
- (when versionp
- (unless (parse-version version nil)
- (warn (compatfmt "~@<Invalid version ~S for component ~S~@[ of ~S~]~@:>")
- version name parent)))
-
- (let* ((args (list* :name (coerce-name name)
- :pathname pathname
- :parent parent
- (remove-keys
- '(components pathname default-component-class
- perform explain output-files operation-done-p
- weakly-depends-on depends-on serial in-order-to)
- rest)))
- (ret (find-component parent name)))
- (when weakly-depends-on
- (appendf depends-on (remove-if (complement #'(lambda (x) (find-system x nil))) weakly-depends-on)))
- (when *serial-depends-on*
- (push *serial-depends-on* depends-on))
- (if ret ; preserve identity
- (apply 'reinitialize-instance ret args)
- (setf ret (apply 'make-instance (class-for-type parent type) args)))
- (component-pathname ret) ; eagerly compute the absolute pathname
- (when (typep ret 'module)
- (setf (module-default-component-class ret)
- (or default-component-class
- (and (typep parent 'module)
- (module-default-component-class parent))))
- (let ((*serial-depends-on* nil))
- (setf (module-components ret)
- (loop
- :for c-form :in components
- :for c = (parse-component-form ret c-form)
- :for name = (component-name c)
- :collect c
- :when serial :do (setf *serial-depends-on* name))))
- (compute-module-components-by-name ret))
-
- (setf (component-load-dependencies ret) depends-on) ;; Used by POIU
-
- (setf (component-in-order-to ret)
- (union-of-dependencies
- in-order-to
- `((compile-op (compile-op ,@depends-on))
- (load-op (load-op ,@depends-on)))))
- (setf (component-do-first ret)
- (union-of-dependencies
- do-first
- `((compile-op (load-op ,@depends-on)))))
-
- (%refresh-component-inline-methods ret rest)
- ret)))
-
-(defun* reset-system (system &rest keys &key &allow-other-keys)
- (change-class (change-class system 'proto-system) 'system)
- (apply 'reinitialize-instance system keys))
-
-(defun* do-defsystem (name &rest options
- &key pathname (class 'system)
- defsystem-depends-on &allow-other-keys)
- ;; The system must be registered before we parse the body,
- ;; otherwise we recur when trying to find an existing system
- ;; of the same name to reuse options (e.g. pathname) from.
- ;; To avoid infinite recursion in cases where you defsystem a system
- ;; that is registered to a different location to find-system,
- ;; we also need to remember it in a special variable *systems-being-defined*.
- (with-system-definitions ()
- (let* ((name (coerce-name name))
- (registered (system-registered-p name))
- (registered! (if registered
- (rplaca registered (get-universal-time))
- (register-system (make-instance 'system :name name))))
- (system (reset-system (cdr registered!)
- :name name :source-file (load-pathname)))
- (component-options (remove-keys '(:class) options)))
- (setf (gethash name *systems-being-defined*) system)
- (apply 'load-systems defsystem-depends-on)
- ;; We change-class (when necessary) AFTER we load the defsystem-dep's
- ;; since the class might not be defined as part of those.
- (let ((class (class-for-type nil class)))
- (unless (eq (type-of system) class)
- (change-class system class)))
- (parse-component-form
- nil (list*
- :module name
- :pathname (determine-system-pathname pathname)
- component-options)))))
-
-(defmacro defsystem (name &body options)
- `(apply 'do-defsystem ',name ',options))
-
-;;;; ---------------------------------------------------------------------------
-;;;; run-shell-command
-;;;;
-;;;; run-shell-command functions for other lisp implementations will be
-;;;; gratefully accepted, if they do the same thing.
-;;;; If the docstring is ambiguous, send a bug report.
-;;;;
-;;;; WARNING! The function below is mostly dysfunctional.
-;;;; For instance, it will probably run fine on most implementations on Unix,
-;;;; which will hopefully use the shell /bin/sh (which we force in some cases)
-;;;; which is hopefully reasonably compatible with a POSIX *or* Bourne shell.
-;;;; But behavior on Windows may vary wildly between implementations,
-;;;; either relying on your having installed a POSIX sh, or going through
-;;;; the CMD.EXE interpreter, for a totally different meaning, depending on
-;;;; what is easily expressible in said implementation.
-;;;;
-;;;; We probably should move this functionality to its own system and deprecate
-;;;; use of it from the asdf package. However, this would break unspecified
-;;;; existing software, so until a clear alternative exists, we can't deprecate
-;;;; it, and even after it's been deprecated, we will support it for a few
-;;;; years so everyone has time to migrate away from it. -- fare 2009-12-01
-;;;;
-;;;; As a suggested replacement which is portable to all ASDF-supported
-;;;; implementations and operating systems except Genera, I recommend
-;;;; xcvb-driver's xcvb-driver:run-program/process-output-stream and its
-;;;; derivatives such as xcvb-driver:run-program/for-side-effects.
-
-(defun* run-shell-command (control-string &rest args)
- "Interpolate ARGS into CONTROL-STRING as if by FORMAT, and
-synchronously execute the result using a Bourne-compatible shell, with
-output to *VERBOSE-OUT*. Returns the shell's exit code."
- (let ((command (apply 'format nil control-string args)))
- (asdf-message "; $ ~A~%" command)
-
- #+abcl
- (ext:run-shell-command command :output *verbose-out*)
-
- #+allegro
- ;; will this fail if command has embedded quotes - it seems to work
- (multiple-value-bind (stdout stderr exit-code)
- (excl.osi:command-output
- #-mswindows (vector "/bin/sh" "/bin/sh" "-c" command)
- #+mswindows command ; BEWARE!
- :input nil :whole nil
- #+mswindows :show-window #+mswindows :hide)
- (asdf-message "~{~&~a~%~}~%" stderr)
- (asdf-message "~{~&~a~%~}~%" stdout)
- exit-code)
-
- #+clisp
- ;; CLISP returns NIL for exit status zero.
- (if *verbose-out*
- (let* ((new-command (format nil "( ~A ) ; r=$? ; echo ; echo ASDF-EXIT-STATUS $r"
- command))
- (outstream (ext:run-shell-command new-command :output :stream :wait t)))
- (multiple-value-bind (retval out-lines)
- (unwind-protect
- (parse-clisp-shell-output outstream)
- (ignore-errors (close outstream)))
- (asdf-message "~{~&~a~%~}~%" out-lines)
- retval))
- ;; there will be no output, just grab up the exit status
- (or (ext:run-shell-command command :output nil :wait t) 0))
-
- #+clozure
- (nth-value 1
- (ccl:external-process-status
- (ccl:run-program
- (cond
- ((os-unix-p) "/bin/sh")
- ((os-windows-p) (strcat "CMD /C " command)) ; BEWARE!
- (t (error "Unsupported OS")))
- (if (os-unix-p) (list "-c" command) '())
- :input nil :output *verbose-out* :wait t)))
-
- #+(or cmu scl)
- (ext:process-exit-code
- (ext:run-program
- "/bin/sh"
- (list "-c" command)
- :input nil :output *verbose-out*))
-
- #+cormanlisp
- (win32:system command)
-
- #+ecl ;; courtesy of Juan Jose Garcia Ripoll
- (ext:system command)
-
- #+gcl
- (lisp:system command)
-
- #+lispworks
- (apply 'system:call-system-showing-output command
- :show-cmd nil :prefix "" :output-stream *verbose-out*
- (when (os-unix-p) '(:shell-type "/bin/sh")))
-
- #+mcl
- (ccl::with-cstrs ((%command command)) (_system %command))
-
- #+sbcl
- (sb-ext:process-exit-code
- (apply 'sb-ext:run-program
- #+win32 "sh" #-win32 "/bin/sh"
- (list "-c" command)
- :input nil :output *verbose-out*
- #+win32 '(:search t) #-win32 nil))
-
- #+xcl
- (ext:run-shell-command command)
-
- #-(or abcl allegro clisp clozure cmu ecl gcl lispworks mcl sbcl scl xcl)
- (error "RUN-SHELL-COMMAND not implemented for this Lisp")))
-
-#+clisp
-(defun* parse-clisp-shell-output (stream)
- "Helper function for running shell commands under clisp. Parses a specially-
-crafted output string to recover the exit status of the shell command and a
-list of lines of output."
- (loop :with status-prefix = "ASDF-EXIT-STATUS "
- :with prefix-length = (length status-prefix)
- :with exit-status = -1 :with lines = ()
- :for line = (read-line stream nil nil)
- :while line :do (push line lines) :finally
- (let* ((last (car lines))
- (status (and last (>= (length last) prefix-length)
- (string-equal last status-prefix :end1 prefix-length)
- (parse-integer last :start prefix-length :junk-allowed t))))
- (when status
- (setf exit-status status)
- (pop lines) (when (equal "" (car lines)) (pop lines)))
- (return (values exit-status (reverse lines))))))
-
-;;;; ---------------------------------------------------------------------------
-;;;; system-relative-pathname
-
-(defun* system-definition-pathname (x)
- ;; As of 2.014.8, we mean to make this function obsolete,
- ;; but that won't happen until all clients have been updated.
- ;;(cerror "Use ASDF:SYSTEM-SOURCE-FILE instead"
- "Function ASDF:SYSTEM-DEFINITION-PATHNAME is obsolete.
-It used to expose ASDF internals with subtle differences with respect to
-user expectations, that have been refactored away since.
-We recommend you use ASDF:SYSTEM-SOURCE-FILE instead
-for a mostly compatible replacement that we're supporting,
-or even ASDF:SYSTEM-SOURCE-DIRECTORY or ASDF:SYSTEM-RELATIVE-PATHNAME
-if that's whay you mean." ;;)
- (system-source-file x))
-
-(defmethod system-source-file ((system system))
- (%system-source-file system))
-(defmethod system-source-file ((system-name string))
- (%system-source-file (find-system system-name)))
-(defmethod system-source-file ((system-name symbol))
- (%system-source-file (find-system system-name)))
-
-(defun* system-source-directory (system-designator)
- "Return a pathname object corresponding to the
-directory in which the system specification (.asd file) is
-located."
- (pathname-directory-pathname (system-source-file system-designator)))
-
-(defun* relativize-directory (directory)
- (cond
- ((stringp directory)
- (list :relative directory))
- ((eq (car directory) :absolute)
- (cons :relative (cdr directory)))
- (t
- directory)))
-
-(defun* relativize-pathname-directory (pathspec)
- (let ((p (pathname pathspec)))
- (make-pathname
- :directory (relativize-directory (pathname-directory p))
- :defaults p)))
-
-(defun* system-relative-pathname (system name &key type)
- (subpathname (system-source-directory system) name :type type))
-
-
-;;; ---------------------------------------------------------------------------
-;;; implementation-identifier
-;;;
-;;; produce a string to identify current implementation.
-;;; Initially stolen from SLIME's SWANK, rewritten since.
-;;; We're back to runtime checking, for the sake of e.g. ABCL.
-
-(defun* first-feature (features)
- (dolist (x features)
- (multiple-value-bind (val feature)
- (if (consp x) (values (first x) (cons :or (rest x))) (values x x))
- (when (featurep feature) (return val)))))
-
-(defun implementation-type ()
- (first-feature
- '(:abcl (:acl :allegro) (:ccl :clozure) :clisp (:corman :cormanlisp) :cmu
- :ecl :gcl (:lw :lispworks) :mcl :sbcl :scl :symbolics :xcl)))
-
-(defun operating-system ()
- (first-feature
- '(:cygwin (:win :windows :mswindows :win32 :mingw32) ;; try cygwin first!
- (:linux :linux :linux-target) ;; for GCL at least, must appear before :bsd
- (:macosx :macosx :darwin :darwin-target :apple) ; also before :bsd
- (:solaris :solaris :sunos) (:bsd :bsd :freebsd :netbsd :openbsd) :unix
- :genera)))
-
-(defun architecture ()
- (first-feature
- '((:x64 :amd64 :x86-64 :x86_64 :x8664-target (:and :word-size=64 :pc386))
- (:x86 :x86 :i386 :i486 :i586 :i686 :pentium3 :pentium4 :pc386 :iapx386 :x8632-target)
- (:ppc64 :ppc64 :ppc64-target) (:ppc32 :ppc32 :ppc32-target :ppc :powerpc)
- :hppa64 :hppa :sparc64 (:sparc32 :sparc32 :sparc)
- :mipsel :mipseb :mips :alpha (:arm :arm :arm-target) :imach
- ;; Java comes last: if someone uses C via CFFI or otherwise JNA or JNI,
- ;; we may have to segregate the code still by architecture.
- (:java :java :java-1.4 :java-1.5 :java-1.6 :java-1.7))))
-
-#+clozure
-(defun* ccl-fasl-version ()
- ;; the fasl version is target-dependent from CCL 1.8 on.
- (or (and (fboundp 'ccl::target-fasl-version)
- (funcall 'ccl::target-fasl-version))
- (and (boundp 'ccl::fasl-version)
- (symbol-value 'ccl::fasl-version))
- (error "Can't determine fasl version.")))
-
-(defun lisp-version-string ()
- (let ((s (lisp-implementation-version)))
- (car ; as opposed to OR, this idiom prevents some unreachable code warning
- (list
- #+allegro
- (format nil "~A~A~@[~A~]"
- excl::*common-lisp-version-number*
- ;; ANSI vs MoDeRn - thanks to Robert Goldman and Charley Cox
- (if (eq excl:*current-case-mode* :case-sensitive-lower) "M" "A")
- ;; Note if not using International ACL
- ;; see http://www.franz.com/support/documentation/8.1/doc/operators/excl/ics-target-case.htm
- (excl:ics-target-case (:-ics "8")))
- #+armedbear (format nil "~a-fasl~a" s system::*fasl-version*)
- #+clisp
- (subseq s 0 (position #\space s)) ; strip build information (date, etc.)
- #+clozure
- (format nil "~d.~d-f~d" ; shorten for windows
- ccl::*openmcl-major-version*
- ccl::*openmcl-minor-version*
- (logand (ccl-fasl-version) #xFF))
- #+cmu (substitute #\- #\/ s)
- #+scl (format nil "~A~A" s
- ;; ANSI upper case vs lower case.
- (ecase ext:*case-mode* (:upper "") (:lower "l")))
- #+ecl (format nil "~A~@[-~A~]" s
- (let ((vcs-id (ext:lisp-implementation-vcs-id)))
- (subseq vcs-id 0 (min (length vcs-id) 8))))
- #+gcl (subseq s (1+ (position #\space s)))
- #+genera
- (multiple-value-bind (major minor) (sct:get-system-version "System")
- (format nil "~D.~D" major minor))
- #+mcl (subseq s 8) ; strip the leading "Version "
- s))))
-
-(defun* implementation-identifier ()
- (substitute-if
- #\_ #'(lambda (x) (find x " /:;&^\\|?<>(){}[]$#`'\""))
- (format nil "~(~a~@{~@[-~a~]~}~)"
- (or (implementation-type) (lisp-implementation-type))
- (or (lisp-version-string) (lisp-implementation-version))
- (or (operating-system) (software-type))
- (or (architecture) (machine-type)))))
-
-
-;;; ---------------------------------------------------------------------------
-;;; Generic support for configuration files
-
-(defun inter-directory-separator ()
- (if (os-unix-p) #\: #\;))
-
-(defun* user-homedir ()
- (truenamize
- (pathname-directory-pathname
- #+mcl (current-user-homedir-pathname)
- #-mcl (user-homedir-pathname))))
-
-(defun* ensure-absolute-pathname* (x fmt &rest args)
- (and (plusp (length x))
- (or (absolute-pathname-p x)
- (cerror "ignore relative pathname"
- "Invalid relative pathname ~A~@[ ~?~]" x fmt args))
- x))
-(defun* split-absolute-pathnames (x fmt &rest args)
- (loop :for dir :in (split-string
- x :separator (string (inter-directory-separator)))
- :do (apply 'ensure-absolute-pathname* dir fmt args)
- :collect dir))
-(defun getenv-absolute-pathname (x &aux (s (getenv x)))
- (ensure-absolute-pathname* s "from (getenv ~S)" x))
-(defun getenv-absolute-pathnames (x &aux (s (getenv x)))
- (split-absolute-pathnames s "from (getenv ~S) = ~S" x s))
-
-(defun* user-configuration-directories ()
- (let ((dirs
- `(,@(when (os-unix-p)
- (cons
- (subpathname* (getenv-absolute-pathname "XDG_CONFIG_HOME") "common-lisp/")
- (loop :for dir :in (getenv-absolute-pathnames "XDG_CONFIG_DIRS")
- :collect (subpathname* dir "common-lisp/"))))
- ,@(when (os-windows-p)
- `(,(subpathname* (or #+lispworks (sys:get-folder-path :local-appdata)
- (getenv-absolute-pathname "LOCALAPPDATA"))
- "common-lisp/config/")
- ;; read-windows-registry HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\User Shell Folders\AppData
- ,(subpathname* (or #+lispworks (sys:get-folder-path :appdata)
- (getenv-absolute-pathname "APPDATA"))
- "common-lisp/config/")))
- ,(subpathname (user-homedir) ".config/common-lisp/"))))
- (remove-duplicates (remove-if-not #'absolute-pathname-p dirs)
- :from-end t :test 'equal)))
-
-(defun* system-configuration-directories ()
- (cond
- ((os-unix-p) '(#p"/etc/common-lisp/"))
- ((os-windows-p)
- (aif
- ;; read-windows-registry HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\User Shell Folders\Common AppData
- (subpathname* (or #+lispworks (sys:get-folder-path :common-appdata)
- (getenv-absolute-pathname "ALLUSERSAPPDATA")
- (subpathname* (getenv-absolute-pathname "ALLUSERSPROFILE") "Application Data/"))
- "common-lisp/config/")
- (list it)))))
-
-(defun* in-first-directory (dirs x &key (direction :input))
- (loop :with fun = (ecase direction
- ((nil :input :probe) 'probe-file*)
- ((:output :io) 'identity))
- :for dir :in dirs
- :thereis (and dir (funcall fun (merge-pathnames* x (ensure-directory-pathname dir))))))
-
-(defun* in-user-configuration-directory (x &key (direction :input))
- (in-first-directory (user-configuration-directories) x :direction direction))
-(defun* in-system-configuration-directory (x &key (direction :input))
- (in-first-directory (system-configuration-directories) x :direction direction))
-
-(defun* configuration-inheritance-directive-p (x)
- (let ((kw '(:inherit-configuration :ignore-inherited-configuration)))
- (or (member x kw)
- (and (length=n-p x 1) (member (car x) kw)))))
-
-(defun* report-invalid-form (reporter &rest args)
- (etypecase reporter
- (null
- (apply 'error 'invalid-configuration args))
- (function
- (apply reporter args))
- ((or symbol string)
- (apply 'error reporter args))
- (cons
- (apply 'apply (append reporter args)))))
-
-(defvar *ignored-configuration-form* nil)
-
-(defun* validate-configuration-form (form tag directive-validator
- &key location invalid-form-reporter)
- (unless (and (consp form) (eq (car form) tag))
- (setf *ignored-configuration-form* t)
- (report-invalid-form invalid-form-reporter :form form :location location)
- (return-from validate-configuration-form nil))
- (loop :with inherit = 0 :with ignore-invalid-p = nil :with x = (list tag)
- :for directive :in (cdr form)
- :when (cond
- ((configuration-inheritance-directive-p directive)
- (incf inherit) t)
- ((eq directive :ignore-invalid-entries)
- (setf ignore-invalid-p t) t)
- ((funcall directive-validator directive)
- t)
- (ignore-invalid-p
- nil)
- (t
- (setf *ignored-configuration-form* t)
- (report-invalid-form invalid-form-reporter :form directive :location location)
- nil))
- :do (push directive x)
- :finally
- (unless (= inherit 1)
- (report-invalid-form invalid-form-reporter
- :arguments (list (compatfmt "~@<One and only one of ~S or ~S is required.~@:>")
- :inherit-configuration :ignore-inherited-configuration)))
- (return (nreverse x))))
-
-(defun* validate-configuration-file (file validator &key description)
- (let ((forms (read-file-forms file)))
- (unless (length=n-p forms 1)
- (error (compatfmt "~@<One and only one form allowed for ~A. Got: ~3i~_~S~@:>~%")
- description forms))
- (funcall validator (car forms) :location file)))
-
-(defun* hidden-file-p (pathname)
- (equal (first-char (pathname-name pathname)) #\.))
-
-(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))))))
-
-(defun* validate-configuration-directory (directory tag validator &key invalid-form-reporter)
- "Map the VALIDATOR across the .conf files in DIRECTORY, the TAG will
-be applied to the results to yield a configuration form. Current
-values of TAG include :source-registry and :output-translations."
- (let ((files (sort (ignore-errors
- (remove-if
- 'hidden-file-p
- (directory* (make-pathname :name :wild :type "conf" :defaults directory))))
- #'string< :key #'namestring)))
- `(,tag
- ,@(loop :for file :in files :append
- (loop :with ignore-invalid-p = nil
- :for form :in (read-file-forms file)
- :when (eq form :ignore-invalid-entries)
- :do (setf ignore-invalid-p t)
- :else
- :when (funcall validator form)
- :collect form
- :else
- :when ignore-invalid-p
- :do (setf *ignored-configuration-form* t)
- :else
- :do (report-invalid-form invalid-form-reporter :form form :location file)))
- :inherit-configuration)))
-
-
-;;; ---------------------------------------------------------------------------
-;;; asdf-output-translations
-;;;
-;;; this code is heavily inspired from
-;;; asdf-binary-translations, common-lisp-controller and cl-launch.
-;;; ---------------------------------------------------------------------------
-
-(defvar *output-translations* ()
- "Either NIL (for uninitialized), or a list of one element,
-said element itself being a sorted list of mappings.
-Each mapping is a pair of a source pathname and destination pathname,
-and the order is by decreasing length of namestring of the source pathname.")
-
-(defvar *user-cache*
- (flet ((try (x &rest sub) (and x `(,x ,@sub))))
- (or
- (try (getenv-absolute-pathname "XDG_CACHE_HOME") "common-lisp" :implementation)
- (when (os-windows-p)
- (try (or #+lispworks (sys:get-folder-path :local-appdata)
- (getenv-absolute-pathname "LOCALAPPDATA")
- #+lispworks (sys:get-folder-path :appdata)
- (getenv-absolute-pathname "APPDATA"))
- "common-lisp" "cache" :implementation))
- '(:home ".cache" "common-lisp" :implementation))))
-
-(defun* output-translations ()
- (car *output-translations*))
-
-(defun* (setf output-translations) (new-value)
- (setf *output-translations*
- (list
- (stable-sort (copy-list new-value) #'>
- :key #'(lambda (x)
- (etypecase (car x)
- ((eql t) -1)
- (pathname
- (let ((directory (pathname-directory (car x))))
- (if (listp directory) (length directory) 0))))))))
- new-value)
-
-(defun* output-translations-initialized-p ()
- (and *output-translations* t))
-
-(defun* clear-output-translations ()
- "Undoes any initialization of the output translations.
-You might want to call that before you dump an image that would be resumed
-with a different configuration, so the configuration would be re-read then."
- (setf *output-translations* '())
- (values))
-
-(declaim (ftype (function (t &key (:directory boolean) (:wilden boolean))
- (values (or null pathname) &optional))
- resolve-location))
-
-(defun* resolve-relative-location-component (x &key directory wilden)
- (let ((r (etypecase x
- (pathname x)
- (string (coerce-pathname x :type (when directory :directory)))
- (cons
- (if (null (cdr x))
- (resolve-relative-location-component
- (car x) :directory directory :wilden wilden)
- (let* ((car (resolve-relative-location-component
- (car x) :directory t :wilden nil)))
- (merge-pathnames*
- (resolve-relative-location-component
- (cdr x) :directory directory :wilden wilden)
- car))))
- ((eql :default-directory)
- (relativize-pathname-directory (default-directory)))
- ((eql :*/) *wild-directory*)
- ((eql :**/) *wild-inferiors*)
- ((eql :*.*.*) *wild-file*)
- ((eql :implementation)
- (coerce-pathname (implementation-identifier) :type :directory))
- ((eql :implementation-type)
- (coerce-pathname (string-downcase (implementation-type)) :type :directory)))))
- (when (absolute-pathname-p r)
- (error (compatfmt "~@<pathname ~S is not relative~@:>") x))
- (if (or (pathnamep x) (not wilden)) r (wilden r))))
-
-(defvar *here-directory* nil
- "This special variable is bound to the currect directory during calls to
-PROCESS-SOURCE-REGISTRY in order that we be able to interpret the :here
-directive.")
-
-(defun* resolve-absolute-location-component (x &key directory wilden)
- (let* ((r
- (etypecase x
- (pathname x)
- (string (let ((p (#+mcl probe-posix #-mcl parse-namestring x)))
- #+mcl (unless p (error "POSIX pathname ~S does not exist" x))
- (if directory (ensure-directory-pathname p) p)))
- (cons
- (return-from resolve-absolute-location-component
- (if (null (cdr x))
- (resolve-absolute-location-component
- (car x) :directory directory :wilden wilden)
- (merge-pathnames*
- (resolve-relative-location-component
- (cdr x) :directory directory :wilden wilden)
- (resolve-absolute-location-component
- (car x) :directory t :wilden nil)))))
- ((eql :root)
- ;; special magic! we encode such paths as relative pathnames,
- ;; but it means "relative to the root of the source pathname's host and device".
- (return-from resolve-absolute-location-component
- (let ((p (make-pathname :directory '(:relative))))
- (if wilden (wilden p) p))))
- ((eql :home) (user-homedir))
- ((eql :here)
- (resolve-location (or *here-directory*
- ;; give semantics in the case of use interactively
- :default-directory)
- :directory t :wilden nil))
- ((eql :user-cache) (resolve-location *user-cache* :directory t :wilden nil))
- ((eql :system-cache)
- (error "Using the :system-cache is deprecated. ~%~
-Please remove it from your ASDF configuration"))
- ((eql :default-directory) (default-directory))))
- (s (if (and wilden (not (pathnamep x)))
- (wilden r)
- r)))
- (unless (absolute-pathname-p s)
- (error (compatfmt "~@<Invalid designator for an absolute pathname: ~3i~_~S~@:>") x))
- s))
-
-(defun* resolve-location (x &key directory wilden)
- (if (atom x)
- (resolve-absolute-location-component x :directory directory :wilden wilden)
- (loop :with path = (resolve-absolute-location-component
- (car x) :directory (and (or directory (cdr x)) t)
- :wilden (and wilden (null (cdr x))))
- :for (component . morep) :on (cdr x)
- :for dir = (and (or morep directory) t)
- :for wild = (and wilden (not morep))
- :do (setf path (merge-pathnames*
- (resolve-relative-location-component
- component :directory dir :wilden wild)
- path))
- :finally (return path))))
-
-(defun* location-designator-p (x)
- (flet ((absolute-component-p (c)
- (typep c '(or string pathname
- (member :root :home :here :user-cache :system-cache :default-directory))))
- (relative-component-p (c)
- (typep c '(or string pathname
- (member :default-directory :*/ :**/ :*.*.*
- :implementation :implementation-type)))))
- (or (typep x 'boolean)
- (absolute-component-p x)
- (and (consp x) (absolute-component-p (first x)) (every #'relative-component-p (rest x))))))
-
-(defun* location-function-p (x)
- (and
- (length=n-p x 2)
- (eq (car x) :function)
- (or (symbolp (cadr x))
- (and (consp (cadr x))
- (eq (caadr x) 'lambda)
- (length=n-p (cadadr x) 2)))))
-
-(defun* validate-output-translations-directive (directive)
- (or (member directive '(:enable-user-cache :disable-cache nil))
- (and (consp directive)
- (or (and (length=n-p directive 2)
- (or (and (eq (first directive) :include)
- (typep (second directive) '(or string pathname null)))
- (and (location-designator-p (first directive))
- (or (location-designator-p (second directive))
- (location-function-p (second directive))))))
- (and (length=n-p directive 1)
- (location-designator-p (first directive)))))))
-
-(defun* validate-output-translations-form (form &key location)
- (validate-configuration-form
- form
- :output-translations
- 'validate-output-translations-directive
- :location location :invalid-form-reporter 'invalid-output-translation))
-
-(defun* validate-output-translations-file (file)
- (validate-configuration-file
- file 'validate-output-translations-form :description "output translations"))
-
-(defun* validate-output-translations-directory (directory)
- (validate-configuration-directory
- directory :output-translations 'validate-output-translations-directive
- :invalid-form-reporter 'invalid-output-translation))
-
-(defun* parse-output-translations-string (string &key location)
- (cond
- ((or (null string) (equal string ""))
- '(:output-translations :inherit-configuration))
- ((not (stringp string))
- (error (compatfmt "~@<Environment string isn't: ~3i~_~S~@:>") string))
- ((eql (char string 0) #\")
- (parse-output-translations-string (read-from-string string) :location location))
- ((eql (char string 0) #\()
- (validate-output-translations-form (read-from-string string) :location location))
- (t
- (loop
- :with inherit = nil
- :with directives = ()
- :with start = 0
- :with end = (length string)
- :with source = nil
- :with separator = (inter-directory-separator)
- :for i = (or (position separator string :start start) end) :do
- (let ((s (subseq string start i)))
- (cond
- (source
- (push (list source (if (equal "" s) nil s)) directives)
- (setf source nil))
- ((equal "" s)
- (when inherit
- (error (compatfmt "~@<Only one inherited configuration allowed: ~3i~_~S~@:>")
- string))
- (setf inherit t)
- (push :inherit-configuration directives))
- (t
- (setf source s)))
- (setf start (1+ i))
- (when (> start end)
- (when source
- (error (compatfmt "~@<Uneven number of components in source to destination mapping: ~3i~_~S~@:>")
- string))
- (unless inherit
- (push :ignore-inherited-configuration directives))
- (return `(:output-translations ,@(nreverse directives)))))))))
-
-(defparameter *default-output-translations*
- '(environment-output-translations
- user-output-translations-pathname
- user-output-translations-directory-pathname
- system-output-translations-pathname
- system-output-translations-directory-pathname))
-
-(defun* wrapping-output-translations ()
- `(:output-translations
- ;; Some implementations have precompiled ASDF systems,
- ;; so we must disable translations for implementation paths.
- #+sbcl ,(let ((h (getenv "SBCL_HOME")))
- (when (plusp (length h)) `((,(truenamize h) ,*wild-inferiors*) ())))
- ;; The below two are not needed: no precompiled ASDF system there
- ;; #+ecl (,(translate-logical-pathname "SYS:**;*.*") ())
- ;; #+clozure ,(ignore-errors (list (wilden (let ((*default-pathname-defaults* #p"")) (truename #p"ccl:"))) ()))
- ;; All-import, here is where we want user stuff to be:
- :inherit-configuration
- ;; These are for convenience, and can be overridden by the user:
- #+abcl (#p"/___jar___file___root___/**/*.*" (:user-cache #p"**/*.*"))
- #+abcl (#p"jar:file:/**/*.jar!/**/*.*" (:function translate-jar-pathname))
- ;; We enable the user cache by default, and here is the place we do:
- :enable-user-cache))
-
-(defparameter *output-translations-file* (coerce-pathname "asdf-output-translations.conf"))
-(defparameter *output-translations-directory* (coerce-pathname "asdf-output-translations.conf.d/"))
-
-(defun* user-output-translations-pathname (&key (direction :input))
- (in-user-configuration-directory *output-translations-file* :direction direction))
-(defun* system-output-translations-pathname (&key (direction :input))
- (in-system-configuration-directory *output-translations-file* :direction direction))
-(defun* user-output-translations-directory-pathname (&key (direction :input))
- (in-user-configuration-directory *output-translations-directory* :direction direction))
-(defun* system-output-translations-directory-pathname (&key (direction :input))
- (in-system-configuration-directory *output-translations-directory* :direction direction))
-(defun* environment-output-translations ()
- (getenv "ASDF_OUTPUT_TRANSLATIONS"))
-
-(defgeneric* process-output-translations (spec &key inherit collect))
-(declaim (ftype (function (t &key (:collect (or symbol function))) t)
- inherit-output-translations))
-(declaim (ftype (function (t &key (:collect (or symbol function)) (:inherit list)) t)
- process-output-translations-directive))
-
-(defmethod process-output-translations ((x symbol) &key
- (inherit *default-output-translations*)
- collect)
- (process-output-translations (funcall x) :inherit inherit :collect collect))
-(defmethod process-output-translations ((pathname pathname) &key inherit collect)
- (cond
- ((directory-pathname-p pathname)
- (process-output-translations (validate-output-translations-directory pathname)
- :inherit inherit :collect collect))
- ((probe-file* pathname)
- (process-output-translations (validate-output-translations-file pathname)
- :inherit inherit :collect collect))
- (t
- (inherit-output-translations inherit :collect collect))))
-(defmethod process-output-translations ((string string) &key inherit collect)
- (process-output-translations (parse-output-translations-string string)
- :inherit inherit :collect collect))
-(defmethod process-output-translations ((x null) &key inherit collect)
- (declare (ignorable x))
- (inherit-output-translations inherit :collect collect))
-(defmethod process-output-translations ((form cons) &key inherit collect)
- (dolist (directive (cdr (validate-output-translations-form form)))
- (process-output-translations-directive directive :inherit inherit :collect collect)))
-
-(defun* inherit-output-translations (inherit &key collect)
- (when inherit
- (process-output-translations (first inherit) :collect collect :inherit (rest inherit))))
-
-(defun* process-output-translations-directive (directive &key inherit collect)
- (if (atom directive)
- (ecase directive
- ((:enable-user-cache)
- (process-output-translations-directive '(t :user-cache) :collect collect))
- ((:disable-cache)
- (process-output-translations-directive '(t t) :collect collect))
- ((:inherit-configuration)
- (inherit-output-translations inherit :collect collect))
- ((:ignore-inherited-configuration :ignore-invalid-entries nil)
- nil))
- (let ((src (first directive))
- (dst (second directive)))
- (if (eq src :include)
- (when dst
- (process-output-translations (pathname dst) :inherit nil :collect collect))
- (when src
- (let ((trusrc (or (eql src t)
- (let ((loc (resolve-location src :directory t :wilden t)))
- (if (absolute-pathname-p loc) (truenamize loc) loc)))))
- (cond
- ((location-function-p dst)
- (funcall collect
- (list trusrc
- (if (symbolp (second dst))
- (fdefinition (second dst))
- (eval (second dst))))))
- ((eq dst t)
- (funcall collect (list trusrc t)))
- (t
- (let* ((trudst (if dst
- (resolve-location dst :directory t :wilden t)
- trusrc))
- (wilddst (merge-pathnames* *wild-file* trudst)))
- (funcall collect (list wilddst t))
- (funcall collect (list trusrc trudst)))))))))))
-
-(defun* compute-output-translations (&optional parameter)
- "read the configuration, return it"
- (remove-duplicates
- (while-collecting (c)
- (inherit-output-translations
- `(wrapping-output-translations ,parameter ,@*default-output-translations*) :collect #'c))
- :test 'equal :from-end t))
-
-(defvar *output-translations-parameter* nil)
-
-(defun* initialize-output-translations (&optional (parameter *output-translations-parameter*))
- "read the configuration, initialize the internal configuration variable,
-return the configuration"
- (setf *output-translations-parameter* parameter
- (output-translations) (compute-output-translations parameter)))
-
-(defun* disable-output-translations ()
- "Initialize output translations in a way that maps every file to itself,
-effectively disabling the output translation facility."
- (initialize-output-translations
- '(:output-translations :disable-cache :ignore-inherited-configuration)))
-
-;; checks an initial variable to see whether the state is initialized
-;; or cleared. In the former case, return current configuration; in
-;; the latter, initialize. ASDF will call this function at the start
-;; of (asdf:find-system).
-(defun* ensure-output-translations ()
- (if (output-translations-initialized-p)
- (output-translations)
- (initialize-output-translations)))
-
-(defun* translate-pathname* (path absolute-source destination &optional root source)
- (declare (ignore source))
- (cond
- ((functionp destination)
- (funcall destination path absolute-source))
- ((eq destination t)
- path)
- ((not (pathnamep destination))
- (error "Invalid destination"))
- ((not (absolute-pathname-p destination))
- (translate-pathname path absolute-source (merge-pathnames* destination root)))
- (root
- (translate-pathname (directorize-pathname-host-device path) absolute-source destination))
- (t
- (translate-pathname path absolute-source destination))))
-
-(defun* apply-output-translations (path)
- #+cormanlisp (truenamize path) #-cormanlisp
- (etypecase path
- (logical-pathname
- path)
- ((or pathname string)
- (ensure-output-translations)
- (loop :with p = (truenamize path)
- :for (source destination) :in (car *output-translations*)
- :for root = (when (or (eq source t)
- (and (pathnamep source)
- (not (absolute-pathname-p source))))
- (pathname-root p))
- :for absolute-source = (cond
- ((eq source t) (wilden root))
- (root (merge-pathnames* source root))
- (t source))
- :when (or (eq source t) (pathname-match-p p absolute-source))
- :return (translate-pathname* p absolute-source destination root source)
- :finally (return p)))))
-
-(defmethod output-files :around (operation component)
- "Translate output files, unless asked not to"
- operation component ;; hush genera, not convinced by declare ignorable(!)
- (values
- (multiple-value-bind (files fixedp) (call-next-method)
- (if fixedp
- files
- (mapcar #'apply-output-translations files)))
- t))
-
-(defun* compile-file-pathname* (input-file &rest keys &key output-file &allow-other-keys)
- (if (absolute-pathname-p output-file)
- ;; what cfp should be doing, w/ mp* instead of mp
- (let* ((type (pathname-type (apply 'compile-file-pathname "x.lisp" keys)))
- (defaults (make-pathname
- :type type :defaults (merge-pathnames* input-file))))
- (merge-pathnames* output-file defaults))
- (apply-output-translations
- (apply 'compile-file-pathname input-file keys))))
-
-(defun* tmpize-pathname (x)
- (make-pathname
- :name (strcat "ASDF-TMP-" (pathname-name x))
- :defaults x))
-
-(defun* delete-file-if-exists (x)
- (when (and x (probe-file* x))
- (delete-file x)))
-
-(defun* compile-file* (input-file &rest keys &key output-file &allow-other-keys)
- (let* ((output-file (apply 'compile-file-pathname* input-file :output-file output-file keys))
- (tmp-file (tmpize-pathname output-file))
- (status :error))
- (multiple-value-bind (output-truename warnings-p failure-p)
- (apply 'compile-file input-file :output-file tmp-file keys)
- (cond
- (failure-p
- (setf status *compile-file-failure-behaviour*))
- (warnings-p
- (setf status *compile-file-warnings-behaviour*))
- (t
- (setf status :success)))
- (ecase status
- ((:success :warn :ignore)
- (delete-file-if-exists output-file)
- (when output-truename
- (rename-file output-truename output-file)
- (setf output-truename output-file)))
- (:error
- (delete-file-if-exists output-truename)
- (setf output-truename nil)))
- (values output-truename warnings-p failure-p))))
-
-#+abcl
-(defun* translate-jar-pathname (source wildcard)
- (declare (ignore wildcard))
- (let* ((p (pathname (first (pathname-device source))))
- (root (format nil "/___jar___file___root___/~@[~A/~]"
- (and (find :windows *features*)
- (pathname-device p)))))
- (apply-output-translations
- (merge-pathnames*
- (relativize-pathname-directory source)
- (merge-pathnames*
- (relativize-pathname-directory (ensure-directory-pathname p))
- root)))))
-
-;;;; -----------------------------------------------------------------
-;;;; Compatibility mode for ASDF-Binary-Locations
-
-(defmethod operate :before (operation-class system &rest args &key &allow-other-keys)
- (declare (ignorable operation-class system args))
- (when (find-symbol* '#:output-files-for-system-and-operation :asdf)
- (error "ASDF 2 is not compatible with ASDF-BINARY-LOCATIONS, which you are using.
-ASDF 2 now achieves the same purpose with its builtin ASDF-OUTPUT-TRANSLATIONS,
-which should be easier to configure. Please stop using ASDF-BINARY-LOCATIONS,
-and instead use ASDF-OUTPUT-TRANSLATIONS. See the ASDF manual for details.
-In case you insist on preserving your previous A-B-L configuration, but
-do not know how to achieve the same effect with A-O-T, you may use function
-ASDF:ENABLE-ASDF-BINARY-LOCATIONS-COMPATIBILITY as documented in the manual;
-call that function where you would otherwise have loaded and configured A-B-L.")))
-
-(defun* enable-asdf-binary-locations-compatibility
- (&key
- (centralize-lisp-binaries nil)
- (default-toplevel-directory
- (subpathname (user-homedir) ".fasls/")) ;; Use ".cache/common-lisp/" instead ???
- (include-per-user-information nil)
- (map-all-source-files (or #+(or ecl clisp) t nil))
- (source-to-target-mappings nil))
- #+(or ecl clisp)
- (when (null map-all-source-files)
- (error "asdf:enable-asdf-binary-locations-compatibility doesn't support :map-all-source-files nil on ECL and CLISP"))
- (let* ((fasl-type (pathname-type (compile-file-pathname "foo.lisp")))
- (mapped-files (if map-all-source-files *wild-file*
- (make-pathname :type fasl-type :defaults *wild-file*)))
- (destination-directory
- (if centralize-lisp-binaries
- `(,default-toplevel-directory
- ,@(when include-per-user-information
- (cdr (pathname-directory (user-homedir))))
- :implementation ,*wild-inferiors*)
- `(:root ,*wild-inferiors* :implementation))))
- (initialize-output-translations
- `(:output-translations
- ,@source-to-target-mappings
- ((:root ,*wild-inferiors* ,mapped-files)
- (,@destination-directory ,mapped-files))
- (t t)
- :ignore-inherited-configuration))))
-
-;;;; -----------------------------------------------------------------
-;;;; Source Registry Configuration, by Francois-Rene Rideau
-;;;; See the Manual and https://bugs.launchpad.net/asdf/+bug/485918
-
-;; Using ack 1.2 exclusions
-(defvar *default-source-registry-exclusions*
- '(".bzr" ".cdv"
- ;; "~.dep" "~.dot" "~.nib" "~.plst" ; we don't support ack wildcards
- ".git" ".hg" ".pc" ".svn" "CVS" "RCS" "SCCS" "_darcs"
- "_sgbak" "autom4te.cache" "cover_db" "_build"
- "debian")) ;; debian often builds stuff under the debian directory... BAD.
-
-(defvar *source-registry-exclusions* *default-source-registry-exclusions*)
-
-(defvar *source-registry* nil
- "Either NIL (for uninitialized), or an equal hash-table, mapping
-system names to pathnames of .asd files")
-
-(defun* source-registry-initialized-p ()
- (typep *source-registry* 'hash-table))
-
-(defun* clear-source-registry ()
- "Undoes any initialization of the source registry.
-You might want to call that before you dump an image that would be resumed
-with a different configuration, so the configuration would be re-read then."
- (setf *source-registry* nil)
- (values))
-
-(defparameter *wild-asd*
- (make-pathname :directory nil :name *wild* :type "asd" :version :newest))
-
-(defun* filter-logical-directory-results (directory entries merger)
- (if (typep directory 'logical-pathname)
- ;; Try hard to not resolve logical-pathname into physical pathnames;
- ;; otherwise logical-pathname users/lovers will be disappointed.
- ;; If directory* could use some implementation-dependent magic,
- ;; we will have logical pathnames already; otherwise,
- ;; we only keep pathnames for which specifying the name and
- ;; translating the LPN commute.
- (loop :for f :in entries
- :for p = (or (and (typep f 'logical-pathname) f)
- (let* ((u (ignore-errors (funcall merger f))))
- ;; The first u avoids a cumbersome (truename u) error
- (and u (equal (ignore-errors (truename u)) f) u)))
- :when p :collect p)
- entries))
-
-(defun* directory-files (directory &optional (pattern *wild-file*))
- (when (wild-pathname-p directory)
- (error "Invalid wild in ~S" directory))
- (unless (member (pathname-directory pattern) '(() (:relative)) :test 'equal)
- (error "Invalid file pattern ~S" pattern))
- (let ((entries (ignore-errors (directory* (merge-pathnames* pattern directory)))))
- (filter-logical-directory-results
- directory entries
- #'(lambda (f)
- (make-pathname :defaults directory
- :name (pathname-name f) :type (ununspecific (pathname-type f))
- :version (ununspecific (pathname-version f)))))))
-
-(defun* directory-asd-files (directory)
- (directory-files directory *wild-asd*))
-
-(defun* subdirectories (directory)
- (let* ((directory (ensure-directory-pathname directory))
- #-(or abcl cormanlisp genera xcl)
- (wild (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) (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 (normalize-pathname-directory-component
- (pathname-directory directory))))
- #'(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 (last dir))))))))))
-
-(defun* collect-asds-in-directory (directory collect)
- (map () collect (directory-asd-files directory)))
-
-(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))))
-
-(defun* collect-sub*directories-asd-files
- (directory &key
- (exclude *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* validate-source-registry-directive (directive)
- (or (member directive '(:default-registry))
- (and (consp directive)
- (let ((rest (rest directive)))
- (case (first directive)
- ((:include :directory :tree)
- (and (length=n-p rest 1)
- (location-designator-p (first rest))))
- ((:exclude :also-exclude)
- (every #'stringp rest))
- ((:default-registry)
- (null rest)))))))
-
-(defun* validate-source-registry-form (form &key location)
- (validate-configuration-form
- form :source-registry 'validate-source-registry-directive
- :location location :invalid-form-reporter 'invalid-source-registry))
-
-(defun* validate-source-registry-file (file)
- (validate-configuration-file
- file 'validate-source-registry-form :description "a source registry"))
-
-(defun* validate-source-registry-directory (directory)
- (validate-configuration-directory
- directory :source-registry 'validate-source-registry-directive
- :invalid-form-reporter 'invalid-source-registry))
-
-(defun* parse-source-registry-string (string &key location)
- (cond
- ((or (null string) (equal string ""))
- '(:source-registry :inherit-configuration))
- ((not (stringp string))
- (error (compatfmt "~@<Environment string isn't: ~3i~_~S~@:>") string))
- ((find (char string 0) "\"(")
- (validate-source-registry-form (read-from-string string) :location location))
- (t
- (loop
- :with inherit = nil
- :with directives = ()
- :with start = 0
- :with end = (length string)
- :with separator = (inter-directory-separator)
- :for pos = (position separator string :start start) :do
- (let ((s (subseq string start (or pos end))))
- (flet ((check (dir)
- (unless (absolute-pathname-p dir)
- (error (compatfmt "~@<source-registry string must specify absolute pathnames: ~3i~_~S~@:>") string))
- dir))
- (cond
- ((equal "" s) ; empty element: inherit
- (when inherit
- (error (compatfmt "~@<Only one inherited configuration allowed: ~3i~_~S~@:>")
- string))
- (setf inherit t)
- (push ':inherit-configuration directives))
- ((ends-with s "//") ;; TODO: allow for doubling of separator even outside Unix?
- (push `(:tree ,(check (subseq s 0 (- (length s) 2)))) directives))
- (t
- (push `(:directory ,(check s)) directives))))
- (cond
- (pos
- (setf start (1+ pos)))
- (t
- (unless inherit
- (push '(:ignore-inherited-configuration) directives))
- (return `(:source-registry ,@(nreverse directives))))))))))
-
-(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)))
-
-(defparameter *default-source-registries*
- '(environment-source-registry
- user-source-registry
- user-source-registry-directory
- system-source-registry
- system-source-registry-directory
- default-source-registry))
-
-(defparameter *source-registry-file* (coerce-pathname "source-registry.conf"))
-(defparameter *source-registry-directory* (coerce-pathname "source-registry.conf.d/"))
-
-(defun* wrapping-source-registry ()
- `(:source-registry
- #+sbcl (:tree ,(truenamize (getenv "SBCL_HOME")))
- :inherit-configuration
- #+cmu (:tree #p"modules:")
- #+scl (:tree #p"file://modules/")))
-(defun* default-source-registry ()
- `(:source-registry
- #+sbcl (:directory ,(subpathname (user-homedir) ".sbcl/systems/"))
- (:directory ,(default-directory))
- ,@(loop :for dir :in
- `(,@(when (os-unix-p)
- `(,(or (getenv-absolute-pathname "XDG_DATA_HOME")
- (subpathname (user-homedir) ".local/share/"))
- ,@(or (getenv-absolute-pathnames "XDG_DATA_DIRS")
- '("/usr/local/share" "/usr/share"))))
- ,@(when (os-windows-p)
- `(,(or #+lispworks (sys:get-folder-path :local-appdata)
- (getenv-absolute-pathname "LOCALAPPDATA"))
- ,(or #+lispworks (sys:get-folder-path :appdata)
- (getenv-absolute-pathname "APPDATA"))
- ,(or #+lispworks (sys:get-folder-path :common-appdata)
- (getenv-absolute-pathname "ALLUSERSAPPDATA")
- (subpathname* (getenv-absolute-pathname "ALLUSERSPROFILE") "Application Data/")))))
- :collect `(:directory ,(subpathname* dir "common-lisp/systems/"))
- :collect `(:tree ,(subpathname* dir "common-lisp/source/")))
- :inherit-configuration))
-(defun* user-source-registry (&key (direction :input))
- (in-user-configuration-directory *source-registry-file* :direction direction))
-(defun* system-source-registry (&key (direction :input))
- (in-system-configuration-directory *source-registry-file* :direction direction))
-(defun* user-source-registry-directory (&key (direction :input))
- (in-user-configuration-directory *source-registry-directory* :direction direction))
-(defun* system-source-registry-directory (&key (direction :input))
- (in-system-configuration-directory *source-registry-directory* :direction direction))
-(defun* environment-source-registry ()
- (getenv "CL_SOURCE_REGISTRY"))
-
-(defgeneric* process-source-registry (spec &key inherit register))
-(declaim (ftype (function (t &key (:register (or symbol function))) t)
- inherit-source-registry))
-(declaim (ftype (function (t &key (:register (or symbol function)) (:inherit list)) t)
- process-source-registry-directive))
-
-(defmethod process-source-registry ((x symbol) &key inherit register)
- (process-source-registry (funcall x) :inherit inherit :register register))
-(defmethod process-source-registry ((pathname pathname) &key inherit register)
- (cond
- ((directory-pathname-p pathname)
- (let ((*here-directory* (truenamize pathname)))
- (process-source-registry (validate-source-registry-directory pathname)
- :inherit inherit :register register)))
- ((probe-file* pathname)
- (let ((*here-directory* (pathname-directory-pathname pathname)))
- (process-source-registry (validate-source-registry-file pathname)
- :inherit inherit :register register)))
- (t
- (inherit-source-registry inherit :register register))))
-(defmethod process-source-registry ((string string) &key inherit register)
- (process-source-registry (parse-source-registry-string string)
- :inherit inherit :register register))
-(defmethod process-source-registry ((x null) &key inherit register)
- (declare (ignorable x))
- (inherit-source-registry inherit :register register))
-(defmethod process-source-registry ((form cons) &key inherit register)
- (let ((*source-registry-exclusions* *default-source-registry-exclusions*))
- (dolist (directive (cdr (validate-source-registry-form form)))
- (process-source-registry-directive directive :inherit inherit :register register))))
-
-(defun* inherit-source-registry (inherit &key register)
- (when inherit
- (process-source-registry (first inherit) :register register :inherit (rest inherit))))
-
-(defun* process-source-registry-directive (directive &key inherit register)
- (destructuring-bind (kw &rest rest) (if (consp directive) directive (list directive))
- (ecase kw
- ((:include)
- (destructuring-bind (pathname) rest
- (process-source-registry (resolve-location pathname) :inherit nil :register register)))
- ((:directory)
- (destructuring-bind (pathname) rest
- (when pathname
- (funcall register (resolve-location pathname :directory t)))))
- ((:tree)
- (destructuring-bind (pathname) rest
- (when pathname
- (funcall register (resolve-location pathname :directory t)
- :recurse t :exclude *source-registry-exclusions*))))
- ((:exclude)
- (setf *source-registry-exclusions* rest))
- ((:also-exclude)
- (appendf *source-registry-exclusions* rest))
- ((:default-registry)
- (inherit-source-registry '(default-source-registry) :register register))
- ((:inherit-configuration)
- (inherit-source-registry inherit :register register))
- ((:ignore-inherited-configuration)
- nil)))
- nil)
-
-(defun* flatten-source-registry (&optional parameter)
- (remove-duplicates
- (while-collecting (collect)
- (let ((*default-pathname-defaults* (default-directory)))
- (inherit-source-registry
- `(wrapping-source-registry
- ,parameter
- ,@*default-source-registries*)
- :register #'(lambda (directory &key recurse exclude)
- (collect (list directory :recurse recurse :exclude exclude))))))
- :test 'equal :from-end t))
-
-;; Will read the configuration and initialize all internal variables.
-(defun* compute-source-registry (&optional parameter (registry *source-registry*))
- (dolist (entry (flatten-source-registry parameter))
- (destructuring-bind (directory &key recurse exclude) entry
- (let* ((h (make-hash-table :test 'equal))) ; table to detect duplicates
- (register-asd-directory
- directory :recurse recurse :exclude exclude :collect
- #'(lambda (asd)
- (let* ((name (pathname-name asd))
- (name (if (typep asd 'logical-pathname)
- ;; logical pathnames are upper-case,
- ;; at least in the CLHS and on SBCL,
- ;; yet (coerce-name :foo) is lower-case.
- ;; won't work well with (load-system "Foo")
- ;; instead of (load-system 'foo)
- (string-downcase name)
- name)))
- (cond
- ((gethash name registry) ; already shadowed by something else
- nil)
- ((gethash name h) ; conflict at current level
- (when *asdf-verbose*
- (warn (compatfmt "~@<In source-registry entry ~A~@[/~*~] ~
- found several entries for ~A - picking ~S over ~S~:>")
- directory recurse name (gethash name h) asd)))
- (t
- (setf (gethash name registry) asd)
- (setf (gethash name h) asd))))))
- h)))
- (values))
-
-(defvar *source-registry-parameter* nil)
-
-(defun* initialize-source-registry (&optional (parameter *source-registry-parameter*))
- (setf *source-registry-parameter* parameter)
- (setf *source-registry* (make-hash-table :test 'equal))
- (compute-source-registry parameter))
-
-;; Checks an initial variable to see whether the state is initialized
-;; or cleared. In the former case, return current configuration; in
-;; the latter, initialize. ASDF will call this function at the start
-;; of (asdf:find-system) to make sure the source registry is initialized.
-;; However, it will do so *without* a parameter, at which point it
-;; will be too late to provide a parameter to this function, though
-;; you may override the configuration explicitly by calling
-;; initialize-source-registry directly with your parameter.
-(defun* ensure-source-registry (&optional parameter)
- (unless (source-registry-initialized-p)
- (initialize-source-registry parameter))
- (values))
-
-(defun* sysdef-source-registry-search (system)
- (ensure-source-registry)
- (values (gethash (coerce-name system) *source-registry*)))
-
-(defun* clear-configuration ()
- (clear-source-registry)
- (clear-output-translations))
-
-
-;;; ECL support for COMPILE-OP / LOAD-OP
-;;;
-;;; In ECL, these operations produce both FASL files and the
-;;; object files that they are built from. Having both of them allows
-;;; us to later on reuse the object files for bundles, libraries,
-;;; standalone executables, etc.
-;;;
-;;; This has to be in asdf.lisp and not asdf-ecl.lisp, or else it becomes
-;;; a problem for asdf on ECL to compile asdf-ecl.lisp after loading asdf.lisp.
-;;;
-#+ecl
-(progn
- (setf *compile-op-compile-file-function* 'ecl-compile-file)
-
- (defun ecl-compile-file (input-file &rest keys &key &allow-other-keys)
- (if (use-ecl-byte-compiler-p)
- (apply 'compile-file* input-file keys)
- (multiple-value-bind (object-file flags1 flags2)
- (apply 'compile-file* input-file :system-p t keys)
- (values (and object-file
- (c::build-fasl (compile-file-pathname object-file :type :fasl)
- :lisp-files (list object-file))
- object-file)
- flags1
- flags2))))
-
- (defmethod output-files ((operation compile-op) (c cl-source-file))
- (declare (ignorable operation))
- (let* ((p (lispize-pathname (component-pathname c)))
- (f (compile-file-pathname p :type :fasl)))
- (if (use-ecl-byte-compiler-p)
- (list f)
- (list (compile-file-pathname p :type :object) f))))
-
- (defmethod perform ((o load-op) (c cl-source-file))
- (map () #'load
- (loop :for i :in (input-files o c)
- :unless (string= (pathname-type i) "fas")
- :collect (compile-file-pathname (lispize-pathname i))))))
-
-;;;; -----------------------------------------------------------------
-;;;; Hook into REQUIRE for ABCL, CLISP, ClozureCL, CMUCL, ECL and SBCL
-;;;;
-(defvar *require-asdf-operator* 'load-op)
-
-(defun* module-provide-asdf (name)
- (handler-bind
- ((style-warning #'muffle-warning)
- #-genera
- (missing-component (constantly nil))
- (error #'(lambda (e)
- (format *error-output* (compatfmt "~@<ASDF could not load ~(~A~) because ~A.~@:>~%")
- name e))))
- (let ((*verbose-out* (make-broadcast-stream))
- (system (find-system (string-downcase name) nil)))
- (when system
- (operate *require-asdf-operator* system :verbose nil)
- t))))
-
-#+(or abcl clisp clozure cmu ecl sbcl)
-(let ((x (and #+clisp (find-symbol* '#:*module-provider-functions* :custom))))
- (when x
- (eval `(pushnew 'module-provide-asdf
- #+abcl sys::*module-provider-functions*
- #+clisp ,x
- #+clozure ccl:*module-provider-functions*
- #+(or cmu ecl) ext:*module-provider-functions*
- #+sbcl sb-ext:*module-provider-functions*))))
-
-
-;;;; -------------------------------------------------------------------------
-;;;; Cleanups after hot-upgrade.
-;;;; Things to do in case we're upgrading from a previous version of ASDF.
-;;;; See https://bugs.launchpad.net/asdf/+bug/485687
-;;;;
-
-;;; If a previous version of ASDF failed to read some configuration, try again.
-(when *ignored-configuration-form*
- (clear-configuration)
- (setf *ignored-configuration-form* nil))
-
-;;;; -----------------------------------------------------------------
-;;;; Done!
-(when *load-verbose*
- (asdf-message ";; ASDF, version ~a~%" (asdf-version)))
-
-#+allegro
-(eval-when (:compile-toplevel :execute)
- (when (boundp 'excl:*warn-on-nested-reader-conditionals*)
- (setf excl:*warn-on-nested-reader-conditionals* *acl-warn-save*)))
-
-(pushnew :asdf *features*)
-(pushnew :asdf2 *features*)
-
-(provide :asdf)
-
-;;; Local Variables:
-;;; mode: lisp
-;;; End:
common-lisp.net / projects/clfswm/clfswm.git / commitdiff
