- (defun get-folder-path (folder)
- (or ;; this semi-portably implements a subset of the functionality of lispworks' sys:get-folder-path
- #+(and lispworks mswindows) (sys:get-folder-path folder)
- ;; read-windows-registry HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\User Shell Folders\AppData
- (ecase folder
- (:local-appdata (getenv-absolute-directory "LOCALAPPDATA"))
- (:appdata (getenv-absolute-directory "APPDATA"))
- (:common-appdata (or (getenv-absolute-directory "ALLUSERSAPPDATA")
- (subpathname* (getenv-absolute-directory "ALLUSERSPROFILE") "Application Data/"))))))
-
- (defun user-configuration-directories ()
- (let ((dirs
- `(,@(when (os-unix-p)
- (cons
- (subpathname* (getenv-absolute-directory "XDG_CONFIG_HOME") "common-lisp/")
- (loop :for dir :in (getenv-absolute-directories "XDG_CONFIG_DIRS")
- :collect (subpathname* dir "common-lisp/"))))
- ,@(when (os-windows-p)
- `(,(subpathname* (get-folder-path :local-appdata) "common-lisp/config/")
- ,(subpathname* (get-folder-path :appdata) "common-lisp/config/")))
- ,(subpathname (user-homedir-pathname) ".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)
- (if-let (it (subpathname* (get-folder-path :common-appdata) "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 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-pathname-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)))
-
- (defun resolve-relative-location (x &key ensure-directory wilden)
- (ensure-pathname
- (etypecase x
- (pathname x)
- (string (parse-unix-namestring
- x :ensure-directory ensure-directory))
- (cons
- (if (null (cdr x))
- (resolve-relative-location
- (car x) :ensure-directory ensure-directory :wilden wilden)
- (let* ((car (resolve-relative-location
- (car x) :ensure-directory t :wilden nil)))
- (merge-pathnames*
- (resolve-relative-location
- (cdr x) :ensure-directory ensure-directory :wilden wilden)
- car))))
- ((eql :*/) *wild-directory*)
- ((eql :**/) *wild-inferiors*)
- ((eql :*.*.*) *wild-file*)
- ((eql :implementation)
- (parse-unix-namestring
- (implementation-identifier) :ensure-directory t))
- ((eql :implementation-type)
- (parse-unix-namestring
- (string-downcase (implementation-type)) :ensure-directory t))
- ((eql :hostname)
- (parse-unix-namestring (hostname) :ensure-directory t)))
- :wilden (and wilden (not (pathnamep x)) (not (member x '(:*/ :**/ :*.*.*))))
- :want-relative t))
-
- (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.")
-
- (defvar *user-cache* nil
- "A specification as per RESOLVE-LOCATION of where the user keeps his FASL cache")
-
- (defun compute-user-cache ()
- (setf *user-cache*
- (flet ((try (x &rest sub) (and x `(,x ,@sub))))
- (or
- (try (getenv-absolute-directory "XDG_CACHE_HOME") "common-lisp" :implementation)
- (when (os-windows-p)
- (try (or (get-folder-path :local-appdata)
- (get-folder-path :appdata))
- "common-lisp" "cache" :implementation))
- '(:home ".cache" "common-lisp" :implementation)))))
- (register-image-restore-hook 'compute-user-cache)
-
- (defun resolve-absolute-location (x &key ensure-directory wilden)
- (ensure-pathname
- (etypecase x
- (pathname x)
- (string
- (let ((p #-mcl (parse-namestring x)
- #+mcl (probe-posix x)))
- #+mcl (unless p (error "POSIX pathname ~S does not exist" x))
- (if ensure-directory (ensure-directory-pathname p) p)))
- (cons
- (return-from resolve-absolute-location
- (if (null (cdr x))
- (resolve-absolute-location
- (car x) :ensure-directory ensure-directory :wilden wilden)
- (merge-pathnames*
- (resolve-relative-location
- (cdr x) :ensure-directory ensure-directory :wilden wilden)
- (resolve-absolute-location
- (car x) :ensure-directory t :wilden nil)))))
- ((eql :root)
- ;; special magic! we return a relative pathname,
- ;; but what it means to the output-translations is
- ;; "relative to the root of the source pathname's host and device".
- (return-from resolve-absolute-location
- (let ((p (make-pathname* :directory '(:relative))))
- (if wilden (wilden p) p))))
- ((eql :home) (user-homedir-pathname))
- ((eql :here) (resolve-absolute-location
- *here-directory* :ensure-directory t :wilden nil))
- ((eql :user-cache) (resolve-absolute-location
- *user-cache* :ensure-directory t :wilden nil)))
- :wilden (and wilden (not (pathnamep x)))
- :resolve-symlinks *resolve-symlinks*
- :want-absolute t))
-
- ;; Try to override declaration in previous versions of ASDF.
- (declaim (ftype (function (t &key (:directory boolean) (:wilden boolean)
- (:ensure-directory boolean)) t) resolve-location))
-
- (defun* (resolve-location) (x &key ensure-directory wilden directory)
- ;; :directory backward compatibility, until 2014-01-16: accept directory as well as ensure-directory
- (loop* :with dirp = (or directory ensure-directory)
- :with (first . rest) = (if (atom x) (list x) x)
- :with path = (resolve-absolute-location
- first :ensure-directory (and (or dirp rest) t)
- :wilden (and wilden (null rest)))
- :for (element . morep) :on rest
- :for dir = (and (or morep dirp) t)
- :for wild = (and wilden (not morep))
- :for sub = (merge-pathnames*
- (resolve-relative-location
- element :ensure-directory dir :wilden wild)
- path)
- :do (setf path (if (absolute-pathname-p sub) (resolve-symlinks* sub) sub))
- :finally (return path)))
-
- (defun location-designator-p (x)
- (flet ((absolute-component-p (c)
- (typep c '(or string pathname
- (member :root :home :here :user-cache))))
- (relative-component-p (c)
- (typep c '(or string pathname
- (member :*/ :**/ :*.*.* :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)))))
-
- (defvar *clear-configuration-hook* '())
-
- (defun register-clear-configuration-hook (hook-function &optional call-now-p)
- (register-hook-function '*clear-configuration-hook* hook-function call-now-p))
-
- (defun clear-configuration ()
- (call-functions *clear-configuration-hook*))
-
- (register-image-dump-hook 'clear-configuration)
-
- ;; If a previous version of ASDF failed to read some configuration, try again.
- (defun upgrade-configuration ()
- (when *ignored-configuration-form*
- (clear-configuration)
- (setf *ignored-configuration-form* nil))))
-
-
-;;;; -------------------------------------------------------------------------
-;;; Hacks for backward-compatibility of the driver
-
-(asdf/package:define-package :asdf/backward-driver
- (:recycle :asdf/backward-driver :asdf)
- (:use :asdf/common-lisp :asdf/package :asdf/utility
- :asdf/pathname :asdf/stream :asdf/os :asdf/image
- :asdf/run-program :asdf/lisp-build
- :asdf/configuration)
- (:export
- #:coerce-pathname #:component-name-to-pathname-components
- #+(or ecl mkcl) #:compile-file-keeping-object
- ))
-(in-package :asdf/backward-driver)
-
-;;;; Backward compatibility with various pathname functions.
-
-(with-upgradability ()
- (defun coerce-pathname (name &key type defaults)
- ;; For backward-compatibility only, for people using internals
- ;; Reported users in quicklisp: hu.dwim.asdf, asdf-utils, xcvb
- ;; Will be removed after 2014-01-16.
- ;;(warn "Please don't use ASDF::COERCE-PATHNAME. Use ASDF/PATHNAME:PARSE-UNIX-NAMESTRING.")
- (parse-unix-namestring name :type type :defaults defaults))
-
- (defun component-name-to-pathname-components (unix-style-namestring
- &key force-directory force-relative)
- ;; Will be removed after 2014-01-16.
- ;; (warn "Please don't use ASDF::COMPONENT-NAME-TO-PATHNAME-COMPONENTS, use SPLIT-UNIX-NAMESTRING-DIRECTORY-COMPONENTS")
- (multiple-value-bind (relabs path filename file-only)
- (split-unix-namestring-directory-components
- unix-style-namestring :ensure-directory force-directory)
- (declare (ignore file-only))
- (when (and force-relative (not (eq relabs :relative)))
- (error (compatfmt "~@<Absolute pathname designator not allowed: ~3i~_~S~@:>")
- unix-style-namestring))
- (values relabs path filename)))
-
- #+(or ecl mkcl)
- (defun compile-file-keeping-object (&rest args) (apply #'compile-file* args)))
-;;;; ---------------------------------------------------------------------------
-;;;; Re-export all the functionality in asdf/driver
-
-(asdf/package:define-package :asdf/driver
- (:nicknames :asdf-driver :asdf-utils)
- (:use :asdf/common-lisp :asdf/package :asdf/utility
- :asdf/os :asdf/pathname :asdf/stream :asdf/filesystem :asdf/image
- :asdf/run-program :asdf/lisp-build
- :asdf/configuration :asdf/backward-driver)
- (:reexport
- ;; NB: excluding asdf/common-lisp
- ;; which include all of CL with compatibility modifications on select platforms.
- :asdf/package :asdf/utility
- :asdf/os :asdf/pathname :asdf/stream :asdf/filesystem :asdf/image
- :asdf/run-program :asdf/lisp-build
- :asdf/configuration :asdf/backward-driver))
-;;;; -------------------------------------------------------------------------
-;;;; Handle upgrade as forward- and backward-compatibly as possible
-;; See https://bugs.launchpad.net/asdf/+bug/485687
-
-(asdf/package:define-package :asdf/upgrade
- (:recycle :asdf/upgrade :asdf)
- (:use :asdf/common-lisp :asdf/driver)
- (:export
- #:asdf-version #:*previous-asdf-versions* #:*asdf-version*
- #:asdf-message #:*verbose-out*
- #:upgrading-p #:when-upgrading #:upgrade-asdf #:asdf-upgrade-error
- #:*post-upgrade-cleanup-hook* #:*post-upgrade-restart-hook* #:cleanup-upgraded-asdf
- ;; There will be no symbol left behind!
- #:intern*)
- (:import-from :asdf/package #:intern* #:find-symbol*))
-(in-package :asdf/upgrade)
-
-;;; Special magic to detect if this is an upgrade
-
-(with-upgradability ()
- (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) \"3.4.5.67\")."
- (when (find-package :asdf)
- (or (symbol-value (find-symbol (string :*asdf-version*) :asdf))
- (let* ((revsym (find-symbol (string :*asdf-revision*) :asdf))
- (rev (and revsym (boundp revsym) (symbol-value revsym))))
- (etypecase rev
- (string rev)
- (cons (format nil "~{~D~^.~}" rev))
- (null "1.0"))))))
- (defvar *asdf-version* nil)
- (defvar *previous-asdf-versions* nil)
- (defvar *verbose-out* nil)
- (defun asdf-message (format-string &rest format-args)
- (when *verbose-out* (apply 'format *verbose-out* format-string format-args)))
- (defvar *post-upgrade-cleanup-hook* ())
- (defvar *post-upgrade-restart-hook* ())
- (defun upgrading-p ()
- (and *previous-asdf-versions* (not (equal *asdf-version* (first *previous-asdf-versions*)))))
- (defmacro when-upgrading ((&key (upgrading-p '(upgrading-p)) when) &body body)
- `(with-upgradability ()
- (when (and ,upgrading-p ,@(when when `(,when)))
- (handler-bind ((style-warning #'muffle-warning))
- (eval '(progn ,@body))))))
- (let* (;; For bug reporting sanity, please always bump this version when you modify this file.
- ;; Please also modify asdf.asd to reflect this change. make bump-version v=3.4.5.67.8
- ;; 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.
- ;; "3.4" would be the general branch for major version 3, minor version 4.
- ;; "3.4.5" would be an official release in the 3.4 branch.
- ;; "3.4.5.67" would be a development version in the official upstream of 3.4.5.
- ;; "3.4.5.0.8" would be your eighth local modification of official release 3.4.5
- ;; "3.4.5.67.8" would be your eighth local modification of development version 3.4.5.67
- (asdf-version "2.29")
- (existing-version (asdf-version)))
- (setf *asdf-version* asdf-version)
- (when (and existing-version (not (equal asdf-version existing-version)))
- (push existing-version *previous-asdf-versions*)
- (when (or *load-verbose* *verbose-out*)
- (format *trace-output*
- (compatfmt "~&~@<; ~@;Upgrading ASDF ~@[from version ~A ~]to version ~A~@:>~%")
- existing-version asdf-version)))))
-
-(when-upgrading ()
- (let ((redefined-functions ;; gf signature and/or semantics changed incompatibly. Oops.
- '(#:component-relative-pathname #:component-parent-pathname ;; component
- #:source-file-type
- #:find-system #:system-source-file #:system-relative-pathname ;; system
- #:find-component ;; find-component
- #:explain #:perform #:perform-with-restarts #:input-files #:output-files ;; action
- #:component-depends-on #:component-self-dependencies #:operation-done-p
- #:traverse ;; plan
- #:operate ;; operate
- #:parse-component-form ;; defsystem
- #:apply-output-translations ;; output-translations
- #:process-output-translations-directive
- #:inherit-source-registry #:process-source-registry ;; source-registry
- #:process-source-registry-directive
- #:trivial-system-p ;; bundle
- ;; NB: it's too late to do anything about asdf-driver functions!
- ))
- (uninterned-symbols
- '(#:*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
- (declare (ignorable redefined-functions uninterned-symbols))
- (loop :for name :in (append #-(or ecl) redefined-functions)
- :for sym = (find-symbol* name :asdf nil) :do
- (when sym
- (fmakunbound sym)))
- (loop :with asdf = (find-package :asdf)
- :for name :in (append #+(or ecl) redefined-functions uninterned-symbols) ;XXX
- :for sym = (find-symbol* name :asdf nil)
- :for base-pkg = (and sym (symbol-package sym)) :do
- (when sym
- (cond
- ((or (eq base-pkg asdf) (not base-pkg))
- (unintern* sym asdf)
- (intern* sym asdf))
- (t
- (unintern* sym base-pkg)
- (let ((new (intern* sym base-pkg)))
- (shadowing-import new asdf))))))))
-
-
-;;; Self-upgrade functions
-
-(with-upgradability ()
- (defun asdf-upgrade-error ()
- ;; Important notice for whom it concerns. The crux of the matter is that
- ;; TRAVERSE can be completely refactored, and so after the find-system returns, it's too late.
- (error "When a system transitively depends on ASDF, it must :defsystem-depends-on (:asdf)~%~
- Otherwise, when you upgrade from ASDF 2, you must do it before you operate on any system.~%"))
-
- (defun cleanup-upgraded-asdf (&optional (old-version (first *previous-asdf-versions*)))
- (let ((new-version (asdf-version)))
- (unless (equal old-version new-version)
- (push new-version *previous-asdf-versions*)
- (when old-version
- (cond
- ((version-compatible-p new-version old-version)
- (asdf-message (compatfmt "~&~@<; ~@;Upgraded ASDF from version ~A to version ~A~@:>~%")
- old-version new-version))
- ((version-compatible-p 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)))
- (call-functions (reverse *post-upgrade-cleanup-hook*))
- t))))
-
- (defun upgrade-asdf ()
- "Try to upgrade of ASDF. If a different version was used, return T.
- We need do that before we operate on anything that may possibly depend on ASDF."
- (let ((*load-print* nil)
- (*compile-print* nil))
- (handler-bind (((or style-warning warning) #'muffle-warning))
- (symbol-call :asdf :load-system :asdf :verbose nil))))
-
- (register-hook-function '*post-upgrade-cleanup-hook* 'upgrade-configuration))
-
-;;;; -------------------------------------------------------------------------
-;;;; Components
-
-(asdf/package:define-package :asdf/component
- (:recycle :asdf/component :asdf)
- (:use :asdf/common-lisp :asdf/driver :asdf/upgrade)
- (:export
- #:component #:component-find-path
- #:component-name #:component-pathname #:component-relative-pathname
- #:component-parent #:component-system #:component-parent-pathname
- #:child-component #:parent-component #:module
- #:file-component
- #:source-file #:c-source-file #:java-source-file
- #:static-file #:doc-file #:html-file
- #:source-file-type ;; backward-compatibility
- #:component-in-order-to #:component-sibling-dependencies
- #:component-if-feature #:around-compile-hook
- #:component-description #:component-long-description
- #:component-version #:version-satisfies
- #:component-inline-methods ;; backward-compatibility only. DO NOT USE!
- #:component-operation-times ;; For internal use only.
- ;; portable ASDF encoding and implementation-specific external-format
- #:component-external-format #:component-encoding
- #:component-children-by-name #:component-children #:compute-children-by-name
- #:component-build-operation
- #:module-default-component-class
- #:module-components ;; backward-compatibility. DO NOT USE.
- #:sub-components
-
- ;; Internals we'd like to share with the ASDF package, especially for upgrade purposes
- #:name #:version #:description #:long-description #:author #:maintainer #:licence
- #:components-by-name #:components
- #:children #:children-by-name #:default-component-class
- #:author #:maintainer #:licence #:source-file #:defsystem-depends-on
- #:sibling-dependencies #:if-feature #:in-order-to #:inline-methods
- #:relative-pathname #:absolute-pathname #:operation-times #:around-compile
- #:%encoding #:properties #:component-properties #:parent))
-(in-package :asdf/component)
-
-(with-upgradability ()
- (defgeneric component-name (component)
- (:documentation "Name of the COMPONENT, unique relative to its parent"))
- (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-external-format (component))
- (defgeneric component-encoding (component))
- (defgeneric version-satisfies (component version))
- (defgeneric component-version (component))
- (defgeneric (setf component-version) (new-version component))
- (defgeneric component-parent (component))
- (defmethod component-parent ((component null)) (declare (ignorable component)) nil)
-
- ;; Backward compatible way of computing the FILE-TYPE of a component.
- ;; TODO: find users, have them stop using that, remove it for ASDF4.
- (defgeneric (source-file-type) (component system)))
-
-(when-upgrading (:when (find-class 'component nil))
- (defmethod reinitialize-instance :after ((c component) &rest initargs &key)
- (declare (ignorable c initargs)) (values)))
-
-(with-upgradability ()
- (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 :initform nil)
- (description :accessor component-description :initarg :description :initform nil)
- (long-description :accessor component-long-description :initarg :long-description :initform nil)
- (sibling-dependencies :accessor component-sibling-dependencies :initform nil)
- (if-feature :accessor component-if-feature :initform nil :initarg :if-feature)
- ;; In the ASDF object model, dependencies exist between *actions*,
- ;; where an action is a pair of an operation and a component.
- ;; Dependencies are represented as alists of operations
- ;; to a list where each entry is a pair of an operation and a list of component specifiers.
- ;; Up until ASDF 2.26.9, there used to be two kinds of dependencies:
- ;; in-order-to and do-first, each stored in its own slot. Now there is only in-order-to.
- ;; in-order-to used to represent things that modify the filesystem (such as compiling a fasl)
- ;; and do-first things that modify the current image (such as loading a fasl).
- ;; These are now unified because we now correctly propagate timestamps between dependencies.
- ;; Happily, no one seems to have used do-first too much (especially since until ASDF 2.017,
- ;; anything you specified was overridden by ASDF itself anyway), but the name in-order-to remains.
- ;; The names are bad, but they have been the official API since Dan Barlow's ASDF 1.52!
- ;; LispWorks's defsystem has caused-by and requires for in-order-to and do-first respectively.
- ;; Maybe rename the slots in ASDF? But that's not very backward-compatible.
- ;; See our ASDF 2 paper for more complete explanations.
- (in-order-to :initform nil :initarg :in-order-to
- :accessor component-in-order-to)
- ;; 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) ;; OBSOLETE! DELETE THIS IF NO ONE USES.
- ;; ASDF4: rename it from relative-pathname to specified-pathname. It need not be relative.
- ;; There is no initform and no direct accessor for this specified pathname,
- ;; so we only access the information through appropriate methods, after it has been processed.
- ;; Unhappily, some braindead systems directly access the slot. Make them stop before ASDF4.
- (relative-pathname :initarg :pathname)
- ;; The absolute-pathname is computed based on relative-pathname and parent pathname.
- ;; The slot is but a cache used by component-pathname.
- (absolute-pathname)
- (operation-times :initform (make-hash-table)
- :accessor component-operation-times)
- (around-compile :initarg :around-compile)
- ;; Properties are for backward-compatibility with ASDF2 only. DO NOT USE!
- (properties :accessor component-properties :initarg :properties
- :initform nil)
- (%encoding :accessor %component-encoding :initform nil :initarg :encoding)
- ;; For backward-compatibility, this slot is part of component rather than of child-component. ASDF4: stop it.
- (parent :initarg :parent :initform nil :reader component-parent)
- (build-operation
- :initarg :build-operation :initform nil :reader component-build-operation)))
-
- (defun component-find-path (component)
- (check-type component (or null 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))))
-
- (defmethod component-system ((component component))
- (if-let (system (component-parent component))
- (component-system system)
- component)))
-
-
-;;;; Component hierarchy within a system
-;; The tree typically but not necessarily follows the filesystem hierarchy.
-(with-upgradability ()
- (defclass child-component (component) ())
-
- (defclass file-component (child-component)
- ((type :accessor file-type :initarg :type))) ; no default
- (defclass source-file (file-component)
- ((type :initform nil))) ;; NB: many systems have come to rely on this default.
- (defclass c-source-file (source-file)
- ((type :initform "c")))
- (defclass java-source-file (source-file)
- ((type :initform "java")))
- (defclass static-file (source-file)
- ((type :initform nil)))
- (defclass doc-file (static-file) ())
- (defclass html-file (doc-file)
- ((type :initform "html")))
-
- (defclass parent-component (component)
- ((children
- :initform nil
- :initarg :components
- :reader module-components ; backward-compatibility
- :accessor component-children)
- (children-by-name
- :reader module-components-by-name ; backward-compatibility
- :accessor component-children-by-name)
- (default-component-class
- :initform nil
- :initarg :default-component-class
- :accessor module-default-component-class))))
-
-(with-upgradability ()
- (defun compute-children-by-name (parent &key only-if-needed-p)
- (unless (and only-if-needed-p (slot-boundp parent 'children-by-name))
- (let ((hash (make-hash-table :test 'equal)))
- (setf (component-children-by-name parent) hash)
- (loop :for c :in (component-children parent)
- :for name = (component-name c)
- :for previous = (gethash name hash)
- :do (when previous (error 'duplicate-names :name name))
- (setf (gethash name hash) c))
- hash))))
-
-(when-upgrading (:when (find-class 'module nil))
- (defmethod reinitialize-instance :after ((m module) &rest initargs &key)
- (declare (ignorable m initargs)) (values))
- (defmethod update-instance-for-redefined-class :after
- ((m module) added deleted plist &key)
- (declare (ignorable m added deleted plist))
- (when (and (member 'children added) (member 'components deleted))
- (setf (slot-value m 'children)
- ;; old ECLs provide an alist instead of a plist(!)
- (if (or #+ecl (consp (first plist))) (or #+ecl (cdr (assoc 'components plist)))
- (getf plist 'components)))
- (compute-children-by-name m))))
-
-(with-upgradability ()
- (defclass module (child-component parent-component)
- (#+clisp (components)))) ;; backward compatibility during upgrade only
-
-
-;;;; component pathnames
-(with-upgradability ()
- (defgeneric* (component-parent-pathname) (component))
- (defmethod component-parent-pathname (component)
- (component-pathname (component-parent component)))
-
- (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-relative-pathname ((component component))
- ;; source-file-type is backward-compatibility with ASDF1;
- ;; we ought to be able to extract this from the component alone with COMPONENT-TYPE.
- ;; TODO: track who uses it, and have them not use it anymore.
- (parse-unix-namestring
- (or (and (slot-boundp component 'relative-pathname)
- (slot-value component 'relative-pathname))
- (component-name component))
- :want-relative t
- :type (source-file-type component (component-system component))
- :defaults (component-parent-pathname component)))
-
- (defmethod source-file-type ((component parent-component) system)
- (declare (ignorable component system))
- :directory)
-
- (defmethod source-file-type ((component file-component) system)
- (declare (ignorable system))
- (file-type component)))
-
-
-;;;; Encodings
-(with-upgradability ()
- (defmethod component-encoding ((c component))
- (or (loop :for x = c :then (component-parent x)
- :while x :thereis (%component-encoding x))
- (detect-encoding (component-pathname c))))
-
- (defmethod component-external-format ((c component))
- (encoding-external-format (component-encoding c))))
-
-
-;;;; around-compile-hook
-(with-upgradability ()
- (defgeneric around-compile-hook (component))
- (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))))))
-
-
-;;;; version-satisfies
-(with-upgradability ()
- (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))
-
- (defmethod version-satisfies ((cver string) version)
- (version-compatible-p cver version)))
-
-
-;;; all sub-components (of a given type)
-(with-upgradability ()
- (defun sub-components (component &key (type t))
- (while-collecting (c)
- (labels ((recurse (x)
- (when (if-let (it (component-if-feature x)) (featurep it) t)
- (when (typep x type)
- (c x))
- (when (typep x 'parent-component)
- (map () #'recurse (component-children x))))))
- (recurse component)))))