Commit 2b35d7c9 by Robert Goldman

Merge branch 'plan' into 'master'

Add support for proper phase separation See merge request !37
parents 5eca3749 65d16a93
......@@ -48,6 +48,7 @@ lib/
test/try-reloading-dependency.asd
test/fileMissing.lisp
test/hello-world-example
test/test-include.asd
build-stamp
......
......@@ -80,13 +80,13 @@ 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 $* = $($*)
# Making ASDF itself should be our first, default, target:
build/asdf.lisp: show-version $(all_lisp)
build/asdf.lisp: $(all_lisp)
mkdir -p build
rm -f $@
cat $(all_lisp) > $@
......
......@@ -3,24 +3,26 @@
(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)
#-clisp (:unintern #:required-components #:traverse-action #:traverse-sub-actions)
(:import-from :asdf/component #:%additional-input-files)
(: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 +51,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 +112,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 +130,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 +308,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 +380,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))
......@@ -377,7 +430,8 @@ They may rely on the order of the files to discriminate between inputs.
Updates the action's COMPONENT-OPERATION-TIME to match the COMPUTE-ACTION-STAMP
using the JUST-DONE flag."))
(defgeneric compute-action-stamp (plan operation component &key just-done)
(defgeneric compute-action-stamp (plan- operation component &key just-done)
;; NB: using plan- rather than plan above allows clisp to upgrade from 2.26(!)
(:documentation "Has this action been successfully done already,
and at what known timestamp has it been done at or will it be done at?
* PLAN is a plan object modelling future effects of actions,
......@@ -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"
......@@ -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 :asdf/bundle)
(:export
#:*asdf-verbose*
#:operation-error #:compile-error #:compile-failed #:compile-warned
......@@ -15,13 +16,14 @@
#:operation-on-failure #:operation-on-warnings #:on-failure #:on-warnings
#:component-property
#:run-shell-command
#:system-definition-pathname
#:explain))
#:system-definition-pathname #:system-registered-p #:require-system
#:explain
#+ecl #:make-build))
(in-package :asdf/backward-interface)
;; NB: the warning status of these functions may have to be distinguished later,
;; as some get removed faster than the others in client code.
(with-asdf-deprecation (:style-warning "3.2")
(with-asdf-deprecation (:style-warning "3.2" :warning "3.4")
;; These conditions from ASDF 1 and 2 are used by many packages in Quicklisp;
;; but ASDF3 replaced them with somewhat different variants of uiop:compile-condition
......@@ -208,3 +210,69 @@ 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))))
;;; This function is for backward compatibility with ECL only.
#+ecl
(with-asdf-deprecation (:style-warning "3.2" :warning "9999")
(defun make-build (system &rest args
&key (monolithic nil) (type :fasl) (move-here nil move-here-p)
prologue-code epilogue-code no-uiop
prefix-lisp-object-files postfix-lisp-object-files extra-object-files
&allow-other-keys)
(let* ((operation (asdf/bundle::select-bundle-operation type monolithic))
(move-here-path (if (and move-here
(typep move-here '(or pathname string)))
(ensure-pathname move-here :namestring :lisp :ensure-directory t)
(system-relative-pathname system "asdf-output/")))
(extra-build-args (remove-plist-keys
'(:monolithic :type :move-here
:prologue-code :epilogue-code :no-uiop
:prefix-lisp-object-files :postfix-lisp-object-files
:extra-object-files)
args))
(build-system (if (subtypep operation 'image-op)
(eval `(defsystem "asdf.make-build"
:class program-system
:source-file nil
:pathname ,(system-source-directory system)
:build-operation ,operation
:build-pathname ,(subpathname move-here-path
(file-namestring (first (output-files operation system))))
:depends-on (,(coerce-name system))
:prologue-code ,prologue-code
:epilogue-code ,epilogue-code
:no-uiop ,no-uiop
:prefix-lisp-object-files ,prefix-lisp-object-files
:postfix-lisp-object-files ,postfix-lisp-object-files
:extra-object-files ,extra-object-files
:extra-build-args ,extra-build-args))
system))
(files (output-files operation build-system)))
(operate operation build-system)
(if (or move-here
(and (null move-here-p) (member operation '(program-op image-op))))
(loop :with dest-path = (resolve-symlinks* (ensure-directories-exist move-here-path))
:for f :in files
:for new-f = (make-pathname :name (pathname-name f)
:type (pathname-type f)
:defaults dest-path)
:do (rename-file-overwriting-target f new-f)
:collect new-f)
files))))
......@@ -7,7 +7,7 @@
(:export #:load-sysdef))
(in-package :asdf/backward-internals)
(with-asdf-deprecation (:style-warning "3.2")
(with-asdf-deprecation (:style-warning "3.2" :warning "3.4")
(defun load-sysdef (name pathname)
(declare (ignore name pathname))
;; Needed for backward compatibility with swank-asdf from SLIME 2015-12-01 or older.
......
......@@ -4,8 +4,9 @@
(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/find-component ;; used by ECL
: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 +324,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 +442,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 +497,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:
......@@ -527,7 +527,7 @@ which is probably not what you want; you probably need to tweak your output tran
(defun linkable-system (x)
(or (if-let (s (find-system x))
(and (system-source-file x) s))
(and (output-files 'lib-op s) s))
(if-let (p (system-module-pathname (coerce-name x)))
(make-prebuilt-system x p))))
......@@ -544,7 +544,8 @@ which is probably not what you want; you probably need to tweak your output tran
`((lib-op
,@(unless (no-uiop c)
(list (linkable-system "cmp")
(unless (or (gethash "uiop" deps) (gethash "asdf" deps))
(unless (or (and (gethash "uiop" deps) (linkable-system "uiop"))
(and (gethash "asdf" deps) (linkable-system "asdf")))
(or (linkable-system "uiop")
(linkable-system "asdf")
"asdf")))))
......
;;;; -------------------------------------------------------------------------
;;;; Session cache
(uiop/package:define-package :asdf/cache
(:use :uiop/common-lisp :uiop :asdf/upgrade)
(:export #:get-file-stamp #:compute-file-stamp #:register-file-stamp
#:set-asdf-cache-entry #:unset-asdf-cache-entry #:consult-asdf-cache
#:do-asdf-cache #:normalize-namestring
#:call-with-asdf-cache #:with-asdf-cache #:*asdf-cache*
#:clear-configuration-and-retry #:retry))
(in-package :asdf/cache)
;;; The ASDF session cache is used to memoize some computations. It is instrumental in achieving:
;; * Consistency in the view of the world relied on by ASDF within a given session.
;; Inconsistencies in file stamps, system definitions, etc., could cause infinite loops
;; (a.k.a. stack overflows) and other erratic behavior.
;; * Speed and reliability of ASDF, with fewer side-effects from access to the filesystem, and
;; no expensive recomputations of transitive dependencies for some input-files or output-files.
;; * Testability of ASDF with the ability to fake timestamps without actually touching files.
(with-upgradability ()
;; The session cache variable.
;; NIL when outside a session, an equal hash-table when inside a session.
(defvar *asdf-cache* nil)
;; Set a session cache entry for KEY to a list of values VALUE-LIST, when inside a session.
;; Return those values.
(defun set-asdf-cache-entry (key value-list)
(values-list (if *asdf-cache*
(setf (gethash key *asdf-cache*) value-list)
value-list)))
;; Unset the session cache entry for KEY, when inside a session.
(defun unset-asdf-cache-entry (key)
(when *asdf-cache*
(remhash key *asdf-cache*)))
;; Consult the session cache entry for KEY if present and in a session;
;; if not present, compute it by calling the THUNK,
;; and set the session cache entry accordingly, if in a session.
;; Return the values from the cache and/or the thunk computation.
(defun consult-asdf-cache (key &optional thunk)
(if *asdf-cache*
(multiple-value-bind (results foundp) (gethash key *asdf-cache*)
(if foundp
(values-list results)
(set-asdf-cache-entry key (multiple-value-list (call-function thunk)))))
(call-function thunk)))
;; Syntactic sugar for consult-asdf-cache
(defmacro do-asdf-cache (key &body body)
`(consult-asdf-cache ,key #'(lambda () ,@body)))
;; Compute inside a ASDF session with a cache.
;; First, make sure an ASDF session is underway, by binding the session cache variable
;; to a new hash-table if it's currently null (or even if it isn't, if OVERRIDE is true).
;; Second, if a new session was started, establish restarts for retrying the overall computation.
;; Finally, consult the cache if a KEY was specified with the THUNK as a fallback when the cache
;; entry isn't found, or just call the THUNK if no KEY was specified.
(defun call-with-asdf-cache (thunk &key override key)
(let ((fun (if key #'(lambda () (consult-asdf-cache key thunk)) thunk)))
(if (and *asdf-cache* (not override))
(funcall fun)
(loop
(restart-case
(let ((*asdf-cache* (make-hash-table :test 'equal)))
(return (funcall fun)))
(retry ()
:report (lambda (s)
(format s (compatfmt "~@<Retry ASDF operation.~@:>"))))
(clear-configuration-and-retry ()
:report (lambda (s)
(format s (compatfmt "~@<Retry ASDF operation after resetting the configuration.~@:>")))
(clear-configuration)))))))
;; Syntactic sugar for call-with-asdf-cache
(defmacro with-asdf-cache ((&key key override) &body body)
`(call-with-asdf-cache #'(lambda () ,@body) :override ,override :key ,key))
;;; Define specific accessor for file (date) stamp.
;; Normalize a namestring for use as a key in the session cache.
(defun normalize-namestring (pathname)
(let ((resolved (resolve-symlinks*
(ensure-absolute-pathname
(physicalize-pathname pathname)
'get-pathname-defaults))))
(with-pathname-defaults () (namestring resolved))))
;; Compute the file stamp for a normalized namestring
(defun compute-file-stamp (normalized-namestring)
(with-pathname-defaults ()
(safe-file-write-date normalized-namestring)))
;; Override the time STAMP associated to a given FILE in the session cache.
;; If no STAMP is specified, recompute a new one from the filesystem.
(defun register-file-stamp (file &optional (stamp nil stampp))
(let* ((namestring (normalize-namestring file))
(stamp (if stampp stamp (compute-file-stamp namestring))))
(set-asdf-cache-entry `(get-file-stamp ,namestring) (list stamp))))
;; Get or compute a memoized stamp for given FILE from the session cache.
(defun get-file-stamp (file)
(when file
(let ((namestring (normalize-namestring file)))
(do-asdf-cache `(get-file-stamp ,namestring) (compute-file-stamp namestring))))))
......@@ -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
......
(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)
......@@ -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.