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.
You can find the latest version of this manual at
@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
a copy of this software and associated documentation files (the
......@@ -173,7 +173,7 @@ the ASDF internals and how to extend ASDF.
@emph{Nota Bene}:
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
in all actively maintained CL implementations that used to bundle ASDF 1,
plus some implementations that didn't use to,
......
;;; -*- mode: Common-Lisp; Base: 10 ; Syntax: ANSI-Common-Lisp -*-
;;; This is ASDF 3.1.0.49: Another System Definition Facility.
;;; -*- mode: Common-Lisp; Base: 10 ; Syntax: ANSI-Common-Lisp ; buffer-read-only: t; -*-
;;; This is ASDF 3.1.0.65: Another System Definition Facility.
;;;
;;; Feedback, bug reports, and patches are all welcome:
;;; please mail to <asdf-devel@common-lisp.net>.
......@@ -53,6 +53,13 @@
(eval-when (:load-toplevel :compile-toplevel :execute)
(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.
(eval-when (:load-toplevel :compile-toplevel :execute)
(unless (member :asdf3 *features*)
......@@ -71,7 +78,8 @@
(away (format nil "~A-~A" :asdf existing-version)))
(when (and existing-version
(< 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)
(when *load-verbose*
(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,
Note that this does _not_ check to see that PATHNAME points to an
actually-existing directory."
(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)))
(flet ((check-one (x)
(member x '(nil :unspecific "") :test 'equal)))
......@@ -2811,6 +2822,13 @@ or the original (parsed) pathname if it is false (the default)."
 
(defun directory-exists-p (x)
"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)))
(and (directory-pathname-p p) p)))
 
......@@ -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
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."
(if (logical-pathname-p directory)
;; 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 (logical-pathname-p f) f)
(let* ((u (ignore-errors (call-function merger f))))
;; The first u avoids a cumbersome (truename u) error.
;; At this point f should already be a truename,
;; but isn't quite in CLISP, for it doesn't have :version :newest
(and u (equal (truename* u) (truename* f)) u)))
:when p :collect p)
entries))
(remove-duplicates ;; on CLISP, querying ~/ will return duplicates
(if (logical-pathname-p directory)
;; 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 (logical-pathname-p f) f)
(let* ((u (ignore-errors (call-function merger f))))
;; The first u avoids a cumbersome (truename u) error.
;; At this point f should already be a truename,
;; but isn't quite in CLISP, for it doesn't have :version :newest
(and u (equal (truename* u) (truename* f)) u)))
:when p :collect p)
entries)
:test 'pathname-equal))
 
(defun directory-files (directory &optional (pattern *wild-file*))
"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."
"Return a list of the files in a directory according to the PATTERN.
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)))
(when (logical-pathname-p dir)
;; Because of the filtering we do below,
......@@ -2870,13 +2895,14 @@ which is not very portable to override. Try not resolve symlinks if implementati
#+clisp
(when (equal :wild (pathname-type pattern))
(ignore-errors (directory* (make-pathname :type nil :defaults pat)))))))
(filter-logical-directory-results
directory entries
#'(lambda (f)
(make-pathname :defaults dir
:name (make-pathname-component-logical (pathname-name f))
:type (make-pathname-component-logical (pathname-type f))
:version (make-pathname-component-logical (pathname-version f))))))))
(remove-if 'directory-pathname-p
(filter-logical-directory-results
directory entries
#'(lambda (f)
(make-pathname :defaults dir
:name (make-pathname-component-logical (pathname-name f))
:type (make-pathname-component-logical (pathname-type f))
:version (make-pathname-component-logical (pathname-version f)))))))))
 
(defun subdirectories (directory)
"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
:linewise linewise :prefix prefix :element-type element-type :buffer-size buffer-size))
 
