Commit d78df051 authored by Francois-Rene Rideau's avatar Francois-Rene Rideau Committed by Robert P. Goldman

2.28.1: various upgrade issues

1- To make life easier on Xach, stop requiring asdf.lisp to be loaded as source
before it's compiled. Instead, wrap each and every single form in an eval-when,
most of the time via the with-upgradability macro that also transforms
defun into defun* and defgeneric into defgeneric*.
Causes massive reindentation :-(

2- Have a proper :version for fallback systems.
Will make systems that check the version happier.

3- protect a condition with #+sb-eval. Fixes lp#1116408.

4- Protect warnings-file methods with dynamic when *warnings-file-type*
rather than static #+.
parent 6f3a8730
* implement deferred warnings support on abcl, allegro, clisp, cmucl, lispworks, scl)
* fix upgrade on clisp
** Extract minimal test case
* Bug found by fe[nl]ix: infinite loop if the definitions in an asd file
......
This diff is collapsed.
......@@ -29,9 +29,9 @@
:description "The defsystem part of ASDF"
:long-name "Another System Definition Facility"
:description "The portable defsystem for Common Lisp"
:long-description "ASDF/DEFSYSTEM is the standard DEFSYSTEM facility for Common Lisp,
:long-description "ASDF/DEFSYSTEM is the de facto standard DEFSYSTEM facility for Common Lisp,
a successor to Dan Barlow's ASDF and Francois-Rene Rideau's ASDF2.
For bootstrap purposes, it comes bundled with ASDF/DRIVER in a single file asdf.lisp."
For bootstrap purposes, it comes bundled with ASDF/DRIVER in a single file, asdf.lisp."
:homepage "http://common-lisp.net/projects/asdf/"
:bug-tracker "https://launchpad.net/asdf/"
:mailto "asdf-devel@common-lisp.net"
......@@ -74,25 +74,13 @@
:licence "MIT"
:description "Another System Definition Facility"
:long-description "ASDF builds Common Lisp software organized into defined systems."
:version "2.28" ;; to be automatically updated by make bump-version
:version "2.28.1" ;; to be automatically updated by make bump-version
:depends-on ()
#+asdf3 :encoding #+asdf3 :utf-8
;; For most purposes, asdf itself specially counts as a builtin system.
;; If you want to link it or do something forbidden to builtin systems,
;; specify separate dependencies on asdf-driver and asdf-defsystem.
#+asdf3 :builtin-system-p #+asdf3 t
:components
((:module "build"
:components
(#-gcl2.6
(:file "asdf"
#+asdf3 :in-order-to #+asdf3 ((compile-op (load-source-op "asdf")))))))
:in-order-to (#+asdf3 (prepare-source-op (monolithic-concatenate-source-op :asdf/defsystem))))
:components ((:module "build" :components ((:file "asdf"))))
:in-order-to (#+asdf3 (prepare-op (monolithic-concatenate-source-op :asdf/defsystem))))
;; Using :do-first instead of :in-order-to works above from ASDF 2.017 to 2.26,
;; but only this (or an equivalent defmethod component-do-first) works for ASDF1
#-asdf3
(setf (slot-value
(find-component (find-component (find-system "asdf") "build") "asdf")
'asdf::do-first)
'((compile-op (load-source-op "asdf"))))
......@@ -15,14 +15,15 @@
;;;; Backward compatibility with various pathname functions.
(defun* coerce-pathname (name &key type defaults)
(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
(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")
......@@ -35,5 +36,5 @@
unix-style-namestring))
(values relabs path filename)))
#+(or ecl mkcl)
(defun* compile-file-keeping-object (&rest args) (apply #'compile-file* args))
#+(or ecl mkcl)
(defun compile-file-keeping-object (&rest args) (apply #'compile-file* args)))
......@@ -20,38 +20,39 @@
#:system-definition-pathname))
(in-package :asdf/backward-interface)
(define-condition operation-error (error) ;; Bad, backward-compatible name
(with-upgradability ()
(define-condition operation-error (error) ;; Bad, backward-compatible name
;; Used by SBCL, cffi-tests, clsql-mysql, clsql-uffi, qt, elephant, uffi-tests, sb-grovel
((component :reader error-component :initarg :component)
(operation :reader error-operation :initarg :operation))
(:report (lambda (c s)
(format s (compatfmt "~@<~A while invoking ~A on ~A~@:>")
(type-of c) (error-operation c) (error-component c)))))
(define-condition compile-error (operation-error) ())
(define-condition compile-failed (compile-error) ())
(define-condition compile-warned (compile-error) ())
(define-condition compile-error (operation-error) ())
(define-condition compile-failed (compile-error) ())
(define-condition compile-warned (compile-error) ())
(defun* component-load-dependencies (component)
(defun component-load-dependencies (component)
;; Old deprecated name for the same thing. Please update your software.
(component-sibling-dependencies component))
(defgeneric* operation-forced (operation)) ;; Used by swank.asd for swank-loader.
(defmethod operation-forced ((o operation)) (getf (operation-original-initargs o) :force))
(defgeneric operation-forced (operation)) ;; Used by swank.asd for swank-loader.
(defmethod operation-forced ((o operation)) (getf (operation-original-initargs o) :force))
(defgeneric* operation-on-warnings (operation))
(defgeneric* operation-on-failure (operation))
#-gcl2.6 (defgeneric* (setf operation-on-warnings) (x operation))
#-gcl2.6 (defgeneric* (setf operation-on-failure) (x operation))
(defmethod operation-on-warnings ((o operation))
(defgeneric operation-on-warnings (operation))
(defgeneric operation-on-failure (operation))
#-gcl2.6 (defgeneric (setf operation-on-warnings) (x operation))
#-gcl2.6 (defgeneric (setf operation-on-failure) (x operation))
(defmethod operation-on-warnings ((o operation))
(declare (ignorable o)) *compile-file-warnings-behaviour*)
(defmethod operation-on-failure ((o operation))
(defmethod operation-on-failure ((o operation))
(declare (ignorable o)) *compile-file-failure-behaviour*)
(defmethod (setf operation-on-warnings) (x (o operation))
(defmethod (setf operation-on-warnings) (x (o operation))
(declare (ignorable o)) (setf *compile-file-warnings-behaviour* x))
(defmethod (setf operation-on-failure) (x (o operation))
(defmethod (setf operation-on-failure) (x (o operation))
(declare (ignorable o)) (setf *compile-file-failure-behaviour* x))
(defun* system-definition-pathname (x)
(defun system-definition-pathname (x)
;; As of 2.014.8, we mean to make this function obsolete,
;; but that won't happen until all clients have been updated.
;;(cerror "Use ASDF:SYSTEM-SOURCE-FILE instead"
......@@ -62,12 +63,13 @@ We recommend you use ASDF:SYSTEM-SOURCE-FILE instead
for a mostly compatible replacement that we're supporting,
or even ASDF:SYSTEM-SOURCE-DIRECTORY or ASDF:SYSTEM-RELATIVE-PATHNAME
if that's whay you mean." ;;)
(system-source-file x))
(system-source-file x)))
;;;; ASDF-Binary-Locations compatibility
(defun* enable-asdf-binary-locations-compatibility
;; This remains supported for legacy user, but not recommended for new users.
(with-upgradability ()
(defun enable-asdf-binary-locations-compatibility
(&key
(centralize-lisp-binaries nil)
(default-toplevel-directory
......@@ -105,7 +107,7 @@ if that's whay you mean." ;;)
(t t)
:ignore-inherited-configuration))))
(defmethod operate :before (operation-class system &rest args &key &allow-other-keys)
(defmethod operate :before (operation-class system &rest args &key &allow-other-keys)
(declare (ignorable operation-class system args))
(when (find-symbol* '#:output-files-for-system-and-operation :asdf nil)
(error "ASDF 2 is not compatible with ASDF-BINARY-LOCATIONS, which you are using.
......@@ -115,15 +117,14 @@ and instead use ASDF-OUTPUT-TRANSLATIONS. See the ASDF manual for details.
In case you insist on preserving your previous A-B-L configuration, but
do not know how to achieve the same effect with A-O-T, you may use function
ASDF:ENABLE-ASDF-BINARY-LOCATIONS-COMPATIBILITY as documented in the manual;
call that function where you would otherwise have loaded and configured A-B-L.")))
call that function where you would otherwise have loaded and configured A-B-L."))))
;;;; run-shell-command
;;
;; WARNING! The function below is dysfunctional and deprecated.
;;; run-shell-command
;; WARNING! The function below is not just deprecated but also dysfunctional.
;; Please use asdf/run-program:run-program instead.
;;
(defun* run-shell-command (control-string &rest args)
(with-upgradability ()
(defun run-shell-command (control-string &rest args)
"Interpolate ARGS into CONTROL-STRING as if by FORMAT, and
synchronously execute the result using a Bourne-compatible shell, with
output to *VERBOSE-OUT*. Returns the shell's exit code.
......@@ -133,21 +134,23 @@ Deprecated function, for backward-compatibility only.
Please use ASDF-DRIVER:RUN-PROGRAM instead."
(let ((command (apply 'format nil control-string args)))
(asdf-message "; $ ~A~%" command)
(run-program command :force-shell t :ignore-error-status t :output *verbose-out*)))
(run-program command :force-shell t :ignore-error-status t :output *verbose-out*))))
(defvar *asdf-verbose* nil) ;; backward-compatibility with ASDF2 only. Unused.
(with-upgradability ()
(defvar *asdf-verbose* nil)) ;; backward-compatibility with ASDF2 only. Unused.
;; backward-compatibility methods. Do NOT use in new code. NOT SUPPORTED.
(defgeneric* component-property (component property))
#-gcl2.6 (defgeneric* (setf component-property) (new-value component property))
(with-upgradability ()
(defgeneric component-property (component property))
(defgeneric (setf component-property) (new-value component property))
(defmethod component-property ((c component) property)
(defmethod component-property ((c component) property)
(cdr (assoc property (slot-value c 'properties) :test #'equal)))
(defmethod (setf component-property) (new-value (c component) property)
(defmethod (setf component-property) (new-value (c component) property)
(let ((a (assoc property (slot-value c 'properties) :test #'equal)))
(if a
(setf (cdr a) new-value)
(setf (slot-value c 'properties)
(acons property new-value (slot-value c 'properties)))))
new-value)
new-value))
......@@ -15,11 +15,11 @@
(in-package :asdf/backward-internals)
;;;; Backward compatibility with "inline methods"
(defparameter +asdf-methods+
(with-upgradability ()
(defparameter +asdf-methods+
'(perform-with-restarts perform explain output-files operation-done-p))
(defun* %remove-component-inline-methods (component)
(defun %remove-component-inline-methods (component)
(dolist (name +asdf-methods+)
(map ()
;; this is inefficient as most of the stored
......@@ -31,7 +31,7 @@
;; clear methods, then add the new ones
(component-inline-methods component) nil)
(defun* %define-component-inline-methods (ret rest)
(defun %define-component-inline-methods (ret rest)
(dolist (name +asdf-methods+)
(let ((keyword (intern (symbol-name name) :keyword)))
(loop :for data = rest :then (cddr data)
......@@ -45,16 +45,17 @@
,@body))
(component-inline-methods ret)))))))
(defun* %refresh-component-inline-methods (component rest)
(defun %refresh-component-inline-methods (component rest)
(%remove-component-inline-methods component)
(%define-component-inline-methods component rest))
(%define-component-inline-methods component rest)))
;;;; PARTIAL SUPPORT for the :if-component-dep-fails component attribute
;; and the companion asdf:feature pseudo-dependency.
;; This won't recurse into dependencies to accumulate feature conditions.
;; Therefore it will accept the SB-ROTATE-BYTE of an old SBCL
;; (older than 1.1.2.20-fe6da9f) but won't suffice to load an old nibbles.
(defun* %resolve-if-component-dep-fails (if-component-dep-fails component)
(with-upgradability ()
(defun %resolve-if-component-dep-fails (if-component-dep-fails component)
(asdf-message "The system definition for ~S uses deprecated ~
ASDF option :IF-COMPONENT-DEP-DAILS. ~
Starting with ASDF 3, please use :IF-FEATURE instead"
......@@ -67,22 +68,23 @@
:for c :in (component-children component) :do
(loop* :for (feature? feature) :in (component-depends-on o c)
:when (eq feature? 'feature) :do
(setf (component-if-feature c) feature)))))
(setf (component-if-feature c) feature))))))
(when-upgrading (:when (fboundp 'make-sub-operation))
(defun* make-sub-operation (c o dep-c dep-o)
(defun make-sub-operation (c o dep-c dep-o)
(declare (ignore c o dep-c dep-o)) (asdf-upgrade-error)))
;;;; load-sysdef
(defun* load-sysdef (name pathname)
(with-upgradability ()
(defun load-sysdef (name pathname)
(load-asd pathname :name name))
(defun* make-temporary-package ()
(defun make-temporary-package ()
;; For loading a .asd file, we dont't make a temporary package anymore,
;; but use ASDF-USER. I'd like to have this function do this,
;; but since whoever uses it is likely to delete-package the result afterwards,
;; this would be a bad idea, so preserve the old behavior.
(make-package (fresh-package-name :prefix :asdf :index 0) :use '(:cl :asdf)))
(make-package (fresh-package-name :prefix :asdf :index 0) :use '(:cl :asdf))))
This diff is collapsed.
......@@ -13,15 +13,16 @@
;; * fewer accesses to the filesystem
;; * the ability to test with fake timestamps, without touching files
(defvar *asdf-cache* nil)
(with-upgradability ()
(defvar *asdf-cache* nil)
(defun set-asdf-cache-entry (key value-list)
(defun set-asdf-cache-entry (key value-list)
(apply 'values
(if *asdf-cache*
(setf (gethash key *asdf-cache*) value-list)
value-list)))
(defun consult-asdf-cache (key thunk)
(defun consult-asdf-cache (key thunk)
(if *asdf-cache*
(multiple-value-bind (results foundp) (gethash key *asdf-cache*)
(if foundp
......@@ -29,23 +30,25 @@
(set-asdf-cache-entry key (multiple-value-list (funcall thunk)))))
(funcall thunk)))
(defmacro do-asdf-cache (key &body body)
(defmacro do-asdf-cache (key &body body)
`(consult-asdf-cache ,key #'(lambda () ,@body)))
(defun call-with-asdf-cache (thunk &key override)
(defun call-with-asdf-cache (thunk &key override)
(if (and *asdf-cache* (not override))
(funcall thunk)
(let ((*asdf-cache* (make-hash-table :test 'equal)))
(funcall thunk))))
(defmacro with-asdf-cache ((&key override) &body body)
(defmacro with-asdf-cache ((&key override) &body body)
`(call-with-asdf-cache #'(lambda () ,@body) :override ,override))
(defun compute-file-stamp (file)
(defun compute-file-stamp (file)
(safe-file-write-date file))
(defun register-file-stamp (file &optional (stamp (compute-file-stamp file)))
(defun register-file-stamp (file &optional (stamp (compute-file-stamp file)))
(set-asdf-cache-entry `(get-file-stamp ,file) (list stamp)))
(defun get-file-stamp (file)
(do-asdf-cache `(get-file-stamp ,file) (compute-file-stamp file)))
(defun get-file-stamp (file)
(do-asdf-cache `(get-file-stamp ,file) (compute-file-stamp file))))
......@@ -47,7 +47,7 @@
(setf *print-readably* nil))
#+cormanlisp
(progn
(eval-when (:load-toplevel :compile-toplevel :execute)
(deftype logical-pathname () nil)
(defun make-broadcast-stream () *error-output*)
(defun translate-logical-pathname (x) x)
......@@ -81,8 +81,8 @@
(export 'type-of :asdf/common-lisp)
(export 'system:*load-pathname* :asdf/common-lisp))
#+gcl2.6
(progn ;; Doesn't support either logical-pathnames or output-translations.
#+gcl2.6 ;; Doesn't support either logical-pathnames or output-translations.
(eval-when (:load-toplevel :compile-toplevel :execute)
(defvar *gcl2.6* t)
(deftype logical-pathname () nil)
(defun type-of (x) (class-name (class-of x)))
......@@ -108,13 +108,14 @@
(namestring (make-pathname :name nil :type nil :version nil :defaults path))))))
#+genera
(unless (fboundp 'ensure-directories-exist)
(eval-when (:load-toplevel :compile-toplevel :execute)
(unless (fboundp 'ensure-directories-exist)
(defun ensure-directories-exist (path)
(fs:create-directories-recursively (pathname path))))
(fs:create-directories-recursively (pathname path)))))
#.(or #+mcl ;; the #$ doesn't work on other lisps, even protected by #+mcl
#.(or #+mcl ;; the #$ doesn't work on other lisps, even protected by #+mcl, so we use this trick
(read-from-string
"(eval-when (:compile-toplevel :load-toplevel :execute)
"(eval-when (:load-toplevel :compile-toplevel :execute)
(ccl:define-entry-point (_getenv \"getenv\") ((name :string)) :string)
(ccl:define-entry-point (_system \"system\") ((name :string)) :int)
;; Note: ASDF may expect user-homedir-pathname to provide
......@@ -138,9 +139,10 @@
;;;; Looping
(defmacro loop* (&rest rest)
(eval-when (:load-toplevel :compile-toplevel :execute)
(defmacro loop* (&rest rest)
#-genera `(loop ,@rest)
#+genera `(lisp:loop ,@rest)) ;; In genera, CL:LOOP can't destructure, so we use LOOP*. Sigh.
#+genera `(lisp:loop ,@rest))) ;; In genera, CL:LOOP can't destructure, so we use LOOP*. Sigh.
;;;; compatfmt: avoid fancy format directives when unsupported
......
......@@ -37,31 +37,33 @@
#:%encoding #:properties #:component-properties #:parent))
(in-package :asdf/component)
(defgeneric* component-name (component)
(with-upgradability ()
(defgeneric component-name (component)
(:documentation "Name of the COMPONENT, unique relative to its parent"))
(defgeneric* component-system (component)
(defgeneric component-system (component)
(:documentation "Find the top-level system containing COMPONENT"))
(defgeneric* component-pathname (component)
(defgeneric component-pathname (component)
(:documentation "Extracts the pathname applicable for a particular component."))
(defgeneric* (component-relative-pathname) (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-external-format (component))
(defgeneric component-encoding (component))
(defgeneric version-satisfies (component version))
;;; Backward compatible way of computing the FILE-TYPE of a component.
;;; TODO: find users, have them stop using that.
(defgeneric* (source-file-type) (component system))
;; 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)))
(defclass component ()
(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
......@@ -113,42 +115,42 @@ another pathname in a degenerate way."))
(build-operation
:initarg :build-operation :initform nil :reader component-build-operation)))
(defun* component-find-path (component)
(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)
(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))
(defmethod component-system ((component component))
(if-let (system (component-parent component))
(component-system system)
component))
component)))
;;;; 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) ())
(defclass file-component (child-component)
(defclass file-component (child-component)
((type :accessor file-type :initarg :type))) ; no default
(defclass source-file (file-component)
(defclass source-file (file-component)
((type :initform nil))) ;; NB: many systems have come to rely on this default.
(defclass c-source-file (source-file)
(defclass c-source-file (source-file)
((type :initform "c")))
(defclass java-source-file (source-file)
(defclass java-source-file (source-file)
((type :initform "java")))
(defclass static-file (source-file)
(defclass static-file (source-file)
((type :initform nil)))
(defclass doc-file (static-file) ())
(defclass html-file (doc-file)
(defclass doc-file (static-file) ())
(defclass html-file (doc-file)
((type :initform "html")))
(defclass parent-component (component)
(defclass parent-component (component)
((children
:initform nil
:initarg :components
......@@ -160,10 +162,10 @@ 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))))
(eval-when (:compile-toplevel :load-toplevel :execute)
(defun* compute-children-by-name (parent &key only-if-needed-p)
(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)
......@@ -187,17 +189,18 @@ another pathname in a degenerate way."))
(getf plist 'components)))
(compute-children-by-name m))))
(defclass module (child-component parent-component)
(#+clisp (components))) ;; backward compatibility during upgrade only
(with-upgradability ()
(defclass module (child-component parent-component)
(#+clisp (components)))) ;; backward compatibility during upgrade only
;;;; component pathnames
(defgeneric* (component-parent-pathname) (component))
(defmethod component-parent-pathname (component)
(with-upgradability ()
(defgeneric* (component-parent-pathname) (component))
(defmethod component-parent-pathname (component)
(component-pathname (component-parent component)))
(defmethod component-pathname ((component component))
(defmethod component-pathname ((component component))
(if (slot-boundp component 'absolute-pathname)
(slot-value component 'absolute-pathname)
(let ((pathname
......@@ -210,7 +213,7 @@ another pathname in a degenerate way."))
(setf (slot-value component 'absolute-pathname) pathname)
pathname)))
(defmethod component-relative-pathname ((component component))
(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.
......@@ -222,53 +225,53 @@ 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)
(defmethod source-file-type ((component parent-component) system)
(declare (ignorable component system))
:directory)
(defmethod source-file-type ((component file-component) system)
(defmethod source-file-type ((component file-component) system)
(declare (ignorable system))
(file-type component))
(file-type component)))
;;;; Encodings
(defmethod component-encoding ((c component))
(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)))
(defmethod component-external-format ((c component))
(encoding-external-format (component-encoding c))))
;;;; around-compile-hook
(defgeneric* around-compile-hook (component))
(defmethod around-compile-hook ((c component))
(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)))))
(around-compile-hook (component-parent c))))))
;;;; version-satisfies
(defmethod version-satisfies ((c component) version)
(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))
(defmethod version-satisfies ((cver string) version)
(version-compatible-p cver version)))
;;; all sub-components (of a given type)
(defun* sub-components (component &key (type t))
(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)
......@@ -276,5 +279,5 @@ another pathname in a degenerate way."))
(c x))
(when (typep x 'parent-component)
(map () #'recurse (component-children x))))))
(recurse component))))
(recurse component)))))
......@@ -23,21 +23,22 @@
;;;
;;; Concatenate sources
;;;
(defclass concatenate-source-op (bundle-op)
(with-upgradability ()
(defclass concatenate-source-op (bundle-op)
((bundle-type :initform "lisp")))
(defclass load-concatenated-source-op (basic-load-op operation)
(defclass load-concatenated-source-op (basic-load-op operation)
((bundle-type :initform :no-output-file)))
(defclass compile-concatenated-source-op (basic-compile-op bundle-op)
(defclass compile-concatenated-source-op (basic-compile-op bundle-op)
((bundle-type :initform :fasl)))
(defclass load-compiled-concatenated-source-op (basic-load-op operation)
(defclass load-compiled-concatenated-source-op (basic-load-op operation)
((bundle-type :initform :no-output-file)))
(defclass monolithic-concatenate-source-op (concatenate-source-op monolithic-op) ())
(defclass monolithic-load-concatenated-source-op (load-concatenated-source-op monolithic-op) ())
(defclass monolithic-compile-concatenated-source-op (compile-concatenated-source-op monolithic-op) ())
(defclass monolithic-load-compiled-concatenated-source-op (load-compiled-concatenated-source-op monolithic-op) ())
(defclass monolithic-concatenate-source-op (concatenate-source-op monolithic-op) ())
(defclass monolithic-load-concatenated-source-op (load-concatenated-source-op monolithic-op) ())
(defclass monolithic-compile-concatenated-source-op (compile-concatenated-source-op monolithic-op) ())
(defclass monolithic-load-compiled-concatenated-source-op (load-compiled-concatenated-source-op monolithic-op) ())
(defmethod input-files ((operation concatenate-source-op) (s system))
(defmethod input-files ((operation concatenate-source-op) (s system))
(loop :with encoding = (or (component-encoding s) *default-encoding*)
:with other-encodings = '()
:with around-compile = (around-compile-hook s)
......@@ -64,42 +65,42 @@
operation around-compile other-around-compile))
(return inputs)))
(defmethod input-files ((o load-concatenated-source-op) (s system))
(defmethod input-files ((o load-concatenated-source-op) (s system))
(direct-dependency-files o s))
(defmethod input-files ((o compile-concatenated-source-op) (s system))
(defmethod input-files ((o compile-concatenated-source-op) (s system))
(direct-dependency-files o s))
(defmethod output-files ((o compile-concatenated-source-op) (s system))
(defmethod output-files ((o compile-concatenated-source-op) (s system))
(let ((input (first (input-files o s))))
(list (compile-file-pathname input))))
(defmethod input-files ((o load-compiled-concatenated-source-op) (s system))
(defmethod input-files ((o load-compiled-concatenated-source-op) (s system))
(direct-dependency-files o s))
(defmethod perform ((o concatenate-source-op) (s system))
(defmethod perform ((o concatenate-source-op) (s system))
(let ((inputs (input-files o s))
(output (output-file o s)))
(concatenate-files inputs output)))
(defmethod perform ((o load-concatenated-source-op) (s system))
(defmethod perform ((o load-concatenated-source-op) (s system))
(perform-lisp-load-source o s))
(defmethod perform ((o compile-concatenated-source-op) (s system))
(defmethod perform ((o compile-concatenated-source-op) (s system))
(perform-lisp-compilation o s))
(defmethod perform ((o load-compiled-concatenated-source-op) (s system))
(defmethod perform ((o load-compiled-concatenated-source-op) (s system))
(perform-lisp-load-fasl o s))
(defmethod component-depends-on ((o concatenate-source-op) (s system))
(defmethod component-depends-on ((o concatenate-source-op) (s system))
(declare (ignorable o s)) nil)
(defmethod component-depends-on ((o load-concatenated-source-op) (s system))
(defmethod component-depends-on ((o load-concatenated-source-op) (s system))
(declare (ignorable o s)) `((prepare-op ,s) (concatenate-source-op ,s)))
(defmethod component-depends-on ((o compile-concatenated-source-op) (s system))
(defmethod component-depends-on ((o compile-concatenated-source-op) (s system))
(declare (ignorable o s)) `((concatenate-source-op ,s)))
(defmethod component-depends-on ((o load-compiled-concatenated-source-op) (s system))
(defmethod component-depends-on ((o load-compiled-concatenated-source-op) (s system))
(declare (ignorable o s)) `((compile-concatenated-source-op ,s)))
(defmethod component-depends-on ((o monolithic-concatenate-source-op) (s system))
(defmethod component-depends-on ((o monolithic-concatenate-source-op) (s system))
(declare (ignorable o s)) nil)
(defmethod component-depends-on ((o monolithic-load-concatenated-source-op) (s system))
(defmethod component-depends-on ((o monolithic-load-concatenated-source-op) (s system))
(declare (ignorable o s)) `((monolithic-concatenate-source-op ,s)))
(defmethod component-depends-on ((o monolithic-compile-concatenated-source-op) (s system))
(defmethod component-depends-on ((o monolithic-compile-concatenated-source-op) (s system))
(declare (ignorable o s)) `((monolithic-concatenate-source-op ,s)))
(defmethod component-depends-on ((o monolithic-load-compiled-concatenated-source-op) (s system))
(declare (ignorable o s)) `((monolithic-compile-concatenated-source-op ,s)))
(defmethod component-depends-on ((o monolithic-load-compiled-concatenated-source-op) (s system))
(declare (ignorable o s)) `((monolithic-compile-concatenated-source-op ,s))))
......@@ -18,7 +18,8 @@
#:resolve-relative-location #:resolve-absolute-location #:upgrade-configuration))
(in-package :asdf/configuration)