...
 
Commits (55)
......@@ -80,7 +80,7 @@ XCL ?= xcl
header_lisp := header.lisp
driver_lisp := uiop/package.lisp uiop/common-lisp.lisp uiop/utility.lisp uiop/version.lisp uiop/os.lisp uiop/pathname.lisp uiop/filesystem.lisp uiop/stream.lisp uiop/image.lisp uiop/lisp-build.lisp uiop/launch-program.lisp uiop/run-program.lisp uiop/configuration.lisp uiop/backward-driver.lisp uiop/driver.lisp
defsystem_lisp := upgrade.lisp cache.lisp component.lisp system.lisp find-system.lisp find-component.lisp operation.lisp action.lisp lisp-action.lisp plan.lisp operate.lisp parse-defsystem.lisp bundle.lisp concatenate-source.lisp output-translations.lisp source-registry.lisp package-inferred-system.lisp backward-interface.lisp backward-internals.lisp interface.lisp user.lisp footer.lisp
defsystem_lisp := upgrade.lisp session.lisp component.lisp operation.lisp system.lisp system-registry.lisp action.lisp lisp-action.lisp find-component.lisp forcing.lisp plan.lisp operate.lisp find-system.lisp parse-defsystem.lisp bundle.lisp concatenate-source.lisp package-inferred-system.lisp output-translations.lisp source-registry.lisp backward-internals.lisp backward-interface.lisp interface.lisp user.lisp footer.lisp
all_lisp := $(header_lisp) $(driver_lisp) $(defsystem_lisp)
print-% : ; @echo $* = $($*)
......
This diff is collapsed.
......@@ -3,24 +3,27 @@
(uiop/package:define-package :asdf/action
(:nicknames :asdf-action)
(:recycle :asdf/action :asdf)
(:use :uiop/common-lisp :uiop :asdf/upgrade
:asdf/component :asdf/system #:asdf/cache :asdf/find-system :asdf/find-component :asdf/operation)
(:recycle :asdf/action :asdf/plan :asdf)
(:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/session :asdf/component :asdf/operation)
(:import-from :asdf/operation #:check-operation-constructor)
(:import-from :asdf/component #:%additional-input-files)
#-clisp (:unintern #:required-components #:traverse-action #:traverse-sub-actions)
(:export
#:action #:define-convenience-action-methods
#:action-description
#:downward-operation #:upward-operation #:sideway-operation #:selfward-operation #:non-propagating-operation
#:action-description #:format-action
#: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
#:action-operation #:action-component #:make-action
#:component-operation-time #:mark-operation-done #:compute-action-stamp
#:perform #:perform-with-restarts #:retry #:accept
#:action-path #:find-action #:stamp #:done-p
#:action-path #:find-action
#:operation-definition-warning #:operation-definition-error ;; condition
))
#:action-valid-p
#:circular-dependency #:circular-dependency-actions
#:call-while-visiting-action #:while-visiting-action
#:additional-input-files))
(in-package :asdf/action)
(eval-when (#-lispworks :compile-toplevel :load-toplevel :execute) ;; LispWorks issues spurious warning
......@@ -49,9 +52,10 @@ and a class-name or class designates the canonical instance of the designated cl
(with-upgradability ()
(defun action-path (action)
"A readable data structure that identifies the action."
(let ((o (action-operation action))
(c (action-component action)))
(cons (type-of o) (component-find-path c))))
(when action
(let ((o (action-operation action))
(c (action-component action)))
(cons (type-of o) (component-find-path c)))))
(defun find-action (path)
"Reconstitute an action from its action-path"
(destructuring-bind (o . c) path (make-action (make-operation o) (find-component () c)))))
......@@ -109,7 +113,7 @@ and a class-name or class designates the canonical instance of the designated cl
,if-no-component))))))))
;;;; self-description
;;;; Self-description
(with-upgradability ()
(defgeneric action-description (operation component)
(:documentation "returns a phrase that describes performing this operation
......@@ -127,6 +131,42 @@ Use it in FORMAT control strings as ~/asdf-action:format-action/"
(princ (action-description operation component) stream))))
;;;; Detection of circular dependencies
(with-upgradability ()
(defun (action-valid-p) (operation component)
"Is this action valid to include amongst dependencies?"
;; If either the operation or component was resolved to nil, the action is invalid.
;; :if-feature will invalidate actions on components for which the features don't apply.
(and operation component
(if-let (it (component-if-feature component)) (featurep it) t)))
(define-condition circular-dependency (system-definition-error)
((actions :initarg :actions :reader circular-dependency-actions))
(:report (lambda (c s)
(format s (compatfmt "~@<Circular dependency: ~3i~_~S~@:>")
(circular-dependency-actions c)))))
(defun call-while-visiting-action (operation component fun)
"Detect circular dependencies"
(with-asdf-session ()
(with-accessors ((action-set visiting-action-set)
(action-list visiting-action-list)) *asdf-session*
(let ((action (cons operation component)))
(when (gethash action action-set)
(error 'circular-dependency :actions
(member action (reverse action-list) :test 'equal)))
(setf (gethash action action-set) t)
(push action action-list)
(unwind-protect
(funcall fun)
(pop action-list)
(setf (gethash action action-set) nil))))))
;; Syntactic sugar for call-while-visiting-action
(defmacro while-visiting-action ((o c) &body body)
`(call-while-visiting-action ,o ,c #'(lambda () ,@body))))
;;;; Dependencies
(with-upgradability ()
(defgeneric component-depends-on (operation component) ;; ASDF4: rename to component-dependencies
......@@ -269,7 +309,7 @@ The class needs to be updated for ASDF 3.1 and specify appropriate propagation m
don't. In the future this functionality will be removed, and the default will be no propagation."
(uiop/version::notify-deprecated-function
(version-deprecation *asdf-version* :style-warning "3.2")
'backward-compatible-depends-on)
`(backward-compatible-depends-on :for-operation ,o))
`(,@(sideway-operation-depends-on o c)
,@(when (typep c 'parent-component) (downward-operation-depends-on o c))))
......@@ -341,10 +381,24 @@ They may rely on the order of the files to discriminate between inputs.
(assert (length=n-p files 1))
(first files)))
(defgeneric additional-input-files (operation component)
(:documentation "Additional input files for the operation on this
component. These are files that are inferred, rather than
explicitly specified, and these are typically NOT files that
undergo operations directly. Instead, they are files that it is
important for ASDF to know about in order to compute operation times,etc."))
(define-convenience-action-methods additional-input-files (operation component))
(defmethod additional-input-files ((op operation) (comp component))
(cdr (assoc op (%additional-input-files comp))))
;; Memoize input files.
(defmethod input-files :around (operation component)
(do-asdf-cache `(input-files ,operation ,component)
(call-next-method)))
;; get the additional input files, if any
(append (call-next-method)
;; must come after the first, for other code that
;; assumes the first will be the "key" file
(additional-input-files operation component))))
;; By default an action has no input-files.
(defmethod input-files ((o operation) (c component))
......@@ -393,29 +447,17 @@ Returns two values:
* a boolean DONE-P that indicates whether the action has actually been done,
and both its output-files and its in-image side-effects are up to date."))
(defclass action-status ()
((stamp
:initarg :stamp :reader action-stamp
:documentation "STAMP associated with the ACTION if it has been completed already
in some previous image, or T if it needs to be done.")
(done-p
:initarg :done-p :reader action-done-p
:documentation "a boolean, true iff the action was already done (before any planned action)."))
(:documentation "Status of an action"))
(defmethod print-object ((status action-status) stream)
(print-unreadable-object (status stream :type t)
(with-slots (stamp done-p) status
(format stream "~@{~S~^ ~}" :stamp stamp :done-p done-p))))
(defmethod component-operation-time ((o operation) (c component))
(gethash o (component-operation-times c)))
(defmethod (setf component-operation-time) (stamp (o operation) (c component))
(assert stamp () "invalid null stamp for ~A" (action-description o c))
(setf (gethash o (component-operation-times c)) stamp))
(defmethod mark-operation-done ((o operation) (c component))
(setf (component-operation-time o c) (compute-action-stamp nil o c :just-done t))))
(let ((stamp (compute-action-stamp nil o c :just-done t)))
(assert stamp () "Failed to compute a stamp for completed action ~A" (action-description o c))1
(setf (component-operation-time o c) stamp))))
;;;; Perform
......@@ -424,6 +466,8 @@ in some previous image, or T if it needs to be done.")
(:documentation "PERFORM an action, consuming its input-files and building its output-files"))
(define-convenience-action-methods perform (operation component))
(defmethod perform :around ((o operation) (c component))
(while-visiting-action (o c) (call-next-method)))
(defmethod perform :before ((o operation) (c component))
(ensure-all-directories-exist (output-files o c)))
(defmethod perform :after ((o operation) (c component))
......
......@@ -21,7 +21,13 @@
#+asdf3
(defsystem "asdf/driver"
:depends-on ("uiop"))
;; This is the same as "uiop", but used for transclusion in asdf.lisp.
;; Because asdf.asd can't afford to depend on reading uiop.asd
;; (which would cause circularity, since everything depends on reading asdf.asd),
;; we can't "just" :depends-on ("uiop") like we used to do.
:pathname "uiop"
:around-compile call-without-redefinition-warnings ;; we need be the same as uiop
:components #.(getf (read-file-form (subpathname *load-pathname* "uiop/uiop.asd") :at 2) :components))
#+asdf3
(defsystem "asdf/defsystem"
......@@ -40,28 +46,31 @@
:build-operation monolithic-concatenate-source-op
:build-pathname "build/asdf" ;; our target
:around-compile call-without-redefinition-warnings ;; we need be the same as uiop
:depends-on ("asdf/prelude" "uiop")
:depends-on ("asdf/prelude" "asdf/driver")
:encoding :utf-8
:components
((:file "upgrade")
(:file "cache" :depends-on ("upgrade"))
(:file "component" :depends-on ("upgrade"))
(:file "session" :depends-on ("upgrade"))
(:file "component" :depends-on ("session"))
(:file "operation" :depends-on ("session"))
(:file "system" :depends-on ("component"))
(:file "find-system" :depends-on ("system" "cache"))
(:file "find-component" :depends-on ("find-system"))
(:file "operation" :depends-on ("find-system"))
(:file "action" :depends-on ("find-component" "operation"))
(:file "system-registry" :depends-on ("system"))
(:file "action" :depends-on ("session" "system" "operation"))
(:file "lisp-action" :depends-on ("action"))
(:file "plan" :depends-on ("lisp-action"))
(:file "find-component" :depends-on ("component"))
(:file "forcing" :depends-on ("operation" "system-registry"))
(:file "plan" :depends-on ("lisp-action" "find-component" "forcing"))
(:file "operate" :depends-on ("plan"))
(:file "parse-defsystem" :depends-on ("cache" "system" "lisp-action" "operate"))
(:file "bundle" :depends-on ("lisp-action" "operate" "parse-defsystem"))
(:file "concatenate-source" :depends-on ("plan" "parse-defsystem" "bundle"))
(:file "find-system" :depends-on ("system-registry" "operate"))
(:file "parse-defsystem" :depends-on ("system-registry" "lisp-action" "operate"
"find-system"))
(:file "bundle" :depends-on ("lisp-action" "parse-defsystem"))
(:file "concatenate-source" :depends-on ("bundle"))
(:file "package-inferred-system" :depends-on ("parse-defsystem"))
(:file "output-translations" :depends-on ("operate"))
(:file "source-registry" :depends-on ("find-system"))
(:file "package-inferred-system" :depends-on ("system" "find-system" "parse-defsystem"))
(:file "backward-interface" :depends-on ("operate" "output-translations"))
(:file "backward-internals" :depends-on ("find-system" "parse-defsystem"))
(:file "backward-interface" :depends-on ("output-translations"))
(:file "interface" :depends-on
("parse-defsystem" "concatenate-source"
"output-translations" "source-registry" "package-inferred-system"
......@@ -75,7 +84,7 @@
:licence "MIT"
:description "Another System Definition Facility"
:long-description "ASDF builds Common Lisp software organized into defined systems."
:version "3.2.1" ;; to be automatically updated by make bump-version
:version "3.3.0" ;; to be automatically updated by make bump-version
:depends-on ()
#+asdf3 :encoding #+asdf3 :utf-8
:class #+asdf3.1 package-inferred-system #-asdf3.1 system
......@@ -85,4 +94,3 @@
#+asdf3 :builtin-system-p #+asdf3 t
:components ((:module "build" :components ((:file "asdf"))))
:in-order-to (#+asdf3 (prepare-op (monolithic-concatenate-source-op "asdf/defsystem"))))
......@@ -3,9 +3,10 @@
(uiop/package:define-package :asdf/backward-interface
(:recycle :asdf/backward-interface :asdf)
(:use :uiop/common-lisp :uiop :asdf/upgrade
:asdf/component :asdf/system :asdf/find-system :asdf/operation :asdf/action
:asdf/lisp-action :asdf/plan :asdf/operate :asdf/output-translations)
(:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/session
:asdf/component :asdf/system :asdf/system-registry :asdf/operation :asdf/action
:asdf/lisp-action :asdf/plan :asdf/operate
:asdf/find-system :asdf/parse-defsystem :asdf/output-translations)
(:export
#:*asdf-verbose*
#:operation-error #:compile-error #:compile-failed #:compile-warned
......@@ -15,7 +16,7 @@
#:operation-on-failure #:operation-on-warnings #:on-failure #:on-warnings
#:component-property
#:run-shell-command
#:system-definition-pathname
#:system-definition-pathname #:system-registered-p #:require-system
#:explain))
(in-package :asdf/backward-interface)
......@@ -208,3 +209,20 @@ DEPRECATED. Use ASDF:ACTION-DESCRIPTION and/or ASDF::FORMAT-ACTION instead."))
(define-convenience-action-methods explain (operation component)))
(defmethod explain ((o operation) (c component))
(asdf-message (compatfmt "~&~@<; ~@;~A~:>~%") (action-description o c))))
(with-asdf-deprecation (:style-warning "3.3")
(defun system-registered-p (name)
"DEPRECATED. Return a generalized boolean that is true if a system of given NAME was registered already.
NAME is a system designator, to be normalized by COERCE-NAME.
The value returned if true is a pair of a timestamp and a system object."
(if-let (system (registered-system name))
(cons (if-let (primary-system (registered-system (primary-system-name name)))
(component-operation-time 'define-op primary-system))
system)))
(defun require-system (system &rest keys &key &allow-other-keys)
"Ensure the specified SYSTEM is loaded, passing the KEYS to OPERATE, but do not update the
system or its dependencies if it has already been loaded."
(declare (ignore keys))
(unless (component-loaded-p system)
(load-system system))))
......@@ -4,8 +4,8 @@
(uiop/package:define-package :asdf/bundle
(:recycle :asdf/bundle :asdf)
(:use :uiop/common-lisp :uiop :asdf/upgrade
:asdf/component :asdf/system :asdf/find-system :asdf/find-component :asdf/operation
:asdf/action :asdf/lisp-action :asdf/plan :asdf/operate :asdf/defsystem)
:asdf/component :asdf/system :asdf/operation
:asdf/action :asdf/lisp-action :asdf/plan :asdf/operate :asdf/parse-defsystem)
(:export
#:bundle-op #:bundle-type #:program-system
#:bundle-system #:bundle-pathname-type #:direct-dependency-files
......@@ -323,9 +323,9 @@ or of opaque libraries shipped along the source code."))
;; your component-depends-on method must gather the correct dependencies in the correct order.
(while-collecting (collect)
(map-direct-dependencies
t o c #'(lambda (sub-o sub-c)
(loop :for f :in (funcall key sub-o sub-c)
:when (funcall test f) :do (collect f))))))
o c #'(lambda (sub-o sub-c)
(loop :for f :in (funcall key sub-o sub-c)
:when (funcall test f) :do (collect f))))))
(defun pathname-type-equal-function (type)
#'(lambda (p) (equalp (pathname-type p) type)))
......@@ -441,7 +441,7 @@ or of opaque libraries shipped along the source code."))
:keep-operation 'basic-load-op))
(while-collecting (x) ;; resolve the sideway-dependencies of s
(map-direct-dependencies
t 'load-op s
'load-op s
#'(lambda (o c)
(when (and (typep o 'load-op) (typep c 'system))
(x c)))))))
......@@ -496,7 +496,6 @@ which is probably not what you want; you probably need to tweak your output tran
(perform-lisp-load-fasl o s))
(defmethod component-depends-on ((o load-bundle-op) (s precompiled-system))
#+xcl (declare (ignorable o))
`((load-op ,s) ,@(call-next-method))))
#| ;; Example use:
......
......@@ -2,10 +2,11 @@
;;;; Components
(uiop/package:define-package :asdf/component
(:recycle :asdf/component :asdf/defsystem :asdf/find-system :asdf)
(:use :uiop/common-lisp :uiop :asdf/upgrade)
(:recycle :asdf/component :asdf/find-component :asdf)
(:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/session)
(:export
#:component #:component-find-path
#:find-component ;; methods defined in find-component
#:component-name #:component-pathname #:component-relative-pathname
#:component-parent #:component-system #:component-parent-pathname
#:child-component #:parent-component #:module
......@@ -29,7 +30,6 @@
#:sub-components
;; conditions
#:system-definition-error ;; top level, moved here because this is the earliest place for it.
#:duplicate-names
;; Internals we'd like to share with the ASDF package, especially for upgrade purposes
......@@ -81,15 +81,6 @@ or NIL for top-level components (a.k.a. systems)"))
(defgeneric source-file-type (component system)
(:documentation "DEPRECATED. Use the FILE-TYPE of a COMPONENT instead."))
(define-condition system-definition-error (error) ()
;; [this use of :report should be redundant, but unfortunately it's not.
;; cmucl's lisp::output-instance prefers the kernel:slot-class-print-function
;; over print-object; this is always conditions::%print-condition for
;; condition objects, which in turn does inheritance of :report options at
;; run-time. fortunately, inheritance means we only need this kludge here in
;; order to fix all conditions that build on it. -- rgr, 28-Jul-02.]
#+cmucl (:report print-object))
(define-condition duplicate-names (system-definition-error)
((name :initarg :name :reader duplicate-names-name))
(:report (lambda (c s)
......@@ -147,9 +138,15 @@ or NIL for top-level components (a.k.a. systems)"))
;; For backward-compatibility, this slot is part of component rather than of child-component. ASDF4: stop it.
(parent :initarg :parent :initform nil :reader component-parent)
(build-operation
:initarg :build-operation :initform nil :reader component-build-operation))
:initarg :build-operation :initform nil :reader component-build-operation)
;; Cache for ADDITIONAL-INPUT-FILES function.
(additional-input-files :accessor %additional-input-files :initform nil))
(:documentation "Base class for all components of a build"))
(defgeneric find-component (base path &key registered)
(:documentation "Find a component by resolving the PATH starting from BASE parent.
If REGISTERED is true, only search currently registered systems."))
(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."
......
......@@ -5,7 +5,7 @@
(:recycle :asdf/concatenate-source :asdf)
(:use :uiop/common-lisp :uiop :asdf/upgrade
:asdf/component :asdf/operation
:asdf/system :asdf/find-system
:asdf/system
:asdf/action :asdf/lisp-action :asdf/plan :asdf/bundle)
(:export
#:concatenate-source-op
......
This diff is collapsed.
(uiop:define-package :detect-multiply-used-files
(:nicknames :asdf/contrib/detect-multiply-used-files)
(:use :asdf :uiop :common-lisp)
(:use :asdf/component :asdf/system-registry :uiop :common-lisp)
(:export #:find-fishy-components #:register-component-files #:*file-components*))
(in-package :detect-multiply-used-files)
......@@ -20,7 +20,7 @@
(defun find-fishy-components ()
(clrhash *file-components*)
(map () 'register-component-files (table-keys asdf::*defined-systems*))
(map () 'register-component-files (table-keys *registered-systems*))
(loop :for p :in (sort (table-keys *file-components*) 'string<)
:for l = (gethash p *file-components*)
:when (and (file-pathname-p p) (not (length=n-p l 1)))
......
......@@ -30,4 +30,7 @@ use a wild pathname instead." module)))
(compute-children-by-name self)
(values)))
(defmethod input-files ((o compile-op) (c wild-module)) ())
(defmethod input-files ((o load-op) (c wild-module)) ())
(export 'wild-module)
......@@ -65,7 +65,7 @@ WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
@titlepage
@title ASDF: Another System Definition Facility
@subtitle Manual for Version 3.2.1
@subtitle Manual for Version 3.3.0
@c The following two commands start the copyright page.
@page
@vskip 0pt plus 1filll
......@@ -82,7 +82,7 @@ WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
@node Top, Introduction, (dir), (dir)
@top ASDF: Another System Definition Facility
@ifnottex
Manual for Version 3.2.1
Manual for Version 3.3.0
@end ifnottex
......@@ -1490,6 +1490,12 @@ simple-component-name := string
pathname-specifier := pathname | string | symbol
version-specifier := string
| (:read-file-form <pathname-specifier> <form-specifier>?)
| (:read-file-line <pathname-specifier> <line-specifier>?)
line-specifier := :at integer # base zero
form-specifier := :at [ integer | ( integer+ )]
method-form := (operation-name qual lambda-list @Arest{} body)
qual := method qualifier?
......@@ -1689,12 +1695,17 @@ Instead of a string representing the version,
the @code{:version} argument can be an expression that is resolved to
such a string using the following trivial domain-specific language:
in addition to being a literal string, it can be an expression of the form
@code{(:read-file-form <pathname-or-string> :at <access-at-specifier>)},
which will be resolved by reading a form in the specified pathname
(read as a subpathname of the current system if relative or a unix-namestring).
@code{(:read-file-form <pathname-or-string> [:at <access-at-specifier]>)},
or @code{(:read-file-line <pathname-or-string> [:at
<access-at-specifier]?>)}.
As the name suggests, the former will be resolved by reading a form in the specified pathname
(read as a subpathname of the current system if relative or a
unix-namestring), and the latter by reading a line.
You may use a @code{uiop:access-at} specifier
with the (optional) @code{:at} keyword,
by default the specifier is @code{0}, meaning the first form is returned;
with the @code{:at} keyword,
by default the specifier is @code{0}, meaning the first form/line is
returned.
For @code{:read-file-form},
subforms can also be specified, with e.g. @code{(1 2 2)} specifying
``the third subform (index 2) of the third subform (index 2) of the second form (index 1)''
in the file (mind the off-by-one error in the English language).
......@@ -6249,24 +6260,17 @@ Here's the procedure for experimenting with tests in a REPL:
;; Load the test script support.
(load "script-support.lisp")
;; Initialize the script support.
;; This will also change your *package* to asdf-test.
;; Initialize the script support for interaction.
;; This will also change your *package* to asdf-test
;; after frobbing the asdf-test package to make it usable.
;; NB: this function is also available from package cl-user,
;; and also available with the shorter name da in both packages.
(asdf-test::debug-asdf)
;; In case you modified ASDF since you last tested it,
;; you need to update asdf.lisp itself by evaluating 'make' in a shell,
;; or (require "asdf") (asdf:load-system :asdf) in another CL REPL,
;; if not done in this REPL above.
;; *Then*, in this REPL, you need to evaluate:
;(asdf-test::compile-load-asdf)
(asdf-test:debug-asdf)
;; Now, you may experiment with test code from a .script file.
;; See the instructions given at the end of your failing test
;; to identify which form is needed, e.g.
(frob-packages)
(asdf::with-asdf-cache () (load "test-utilities.script"))
(run-test-script "test-utilities.script")
@end example
......
......@@ -2,15 +2,15 @@
;;;; Finding components
(uiop/package:define-package :asdf/find-component
(:recycle :asdf/find-component :asdf)
(:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/cache
:asdf/component :asdf/system :asdf/find-system)
(:recycle :asdf/find-component :asdf/find-system :asdf)
(:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/session
:asdf/component :asdf/system :asdf/system-registry)
(:export
#:find-component
#:resolve-dependency-name #:resolve-dependency-spec
#:resolve-dependency-combination
;; Conditions
#:missing-component #:missing-component-of-version #:retry
#:missing-component #:missing-requires #:missing-parent #:missing-component-of-version #:retry
#:missing-dependency #:missing-dependency-of-version
#:missing-requires #:missing-parent
#:missing-required-by #:missing-version))
......@@ -19,6 +19,10 @@
;;;; Missing component conditions
(with-upgradability ()
(define-condition missing-component (system-definition-error)
((requires :initform "(unnamed)" :reader missing-requires :initarg :requires)
(parent :initform nil :reader missing-parent :initarg :parent)))
(define-condition missing-component-of-version (missing-component)
((version :initform nil :reader missing-version :initarg :version)))
......@@ -50,9 +54,6 @@
;;;; Finding components
(with-upgradability ()
(defgeneric find-component (base path &key registered)
(:documentation "Find a component by resolving the PATH starting from BASE parent.
If REGISTERED is true, only search currently registered systems."))
(defgeneric resolve-dependency-combination (component combinator arguments)
(:documentation "Return a component satisfying the dependency specification (COMBINATOR . ARGUMENTS)
in the context of COMPONENT"))
......
This diff is collapsed.
......@@ -4,7 +4,7 @@
(uiop/package:define-package :asdf/footer
(:recycle :asdf/footer :asdf)
(:use :uiop/common-lisp :uiop
:asdf/upgrade :asdf/find-system :asdf/operate :asdf/bundle)
:asdf/upgrade :asdf/system-registry :asdf/operate :asdf/bundle)
;; Happily, all those implementations all have the same module-provider hook interface.
#+(or abcl clasp cmucl clozure ecl mkcl sbcl)
(:import-from #+abcl :sys #+(or clasp cmucl ecl) :ext #+clozure :ccl #+mkcl :mk-ext #+sbcl sb-ext
......@@ -67,7 +67,7 @@
(setf excl:*warn-on-nested-reader-conditionals* uiop/common-lisp::*acl-warn-save*))
;; Advertise the features we provide.
(dolist (f '(:asdf :asdf2 :asdf3 :asdf3.1 :asdf3.2 :asdf-package-system)) (pushnew f *features*))
(dolist (f '(:asdf :asdf2 :asdf3 :asdf3.1 :asdf3.2 :asdf3.3)) (pushnew f *features*))
;; Provide both lowercase and uppercase, to satisfy more people, especially LispWorks users.
(provide "asdf") (provide "ASDF")
......
;;;; -------------------------------------------------------------------------
;;;; Forcing
(uiop/package:define-package :asdf/forcing
(:recycle :asdf/forcing :asdf/plan :asdf)
(:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/session
:asdf/component :asdf/operation :asdf/system :asdf/system-registry)
(:export
#:forcing #:make-forcing #:forced #:forced-not #:performable-p
#:normalize-forced-systems #:normalize-forced-not-systems
#:action-forced-p #:action-forced-not-p))
(in-package :asdf/forcing)
;;;; Forcing
(with-upgradability ()
(defclass forcing ()
(;; Can plans using this forcing be PERFORMed? A plan that has different force and force-not
;; settings than the session can only be used for read-only queries that do not cause the
;; status of any action to be raised.
(performable-p :initform nil :initarg :performable-p :reader performable-p)
;; Parameters
(parameters :initform nil :initarg :parameters :reader parameters)
;; Table of systems specified via :force arguments
(forced :initarg :forced :reader forced)
;; Table of systems specified via :force-not argument (and/or immutable)
(forced-not :initarg :forced-not :reader forced-not)))
(defgeneric action-forced-p (forcing operation component)
(:documentation "Is this action forced to happen in this plan?"))
(defgeneric action-forced-not-p (forcing operation component)
(:documentation "Is this action forced to not happen in this plan?
Takes precedence over action-forced-p."))
(defun normalize-forced-systems (force system)
"Given a SYSTEM on which operate is called and the specified FORCE argument,
extract a hash-set of systems that are forced, or a predicate on system names,
or NIL if none are forced, or :ALL if all are."
(etypecase force
((or (member nil :all) hash-table function) force)
(cons (list-to-hash-set (mapcar #'coerce-name force)))
((eql t) (when system (list-to-hash-set (list (coerce-name system)))))))
(defun normalize-forced-not-systems (force-not system)
"Given a SYSTEM on which operate is called, the specified FORCE-NOT argument,
and the set of IMMUTABLE systems, extract a hash-set of systems that are effectively forced-not,
or predicate on system names, or NIL if none are forced, or :ALL if all are."
(let ((requested
(etypecase force-not
((or (member nil :all) hash-table function) force-not)
(cons (list-to-hash-set (mapcar #'coerce-name force-not)))
((eql t) (if system (let ((name (coerce-name system)))
#'(lambda (x) (not (equal x name))))
:all)))))
(if (and *immutable-systems* requested)
#'(lambda (x) (or (call-function requested x)
(call-function *immutable-systems* x)))
(or *immutable-systems* requested))))
;; TODO: shouldn't we be looking up the primary system name, rather than the system name?
(defun action-override-p (forcing operation component override-accessor)
"Given a plan, an action, and a function that given the plan accesses a set of overrides,
i.e. force or force-not, see if the override applies to the current action."
(declare (ignore operation))
(call-function (funcall override-accessor forcing)
(coerce-name (component-system (find-component () component)))))
(defmethod action-forced-p (forcing operation component)
(and
;; Did the user ask us to re-perform the action?
(action-override-p forcing operation component 'forced)
;; You really can't force a builtin system and :all doesn't apply to it.
(not (builtin-system-p (component-system component)))))
(defmethod action-forced-not-p (forcing operation component)
;; Did the user ask us to not re-perform the action?
;; NB: force-not takes precedence over force, as it should
(action-override-p forcing operation component 'forced-not))
;; Null forcing means no forcing either way
(defmethod action-forced-p ((forcing null) (operation operation) (component component))
nil)
(defmethod action-forced-not-p ((forcing null) (operation operation) (component component))
nil)
(defun or-function (fun1 fun2)
(cond
((or (null fun2) (eq fun1 :all)) fun1)
((or (null fun1) (eq fun2 :all)) fun2)
(t #'(lambda (x) (or (call-function fun1 x) (call-function fun2 x))))))
(defun make-forcing (&key performable-p system
(force nil force-p) (force-not nil force-not-p) &allow-other-keys)
(let* ((session-forcing (when *asdf-session* (forcing *asdf-session*)))
(system (and system (coerce-name system)))
(forced (normalize-forced-systems force system))
(forced-not (normalize-forced-not-systems force-not system))
(parameters `(,@(when force `(:force ,force))
,@(when force-not `(:force-not ,force-not))
,@(when (or (eq force t) (eq force-not t)) `(:system ,system))
,@(when performable-p `(:performable-p t))))
forcing)
(cond
((not session-forcing)
(setf forcing (make-instance 'forcing
:performable-p performable-p :parameters parameters
:forced forced :forced-not forced-not))
(when (and performable-p *asdf-session*)
(setf (forcing *asdf-session*) forcing)))
(performable-p
(when (and (not (equal parameters (parameters session-forcing)))
(or force-p force-not-p))
(parameter-error "~*~S and ~S arguments not allowed in a nested call to ~3:*~S ~
unless identically to toplevel"
(find-symbol* :operate :asdf) :force :force-not))
(setf forcing session-forcing))
(t
(setf forcing (make-instance 'forcing
;; Combine force and force-not with values from the toplevel-plan
:parameters `(,@parameters :on-top-of ,(parameters session-forcing))
:forced (or-function (forced session-forcing) forced)
:forced-not (or-function (forced-not session-forcing) forced-not)))))
forcing))
(defmethod print-object ((forcing forcing) stream)
(print-unreadable-object (forcing stream :type t)
(format stream "~{~S~^ ~}" (parameters forcing))))
;; During upgrade, the *asdf-session* may legitimately be NIL, so we must handle that case.
(defmethod forcing ((x null))
(if-let (session (toplevel-asdf-session))
(forcing session)
(make-forcing :performable-p t)))
;; When performing a plan that is a list of actions, use the toplevel asdf sesssion forcing.
(defmethod forcing ((x cons)) (forcing (toplevel-asdf-session))))
;;; -*- mode: Lisp; Base: 10 ; Syntax: ANSI-Common-Lisp ; buffer-read-only: t; -*-
;;; This is ASDF 3.2.1: Another System Definition Facility.
;;; This is ASDF 3.3.0: Another System Definition Facility.
;;;
;;; Feedback, bug reports, and patches are all welcome:
;;; please mail to <asdf-devel@common-lisp.net>.
......
......@@ -7,11 +7,12 @@
(:unintern
#:loaded-systems ; makes for annoying SLIME completion
#:output-files-for-system-and-operation) ; ASDF-BINARY-LOCATION function we use to detect ABL
(:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/cache
:asdf/component :asdf/system :asdf/find-system :asdf/find-component
(:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/session
:asdf/component :asdf/system :asdf/system-registry :asdf/find-component
:asdf/operation :asdf/action :asdf/lisp-action
:asdf/output-translations :asdf/source-registry
:asdf/plan :asdf/operate :asdf/parse-defsystem :asdf/bundle :asdf/concatenate-source
:asdf/forcing :asdf/plan :asdf/operate :asdf/find-system :asdf/parse-defsystem
:asdf/bundle :asdf/concatenate-source
:asdf/backward-internals :asdf/backward-interface :asdf/package-inferred-system)
;; Note: (1) we are NOT automatically reexporting everything from previous packages.
;; (2) we only reexport UIOP functionality when backward-compatibility requires it.
......@@ -27,10 +28,11 @@
#:non-propagating-operation
#:build-op #:make
#:load-op #:prepare-op #:compile-op
#:prepare-source-op #:load-source-op #:test-op
#:prepare-source-op #:load-source-op #:test-op #:define-op
#:feature #:version #:version-satisfies #:upgrade-asdf
#:implementation-identifier #:implementation-type #:hostname
#:input-files #:output-files #:output-file #:perform #:perform-with-restarts
#:input-files #:additional-input-files
#:output-files #:output-file #:perform #:perform-with-restarts
#:operation-done-p #:explain #:action-description #:component-sideway-dependencies
#:needed-in-image-p
#:component-load-dependencies #:run-shell-command ; deprecated, do not use
......@@ -123,7 +125,7 @@
#:missing-dependency
#:missing-dependency-of-version
#:circular-dependency ; errors
#:duplicate-names #:non-toplevel-system #:non-system-system #:bad-system-name
#:duplicate-names #:non-toplevel-system #:non-system-system #:bad-system-name #:system-out-of-date
#:package-inferred-system-missing-package-error
#:operation-definition-warning #:operation-definition-error
......@@ -158,7 +160,8 @@
#:clear-source-registry
#:ensure-source-registry
#:process-source-registry
#:system-registered-p #:registered-systems #:already-loaded-systems
#:system-registered-p ;; DEPRECATED
#:registered-system #:registered-systems #:already-loaded-systems
#:resolve-location
#:asdf-message
#:*user-cache*
......
......@@ -3,9 +3,8 @@
(uiop/package:define-package :asdf/lisp-action
(:recycle :asdf/lisp-action :asdf)
(:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/cache
:asdf/component :asdf/system :asdf/find-component :asdf/find-system
:asdf/operation :asdf/action)
(:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/session
:asdf/component :asdf/system :asdf/operation :asdf/action)
(:export
#:try-recompiling
#:cl-source-file #:cl-source-file.cl #:cl-source-file.lsp
......
......@@ -5,7 +5,7 @@
set here=%~dp0
set header_lisp=header.lisp
set driver_lisp=uiop\package.lisp + uiop\common-lisp.lisp + uiop\utility.lisp + uiop\version.lisp + uiop\os.lisp + uiop\pathname.lisp + uiop\filesystem.lisp + uiop\stream.lisp + uiop\image.lisp + uiop\lisp-build.lisp + uiop\launch-program.lisp + uiop\run-program.lisp + uiop\configuration.lisp + uiop\backward-driver.lisp + uiop\driver.lisp
set defsystem_lisp=upgrade.lisp + cache.lisp + component.lisp + system.lisp + find-system.lisp + find-component.lisp + operation.lisp + action.lisp + lisp-action.lisp + plan.lisp + operate.lisp + parse-defsystem.lisp + bundle.lisp + concatenate-source.lisp + output-translations.lisp + source-registry.lisp + package-inferred-system.lisp + backward-interface.lisp + backward-internals.lisp + interface.lisp + user.lisp + footer.lisp
set defsystem_lisp=upgrade.lisp + session.lisp + component.lisp + operation.lisp + system.lisp + system-registry.lisp + action.lisp + lisp-action.lisp + find-component.lisp + forcing.lisp + plan.lisp + operate.lisp + find-system.lisp + parse-defsystem.lisp + bundle.lisp + concatenate-source.lisp + package-inferred-system.lisp + output-translations.lisp + source-registry.lisp + backward-internals.lisp + backward-interface.lisp + interface.lisp + user.lisp + footer.lisp
%~d0
cd "%~p0"
......
......@@ -6,7 +6,7 @@ here="$(dirname $0)"
header_lisp="header.lisp"
driver_lisp="uiop/package.lisp uiop/common-lisp.lisp uiop/utility.lisp uiop/version.lisp uiop/os.lisp uiop/pathname.lisp uiop/filesystem.lisp uiop/stream.lisp uiop/image.lisp uiop/lisp-build.lisp uiop/launch-program.lisp uiop/run-program.lisp uiop/configuration.lisp uiop/backward-driver.lisp uiop/driver.lisp"
defsystem_lisp="upgrade.lisp cache.lisp component.lisp system.lisp find-system.lisp find-component.lisp operation.lisp action.lisp lisp-action.lisp plan.lisp operate.lisp parse-defsystem.lisp bundle.lisp concatenate-source.lisp output-translations.lisp source-registry.lisp package-inferred-system.lisp backward-interface.lisp backward-internals.lisp interface.lisp user.lisp footer.lisp"
defsystem_lisp="upgrade.lisp session.lisp component.lisp operation.lisp system.lisp system-registry.lisp action.lisp lisp-action.lisp find-component.lisp forcing.lisp plan.lisp operate.lisp find-system.lisp parse-defsystem.lisp bundle.lisp concatenate-source.lisp package-inferred-system.lisp output-translations.lisp source-registry.lisp backward-internals.lisp backward-interface.lisp interface.lisp user.lisp footer.lisp"
all () {
# Default action: bootstrap asdf.lisp
......
This diff is collapsed.
......@@ -3,7 +3,7 @@
(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 :asdf/find-system)
(:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/session)
(:export
#:operation
#:*operations* #:make-operation #:find-operation
......
......@@ -4,8 +4,9 @@
(uiop:define-package :asdf/package-inferred-system
(:recycle :asdf/package-inferred-system :asdf/package-system :asdf)
(:use :uiop/common-lisp :uiop
:asdf/defsystem ;; Using the old name of :asdf/parse-defsystem for compatibility
:asdf/upgrade :asdf/component :asdf/system :asdf/find-system :asdf/lisp-action)
:asdf/upgrade :asdf/session
:asdf/component :asdf/system :asdf/system-registry :asdf/lisp-action
:asdf/parse-defsystem)
(:export
#:package-inferred-system #:sysdef-package-inferred-system-search
#:package-system ;; backward compatibility only. To be removed.
......
......@@ -5,15 +5,20 @@
(:recycle :asdf/parse-defsystem :asdf/defsystem :asdf)
(:nicknames :asdf/defsystem) ;; previous name, to be compatible with, in case anyone cares
(:use :uiop/common-lisp :asdf/driver :asdf/upgrade
:asdf/cache :asdf/component :asdf/system
:asdf/find-system :asdf/find-component :asdf/action :asdf/lisp-action :asdf/operate)
:asdf/session :asdf/component :asdf/system :asdf/system-registry
:asdf/find-component :asdf/action :asdf/lisp-action :asdf/operate)
(:import-from :asdf/system #:depends-on #:weakly-depends-on)
;; these needed for record-additional-system-input-file
(:import-from :asdf/operation #:make-operation)
(:import-from :asdf/component #:%additional-input-files)
(:import-from :asdf/find-system #:define-op)
(:export
#:defsystem #:register-system-definition
#:class-for-type #:*default-component-class*
#:determine-system-directory #:parse-component-form
#:non-toplevel-system #:non-system-system #:bad-system-name
#:sysdef-error-component #:check-component-input))
#:sysdef-error-component #:check-component-input
#:explain))
(in-package :asdf/parse-defsystem)
;;; Pathname
......@@ -101,6 +106,27 @@ Please only define ~S and secondary systems with a name starting with ~S (e.g. ~
(sysdef-error-component ":components must be NIL or a list of components."
type name components)))
(defun record-additional-system-input-file (pathname component parent)
(let* ((record-on (if parent
(loop :with retval
:for par = parent :then (component-parent par)
:while par
:do (setf retval par)
:finally (return retval))
component))
(comp (if (typep record-on 'component)
record-on
;; at this point there will be no parent for RECORD-ON
(find-component record-on nil)))
(op (make-operation 'define-op))
(cell (or (assoc op (%additional-input-files comp))
(let ((new-cell (list op)))
(push new-cell (%additional-input-files comp))
new-cell))))
(pushnew pathname (cdr cell) :test 'pathname-equal)
(values)))
;; Given a form used as :version specification, in the context of a system definition
;; in a file at PATHNAME, for given COMPONENT with given PARENT, normalize the form
;; to an acceptable ASDF-format version.
......@@ -121,12 +147,16 @@ Please only define ~S and secondary systems with a name starting with ~S (e.g. ~
(case (first form)
((:read-file-form)
(destructuring-bind (subpath &key (at 0)) (rest form)
(safe-read-file-form (subpathname pathname subpath)
:at at :package :asdf-user)))
(let ((path (subpathname pathname subpath)))
(record-additional-system-input-file path component parent)
(safe-read-file-form path
:at at :package :asdf-user))))
((:read-file-line)
(destructuring-bind (subpath &key (at 0)) (rest form)
(safe-read-file-line (subpathname pathname subpath)
:at at)))
(let ((path (subpathname pathname subpath)))
(record-additional-system-input-file path component parent)
(safe-read-file-line (subpathname pathname subpath)
:at at))))
(otherwise
(invalid))))
(t
......@@ -288,7 +318,7 @@ system names contained using COERCE-NAME. Return the result."
;; that is registered to a different location to find-system,
;; we also need to remember it in the asdf-cache.
(nest
(with-asdf-cache ())
(with-asdf-session ())
(let* ((name (coerce-name name))
(source-file (if sfp source-file (resolve-symlinks* (load-pathname))))))
(flet ((fix-case (x) (if (logical-pathname-p source-file) (string-downcase x) x))))
......@@ -307,13 +337,12 @@ system names contained using COERCE-NAME. Return the result."
:collect :it)))
(load-systems* deps)
dep-forms))
(registered (system-registered-p name))
(registered! (if registered
(rplaca registered (get-file-stamp source-file))
(register-system
(make-instance 'system :name name :source-file source-file))))
(system (reset-system (cdr registered!)
:name name :source-file source-file))
(system (or (find-system-if-being-defined name)
(if-let (registered (registered-system name))
(reset-system-class registered 'undefined-system
:name name :source-file source-file)
(register-system (make-instance 'undefined-system
:name name :source-file source-file)))))
(component-options
(append
(remove-plist-keys '(:defsystem-depends-on :class) options)
......@@ -329,7 +358,7 @@ system names contained using COERCE-NAME. Return the result."
(unless (subtypep class 'system)
(error 'non-system-system :name name :class-name (class-name class)))
(unless (eq (type-of system) class)
(change-class system class)))
(reset-system-class system class)))
(parse-component-form nil (list* :module name :pathname directory component-options))))
(defmacro defsystem (name &body options)
......
This diff is collapsed.
This diff is collapsed.
......@@ -4,7 +4,7 @@
(uiop/package:define-package :asdf/source-registry
(:recycle :asdf/source-registry :asdf)
(:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/find-system)
(:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/system :asdf/system-registry)
(:export
#:*source-registry-parameter* #:*default-source-registries*
#:invalid-source-registry
......
This diff is collapsed.
......@@ -2,15 +2,15 @@
;;;; Systems
(uiop/package:define-package :asdf/system
(:recycle :asdf :asdf/system)
(:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/component)
(:recycle :asdf :asdf/system :asdf/find-system)
(:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/session :asdf/component)
(:export
#:system #:proto-system
#:system #:proto-system #:undefined-system #:reset-system-class
#:system-source-file #:system-source-directory #:system-relative-pathname
#:reset-system
#:system-description #:system-long-description
#:system-author #:system-maintainer #:system-licence #:system-license
#:system-defsystem-depends-on #:system-depends-on #:system-weakly-depends-on
#:definition-dependency-list #:definition-dependency-set #:system-defsystem-depends-on
#:system-depends-on #:system-weakly-depends-on
#:component-build-pathname #:build-pathname
#:component-entry-point #:entry-point
#:homepage #:system-homepage
......@@ -18,6 +18,7 @@
#:mailto #:system-mailto
#:long-name #:system-long-name
#:source-control #:system-source-control
#:coerce-name #:primary-system-name #:primary-system-p #:coerce-filename
#:find-system #:builtin-system-p)) ;; forward-reference, defined in find-system
(in-package :asdf/system)
......@@ -59,7 +60,14 @@ NB: This interface is subject to change. Please contact ASDF maintainers if you
(defclass proto-system () ; slots to keep when resetting a system
;; To preserve identity for all objects, we'd need keep the components slots
;; but also to modify parse-component-form to reset the recycled objects.
((name) (source-file) #|(children) (children-by-names)|#)
((name)
(source-file)
;; These two slots contains the *inferred* dependencies of define-op,
;; from loading the .asd file, as list and as set.
(definition-dependency-list
:initform nil :accessor definition-dependency-list)
(definition-dependency-set
:initform (list-to-hash-set nil) :accessor definition-dependency-set))
(:documentation "PROTO-SYSTEM defines the elements of identity that are preserved when
a SYSTEM is redefined and its class is modified."))
......@@ -85,6 +93,7 @@ a SYSTEM is redefined and its class is modified."))
(entry-point
:initform nil :initarg :entry-point :accessor component-entry-point)
(source-file :initform nil :initarg :source-file :accessor system-source-file)
;; This slot contains the *declared* defsystem-depends-on dependencies
(defsystem-depends-on :reader system-defsystem-depends-on :initarg :defsystem-depends-on
:initform nil)
;; these two are specially set in parse-component-form, so have no :INITARGs.
......@@ -93,14 +102,54 @@ a SYSTEM is redefined and its class is modified."))
(:documentation "SYSTEM is the base class for top-level components that users may request
ASDF to build."))
(defclass undefined-system (system) ()
(:documentation "System that was not defined yet."))
(defun reset-system (system &rest keys &key &allow-other-keys)
(defun reset-system-class (system new-class &rest keys &key &allow-other-keys)
"Erase any data from a SYSTEM except its basic identity, then reinitialize it
based on supplied KEYS."
(change-class (change-class system 'proto-system) 'system)
(change-class (change-class system 'proto-system) new-class)
(apply 'reinitialize-instance system keys)))
;;; Canonicalizing system names
(with-upgradability ()
(defun coerce-name (name)
"Given a designator for a component NAME, return the name as a string.
The designator can be a COMPONENT (designing its name; note that a SYSTEM is a component),
a SYMBOL (designing its name, downcased), or a STRING (designing itself)."
(typecase name
(component (component-name name))
(symbol (string-downcase name))
(string name)
(t (sysdef-error (compatfmt "~@<Invalid component designator: ~3i~_~A~@:>") name))))
(defun primary-system-name (system-designator)
"Given a system designator NAME, return the name of the corresponding primary system,
after which the .asd file is named. That's the first component when dividing the name
as a string by / slashes. A component designates its system."
(etypecase system-designator
(string (if-let (p (position #\/ system-designator))
(subseq system-designator 0 p) system-designator))
(symbol (primary-system-name (coerce-name system-designator)))
(component (primary-system-name (coerce-name (component-system system-designator))))))
(defun primary-system-p (system)
"Given a system designator SYSTEM, return T if it designates a primary system, or else NIL.
Also return NIL if system is neither a SYSTEM nor a string designating one."
(typecase system
(string (not (find #\/ system)))
(system (primary-system-p (coerce-name system)))))
(defun coerce-filename (name)
"Coerce a system designator NAME into a string suitable as a filename component.
The (current) transformation is to replace characters /:\\ each by --,
the former being forbidden in a filename component.
NB: The onus is unhappily on the user to avoid clashes."
(frob-substrings (coerce-name name) '("/" ":" "\\") "--")))
;;;; Pathnames
(with-upgradability ()
......
......@@ -169,7 +169,7 @@
(logical-pathname-p module-pathname))
(and (stringp file-pathname) (find #\. file-pathname)))
(incf system-count)
(with-asdf-cache (:override t)
(with-asdf-session (:override t)
(clear-system :test-system)
(let* ((system (let ((*verbose-out* nil))
(eval system-definition)))
......
(defsystem "defsystem-dependency"
:depends-on ("overlapping-dependency")
:components ((:file "defsystem-dependency"))
:in-order-to ((test-op (test-op "test-system"))))
(in-package :asdf-test)
(defvar *dd* 0)
(incf *dd*)
(format t "Loaded defsystem-dependency.lisp ~d time~(~:*~p~)~%" *dd*)
(setf (find-class 'asdf::my-cl-source-file) (find-class 'cl-source-file))
(eval-when (:compile-toplevel :load-toplevel :execute)
(defvar *cdd* 0))
(eval-when (:compile-toplevel :execute)
(incf *cdd*))
(defsystem "intermediate-dependency"
:defsystem-depends-on ("defsystem-dependency")
:components ((:my-cl-source-file "intermediate-dependency")))
(in-package :asdf-test)
(defvar *id* 0)
(incf *id*)
(defsystem "main-system"
:depends-on ("overlapping-dependency" "intermediate-dependency")
:components ((:file "main-system")))
(in-package :asdf-test)
(defvar *ms* 0)
(incf *ms*)
(in-package :asdf-test)
(defvar *od* 0)
(defsystem "overlapping-dependency"
;;:perform (load-op (o c) (incf *od*)) ;; Now done in the file.
:components ((:file "overlapping-dependency")))
(in-package :asdf-test)
(defvar *od* 0)
(incf *od*)
(eval-when (:compile-toplevel :load-toplevel :execute)
(defvar *cod* 0))
(eval-when (:compile-toplevel :execute)
(incf *cod*))
(defsystem "test-system"
:defsystem-depends-on ("defsystem-dependency")
:components ((:my-cl-source-file "test-system"))
:perform (test-op (o c) (symbol-call :asdf-test :run-test)))
(in-package :asdf-test)
(setf *dd* 10)
(defun run-test ()
(format t "Running tests...")
t)
;;; -*- Lisp -*-
(asdf:defsystem file3-only
:components ((:file "file3")))
(defsystem file3-only
:components ((:file "file3")))
(defvar *file3-only-asd-loaded* 0)
(incf *file3-only-asd-loaded*)
(in-package :test-package)
(assert *file3*)
(defparameter *file4* t)
;;-*- Lisp -*-
(register-directory (subpathname *test-directory* "package-inferred-system-test/"))
(load-system :package-inferred-system-test/a/x)
(load-system :package-inferred-system-test/d)
......@@ -5,7 +7,8 @@
(signals package-inferred-system-missing-package-error (load-system :package-inferred-system-test/e))
;; No such file.
(signals missing-component (load-system :package-inferred-system-test/f))
(signals missing-component
(handler-bind ((system-out-of-date 'continue)) (load-system :package-inferred-system-test/f)))
;; Test that around-compile is inherited by inferred systems.
(assert-equal 3 (symbol-call :package-inferred-system-test/a :add10 1)) ;; add10 must have been compiled in base 2
......@@ -156,7 +156,7 @@ do_tests () {
echo "or more interactively (and maybe with rlwrap or in emacs), start with:" >&2
echo "(cd test ; $icmd )" >&2
echo "then copy/paste:" >&2
echo "'(#.(load \"script-support.lisp\") #.(asdf-test::da) #.(load-asdf) #.(frob-packages) #.(asdf::with-asdf-cache () (load \"$i\")))" >&2
echo "'(#.(load \"script-support.lisp\") #.(asdf-test::da) #.(load-asdf) #.(frob-packages) #.(load \"$i\"))" >&2
fi
echo >&2
echo >&2
......
......@@ -32,7 +32,7 @@ Some constraints:
#:action-name #:in-plan-p
#:test-source #:test-fasl #:resolve-output #:output-location
#:quietly #:join-namestrings
#:clear-cache))
#:reset-session #:reset-session-visited))
(in-package :asdf-test)
......@@ -55,6 +55,8 @@ Some constraints:
))
(defvar *debug-asdf* nil)
(defvar *print-backtrace* t)
(defvar *quit-when-done* t)
(defun verbose (&optional (verbose t) (print verbose))
......@@ -337,12 +339,12 @@ Some constraints:
(assert-equal (file-write-date file) stamp))
;; else
(progn
(unless (asymval :*asdf-cache*)
(error "Trying to use *ASDF-CACHE* in TOUCH-FILE, but cache is not initialized."))
(unless (asymval :*asdf-session*)
(error "Trying to use the ASDF session cache in TOUCH-FILE, but it is not initialized."))
(acall :register-file-stamp file stamp)))))
(defun mark-file-deleted (file)
(unless (asymval :*asdf-cache*) (error "Y U NO use asdf cache?"))
(unless (asymval :*asdf-session*) (error "Y U NO use asdf session?"))
(acall :register-file-stamp (acall :normalize-namestring file) nil))
(defun hash-table->alist (table)
......@@ -403,12 +405,13 @@ is bound, write a message and exit on an error. If
(format *error-output* "~&TEST ABORTED: ~A~&" c))
(finish-outputs*)
(unless *debug-asdf*
(ignore-errors
(format *error-output* "~&Backtrace:~%")
(acall :print-condition-backtrace
c :count 69 :stream *error-output*))
(when *print-backtrace*
(ignore-errors
(format *error-output* "~&Backtrace:~%")
(acall :print-condition-backtrace
c :count 69 :stream *error-output*)))
(leave-test "Script failed" 1)))))
(funcall (or (asym :call-with-asdf-cache) 'funcall) thunk)
(funcall thunk)
(leave-test "Script succeeded" 0)))))
(when *quit-when-done*
(exit-lisp result))))
......@@ -613,7 +616,8 @@ is bound, write a message and exit on an error. If