(defmethod slurp-input-stream ((x (eql 'string)) stream &key stripped)
(declare (ignorable x))
(slurp-stream-string stream :stripped stripped))
 
(defmethod slurp-input-stream ((x (eql :string)) stream &key stripped)
(declare (ignorable x))
(slurp-stream-string stream :stripped stripped))
 
(defmethod slurp-input-stream ((x (eql :lines)) stream &key count)
(declare (ignorable x))
(slurp-stream-lines stream :count count))
 
(defmethod slurp-input-stream ((x (eql :line)) stream &key (at 0))
(declare (ignorable x))
(slurp-stream-line stream :at at))
 
(defmethod slurp-input-stream ((x (eql :forms)) stream &key count)
(declare (ignorable x))
(slurp-stream-forms stream :count count))
 
(defmethod slurp-input-stream ((x (eql :form)) stream &key (at 0))
(declare (ignorable x))
(slurp-stream-form stream :at at))
 
(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))
 
(defmethod slurp-input-stream ((x null) stream &key)
(declare (ignorable x stream))
(defmethod slurp-input-stream ((x null) (stream t) &key)
nil)
 
(defmethod slurp-input-stream ((pathname pathname) input
......@@ -4679,11 +4697,9 @@ Programmers are encouraged to define their own methods for this generic function
(values))
 
(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))
 
(defmethod vomit-output-stream ((x null) stream &key)
(declare (ignorable x stream))
(defmethod vomit-output-stream ((x null) (stream t) &key)
(values))
 
(defmethod vomit-output-stream ((pathname pathname) input
......@@ -6418,7 +6434,7 @@ directive.")
;;;; Handle upgrade as forward- and backward-compatibly as possible
;; See https://bugs.launchpad.net/asdf/+bug/485687
 
(asdf/package:define-package :asdf/upgrade
(uiop/package:define-package :asdf/upgrade
(:recycle :asdf/upgrade :asdf)
(:use :uiop/common-lisp :uiop)
(:export
......@@ -6428,7 +6444,7 @@ directive.")
#:*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*))
(:import-from :uiop/package #:intern* #:find-symbol*))
(in-package :asdf/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
(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)
"A wrapper macro for code that should only be run when upgrading a
previously-loaded version of ASDF."
`(with-upgradability ()
(when (and ,upgrading-p ,@(when when `(,when)))
(handler-bind ((style-warning #'muffle-warning))
......@@ -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.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 "3.1.0.49")
(asdf-version "3.1.0.65")
(existing-version (asdf-version)))
(setf *asdf-version* asdf-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
#:component-self-dependencies
#: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 redefined-functions)
(loop :for name :in redefined-functions
:for sym = (find-symbol* name :asdf nil) :do
(when sym
;; 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
;;;; -------------------------------------------------------------------------
;;;; Components
 
(asdf/package:define-package :asdf/component
(uiop/package:define-package :asdf/component
(:recycle :asdf/component :asdf/defsystem :asdf/find-system :asdf)
(:use :uiop/common-lisp :uiop :asdf/upgrade)
(:export
......@@ -6635,7 +6652,7 @@ another pathname in a degenerate way."))
(defgeneric component-version (component))
(defgeneric (setf component-version) (new-version 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.
;; TODO: find users, have them stop using that, remove it for ASDF4.
......@@ -6657,11 +6674,6 @@ another pathname in a degenerate way."))
(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 ()
(defclass component ()
((name :accessor component-name :initarg :name :type string :documentation
......@@ -6716,6 +6728,8 @@ another pathname in a degenerate way."))
:initarg :build-operation :initform nil :reader component-build-operation)))
 
(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))
(reverse
(loop :for c = component :then (component-parent c)
......@@ -6734,7 +6748,9 @@ another pathname in a degenerate way."))
;;;; Component hierarchy within a system
;; The tree typically but not necessarily follows the filesystem hierarchy.
(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)
((type :accessor file-type :initarg :type))) ; no default
......@@ -6763,7 +6779,9 @@ another pathname in a degenerate way."))
(default-component-class
:initform nil
: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 ()
(defun compute-children-by-name (parent &key only-if-needed-p)
......@@ -6777,19 +6795,6 @@ another pathname in a degenerate way."))
(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
......@@ -6815,9 +6820,10 @@ another pathname in a degenerate way."))
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.
;; 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.
;; 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
(or (and (slot-boundp component 'relative-pathname)
(slot-value component 'relative-pathname))
......@@ -6826,12 +6832,10 @@ another pathname in a degenerate way."))
: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))
(defmethod source-file-type ((component parent-component) (system parent-component))
:directory)
 
(defmethod source-file-type ((component file-component) system)
(declare (ignorable system))
(defmethod source-file-type ((component file-component) (system parent-component))
(file-type component)))
 
 
......@@ -6885,7 +6889,7 @@ another pathname in a degenerate way."))
;;;; -------------------------------------------------------------------------
;;;; Systems
 
(asdf/package:define-package :asdf/system
(uiop/package:define-package :asdf/system
(:recycle :asdf :asdf/system)
(:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/component)
(:export
......@@ -6913,7 +6917,6 @@ another pathname in a degenerate way."))
 
(defgeneric component-entry-point (component))
(defmethod component-entry-point ((c component))
(declare (ignorable c))
nil))
 
 
......@@ -6990,13 +6993,12 @@ in which the system specification (.asd file) is located."
(system-source-directory system))
 
(defmethod component-build-pathname ((c component))
(declare (ignorable c))
nil))
 
;;;; -------------------------------------------------------------------------
;;;; Stamp cache
 
(asdf/package:define-package :asdf/cache
(uiop/package:define-package :asdf/cache
(:use :uiop/common-lisp :uiop :asdf/upgrade)
(:export #:get-file-stamp #:compute-file-stamp #:register-file-stamp
#:consult-asdf-cache #:do-asdf-cache #:normalize-namestring
......@@ -7061,7 +7063,7 @@ in which the system specification (.asd file) is located."
;;;; -------------------------------------------------------------------------
;;;; Finding systems
 
(asdf/package:define-package :asdf/find-system
(uiop/package:define-package :asdf/find-system
(:recycle :asdf/find-system :asdf)
(:use :uiop/common-lisp :uiop :asdf/upgrade
:asdf/component :asdf/system :asdf/cache)
......@@ -7306,7 +7308,6 @@ Going forward, we recommend new users should be using the source-registry.
(register-preloaded-system s :version *asdf-version*))
 
(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~@:>"))))
 
......@@ -7483,7 +7484,7 @@ PREVIOUS-TIME when not null is the time at which the PREVIOUS system was loaded.
;;;; -------------------------------------------------------------------------
;;;; Finding components
 
(asdf/package:define-package :asdf/find-component
(uiop/package:define-package :asdf/find-component
(:recycle :asdf/find-component :asdf)
(:use :uiop/common-lisp :uiop :asdf/upgrade
: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.
(defmethod find-component ((c component) (name cons))
(find-component (find-component c (car name)) (cdr name)))
 
(defmethod find-component (base (actual component))
(declare (ignorable base))
(defmethod find-component ((base t) (actual component))
actual)
 
(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.
(cons combinator arguments) component))
 
(defmethod resolve-dependency-combination (component (combinator (eql :feature)) arguments)
(declare (ignorable combinator))
(when (featurep (first arguments))
(resolve-dependency-spec component (second 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))))
(resolve-dependency-name component (first arguments) (second arguments)))) ;; See lp#527788
 
;;;; -------------------------------------------------------------------------
;;;; 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.
(:use :uiop/common-lisp :uiop :asdf/upgrade)
(:export
#:operation
#:operation-original-initargs #:original-initargs ;; backward-compatibility only. DO NOT USE.
#:build-op ;; THE generic operation
#:*operations* #:make-operation #:find-operation #:feature))
(in-package :asdf/operation)
 
;;; Operation Classes
 
(when-upgrading (:when (find-class 'operation nil))
(defmethod shared-initialize :after ((o operation) slot-names &rest initargs &key)
(declare (ignorable o slot-names initargs)) (values)))
;; override any obsolete shared-initialize method when upgrading from ASDF2.
(defmethod shared-initialize :after ((o operation) (slot-names t) &key)
(values)))
 
(with-upgradability ()
(defclass operation ()
((original-initargs ;; for backward-compat -- used by GBBopen and swank (via operation-forced)
: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
&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)
(setf (operation-original-initargs o) initargs)))
 
......@@ -7656,8 +7656,7 @@ PREVIOUS-TIME when not null is the time at which the PREVIOUS system was loaded.
 
(defgeneric find-operation (context spec)
(:documentation "Find an operation by resolving the SPEC in the CONTEXT"))
(defmethod find-operation (context (spec operation))
(declare (ignorable context))
(defmethod find-operation ((context t) (spec operation))
spec)
(defmethod find-operation (context (spec symbol))
(unless (member spec '(nil feature))
......@@ -7666,15 +7665,12 @@ PREVIOUS-TIME when not null is the time at which the PREVIOUS system was loaded.
(apply 'make-operation spec (operation-original-initargs context))))
(defmethod operation-original-initargs ((context symbol))
(declare (ignorable context))
nil)
(defclass build-op (operation) ()))
nil))
 
;;;; -------------------------------------------------------------------------
;;;; Actions
 
(asdf/package:define-package :asdf/action
(uiop/package:define-package :asdf/action
(:nicknames :asdf-action)
(:recycle :asdf/action :asdf)
(:use :uiop/common-lisp :uiop :asdf/upgrade
......@@ -7682,14 +7678,17 @@ PREVIOUS-TIME when not null is the time at which the PREVIOUS system was loaded.
(:export
#:action #:define-convenience-action-methods
#:explain #:action-description
#:downward-operation #:upward-operation #:sideway-operation #:selfward-operation
#:downward-operation #:upward-operation #:sideway-operation #:selfward-operation #:non-propagating-operation
#:component-depends-on
#:input-files #:output-files #:output-file #:operation-done-p
#:action-status #:action-stamp #:action-done-p
#:component-operation-time #:mark-operation-done #:compute-action-stamp
#:perform #:perform-with-restarts #:retry #:accept
#:traverse-actions #:traverse-sub-actions #:required-components ;; in plan
#:action-path #:find-action #:stamp #:done-p))
#:action-path #:find-action #:stamp #:done-p
#:operation-definition-warning #:operation-definition-error ;; condition
#:build-op ;; THE generic operation
))
(in-package :asdf/action)
 
(eval-when (#-lispworks :compile-toplevel :load-toplevel :execute) ;; LispWorks issues spurious warning
......@@ -7785,7 +7784,14 @@ You can put together sentences using this phrase."))
and each <component> is a component designator with respect to
FIND-COMPONENT in the context of the COMPONENT argument,
and means that the component depends on
<operation> having been performed on each <component>; or
<operation> having been performed on each <component>;
[Note: an <operation> is an operation designator -- it can be either an
operation name or an operation object. Similarly, a <component> may be
a component name or a component object. Also note that, the degenerate
case of (<operation>) is a no-op.]
or
 
(FEATURE <feature>), which means that the component depends
on the <feature> expression satisfying FEATUREP.
......@@ -7797,10 +7803,7 @@ You can put together sentences using this phrase."))
 
(defmethod component-depends-on :around ((o operation) (c component))
(do-asdf-cache `(component-depends-on ,o ,c)
(call-next-method)))
(defmethod component-depends-on ((o operation) (c component))
(cdr (assoc (type-of o) (component-in-order-to c))))) ; User-specified in-order dependencies
(call-next-method))))
 
 
;;;; upward-operation, downward-operation, sideway-operation, selfward-operation
......@@ -7816,8 +7819,10 @@ the action (O . M) of O on module M will depends on each of (D . C) for each chi
The default value for slot DOWNWARD-OPERATION is NIL, which designates the operation O itself.
E.g. in order for a MODULE to be loaded with LOAD-OP (resp. compiled with COMPILE-OP), all the
children of the MODULE must have been loaded with LOAD-OP (resp. compiled with COMPILE-OP."))
(defun downward-operation-depends-on (o c)
`((,(or (downward-operation o) o) ,@(component-children c))))
(defmethod component-depends-on ((o downward-operation) (c parent-component))
`((,(or (downward-operation o) o) ,@(component-children c)) ,@(call-next-method)))
`(,@(downward-operation-depends-on o c) ,@(call-next-method)))
 
(defclass upward-operation (operation)
((upward-operation
......@@ -7831,9 +7836,10 @@ E.g. in order for a COMPONENT to be prepared for loading or compiling with PREPA
must first be prepared for loading or compiling with PREPARE-OP."))
;; For backward-compatibility reasons, a system inherits from module and is a child-component
;; so we must guard against this case. ASDF4: remove that.
(defun upward-operation-depends-on (o c)
(if-let (p (component-parent c)) `((,(or (upward-operation o) o) ,p))))
(defmethod component-depends-on ((o upward-operation) (c child-component))
`(,@(if-let (p (component-parent c))
`((,(or (upward-operation o) o) ,p))) ,@(call-next-method)))
`(,@(upward-operation-depends-on o c) ,@(call-next-method)))
 
(defclass sideway-operation (operation)
((sideway-operation
......@@ -7845,11 +7851,12 @@ designates operation S (where NIL designates O itself), then the action (O . C)
depends on each of (S . D) where D is a declared dependency of C.
E.g. in order for a COMPONENT to be prepared for loading or compiling with PREPARE-OP,
each of its declared dependencies must first be loaded as by LOAD-OP."))
(defmethod component-depends-on ((o sideway-operation) (c component))
(defun sideway-operation-depends-on (o c)
`((,(or (sideway-operation o) o)
,@(loop :for dep :in (component-sideway-dependencies c)
:collect (resolve-dependency-spec c dep)))
,@(call-next-method)))
:collect (resolve-dependency-spec c dep)))))
(defmethod component-depends-on ((o sideway-operation) (c component))
`(,@(sideway-operation-depends-on o c) ,@(call-next-method)))
 
(defclass selfward-operation (operation)
((selfward-operation
......@@ -7858,14 +7865,73 @@ each of its declared dependencies must first be loaded as by LOAD-OP."))
(:documentation "A SELFWARD-OPERATION depends on another operation on the same component.
I.e., if O is a SELFWARD-OPERATION, and its SELFWARD-OPERATION designates a list of operations L,
then the action (O . C) of O on component C depends on each (S . C) for S in L.
E.g. before a component may be loaded by LOAD-OP, it must have been compiled by COMPILE-OP.
A operation-designator designates a singleton list of the designated operation;
a list of operation-designators designates the list of designated operations;
NIL is not a valid operation designator in that context.
E.g. before a component may be loaded by LOAD-OP, it must have been compiled by COMPILE-OP."))
NIL is not a valid operation designator in that context. Note that any dependency
ordering between the operations in a list of SELFWARD-OPERATION should be specified separately
in the respective operation's COMPONENT-DEPENDS-ON methods so that they be scheduled properly."))
(defun selfward-operation-depends-on (o c)
(loop :for op :in (ensure-list (selfward-operation o)) :collect `(,op ,c)))
(defmethod component-depends-on ((o selfward-operation) (c component))
`(,@(loop :for op :in (ensure-list (selfward-operation o))
:collect `(,op ,c))
,@(call-next-method))))
`(,@(selfward-operation-depends-on o c) ,@(call-next-method)))
(defclass non-propagating-operation (operation)
()
(:documentation "A NON-PROPAGATING-OPERATION is an operation that propagates
no dependencies whatsoever. It is supplied in order that the programmer be able
to specify that s/he is intentionally specifying an operation which invokes no
dependencies.")))
;;;---------------------------------------------------------------------------
;;; Help programmers catch obsolete OPERATION subclasses
;;;---------------------------------------------------------------------------
(with-upgradability ()
(define-condition operation-definition-warning (simple-warning)
()
(:documentation "Warning condition related to definition of obsolete OPERATION objects."))
(define-condition operation-definition-error (simple-error)
()
(:documentation "Error condition related to definition of incorrect OPERATION objects."))
(defmethod initialize-instance :before ((o operation) &key)
;; build-op is a special case.
(unless (typep o '(or downward-operation upward-operation sideway-operation
selfward-operation non-propagating-operation))
(warn 'operation-definition-warning
:format-control
"No dependency propagating scheme specified for operation class ~S.
The class needs to be updated for ASDF 3.1 and specify appropriate propagation mixins."
:format-arguments (list (type-of o)))))
(defmethod initialize-instance :before ((o non-propagating-operation) &key)
(when (typep o '(or downward-operation upward-operation sideway-operation selfward-operation))
(error 'operation-definition-error
:format-control
"Inconsistent class: ~S
NON-PROPAGATING-OPERATION is incompatible with propagating operation classes as superclasses."
:format-arguments
(list (type-of o)))))
(defmethod component-depends-on ((o operation) (c component))
`(;; Normal behavior, to allow user-specified in-order-to dependencies
,@(cdr (assoc (type-of o) (component-in-order-to c)))
;; For backward-compatibility with ASDF2, any operation that doesn't specify propagation
;; or non-propagation through an appropriate mixin will be downward and sideway.
,@(unless (typep o '(or downward-operation upward-operation sideway-operation
selfward-operation non-propagating-operation))
`(,@(downward-operation-depends-on o c)
,@(sideway-operation-depends-on o c)))))
(defmethod downward-operation ((o operation)) nil)
(defmethod sideway-operation ((o operation)) nil))
;;;---------------------------------------------------------------------------
;;; End of OPERATION class checking
;;;---------------------------------------------------------------------------
 
 
;;;; Inputs, Outputs, and invisible dependencies
......@@ -7879,7 +7945,6 @@ E.g. before a component may be loaded by LOAD-OP, it must have been compiled by
(define-convenience-action-methods operation-done-p (operation component))
 
(defmethod operation-done-p ((o operation) (c component))
(declare (ignorable o c))