Commit 833980c2 authored by Francois-Rene Rideau's avatar Francois-Rene Rideau

Add out-of-date detection for system definition

parent 0796586f
......@@ -16,7 +16,7 @@
#:input-files #:output-files #:output-file #:operation-done-p
#:action-operation #:action-component #:make-action
#: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
#:operation-definition-warning #:operation-definition-error ;; condition
#:action-valid-p
......@@ -50,9 +50,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)))))
......@@ -110,7 +111,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
......@@ -128,6 +129,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
......@@ -410,11 +447,8 @@ Returns two values:
(:documentation "PERFORM an action, consuming its input-files and building its output-files"))
(define-convenience-action-methods perform (operation component))
(defvar *action* nil
"Action being performed")
(defmethod perform :around ((o operation) (c component))
(let ((*action* (cons o c)))
(call-next-method)))
(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))
......@@ -452,40 +486,3 @@ Returns two values:
(action-description operation component)))
(mark-operation-done operation component)
(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 @@
:asdf/find-component :asdf/system-registry :asdf/plan :asdf/operate)
(:export
#: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)
(with-upgradability ()
......@@ -20,6 +20,13 @@
(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)))))
(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
......@@ -50,13 +57,13 @@
(and (typep operation 'load-op)
(typep component 'system)
(equal "asdf" (coerce-name component))))
(when *action*
(let ((parent-operation (car *action*))
(parent-component (cdr *action*)))
(if-let ((action (first (visiting-action-list *asdf-session*))))
(let ((parent-operation (action-operation action))
(parent-component (action-component action)))
(unless (and (typep parent-operation 'define-op) (typep parent-component 'system))
(error "Invalid recursive use of (OPERATE ~S ~S) while visiting ~S ~
- please use proper dependencies instead."
operation component *action*))
operation component action))
(let ((action (cons operation component)))
(unless (gethash action (definition-dependency-set parent-component))
(push (cons operation component) (definition-dependency-list parent-component))
......@@ -106,8 +113,8 @@
(asdf-message (compatfmt "~&~@<; ~@;Loading system definition~@[ for ~A~] from ~A~@:>~%")
(coerce-name s) pathname)
;; dependencies will depend on what's loaded via definition-dependency-list
(unset-asdf-cache-entry `(component-depends-on ,o ,s))
(load* pathname :external-format (encoding-external-format (detect-encoding pathname))))))
(unset-asdf-cache-entry `(component-depends-on ,o ,s)))
(load* pathname :external-format (encoding-external-format (detect-encoding pathname)))))
(defun load-asd (pathname &key name)
"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."
(progn
;; We already determine this to be obsolete ---
;; 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))
(let ((system (make-instance 'undefined-system
: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.
;; preloaded, with a previous configuration, or before filesystem changes), and
;; load a found .asd if appropriate. Finally, update registration table and return results.
(defmethod find-system ((name string) &optional (error-p t))
(with-asdf-session (:key `(find-system ,name))
(let ((primary-name (primary-system-name name)))
(unless (equal name primary-name)
(find-system primary-name nil)))
(or (and *immutable-systems* (gethash name *immutable-systems*) (registered-system name))
(multiple-value-bind (foundp found-system pathname previous previous-time)
(locate-system name)
(assert (eq foundp (and (or found-system pathname previous) t)))
(let ((previous-pathname (system-source-file previous))
(system (or previous found-system)))
(when (and found-system (not previous))
(register-system found-system))
(when (and system pathname)
(setf (system-source-file system) pathname))
(if-let ((stamp (get-file-stamp pathname)))
(let ((up-to-date-p
(and previous
(or (pathname-equal pathname previous-pathname)
(and pathname previous-pathname
(pathname-equal
(physicalize-pathname pathname)
(physicalize-pathname previous-pathname))))
(stamp<= stamp previous-time)
;; TODO: check that all dependencies are up-to-date.
;; This necessitates traversing them without triggering
;; the adding of nodes to the plan.
)))
(unless up-to-date-p
(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)))))))
(nest
(with-asdf-session (:key `(find-system ,name)))
(let* ((name-primary-p (primary-system-p name))
(primary-system (unless name-primary-p (find-system (primary-system-name name) nil)))))
(or (and *immutable-systems* (gethash name *immutable-systems*) (registered-system name)))
(multiple-value-bind (foundp found-system pathname previous previous-time)
(locate-system name)
(assert (eq foundp (and (or found-system pathname previous) t))))
(let ((previous-pathname (system-source-file previous))
(system (or previous found-system)))
(when (and found-system (not previous))
(register-system found-system))
(when (and system pathname)
(setf (system-source-file system) pathname))
(if-let ((stamp (get-file-stamp pathname)))
(let ((up-to-date-p
(and previous
(or (pathname-equal pathname previous-pathname)
(and pathname previous-pathname
(pathname-equal
(physicalize-pathname pathname)
(physicalize-pathname previous-pathname))))
(stamp<= stamp previous-time)
;; TODO: check that all dependencies are up-to-date.
;; This necessitates traversing them without triggering
;; the adding of nodes to the plan.
(loop :with plan = (or (and *asdf-session*
(session-plan *asdf-session*))
(make-instance *plan-class*))
:for action :in (definition-dependency-list previous)
:always (handler-bind
((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.
(defun mark-component-preloaded (component)
......
......@@ -123,7 +123,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
......
......@@ -18,7 +18,7 @@
#:record-dependency
#:normalize-forced-systems #:action-forced-p #:action-forced-not-p
#: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
#:planned-p #:index #:forced #:forced-not
#:plan-actions-r
......@@ -73,6 +73,9 @@ in some previous image, or T if it needs to be done.")
+action-status-out-of-date+
(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)
(print-unreadable-object (status stream :type t)
(with-slots (stamp done-p planned-p index) status
......@@ -104,6 +107,7 @@ the action of OPERATION on COMPONENT in the PLAN"))
(setf (gethash o times) (action-stamp new-status))))
new-status))
;;;; forcing
(with-upgradability ()
(defgeneric action-forced-p (plan operation component)
......@@ -346,8 +350,9 @@ initialized with SEED."
(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."
(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.
(let ((status (action-status plan operation component)))
(when status
......@@ -369,12 +374,13 @@ initialized with SEED."
(not (eq (action-stamp status) t))))))
(defmethod traverse-action (plan operation component needed-in-image-p)
(while-visiting-action (operation component) ; maintain context, handle circularity.
(block nil
;; 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.
;; TODO: It is also needed to detect OPERATE-in-PERFORM.
(record-dependency plan operation component)
(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,
;; instead of just a dependency order as in vanilla ASDF.
;; TODO: It is also needed to detect OPERATE-in-PERFORM.
(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
;; 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
......@@ -451,6 +457,8 @@ initialized with SEED."
(with-asdf-session ()
(let ((plan (apply 'make-instance (or plan-class *plan-class*)
: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)
plan)))
......@@ -506,15 +514,16 @@ initialized with SEED."
:collect (cons o c))))
(defun collect-action-dependencies (plan operation component)
(while-visiting-action (operation component) ; maintain context, handle circularity.
(let ((action (make-action operation component)))
(unless (gethash action (visited-actions *asdf-session*))
(setf (gethash action (visited-actions *asdf-session*)) t)
(when (and (typep component (plan-component-type plan))
(not (action-forced-not-p plan operation component)))
(map-direct-dependencies operation component
#'(lambda (o c) (collect-action-dependencies plan o c)))
(push action (plan-actions-r plan)))))))
(when (action-valid-p operation component)
(while-visiting-action (operation component) ; maintain context, handle circularity.
(let ((action (make-action operation component)))
(unless (gethash action (visited-actions *asdf-session*))
(setf (gethash action (visited-actions *asdf-session*)) t)
(when (and (typep component (plan-component-type plan))
(not (action-forced-not-p plan operation component)))
(map-direct-dependencies operation component
#'(lambda (o c) (collect-action-dependencies plan o c)))
(push action (plan-actions-r plan))))))))
(defgeneric collect-dependencies (operation component &key &allow-other-keys)
(: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
(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))
((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."))
......@@ -89,11 +96,6 @@ a SYSTEM is redefined and its class is modified."))
;; This slot contains the *declared* defsystem-depends-on dependencies
(defsystem-depends-on :reader system-defsystem-depends-on :initarg :defsystem-depends-on
: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.
(depends-on :reader system-depends-on :initform nil)
(weakly-depends-on :reader system-weakly-depends-on :initform nil))
......
;;-*- 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
(defvar *tddoc* 0)
(incf *tddoc*)
(format t "tddoc loaded ~D times.~%" *tddoc*)
(if (= *tddoc* 1)
(defsystem "test-defsystem-depends-on-change"
......
......@@ -8,10 +8,12 @@
(defparameter tddoc "test-defsystem-depends-on-change")
(defparameter talc "test-asdf-location-change")
(defparameter asdf-user::*tddoc* 0)
(DBG "Load the system, using xach-foo-1")
(push (subpathname *test-directory* "xach-foo-1/") *central-registry*)
(clear-system tddoc)
(load-system tddoc)
(assert-equal asdf-user::*tddoc* 1)
(assert-equal test-asdf-system::*times-loaded* 1)
......@@ -39,9 +41,12 @@
(subpathname *test-directory* "xach-foo-1/test-asdf-location-change.asd")
(system-source-file talc))
(DBG "Now, change a defsystem-depends-on dependency and try again")
(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")
(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 test-asdf-system::*times-loaded* 1) ;; from test-asdf.asd
(assert-equal test-asdf-system::*ta/dcc* 2)
......
......@@ -31,7 +31,8 @@
:components ((:file "file3")))
(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))
......@@ -49,9 +50,11 @@
(assert (not (system-registered-p "unloadable-system"))))
(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"))))
(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"))))
......@@ -2,16 +2,17 @@
(format! t "~%Using ASDF ~A~%" (asdf-version))
(assert (version< "3.0" (asdf-version))) ;; check that we have a recent enough ASDF
(setf *asdf-session* nil)
(DBG "Let's define some methods on input-files, to later check what an upgrade does to them.")
(with-asdf-session (:override t)
(def-test-system "fooey")
(defparameter *ticks* 0)
(defun tick () (incf *ticks*))
(defsystem "foo")
(defmethod input-files :after ((o load-op) (c system)) (tick))
(def-test-system "foo")
(defmethod input-files :after ((o load-op) (c system))
(tick))
(assert-equal *ticks* 0)
(input-files 'load-op "foo")
(assert-equal *ticks* 1)
......@@ -19,6 +20,7 @@
(assert-equal *ticks* 1) ;; It was cached.
(assert (find-system "fooey" nil)))
(DBG "Try load ASDF with an empty configuration")
(initialize-source-registry
'(:source-registry :ignore-inherited-configuration))
......@@ -26,15 +28,15 @@
;; We haven't found it, and got the fallback
(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.
(defun sysdef-bogus-test-search (system)
(declare (ignore system))
(subpathname *test-directory* "always-error.lisp"))
(clear-system "asdf")
(let ((*system-definition-search-functions* '(sysdef-bogus-test-search))
(state "Didn't catch warning"))
(DBG "Bogus attempt at loading an old ASDF: should issue a warning and ignore")
(handler-bind
((simple-warning
#'(lambda (c)
......@@ -43,8 +45,11 @@
(setf state "Caught warning")))))
(clear-system "asdf")
(upgrade-asdf))
(assert-equal state "Caught warning")
(DBG "2nd bogus attempt at loading same old ASDF: should ignore without a warning")
(assert-equal state "Caught 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
((simple-warning
#'(lambda (c)
......@@ -53,6 +58,7 @@
(upgrade-asdf)))
(assert-equal nil (system-source-file (find-system :asdf)))
(DBG "Load ASDF with proper configuration: should find asdf.asd from the source above")
(initialize-source-registry
`(:source-registry
......@@ -60,18 +66,17 @@
(:directory ,*uiop-directory*)
:ignore-inherited-configuration))
(clear-system "asdf")
(with-asdf-session (:override t)
(with-expected-failure (#+xcl t) ;; expected-failure: XCL has trouble with the ASDF upgrade
(load-system :asdf)
(assert-pathname-equal (subpathname *asdf-directory* "asdf.asd")
(system-source-file (find-system :asdf))))
(DBG "Loading from the same version shouldn't have reset methods")
(setf *ticks* 2)
(input-files 'load-op "foo")
(assert-equal *ticks* 3))
(DBG "Loading from an ancient version WILL reset methods")
(assert (find-system "fooey" nil))
(defparameter *current-version* (asdf-version))
......@@ -79,7 +84,6 @@
(assert (asdf/upgrade::upgrading-p))
(clear-system "asdf")
(reset-session)
(with-expected-failure (#+xcl t)
;; expected-failure: XCL has trouble with the ASDF upgrade
(load-system :asdf)
......@@ -88,7 +92,7 @@
(system-source-file (find-system :asdf))))
;; Upgrading from an old-enough version redefined away the input-files method!
(DBG "Upgrading from an old-enough version should have redefined away the input-files method!")
(setf *ticks* 4)
(input-files 'load-op "asdf")
(assert-equal *ticks* 4)
......@@ -96,38 +100,37 @@
(assert (not (find-system "fooey" nil)))
(DBG "Actually upgrade, from a different but forward-compatible version")
;; The data-punting upgrade will mess up component identity, so clear the cache
(reset-session)
(setf asdf::*asdf-version* asdf/upgrade::*oldest-forward-compatible-asdf-version*)
(clear-system "asdf")
(def-test-system "fooey")
(setf *ticks* 5)
(defmethod input-files :after ((load-op operation) (c system))
(setf *ticks* 10)
(defmethod input-files :after ((o load-op) (c system))
(DBG :input-files o c)
(incf *ticks*))
(input-files 'load-op "uiop")
(assert-equal *ticks* 8)
(assert-equal *ticks* 11)
(with-expected-failure (#+xcl t)
;; expected-failure: XCL has trouble with the ASDF upgrade
(load-system :asdf))
;; Upgrading from a recent-enough version, the input-files method was preserved!
;; But we need to clear the cache for it not to be short-circuited.
(reset-session)
(assert (find-system "fooey" nil))
(setf *ticks* 9)
(setf *ticks* 20)
(eval '(input-files 'load-op "uiop"))
(assert-equal *ticks* 12)
(assert-equal *ticks* 21)
(DBG "Checking that the bootstrap script and asdf.asd are in synch")
(defun bootstrap-lisp-files (file line-prefix)
(with-input-file (input (subpathname *asdf-directory* file))
(loop :for line = (read-line input)
:when (string-prefix-p line-prefix line)
:return (subseq line (length line-prefix))
:finally (error "Didn't find ~a in ~a" line-prefix file))))
(DBG "Checking that the bootstrap script and asdf.asd are in synch")
(defun system-lisp-files (system)
(loop :for f :in (input-files 'concatenate-source-op system)
:collect (unix-namestring (enough-pathname f *asdf-directory*))))
......
......@@ -82,8 +82,9 @@ to supersede any previous definition."
(with-upgradability ()
(defvar *uiop-debug-utility*
'(or (ignore-errors
(symbol-call :asdf :system-relative-pathname :uiop "contrib/debug.lisp"))
(symbol-call :uiop/pathname :subpathname (user-homedir-pathname) "common-lisp/asdf/uiop/contrib/debug.lisp"))
(probe-file (symbol-call :asdf :system-relative-pathname :uiop "contrib/debug.lisp")))
(probe-file (symbol-call :uiop/pathname :subpathname
(user-homedir-pathname) "common-lisp/asdf/uiop/contrib/debug.lisp")))
"form that evaluates to the pathname to your favorite debugging utilities")
(defmacro uiop-debug (&rest keys)
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment