Commit 51accff1 authored by Francois-Rene Rideau's avatar Francois-Rene Rideau

Add out-of-date detection for system definition

parent 017cb992
...@@ -16,7 +16,7 @@ ...@@ -16,7 +16,7 @@
#:input-files #:output-files #:output-file #:operation-done-p #:input-files #:output-files #:output-file #:operation-done-p
#:action-operation #:action-component #:make-action #:action-operation #:action-component #:make-action
#:component-operation-time #:mark-operation-done #:compute-action-stamp #:component-operation-time #:mark-operation-done #:compute-action-stamp
#:perform #:perform-with-restarts #:retry #:accept #:*action* #:perform #:perform-with-restarts #:retry #:accept
#:action-path #:find-action #:stamp #:done-p #:action-path #:find-action #:stamp #:done-p
#:operation-definition-warning #:operation-definition-error ;; condition #:operation-definition-warning #:operation-definition-error ;; condition
#:action-valid-p #:action-valid-p
...@@ -50,9 +50,10 @@ and a class-name or class designates the canonical instance of the designated cl ...@@ -50,9 +50,10 @@ and a class-name or class designates the canonical instance of the designated cl
(with-upgradability () (with-upgradability ()
(defun action-path (action) (defun action-path (action)
"A readable data structure that identifies the action." "A readable data structure that identifies the action."
(let ((o (action-operation action)) (when action
(c (action-component action))) (let ((o (action-operation action))
(cons (type-of o) (component-find-path c)))) (c (action-component action)))
(cons (type-of o) (component-find-path c)))))
(defun find-action (path) (defun find-action (path)
"Reconstitute an action from its action-path" "Reconstitute an action from its action-path"
(destructuring-bind (o . c) path (make-action (make-operation o) (find-component () c))))) (destructuring-bind (o . c) path (make-action (make-operation o) (find-component () c)))))
...@@ -110,7 +111,7 @@ and a class-name or class designates the canonical instance of the designated cl ...@@ -110,7 +111,7 @@ and a class-name or class designates the canonical instance of the designated cl
,if-no-component)))))))) ,if-no-component))))))))
;;;; self-description ;;;; Self-description
(with-upgradability () (with-upgradability ()
(defgeneric action-description (operation component) (defgeneric action-description (operation component)
(:documentation "returns a phrase that describes performing this operation (:documentation "returns a phrase that describes performing this operation
...@@ -128,6 +129,42 @@ Use it in FORMAT control strings as ~/asdf-action:format-action/" ...@@ -128,6 +129,42 @@ Use it in FORMAT control strings as ~/asdf-action:format-action/"
(princ (action-description operation component) stream)))) (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 ;;;; Dependencies
(with-upgradability () (with-upgradability ()
(defgeneric component-depends-on (operation component) ;; ASDF4: rename to component-dependencies (defgeneric component-depends-on (operation component) ;; ASDF4: rename to component-dependencies
...@@ -410,11 +447,8 @@ Returns two values: ...@@ -410,11 +447,8 @@ Returns two values:
(:documentation "PERFORM an action, consuming its input-files and building its output-files")) (:documentation "PERFORM an action, consuming its input-files and building its output-files"))
(define-convenience-action-methods perform (operation component)) (define-convenience-action-methods perform (operation component))
(defvar *action* nil
"Action being performed")
(defmethod perform :around ((o operation) (c component)) (defmethod perform :around ((o operation) (c component))
(let ((*action* (cons o c))) (while-visiting-action (o c) (call-next-method)))
(call-next-method)))
(defmethod perform :before ((o operation) (c component)) (defmethod perform :before ((o operation) (c component))
(ensure-all-directories-exist (output-files o c))) (ensure-all-directories-exist (output-files o c)))
(defmethod perform :after ((o operation) (c component)) (defmethod perform :after ((o operation) (c component))
...@@ -452,40 +486,3 @@ Returns two values: ...@@ -452,40 +486,3 @@ Returns two values:
(action-description operation component))) (action-description operation component)))
(mark-operation-done operation component) (mark-operation-done operation component)
(return)))))) (return))))))
;;;; 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"
(when (action-valid-p operation component)
(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))))
...@@ -8,7 +8,7 @@ ...@@ -8,7 +8,7 @@
:asdf/find-component :asdf/system-registry :asdf/plan :asdf/operate) :asdf/find-component :asdf/system-registry :asdf/plan :asdf/operate)
(:export (:export
#:find-system #:locate-system #:load-asd #:define-op #:find-system #:locate-system #:load-asd #:define-op
#:load-system-definition-error #:error-name #:error-pathname #:error-condition)) #:load-system-definition-error #:error-name #:error-pathname #:error-condition #:system-out-of-date))
(in-package :asdf/find-system) (in-package :asdf/find-system)
(with-upgradability () (with-upgradability ()
...@@ -20,6 +20,13 @@ ...@@ -20,6 +20,13 @@
(format s (compatfmt "~@<Error while trying to load definition for system ~A from pathname ~A: ~3i~_~A~@:>") (format s (compatfmt "~@<Error while trying to load definition for system ~A from pathname ~A: ~3i~_~A~@:>")
(error-name c) (error-pathname c) (error-condition c))))) (error-name c) (error-pathname c) (error-condition c)))))
(define-condition system-out-of-date (condition)
;; NB: not an error, not a warning, but a normal expected condition
((name :initarg :name :reader component-name))
(:documentation "condition signaled when a system is detected as being out of date")
(:report (lambda (c s)
(format s "system ~A is out of date" (component-name c)))))
;;; Methods for find-system ;;; Methods for find-system
...@@ -50,13 +57,13 @@ ...@@ -50,13 +57,13 @@
(and (typep operation 'load-op) (and (typep operation 'load-op)
(typep component 'system) (typep component 'system)
(equal "asdf" (coerce-name component)))) (equal "asdf" (coerce-name component))))
(when *action* (if-let ((action (first (visiting-action-list *asdf-session*))))
(let ((parent-operation (car *action*)) (let ((parent-operation (action-operation action))
(parent-component (cdr *action*))) (parent-component (action-component action)))
(unless (and (typep parent-operation 'define-op) (typep parent-component 'system)) (unless (and (typep parent-operation 'define-op) (typep parent-component 'system))
(error "Invalid recursive use of (OPERATE ~S ~S) while visiting ~S ~ (error "Invalid recursive use of (OPERATE ~S ~S) while visiting ~S ~
- please use proper dependencies instead." - please use proper dependencies instead."
operation component *action*)) operation component action))
(let ((action (cons operation component))) (let ((action (cons operation component)))
(unless (gethash action (definition-dependency-set parent-component)) (unless (gethash action (definition-dependency-set parent-component))
(push (cons operation component) (definition-dependency-list parent-component)) (push (cons operation component) (definition-dependency-list parent-component))
...@@ -106,8 +113,8 @@ ...@@ -106,8 +113,8 @@
(asdf-message (compatfmt "~&~@<; ~@;Loading system definition~@[ for ~A~] from ~A~@:>~%") (asdf-message (compatfmt "~&~@<; ~@;Loading system definition~@[ for ~A~] from ~A~@:>~%")
(coerce-name s) pathname) (coerce-name s) pathname)
;; dependencies will depend on what's loaded via definition-dependency-list ;; dependencies will depend on what's loaded via definition-dependency-list
(unset-asdf-cache-entry `(component-depends-on ,o ,s)) (unset-asdf-cache-entry `(component-depends-on ,o ,s)))
(load* pathname :external-format (encoding-external-format (detect-encoding pathname)))))) (load* pathname :external-format (encoding-external-format (detect-encoding pathname)))))
(defun load-asd (pathname &key name) (defun load-asd (pathname &key name)
"Load system definitions from PATHNAME. "Load system definitions from PATHNAME.
...@@ -123,7 +130,9 @@ Do NOT try to load a .asd file directly with CL:LOAD. Always use ASDF:LOAD-ASD." ...@@ -123,7 +130,9 @@ Do NOT try to load a .asd file directly with CL:LOAD. Always use ASDF:LOAD-ASD."
(progn (progn
;; We already determine this to be obsolete --- ;; We already determine this to be obsolete ---
;; or should we move some tests from find-system to check for up-to-date-ness here? ;; or should we move some tests from find-system to check for up-to-date-ness here?
(setf (component-operation-time operation system) nil) (setf (component-operation-time operation system) nil
(definition-dependency-list system) nil
(definition-dependency-set system) (list-to-hash-set nil))
(do-it operation system)) (do-it operation system))
(let ((system (make-instance 'undefined-system (let ((system (make-instance 'undefined-system
:name primary-name :source-file pathname))) :name primary-name :source-file pathname)))
...@@ -214,38 +223,58 @@ PREVIOUS-TIME when not null is the time at which the PREVIOUS system was loaded. ...@@ -214,38 +223,58 @@ PREVIOUS-TIME when not null is the time at which the PREVIOUS system was loaded.
;; preloaded, with a previous configuration, or before filesystem changes), and ;; preloaded, with a previous configuration, or before filesystem changes), and
;; load a found .asd if appropriate. Finally, update registration table and return results. ;; load a found .asd if appropriate. Finally, update registration table and return results.
(defmethod find-system ((name string) &optional (error-p t)) (defmethod find-system ((name string) &optional (error-p t))
(with-asdf-session (:key `(find-system ,name)) (nest
(let ((primary-name (primary-system-name name))) (with-asdf-session (:key `(find-system ,name)))
(unless (equal name primary-name) (let* ((name-primary-p (primary-system-p name))
(find-system primary-name nil))) (primary-system (unless name-primary-p (find-system (primary-system-name name) nil)))))
(or (and *immutable-systems* (gethash name *immutable-systems*) (registered-system name)) (or (and *immutable-systems* (gethash name *immutable-systems*) (registered-system name)))
(multiple-value-bind (foundp found-system pathname previous previous-time) (multiple-value-bind (foundp found-system pathname previous previous-time)
(locate-system name) (locate-system name)
(assert (eq foundp (and (or found-system pathname previous) t))) (assert (eq foundp (and (or found-system pathname previous) t))))
(let ((previous-pathname (system-source-file previous)) (let ((previous-pathname (system-source-file previous))
(system (or previous found-system))) (system (or previous found-system)))
(when (and found-system (not previous)) (when (and found-system (not previous))
(register-system found-system)) (register-system found-system))
(when (and system pathname) (when (and system pathname)
(setf (system-source-file system) pathname)) (setf (system-source-file system) pathname))
(if-let ((stamp (get-file-stamp pathname))) (if-let ((stamp (get-file-stamp pathname)))
(let ((up-to-date-p (let ((up-to-date-p
(and previous (and previous
(or (pathname-equal pathname previous-pathname) (or (pathname-equal pathname previous-pathname)
(and pathname previous-pathname (and pathname previous-pathname
(pathname-equal (pathname-equal
(physicalize-pathname pathname) (physicalize-pathname pathname)
(physicalize-pathname previous-pathname)))) (physicalize-pathname previous-pathname))))
(stamp<= stamp previous-time) (stamp<= stamp previous-time)
;; TODO: check that all dependencies are up-to-date. ;; TODO: check that all dependencies are up-to-date.
;; This necessitates traversing them without triggering ;; This necessitates traversing them without triggering
;; the adding of nodes to the plan. ;; the adding of nodes to the plan.
))) (loop :with plan = (or (and *asdf-session*
(unless up-to-date-p (session-plan *asdf-session*))
(load-asd pathname :name name))))) (make-instance *plan-class*))
;; Try again after having loaded from disk if needed :for action :in (definition-dependency-list previous)
(or (registered-system name) :always (handler-bind
(when error-p (error 'missing-component :requires name))))))) ((system-out-of-date
(lambda (c) (declare (ignore c)) (return nil))))
(action-up-to-date-p plan
(action-operation action)
(action-component action)))
:finally
(let ((o (make-operation 'define-op))
(s (if name-primary-p previous primary-system)))
(when s
(multiple-value-bind (stamp done-p)
(compute-action-stamp plan o s)
(return (and (stamp<= stamp (component-operation-time o s))
done-p)))))))))
(unless up-to-date-p
(restart-case
(signal 'system-out-of-date :name name)
(continue () :report "continue"))
(load-asd pathname :name name)))))
;; Try again after having loaded from disk if needed
(or (registered-system name)
(when error-p (error 'missing-component :requires name)))))
;; Resolved forward reference for asdf/system-registry. ;; Resolved forward reference for asdf/system-registry.
(defun mark-component-preloaded (component) (defun mark-component-preloaded (component)
......
...@@ -123,7 +123,7 @@ ...@@ -123,7 +123,7 @@
#:missing-dependency #:missing-dependency
#:missing-dependency-of-version #:missing-dependency-of-version
#:circular-dependency ; errors #: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 #:package-inferred-system-missing-package-error
#:operation-definition-warning #:operation-definition-error #:operation-definition-warning #:operation-definition-error
......
...@@ -18,7 +18,7 @@ ...@@ -18,7 +18,7 @@
#:record-dependency #:record-dependency
#:normalize-forced-systems #:action-forced-p #:action-forced-not-p #:normalize-forced-systems #:action-forced-p #:action-forced-not-p
#:map-direct-dependencies #:reduce-direct-dependencies #:direct-dependencies #:map-direct-dependencies #:reduce-direct-dependencies #:direct-dependencies
#:compute-action-stamp #:traverse-action #:compute-action-stamp #:traverse-action #:action-up-to-date-p
#:make-plan #:plan-actions #:perform-plan #:plan-operates-on-p #:make-plan #:plan-actions #:perform-plan #:plan-operates-on-p
#:planned-p #:index #:forced #:forced-not #:planned-p #:index #:forced #:forced-not
#:plan-actions-r #:plan-actions-r
...@@ -73,6 +73,9 @@ in some previous image, or T if it needs to be done.") ...@@ -73,6 +73,9 @@ in some previous image, or T if it needs to be done.")
+action-status-out-of-date+ +action-status-out-of-date+
(make-instance 'action-status :stamp stamp :done-p done-p :planned-p planned-p :index index))) (make-instance 'action-status :stamp stamp :done-p done-p :planned-p planned-p :index index)))
(defun action-status-out-of-date-p (status)
(eq (action-stamp status) t))
(defmethod print-object ((status action-status) stream) (defmethod print-object ((status action-status) stream)
(print-unreadable-object (status stream :type t) (print-unreadable-object (status stream :type t)
(with-slots (stamp done-p planned-p index) status (with-slots (stamp done-p planned-p index) status
...@@ -104,6 +107,7 @@ the action of OPERATION on COMPONENT in the PLAN")) ...@@ -104,6 +107,7 @@ the action of OPERATION on COMPONENT in the PLAN"))
(setf (gethash o times) (action-stamp new-status)))) (setf (gethash o times) (action-stamp new-status))))
new-status)) new-status))
;;;; forcing ;;;; forcing
(with-upgradability () (with-upgradability ()
(defgeneric action-forced-p (plan operation component) (defgeneric action-forced-p (plan operation component)
...@@ -346,8 +350,9 @@ initialized with SEED." ...@@ -346,8 +350,9 @@ initialized with SEED."
(defun action-up-to-date-p (plan operation component) (defun action-up-to-date-p (plan operation component)
"Check whether a node is up-to-date, and mark it so if such. But don't add anything to the plan." "Check whether a node is up-to-date, and mark it so if such. But don't add anything to the plan."
(while-visiting-action (operation component) ; maintain context, handle circularity. (block nil
(block nil (unless (action-valid-p operation component) (return nil))
(while-visiting-action (operation component) ; maintain context, handle circularity.
;; Do NOT record the dependency: it might be out of date. ;; Do NOT record the dependency: it might be out of date.
(let ((status (action-status plan operation component))) (let ((status (action-status plan operation component)))
(when status (when status
...@@ -369,12 +374,13 @@ initialized with SEED." ...@@ -369,12 +374,13 @@ initialized with SEED."
(not (eq (action-stamp status) t)))))) (not (eq (action-stamp status) t))))))
(defmethod traverse-action (plan operation component needed-in-image-p) (defmethod traverse-action (plan operation component needed-in-image-p)
(while-visiting-action (operation component) ; maintain context, handle circularity. (block nil
(block nil (unless (action-valid-p operation component) (return nil))
;; Record the dependency. This hook is needed by POIU, which tracks a full dependency graph, ;; Record the dependency. This hook is needed by POIU, which tracks a full dependency graph,
;; instead of just a dependency order as in vanilla ASDF. ;; instead of just a dependency order as in vanilla ASDF.
;; TODO: It is also needed to detect OPERATE-in-PERFORM. ;; TODO: It is also needed to detect OPERATE-in-PERFORM.
(record-dependency plan operation component) (record-dependency plan operation component)
(while-visiting-action (operation component) ; maintain context, handle circularity.
;; needed-in-image distinguishes b/w things that must happen in the ;; needed-in-image distinguishes b/w things that must happen in the
;; current image and those things that simply need to have been done in a previous one. ;; current image and those things that simply need to have been done in a previous one.
(let* ((aniip (needed-in-image-p operation component)) ; action-specific needed-in-image (let* ((aniip (needed-in-image-p operation component)) ; action-specific needed-in-image
...@@ -451,6 +457,8 @@ initialized with SEED." ...@@ -451,6 +457,8 @@ initialized with SEED."
(with-asdf-session () (with-asdf-session ()
(let ((plan (apply 'make-instance (or plan-class *plan-class*) (let ((plan (apply 'make-instance (or plan-class *plan-class*)
:system (component-system c) keys))) :system (component-system c) keys)))
(when (and (null (session-plan *asdf-session*)) (plan-performable-p plan))
(setf (session-plan *asdf-session*) plan))
(traverse-action plan o c t) (traverse-action plan o c t)
plan))) plan)))
...@@ -506,15 +514,16 @@ initialized with SEED." ...@@ -506,15 +514,16 @@ initialized with SEED."
:collect (cons o c)))) :collect (cons o c))))
(defun collect-action-dependencies (plan operation component) (defun collect-action-dependencies (plan operation component)
(while-visiting-action (operation component) ; maintain context, handle circularity. (when (action-valid-p operation component)
(let ((action (make-action operation component))) (while-visiting-action (operation component) ; maintain context, handle circularity.
(unless (gethash action (visited-actions *asdf-session*)) (let ((action (make-action operation component)))
(setf (gethash action (visited-actions *asdf-session*)) t) (unless (gethash action (visited-actions *asdf-session*))
(when (and (typep component (plan-component-type plan)) (setf (gethash action (visited-actions *asdf-session*)) t)
(not (action-forced-not-p plan operation component))) (when (and (typep component (plan-component-type plan))
(map-direct-dependencies operation component (not (action-forced-not-p plan operation component)))
#'(lambda (o c) (collect-action-dependencies plan o c))) (map-direct-dependencies operation component
(push action (plan-actions-r plan))))))) #'(lambda (o c) (collect-action-dependencies plan o c)))
(push action (plan-actions-r plan))))))))
(defgeneric collect-dependencies (operation component &key &allow-other-keys) (defgeneric collect-dependencies (operation component &key &allow-other-keys)
(:documentation "Given an action, build a plan for all of its dependencies.")) (:documentation "Given an action, build a plan for all of its dependencies."))
......
...@@ -60,7 +60,14 @@ NB: This interface is subject to change. Please contact ASDF maintainers if you ...@@ -60,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 (defclass proto-system () ; slots to keep when resetting a system
;; To preserve identity for all objects, we'd need keep the components slots ;; 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. ;; but also to modify parse-component-form to reset the recycled objects.
((name) (source-file)) ((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 (:documentation "PROTO-SYSTEM defines the elements of identity that are preserved when
a SYSTEM is redefined and its class is modified.")) a SYSTEM is redefined and its class is modified."))
...@@ -89,11 +96,6 @@ a SYSTEM is redefined and its class is modified.")) ...@@ -89,11 +96,6 @@ a SYSTEM is redefined and its class is modified."))
;; This slot contains the *declared* defsystem-depends-on dependencies ;; This slot contains the *declared* defsystem-depends-on dependencies
(defsystem-depends-on :reader system-defsystem-depends-on :initarg :defsystem-depends-on (defsystem-depends-on :reader system-defsystem-depends-on :initarg :defsystem-depends-on
:initform nil) :initform nil)
;; These slots contains the *inferred* dependencies of define-op, 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)
;; these two are specially set in parse-component-form, so have no :INITARGs. ;; these two are specially set in parse-component-form, so have no :INITARGs.
(depends-on :reader system-depends-on :initform nil) (depends-on :reader system-depends-on :initform nil)
(weakly-depends-on :reader system-weakly-depends-on :initform nil)) (weakly-depends-on :reader system-weakly-depends-on :initform nil))
......
;;-*- Lisp -*-
(register-directory (subpathname *test-directory* "package-inferred-system-test/")) (register-directory (subpathname *test-directory* "package-inferred-system-test/"))
(load-system :package-inferred-system-test/a/x) (load-system :package-inferred-system-test/a/x)
(load-system :package-inferred-system-test/d) (load-system :package-inferred-system-test/d)
...@@ -5,7 +7,8 @@ ...@@ -5,7 +7,8 @@
(signals package-inferred-system-missing-package-error (load-system :package-inferred-system-test/e)) (signals package-inferred-system-missing-package-error (load-system :package-inferred-system-test/e))
;; No such file. ;; 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. ;; 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 (assert-equal 3 (symbol-call :package-inferred-system-test/a :add10 1)) ;; add10 must have been compiled in base 2
(defvar *tddoc* 0) (defvar *tddoc* 0)
(incf *tddoc*) (incf *tddoc*)
(format t "tddoc loaded ~D times.~%" *tddoc*)
(if (= *tddoc* 1) (if (= *tddoc* 1)
(defsystem "test-defsystem-depends-on-change" (defsystem "test-defsystem-depends-on-change"
......
...@@ -8,10 +8,12 @@ ...@@ -8,10 +8,12 @@
(defparameter tddoc "test-defsystem-depends-on-change") (defparameter tddoc "test-defsystem-depends-on-change")
(defparameter talc "test-asdf-location-change") (defparameter talc "test-asdf-location-change")
(defparameter asdf-user::*tddoc* 0)
(DBG "Load the system, using xach-foo-1") (DBG "Load the system, using xach-foo-1")
(push (subpathname *test-directory* "xach-foo-1/") *central-registry*) (push (subpathname *test-directory* "xach-foo-1/") *central-registry*)
(clear-system tddoc)
(load-system tddoc) (load-system tddoc)
(assert-equal asdf-user::*tddoc* 1) (assert-equal asdf-user::*tddoc* 1)
(assert-equal test-asdf-system::*times-loaded* 1) (assert-equal test-asdf-system::*times-loaded* 1)
...@@ -39,9 +41,12 @@ ...@@ -39,9 +41,12 @@
(subpathname *test-directory* "xach-foo-1/test-asdf-location-change.asd") (subpathname *test-directory* "xach-foo-1/test-asdf-location-change.asd")
(system-source-file talc)) (system-source-file talc))
(DBG "Now, change a defsystem-depends-on dependency and try again") (DBG "Now, change a defsystem-depends-on dependency and try again")
(setf (first *central-registry*) (subpathname *test-directory* "xach-foo-2/")) (setf (first *central-registry*) (subpathname *test-directory* "xach-foo-2/"))
(DBG :before asdf-user::*tddoc* test-asdf-system::*times-loaded* test-asdf-system::*ta/dcc* test-asdf-system::*ta/dcd* test-asdf-system::*ta/dca*)
(load-system "test-defsystem-depends-on-change") (load-system "test-defsystem-depends-on-change")
(DBG :after asdf-user::*tddoc* test-asdf-system::*times-loaded* test-asdf-system::*ta/dcc* test-asdf-system::*ta/dcd* test-asdf-system::*ta/dca*)
(assert-equal asdf-user::*tddoc* 2) (assert-equal asdf-user::*tddoc* 2)
(assert-equal test-asdf-system::*times-loaded* 1) ;; from test-asdf.asd (assert-equal test-asdf-system::*times-loaded* 1) ;; from test-asdf.asd
(assert-equal test-asdf-system::*ta/dcc* 2) (assert-equal test-asdf-system::*ta/dcc* 2)
......
...@@ -31,7 +31,8 @@ ...@@ -31,7 +31,8 @@
:components ((:file "file3"))) :components ((:file "file3")))
(reset-session) (reset-session)
(signals asdf::formatted-system-definition-error (make :test-defsystem-depends-on-3)) (signals asdf::formatted-system-definition-error
(handler-bind ((system-out-of-date 'continue)) (make :test-defsystem-depends-on-3)))
(defparameter *newsym* (gentemp (symbol-name 'feature) :keyword)) (defparameter *newsym* (gentemp (symbol-name 'feature) :keyword))
...@@ -49,9 +50,11 @@ ...@@ -49,9 +50,11 @@
(assert (not (system-registered-p "unloadable-system")))) (assert (not (system-registered-p "unloadable-system"))))
(progn (progn
(signals missing-dependency (find-system "test-defsystem-depends-on-missing-system")) (signals missing-dependency
(handler-bind ((system-out-of-date 'continue)) (find-system "test-defsystem-depends-on-missing-system")))
(assert (not (asdf::registered-system "test-defsystem-depends-on-missing-system")))) (assert (not (asdf::registered-system "test-defsystem-depends-on-missing-system"))))
(progn (progn
(signals asdf::system-definition-error (find-system "test-defsystem-depends-on-circular")) (signals asdf::system-definition-error
(handler-bind ((system-out-of-date 'continue)) (find-system "test-defsystem-depends-on-circular")))
(assert (not (asdf::registered-system "test-defsystem-depends-on-circular")))) (assert (not (asdf::registered-system "test-defsystem-depends-on-circular"))))
...@@ -2,16 +2,17 @@ ...@@ -2,16 +2,17 @@
(format! t "~%Using ASDF ~A~%" (asdf-version)) (format! t "~%Using ASDF ~A~%" (asdf-version))
(assert (version< "3.0" (asdf-version))) ;; check that we have a recent enough ASDF (assert (version< "3.0" (asdf-version))) ;; check that we have a recent enough ASDF
(setf *asdf-session* nil) (setf *asdf-session* nil)
(DBG "Let's define some methods on input-files, to later check what an upgrade does to them.") (DBG "Let's define some methods on input-files, to later check what an upgrade does to them.")
(with-asdf-session (:override t) (with-asdf-session (:override t)
(def-test-system "fooey") (def-test-system "fooey")
(defparameter *ticks* 0) (defparameter *ticks* 0)
(defun tick () (incf *ticks*)) (defun tick () (incf *ticks*))
(defsystem "foo") (def-test-system "foo")
(defmethod input-files :after ((o load-op) (c system)) (tick)) (defmethod input-files :after ((o load-op) (c system))
(tick))
(assert-equal *ticks* 0) (assert-equal *ticks* 0)
(input-files 'load-op "foo") (input-files 'load-op "foo")
(assert-equal *ticks* 1) (assert-equal *ticks* 1)
...@@ -19,6 +20,7 @@ ...@@ -19,6 +20,7 @@
(assert-equal *ticks* 1) ;; It was cached. (assert-equal *ticks* 1) ;; It was cached.
(assert (find-system "fooey" nil))) (assert (find-system "fooey" nil)))
(DBG "Try load ASDF with an empty configuration") (DBG "Try load ASDF with an empty configuration")
(initialize-source-registry (initialize-source-registry
'(:source-registry :ignore-inherited-configuration)) '(:source-registry :ignore-inherited-configuration))
...@@ -26,15 +28,15 @@ ...@@ -26,15 +28,15 @@
;; We haven't found it, and got the fallback ;; We haven't found it, and got the fallback
(assert-equal nil (system-source-file (find-system :asdf))) (assert-equal nil (system-source-file (find-system :asdf)))
(DBG "Bogus attempt at loading an old ASDF: should issue a warning and ignore")
(clear-system "asdf")
;; Bogus sysdef finding function, for the sake of testing no-load-old-version. ;; Bogus sysdef finding function, for the sake of testing no-load-old-version.
(defun sysdef-bogus-test-search (system) (defun sysdef-bogus-test-search (system)
(declare (ignore system)) (declare (ignore system))
(subpathname *test-directory* "always-error.lisp")) (subpathname *test-directory* "always-error.lisp"))
(clear-system "asdf")
(let ((*system-definition-search-functions* '(sysdef-bogus-test-search)) (let ((*system-definition-search-functions* '(sysdef-bogus-test-search))
(state "Didn't catch warning")) (state "Didn't catch warning"))
(DBG "Bogus attempt at loading an old ASDF: should issue a warning and ignore")
(handler-bind (handler-bind
((simple-warning ((simple-warning
#'(lambda (c) #'(lambda (c)
...@@ -43,8 +45,11 @@ ...@@ -43,8 +45,11 @@
(setf state "Caught warning"))))) (setf state "Caught warning")))))
(clear-system "asdf") (clear-system "asdf")
(upgrade-asdf)) (upgrade-asdf))
(assert-equal state "Caught warning") (assert-equal state "Caught warning"))
(DBG "2nd bogus attempt at loading same old ASDF: should ignore without a warning")
(DBG "2nd bogus attempt at loading same old ASDF: should ignore without a warning")
(let ((*system-definition-search-functions* '(sysdef-bogus-test-search)))
(handler-bind (handler-bind
((simple-warning ((simple-warning
#'(lambda (c) #'(lambda (c)
...@@ -53,6 +58,7 @@ ...@@ -53,6 +58,7 @@
(upgrade-asdf))) (upgrade-asdf)))
(assert-equal nil (system-source-file (find-system :asdf))) (assert-equal nil (system-source-file (find-system :asdf)))
(DBG "Load ASDF with proper configuration: should find asdf.asd from the source above") (DBG "Load ASDF with proper configuration: should find asdf.asd from the source above")
(initialize-source-registry (initialize-source-registry
`(:source-registry `(:source-registry
...@@ -60,18 +66,17 @@ ...@@ -60,18 +66,17 @@
(:directory ,*uiop-directory*) (:directory ,*uiop-directory*)
:ignore-inherited-configuration)) :ignore-inherited-configuration))
(clear-system "asdf") (clear-system "asdf")
(with-asdf-session (:override t) (with-asdf-session (:override t)
(with-expected-failure (#+xcl t) ;; expected-failure: XCL has trouble with the ASDF upgrade (with-expected-failure (#+xcl t) ;; expected-failure: XCL has trouble with the ASDF upgrade
(load-system :asdf) (load-system :asdf)
(assert-pathname-equal (subpathname *asdf-directory* "asdf.asd") (assert-pathname-equal (subpathname *asdf-directory* "asdf.asd")
(system-source-file (find-system :asdf)))) (system-source-file (find-system :asdf))))
(DBG "Loading from the same version shouldn't have reset methods") (DBG "Loading from the same version shouldn't have reset methods")
(setf *ticks* 2) (setf *ticks* 2)
(input-files 'load-op "foo") (input-files 'load-op "foo")
(assert-equal *ticks* 3)) (assert-equal *ticks* 3))
(DBG "Loading from an ancient version WILL reset methods") (DBG "Loading from an ancient version WILL reset methods")
(assert (find-system "fooey" nil)) (assert (find-system "fooey" nil))
(defparameter *current-version* (asdf-version))