Commit 5f132666 authored by mevenson@1c010e3e-69d0-11dd-93a8-456734b0d56f's avatar mevenson@1c010e3e-69d0-11dd-93a8-456734b0d56f
Browse files

asdf 3.1.0.65: restores BUNDLE-OP as working.

parent e92acedc
...@@ -35,11 +35,11 @@ for Common Lisp programs and libraries. ...@@ -35,11 +35,11 @@ for Common Lisp programs and libraries.
You can find the latest version of this manual at You can find the latest version of this manual at
@url{http://common-lisp.net/project/asdf/asdf.html}. @url{http://common-lisp.net/project/asdf/asdf.html}.
ASDF Copyright @copyright{} 2001-2013 Daniel Barlow and contributors. ASDF Copyright @copyright{} 2001-2014 Daniel Barlow and contributors.
This manual Copyright @copyright{} 2001-2013 Daniel Barlow and contributors. This manual Copyright @copyright{} 2001-2014 Daniel Barlow and contributors.
This manual revised @copyright{} 2009-2013 Robert P. Goldman and Francois-Rene Rideau. This manual revised @copyright{} 2009-2014 Robert P. Goldman and Francois-Rene Rideau.
Permission is hereby granted, free of charge, to any person obtaining Permission is hereby granted, free of charge, to any person obtaining
a copy of this software and associated documentation files (the a copy of this software and associated documentation files (the
...@@ -173,7 +173,7 @@ the ASDF internals and how to extend ASDF. ...@@ -173,7 +173,7 @@ the ASDF internals and how to extend ASDF.
@emph{Nota Bene}: @emph{Nota Bene}:
We have released ASDF 2.000 on May 31st 2010, We have released ASDF 2.000 on May 31st 2010,
and ASDF 3.0 on January 31st 2013. and ASDF 3.0.0 on May 15th 2013.
Releases of ASDF 2 and later have since then been included Releases of ASDF 2 and later have since then been included
in all actively maintained CL implementations that used to bundle ASDF 1, in all actively maintained CL implementations that used to bundle ASDF 1,
plus some implementations that didn't use to, plus some implementations that didn't use to,
......
;;; -*- mode: Common-Lisp; Base: 10 ; Syntax: ANSI-Common-Lisp -*- ;;; -*- mode: Common-Lisp; Base: 10 ; Syntax: ANSI-Common-Lisp ; buffer-read-only: t; -*-
;;; This is ASDF 3.1.0.49: Another System Definition Facility. ;;; This is ASDF 3.1.0.65: Another System Definition Facility.
;;; ;;;
;;; Feedback, bug reports, and patches are all welcome: ;;; Feedback, bug reports, and patches are all welcome:
;;; please mail to <asdf-devel@common-lisp.net>. ;;; please mail to <asdf-devel@common-lisp.net>.
...@@ -53,6 +53,13 @@ ...@@ -53,6 +53,13 @@
(eval-when (:load-toplevel :compile-toplevel :execute) (eval-when (:load-toplevel :compile-toplevel :execute)
(setf ext:*gc-verbose* nil)) (setf ext:*gc-verbose* nil))
   
;;; pre 1.3.0 ABCL versions do not support the bundle-op on Mac OS X
#+abcl
(eval-when (:load-toplevel :compile-toplevel :execute)
(unless (and (member :darwin *features*)
(second (third (sys::arglist 'directory))))
(push :abcl-bundle-op-supported *features*)))
;; Punt on hard package upgrade: from ASDF1 always, and even from ASDF2 on most implementations. ;; Punt on hard package upgrade: from ASDF1 always, and even from ASDF2 on most implementations.
(eval-when (:load-toplevel :compile-toplevel :execute) (eval-when (:load-toplevel :compile-toplevel :execute)
(unless (member :asdf3 *features*) (unless (member :asdf3 *features*)
...@@ -71,7 +78,8 @@ ...@@ -71,7 +78,8 @@
(away (format nil "~A-~A" :asdf existing-version))) (away (format nil "~A-~A" :asdf existing-version)))
(when (and existing-version (when (and existing-version
(< existing-version-number (< existing-version-number
(or #+(or allegro clisp lispworks sbcl) 2.0 2.27))) #+(or allegro clisp lispworks sbcl) 2.0
#-(or allegro clisp lispworks sbcl) 2.27))
(rename-package :asdf away) (rename-package :asdf away)
(when *load-verbose* (when *load-verbose*
(format t "~&; Renamed old ~A package away to ~A~%" :asdf away)))))) (format t "~&; Renamed old ~A package away to ~A~%" :asdf away))))))
...@@ -2241,6 +2249,9 @@ ways that the filename components can be missing are for it to be NIL, ...@@ -2241,6 +2249,9 @@ ways that the filename components can be missing are for it to be NIL,
Note that this does _not_ check to see that PATHNAME points to an Note that this does _not_ check to see that PATHNAME points to an
actually-existing directory." actually-existing directory."
(when pathname (when pathname
;; I tried using Allegro's excl:file-directory-p, but this cannot be done,
;; because it rejects apparently legal pathnames as
;; ill-formed. [2014/02/10:rpg]
(let ((pathname (pathname pathname))) (let ((pathname (pathname pathname)))
(flet ((check-one (x) (flet ((check-one (x)
(member x '(nil :unspecific "") :test 'equal))) (member x '(nil :unspecific "") :test 'equal)))
...@@ -2811,6 +2822,13 @@ or the original (parsed) pathname if it is false (the default)." ...@@ -2811,6 +2822,13 @@ or the original (parsed) pathname if it is false (the default)."
   
(defun directory-exists-p (x) (defun directory-exists-p (x)
"Is X the name of a directory that exists on the filesystem?" "Is X the name of a directory that exists on the filesystem?"
#+allegro
(excl:probe-directory x)
#+clisp
(handler-case (ext:probe-directory x)
(sys::simple-file-error ()
nil))
#-(or allegro clisp)
(let ((p (probe-file* x :truename t))) (let ((p (probe-file* x :truename t)))
(and (directory-pathname-p p) p))) (and (directory-pathname-p p) p)))
   
...@@ -2835,26 +2853,33 @@ Try to override the defaults to not resolving symlinks, if implementation allows ...@@ -2835,26 +2853,33 @@ Try to override the defaults to not resolving symlinks, if implementation allows
"Given ENTRIES in a DIRECTORY, remove if the directory is logical "Given ENTRIES in a DIRECTORY, remove if the directory is logical
the entries which are physical yet when transformed by MERGER have a different TRUENAME. the entries which are physical yet when transformed by MERGER have a different TRUENAME.
This function is used as a helper to DIRECTORY-FILES to avoid invalid entries when using logical-pathnames." This function is used as a helper to DIRECTORY-FILES to avoid invalid entries when using logical-pathnames."
(if (logical-pathname-p directory) (remove-duplicates ;; on CLISP, querying ~/ will return duplicates
;; Try hard to not resolve logical-pathname into physical pathnames; (if (logical-pathname-p directory)
;; otherwise logical-pathname users/lovers will be disappointed. ;; Try hard to not resolve logical-pathname into physical pathnames;
;; If directory* could use some implementation-dependent magic, ;; otherwise logical-pathname users/lovers will be disappointed.
;; we will have logical pathnames already; otherwise, ;; If directory* could use some implementation-dependent magic,
;; we only keep pathnames for which specifying the name and ;; we will have logical pathnames already; otherwise,
;; translating the LPN commute. ;; we only keep pathnames for which specifying the name and
(loop :for f :in entries ;; translating the LPN commute.
:for p = (or (and (logical-pathname-p f) f) (loop :for f :in entries
(let* ((u (ignore-errors (call-function merger f)))) :for p = (or (and (logical-pathname-p f) f)
;; The first u avoids a cumbersome (truename u) error. (let* ((u (ignore-errors (call-function merger f))))
;; At this point f should already be a truename, ;; The first u avoids a cumbersome (truename u) error.
;; but isn't quite in CLISP, for it doesn't have :version :newest ;; At this point f should already be a truename,
(and u (equal (truename* u) (truename* f)) u))) ;; but isn't quite in CLISP, for it doesn't have :version :newest
:when p :collect p) (and u (equal (truename* u) (truename* f)) u)))
entries)) :when p :collect p)
entries)
:test 'pathname-equal))
   
(defun directory-files (directory &optional (pattern *wild-file*)) (defun directory-files (directory &optional (pattern *wild-file*))
"Return a list of the files in a directory according to the PATTERN, "Return a list of the files in a directory according to the PATTERN.
which is not very portable to override. Try not resolve symlinks if implementation allows." Subdirectories should NOT be returned.
PATTERN defaults to a pattern carefully chosen based on the implementation;
override the default at your own risk.
DIRECTORY-FILES tries NOT to resolve symlinks if the implementation
permits this."
(let ((dir (pathname directory))) (let ((dir (pathname directory)))
(when (logical-pathname-p dir) (when (logical-pathname-p dir)
;; Because of the filtering we do below, ;; Because of the filtering we do below,
...@@ -2870,13 +2895,14 @@ which is not very portable to override. Try not resolve symlinks if implementati ...@@ -2870,13 +2895,14 @@ which is not very portable to override. Try not resolve symlinks if implementati
#+clisp #+clisp
(when (equal :wild (pathname-type pattern)) (when (equal :wild (pathname-type pattern))
(ignore-errors (directory* (make-pathname :type nil :defaults pat))))))) (ignore-errors (directory* (make-pathname :type nil :defaults pat)))))))
(filter-logical-directory-results (remove-if 'directory-pathname-p
directory entries (filter-logical-directory-results
#'(lambda (f) directory entries
(make-pathname :defaults dir #'(lambda (f)
:name (make-pathname-component-logical (pathname-name f)) (make-pathname :defaults dir
:type (make-pathname-component-logical (pathname-type f)) :name (make-pathname-component-logical (pathname-name f))
:version (make-pathname-component-logical (pathname-version f)))))))) :type (make-pathname-component-logical (pathname-type f))
:version (make-pathname-component-logical (pathname-version f)))))))))
   
(defun subdirectories (directory) (defun subdirectories (directory)
"Given a DIRECTORY pathname designator, return a list of the subdirectories under it." "Given a DIRECTORY pathname designator, return a list of the subdirectories under it."
...@@ -4576,35 +4602,27 @@ Programmers are encouraged to define their own methods for this generic function ...@@ -4576,35 +4602,27 @@ Programmers are encouraged to define their own methods for this generic function
:linewise linewise :prefix prefix :element-type element-type :buffer-size buffer-size)) :linewise linewise :prefix prefix :element-type element-type :buffer-size buffer-size))
   
(defmethod slurp-input-stream ((x (eql 'string)) stream &key stripped) (defmethod slurp-input-stream ((x (eql 'string)) stream &key stripped)
(declare (ignorable x))
(slurp-stream-string stream :stripped stripped)) (slurp-stream-string stream :stripped stripped))
   
(defmethod slurp-input-stream ((x (eql :string)) stream &key stripped) (defmethod slurp-input-stream ((x (eql :string)) stream &key stripped)
(declare (ignorable x))
(slurp-stream-string stream :stripped stripped)) (slurp-stream-string stream :stripped stripped))
   
(defmethod slurp-input-stream ((x (eql :lines)) stream &key count) (defmethod slurp-input-stream ((x (eql :lines)) stream &key count)
(declare (ignorable x))
(slurp-stream-lines stream :count count)) (slurp-stream-lines stream :count count))
   
(defmethod slurp-input-stream ((x (eql :line)) stream &key (at 0)) (defmethod slurp-input-stream ((x (eql :line)) stream &key (at 0))
(declare (ignorable x))
(slurp-stream-line stream :at at)) (slurp-stream-line stream :at at))
   
(defmethod slurp-input-stream ((x (eql :forms)) stream &key count) (defmethod slurp-input-stream ((x (eql :forms)) stream &key count)
(declare (ignorable x))
(slurp-stream-forms stream :count count)) (slurp-stream-forms stream :count count))
   
(defmethod slurp-input-stream ((x (eql :form)) stream &key (at 0)) (defmethod slurp-input-stream ((x (eql :form)) stream &key (at 0))
(declare (ignorable x))
(slurp-stream-form stream :at at)) (slurp-stream-form stream :at at))
   
(defmethod slurp-input-stream ((x (eql t)) stream &rest keys &key &allow-other-keys) (defmethod slurp-input-stream ((x (eql t)) stream &rest keys &key &allow-other-keys)
(declare (ignorable x))
(apply 'slurp-input-stream *standard-output* stream keys)) (apply 'slurp-input-stream *standard-output* stream keys))
   
(defmethod slurp-input-stream ((x null) stream &key) (defmethod slurp-input-stream ((x null) (stream t) &key)
(declare (ignorable x stream))
nil) nil)
   
(defmethod slurp-input-stream ((pathname pathname) input (defmethod slurp-input-stream ((pathname pathname) input
...@@ -4679,11 +4697,9 @@ Programmers are encouraged to define their own methods for this generic function ...@@ -4679,11 +4697,9 @@ Programmers are encouraged to define their own methods for this generic function
(values)) (values))
   
(defmethod vomit-output-stream ((x (eql t)) stream &rest keys &key &allow-other-keys) (defmethod vomit-output-stream ((x (eql t)) stream &rest keys &key &allow-other-keys)
(declare (ignorable x))
(apply 'vomit-output-stream *standard-input* stream keys)) (apply 'vomit-output-stream *standard-input* stream keys))
   
(defmethod vomit-output-stream ((x null) stream &key) (defmethod vomit-output-stream ((x null) (stream t) &key)
(declare (ignorable x stream))
(values)) (values))
   
(defmethod vomit-output-stream ((pathname pathname) input (defmethod vomit-output-stream ((pathname pathname) input
...@@ -6418,7 +6434,7 @@ directive.") ...@@ -6418,7 +6434,7 @@ directive.")
;;;; Handle upgrade as forward- and backward-compatibly as possible ;;;; Handle upgrade as forward- and backward-compatibly as possible
;; See https://bugs.launchpad.net/asdf/+bug/485687 ;; See https://bugs.launchpad.net/asdf/+bug/485687
   
(asdf/package:define-package :asdf/upgrade (uiop/package:define-package :asdf/upgrade
(:recycle :asdf/upgrade :asdf) (:recycle :asdf/upgrade :asdf)
(:use :uiop/common-lisp :uiop) (:use :uiop/common-lisp :uiop)
(:export (:export
...@@ -6428,7 +6444,7 @@ directive.") ...@@ -6428,7 +6444,7 @@ directive.")
#:*post-upgrade-cleanup-hook* #:*post-upgrade-restart-hook* #:cleanup-upgraded-asdf #:*post-upgrade-cleanup-hook* #:*post-upgrade-restart-hook* #:cleanup-upgraded-asdf
;; There will be no symbol left behind! ;; There will be no symbol left behind!
#:intern*) #:intern*)
(:import-from :asdf/package #:intern* #:find-symbol*)) (:import-from :uiop/package #:intern* #:find-symbol*))
(in-package :asdf/upgrade) (in-package :asdf/upgrade)
   
;;; Special magic to detect if this is an upgrade ;;; Special magic to detect if this is an upgrade
...@@ -6467,6 +6483,8 @@ You can compare this string with e.g.: (ASDF:VERSION-SATISFIES (ASDF:ASDF-VERSIO ...@@ -6467,6 +6483,8 @@ You can compare this string with e.g.: (ASDF:VERSION-SATISFIES (ASDF:ASDF-VERSIO
(defun upgrading-p () (defun upgrading-p ()
(and *previous-asdf-versions* (not (equal *asdf-version* (first *previous-asdf-versions*))))) (and *previous-asdf-versions* (not (equal *asdf-version* (first *previous-asdf-versions*)))))
(defmacro when-upgrading ((&key (upgrading-p '(upgrading-p)) when) &body body) (defmacro when-upgrading ((&key (upgrading-p '(upgrading-p)) when) &body body)
"A wrapper macro for code that should only be run when upgrading a
previously-loaded version of ASDF."
`(with-upgradability () `(with-upgradability ()
(when (and ,upgrading-p ,@(when when `(,when))) (when (and ,upgrading-p ,@(when when `(,when)))
(handler-bind ((style-warning #'muffle-warning)) (handler-bind ((style-warning #'muffle-warning))
...@@ -6480,7 +6498,7 @@ You can compare this string with e.g.: (ASDF:VERSION-SATISFIES (ASDF:ASDF-VERSIO ...@@ -6480,7 +6498,7 @@ You can compare this string with e.g.: (ASDF:VERSION-SATISFIES (ASDF:ASDF-VERSIO
;; "3.4.5.67" would be a development version in the official branch, on top of 3.4.5. ;; "3.4.5.67" would be a development version in the official branch, on top of 3.4.5.
;; "3.4.5.0.8" would be your eighth local modification of official release 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 ;; "3.4.5.67.8" would be your eighth local modification of development version 3.4.5.67
(asdf-version "3.1.0.49") (asdf-version "3.1.0.65")
(existing-version (asdf-version))) (existing-version (asdf-version)))
(setf *asdf-version* asdf-version) (setf *asdf-version* asdf-version)
(when (and existing-version (not (equal asdf-version existing-version))) (when (and existing-version (not (equal asdf-version existing-version)))
...@@ -6514,8 +6532,7 @@ You can compare this string with e.g.: (ASDF:VERSION-SATISFIES (ASDF:ASDF-VERSIO ...@@ -6514,8 +6532,7 @@ You can compare this string with e.g.: (ASDF:VERSION-SATISFIES (ASDF:ASDF-VERSIO
#:component-self-dependencies #:component-self-dependencies
#:resolve-relative-location-component #:resolve-absolute-location-component #:resolve-relative-location-component #:resolve-absolute-location-component
#:output-files-for-system-and-operation))) ; obsolete ASDF-BINARY-LOCATION function #:output-files-for-system-and-operation))) ; obsolete ASDF-BINARY-LOCATION function
(declare (ignorable redefined-functions uninterned-symbols)) (loop :for name :in redefined-functions
(loop :for name :in (append redefined-functions)
:for sym = (find-symbol* name :asdf nil) :do :for sym = (find-symbol* name :asdf nil) :do
(when sym (when sym
;; On CLISP we seem to be unable to fmakunbound and define a function in the same fasl. Sigh. ;; On CLISP we seem to be unable to fmakunbound and define a function in the same fasl. Sigh.
...@@ -6575,7 +6592,7 @@ You can compare this string with e.g.: (ASDF:VERSION-SATISFIES (ASDF:ASDF-VERSIO ...@@ -6575,7 +6592,7 @@ You can compare this string with e.g.: (ASDF:VERSION-SATISFIES (ASDF:ASDF-VERSIO
;;;; ------------------------------------------------------------------------- ;;;; -------------------------------------------------------------------------
;;;; Components ;;;; Components
   
(asdf/package:define-package :asdf/component (uiop/package:define-package :asdf/component
(:recycle :asdf/component :asdf/defsystem :asdf/find-system :asdf) (:recycle :asdf/component :asdf/defsystem :asdf/find-system :asdf)
(:use :uiop/common-lisp :uiop :asdf/upgrade) (:use :uiop/common-lisp :uiop :asdf/upgrade)
(:export (:export
...@@ -6635,7 +6652,7 @@ another pathname in a degenerate way.")) ...@@ -6635,7 +6652,7 @@ another pathname in a degenerate way."))
(defgeneric component-version (component)) (defgeneric component-version (component))
(defgeneric (setf component-version) (new-version component)) (defgeneric (setf component-version) (new-version component))
(defgeneric component-parent (component)) (defgeneric component-parent (component))
(defmethod component-parent ((component null)) (declare (ignorable component)) nil) (defmethod component-parent ((component null)) nil)
   
;; Backward compatible way of computing the FILE-TYPE of a component. ;; Backward compatible way of computing the FILE-TYPE of a component.
;; TODO: find users, have them stop using that, remove it for ASDF4. ;; TODO: find users, have them stop using that, remove it for ASDF4.
...@@ -6657,11 +6674,6 @@ another pathname in a degenerate way.")) ...@@ -6657,11 +6674,6 @@ another pathname in a degenerate way."))
(duplicate-names-name c)))))) (duplicate-names-name c))))))
   
   
(when-upgrading (:when (find-class 'component nil))
(defmethod reinitialize-instance :after ((c component) &rest initargs &key)
(declare (ignorable c initargs)) (values)))
(with-upgradability () (with-upgradability ()
(defclass component () (defclass component ()
((name :accessor component-name :initarg :name :type string :documentation ((name :accessor component-name :initarg :name :type string :documentation
...@@ -6716,6 +6728,8 @@ another pathname in a degenerate way.")) ...@@ -6716,6 +6728,8 @@ another pathname in a degenerate way."))
:initarg :build-operation :initform nil :reader component-build-operation))) :initarg :build-operation :initform nil :reader component-build-operation)))
   
(defun component-find-path (component) (defun component-find-path (component)
"Return a path from a root system to the COMPONENT.
The return value is a list of component NAMES; a list of strings."
(check-type component (or null component)) (check-type component (or null component))
(reverse (reverse
(loop :for c = component :then (component-parent c) (loop :for c = component :then (component-parent c)
...@@ -6734,7 +6748,9 @@ another pathname in a degenerate way.")) ...@@ -6734,7 +6748,9 @@ another pathname in a degenerate way."))
;;;; Component hierarchy within a system ;;;; Component hierarchy within a system
;; The tree typically but not necessarily follows the filesystem hierarchy. ;; The tree typically but not necessarily follows the filesystem hierarchy.
(with-upgradability () (with-upgradability ()
(defclass child-component (component) ()) (defclass child-component (component) ()
(:documentation "A CHILD-COMPONENT is a component that may be part of
a PARENT-COMPONENT."))
   
(defclass file-component (child-component) (defclass file-component (child-component)
((type :accessor file-type :initarg :type))) ; no default ((type :accessor file-type :initarg :type))) ; no default
...@@ -6763,7 +6779,9 @@ another pathname in a degenerate way.")) ...@@ -6763,7 +6779,9 @@ another pathname in a degenerate way."))
(default-component-class (default-component-class
:initform nil :initform nil
:initarg :default-component-class :initarg :default-component-class
:accessor module-default-component-class)))) :accessor module-default-component-class))
(:documentation "A PARENT-COMPONENT is a component that may have
children.")))
   
(with-upgradability () (with-upgradability ()
(defun compute-children-by-name (parent &key only-if-needed-p) (defun compute-children-by-name (parent &key only-if-needed-p)
...@@ -6777,19 +6795,6 @@ another pathname in a degenerate way.")) ...@@ -6777,19 +6795,6 @@ another pathname in a degenerate way."))
(setf (gethash name hash) c)) (setf (gethash name hash) c))
hash)))) 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 () (with-upgradability ()
(defclass module (child-component parent-component) (defclass module (child-component parent-component)
(#+clisp (components)))) ;; backward compatibility during upgrade only (#+clisp (components)))) ;; backward compatibility during upgrade only
...@@ -6815,9 +6820,10 @@ another pathname in a degenerate way.")) ...@@ -6815,9 +6820,10 @@ another pathname in a degenerate way."))
pathname))) pathname)))
   
(defmethod component-relative-pathname ((component component)) (defmethod component-relative-pathname ((component component))
;; source-file-type is backward-compatibility with ASDF1; ;; SOURCE-FILE-TYPE below is strictly for backward-compatibility with ASDF1.
;; we ought to be able to extract this from the component alone with COMPONENT-TYPE. ;; 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. ;; TODO: track who uses it, and have them not use it anymore;
;; maybe issue a WARNING (then eventually CERROR) if the two methods diverge?
(parse-unix-namestring (parse-unix-namestring
(or (and (slot-boundp component 'relative-pathname) (or (and (slot-boundp component 'relative-pathname)
(slot-value component 'relative-pathname)) (slot-value component 'relative-pathname))
...@@ -6826,12 +6832,10 @@ another pathname in a degenerate way.")) ...@@ -6826,12 +6832,10 @@ another pathname in a degenerate way."))
:type (source-file-type component (component-system component)) :type (source-file-type component (component-system component))
:defaults (component-parent-pathname component))) :defaults (component-parent-pathname component)))
   
(defmethod source-file-type ((component parent-component) system) (defmethod source-file-type ((component parent-component) (system parent-component))
(declare (ignorable component system))
:directory) :directory)
   
(defmethod source-file-type ((component file-component) system) (defmethod source-file-type ((component file-component) (system parent-component))
(declare (ignorable system))
(file-type component))) (file-type component)))
   
   
...@@ -6885,7 +6889,7 @@ another pathname in a degenerate way.")) ...@@ -6885,7 +6889,7 @@ another pathname in a degenerate way."))
;;;; ------------------------------------------------------------------------- ;;;; -------------------------------------------------------------------------
;;;; Systems ;;;; Systems
   
(asdf/package:define-package :asdf/system (uiop/package:define-package :asdf/system
(:recycle :asdf :asdf/system) (:recycle :asdf :asdf/system)
(:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/component) (:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/component)
(:export (:export
...@@ -6913,7 +6917,6 @@ another pathname in a degenerate way.")) ...@@ -6913,7 +6917,6 @@ another pathname in a degenerate way."))
   
(defgeneric component-entry-point (component)) (defgeneric component-entry-point (component))
(defmethod component-entry-point ((c component)) (defmethod component-entry-point ((c component))
(declare (ignorable c))
nil)) nil))
   
   
...@@ -6990,13 +6993,12 @@ in which the system specification (.asd file) is located." ...@@ -6990,13 +6993,12 @@ in which the system specification (.asd file) is located."
(system-source-directory system)) (system-source-directory system))
   
(defmethod component-build-pathname ((c component)) (defmethod component-build-pathname ((c component))
(declare (ignorable c))
nil)) nil))
   
;;;; ------------------------------------------------------------------------- ;;;; -------------------------------------------------------------------------
;;;; Stamp cache ;;;; Stamp cache
   
(asdf/package:define-package :asdf/cache (uiop/package:define-package :asdf/cache
(:use :uiop/common-lisp :uiop :asdf/upgrade) (:use :uiop/common-lisp :uiop :asdf/upgrade)
(:export #:get-file-stamp #:compute-file-stamp #:register-file-stamp (:export #:get-file-stamp #:compute-file-stamp #:register-file-stamp
#:consult-asdf-cache #:do-asdf-cache #:normalize-namestring #:consult-asdf-cache #:do-asdf-cache #:normalize-namestring
...@@ -7061,7 +7063,7 @@ in which the system specification (.asd file) is located." ...@@ -7061,7 +7063,7 @@ in which the system specification (.asd file) is located."
;;;; ------------------------------------------------------------------------- ;;;; -------------------------------------------------------------------------
;;;; Finding systems ;;;; Finding systems
   
(asdf/package:define-package :asdf/find-system (uiop/package:define-package :asdf/find-system
(:recycle :asdf/find-system :asdf) (:recycle :asdf/find-system :asdf)
(:use :uiop/common-lisp :uiop :asdf/upgrade (:use :uiop/common-lisp :uiop :asdf/upgrade
:asdf/component :asdf/system :asdf/cache) :asdf/component :asdf/system :asdf/cache)
...@@ -7306,7 +7308,6 @@ Going forward, we recommend new users should be using the source-registry. ...@@ -7306,7 +7308,6 @@ Going forward, we recommend new users should be using the source-registry.
(register-preloaded-system s :version *asdf-version*)) (register-preloaded-system s :version *asdf-version*))
   
(defmethod find-system ((name null) &optional (error-p t)) (defmethod find-system ((name null) &optional (error-p t))
(declare (ignorable name))
(when error-p (when error-p
(sysdef-error (compatfmt "~@<NIL is not a valid system name~@:>")))) (sysdef-error (compatfmt "~@<NIL is not a valid system name~@:>"))))
   
...@@ -7483,7 +7484,7 @@ PREVIOUS-TIME when not null is the time at which the PREVIOUS system was loaded. ...@@ -7483,7 +7484,7 @@ PREVIOUS-TIME when not null is the time at which the PREVIOUS system was loaded.
;;;; ------------------------------------------------------------------------- ;;;; -------------------------------------------------------------------------
;;;; Finding components ;;;; Finding components
   
(asdf/package:define-package :asdf/find-component (uiop/package:define-package :asdf/find-component
(:recycle :asdf/find-component :asdf) (:recycle :asdf/find-component :asdf)
(:use :uiop/common-lisp :uiop :asdf/upgrade (:use :uiop/common-lisp :uiop :asdf/upgrade
:asdf/component :asdf/system :asdf/find-system) :asdf/component :asdf/system :asdf/find-system)
...@@ -7561,8 +7562,7 @@ PREVIOUS-TIME when not null is the time at which the PREVIOUS system was loaded. ...@@ -7561,8 +7562,7 @@ PREVIOUS-TIME when not null is the time at which the PREVIOUS system was loaded.
(defmethod find-component ((c component) (name cons)) (defmethod find-component ((c component) (name cons))
(find-component (find-component c (car name)) (cdr name))) (find-component (find-component c (car name)) (cdr name)))
   
(defmethod find-component (base (actual component)) (defmethod find-component ((base t) (actual component))
(declare (ignorable base))
actual) actual)
   
(defun resolve-dependency-name (component name &optional version) (defun resolve-dependency-name (component name &optional version)
...@@ -7602,41 +7602,41 @@ PREVIOUS-TIME when not null is the time at which the PREVIOUS system was loaded. ...@@ -7602,41 +7602,41 @@ PREVIOUS-TIME when not null is the time at which the PREVIOUS system was loaded.
(cons combinator arguments) component)) (cons combinator arguments) component))
   
(defmethod resolve-dependency-combination (component (combinator (eql :feature)) arguments) (defmethod resolve-dependency-combination (component (combinator (eql :feature)) arguments)
(declare (ignorable combinator))
(when (featurep (first arguments)) (when (featurep (first arguments))
(resolve-dependency-spec component (second arguments)))) (resolve-dependency-spec component (second arguments))))
   
(defmethod resolve-dependency-combination (component (combinator (eql :version)) arguments) (defmethod resolve-dependency-combination (component (combinator (eql :version)) arguments)
(declare (ignorable combinator)) ;; See https://bugs.launchpad.net/asdf/+bug/527788 (resolve-dependency-name component (first arguments) (second arguments)))) ;; See lp#527788
(resolve-dependency-name component (first arguments) (second arguments))))
   
;;;; ------------------------------------------------------------------------- ;;;; -------------------------------------------------------------------------
;;;; Operations ;;;; Operations
   
(asdf/package:define-package :asdf/operation (uiop/package:define-package :asdf/operation
(:recycle :asdf/operation :asdf/action :asdf) ;; asdf/action for FEATURE pre 2.31.5. (:recycle :asdf/operation :asdf/action :asdf) ;; asdf/action for FEATURE pre 2.31.5.
(:use :uiop/common-lisp :uiop :asdf/upgrade) (:use :uiop/common-lisp :uiop :asdf/upgrade)
(:export (:export
#:operation #:operation
#:operation-original-initargs #:original-initargs ;; backward-compatibility only. DO NOT USE. #:operation-original-initargs #:original-initargs ;; backward-compatibility only. DO NOT USE.
#:build-op ;; THE generic operation
#:*operations* #:make-operation #:find-operation #:feature)) #:*operations* #:make-operation #:find-operation #:feature))
(in-package :asdf/operation) (in-package :asdf/operation)
   
;;; Operation Classes ;;; Operation Classes
   
(when-upgrading (:when (find-class 'operation nil)) (when-upgrading (:when (find-class 'operation nil))
(defmethod shared-initialize :after ((o operation) slot-names &rest initargs &key) ;; override any obsolete shared-initialize method when upgrading from ASDF2.
(declare (ignorable o slot-names initargs)) (values))) (defmethod shared-initialize :after ((o operation) (slot-names t) &key)
(values)))
   
(with-upgradability () (with-upgradability ()
(defclass operation () (defclass operation ()
((original-initargs ;; for backward-compat -- used by GBBopen and swank (via operation-forced) ((original-initargs ;; for backward-compat -- used by GBBopen and swank (via operation-forced)
:initform nil :initarg :original-initargs :accessor operation-original-initargs))) :initform nil :initarg :original-initargs :accessor operation-original-initargs)))
   
;; Cache a copy of the INITARGS in the ORIGINAL-INITARGS slot, if that slot is not
;; already bound.
(defmethod initialize-instance :after ((o operation) &rest initargs (defmethod initialize-instance :after ((o operation) &rest initargs
&key force force-not system verbose &allow-other-keys) &key force force-not system verbose &allow-other-keys)
(declare (ignorable force force-not system verbose)) (declare (ignore force force-not system verbose))
(unless (slot-boundp o 'original-initargs)