Commit fe835596 authored by Francois-Rene Rideau's avatar Francois-Rene Rideau

Separate forcing from plan

Move forcing into its own file.
Include forcing, not plan, among session slots.
Share a toplevel forcing for all performable plans.
Have REQUIRE use load-system, not require-system,
so as not to conflict with session forcing options.
Don't call with-asdf-session outside the test scripts themselves.
Cleanup a few scripts accordingly, and beyond.
parent 833980c2
......@@ -80,7 +80,7 @@ XCL ?= xcl
header_lisp := header.lisp
driver_lisp := uiop/package.lisp uiop/common-lisp.lisp uiop/utility.lisp uiop/version.lisp uiop/os.lisp uiop/pathname.lisp uiop/filesystem.lisp uiop/stream.lisp uiop/image.lisp uiop/lisp-build.lisp uiop/launch-program.lisp uiop/run-program.lisp uiop/configuration.lisp uiop/backward-driver.lisp uiop/driver.lisp
defsystem_lisp := upgrade.lisp session.lisp component.lisp operation.lisp system.lisp system-registry.lisp action.lisp lisp-action.lisp find-component.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
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 $* = $($*)
......
......@@ -52,12 +52,13 @@
(:file "action" :depends-on ("session" "system" "operation"))
(:file "lisp-action" :depends-on ("action"))
(:file "find-component" :depends-on ("component"))
(:file "plan" :depends-on ("lisp-action" "find-component"))
(:file "forcing" :depends-on ("operation" "system-registry"))
(:file "plan" :depends-on ("lisp-action" "find-component" "forcing"))
(:file "operate" :depends-on ("plan"))
(:file "find-system" :depends-on ("system-registry" "operate"))
(:file "parse-defsystem" :depends-on ("system-registry" "lisp-action" "operate"))
(:file "bundle" :depends-on ("lisp-action" "operate" "parse-defsystem"))
(:file "concatenate-source" :depends-on ("plan" "parse-defsystem" "bundle"))
(: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"))
......
......@@ -4,8 +4,8 @@
(uiop/package:define-package :asdf/bundle
(:recycle :asdf/bundle :asdf)
(:use :uiop/common-lisp :uiop :asdf/upgrade
:asdf/component :asdf/system :asdf/find-system :asdf/find-component :asdf/operation
:asdf/action :asdf/lisp-action :asdf/plan :asdf/operate :asdf/defsystem)
:asdf/component :asdf/system :asdf/operation
:asdf/action :asdf/lisp-action :asdf/plan :asdf/operate :asdf/parse-defsystem)
(:export
#:bundle-op #:bundle-type #:program-system
#:bundle-system #:bundle-pathname-type #:direct-dependency-files
......
......@@ -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
......
......@@ -249,9 +249,7 @@ PREVIOUS-TIME when not null is the time at which the PREVIOUS system was loaded.
;; 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*))
(loop :with plan = (make-instance *plan-class*)
:for action :in (definition-dependency-list previous)
:always (handler-bind
((system-out-of-date
......
;;;; -------------------------------------------------------------------------
;;;; Forcing
(uiop/package:define-package :asdf/forcing
(:recycle :asdf/forcing :asdf/plan :asdf)
(:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/session
:asdf/component :asdf/operation :asdf/system :asdf/system-registry)
(:export
#:forcing #:make-forcing #:forced #:forced-not #:performable-p
#:normalize-forced-systems #:normalize-forced-not-systems
#:action-forced-p #:action-forced-not-p))
(in-package :asdf/forcing)
;;;; Forcing
(with-upgradability ()
(defclass forcing ()
(;; Can plans using this forcing be PERFORMed? A plan that has different force and force-not
;; settings than the session can only be used for read-only queries that do not cause the
;; status of any action to be raised.
(performable-p :initform nil :initarg :performable-p :reader performable-p)
;; Parameters
(parameters :initform nil :initarg :parameters :reader parameters)
;; Table of systems specified via :force arguments
(forced :initarg :forced :reader forced)
;; Table of systems specified via :force-not argument (and/or immutable)
(forced-not :initarg :forced-not :reader forced-not)))
(defgeneric action-forced-p (forcing operation component)
(:documentation "Is this action forced to happen in this plan?"))
(defgeneric action-forced-not-p (forcing operation component)
(:documentation "Is this action forced to not happen in this plan?
Takes precedence over action-forced-p."))
(defun normalize-forced-systems (force system)
"Given a SYSTEM on which operate is called and the specified FORCE argument,
extract a hash-set of systems that are forced, or a predicate on system names,
or NIL if none are forced, or :ALL if all are."
(etypecase force
((or (member nil :all) hash-table function) force)
(cons (list-to-hash-set (mapcar #'coerce-name force)))
((eql t) (when system (list-to-hash-set (list (coerce-name system)))))))
(defun normalize-forced-not-systems (force-not system)
"Given a SYSTEM on which operate is called, the specified FORCE-NOT argument,
and the set of IMMUTABLE systems, extract a hash-set of systems that are effectively forced-not,
or predicate on system names, or NIL if none are forced, or :ALL if all are."
(let ((requested
(etypecase force-not
((or (member nil :all) hash-table function) force-not)
(cons (list-to-hash-set (mapcar #'coerce-name force-not)))
((eql t) (if system (let ((name (coerce-name system)))
#'(lambda (x) (not (equal x name))))
:all)))))
(if (and *immutable-systems* requested)
#'(lambda (x) (or (call-function requested x)
(call-function *immutable-systems* x)))
(or *immutable-systems* requested))))
;; TODO: shouldn't we be looking up the primary system name, rather than the system name?
(defun action-override-p (forcing operation component override-accessor)
"Given a plan, an action, and a function that given the plan accesses a set of overrides,
i.e. force or force-not, see if the override applies to the current action."
(declare (ignore operation))
(call-function (funcall override-accessor forcing)
(coerce-name (component-system (find-component () component)))))
(defmethod action-forced-p (forcing operation component)
(and
;; Did the user ask us to re-perform the action?
(action-override-p forcing operation component 'forced)
;; You really can't force a builtin system and :all doesn't apply to it.
(not (builtin-system-p (component-system component)))))
(defmethod action-forced-not-p (forcing operation component)
;; Did the user ask us to not re-perform the action?
;; NB: force-not takes precedence over force, as it should
(action-override-p forcing operation component 'forced-not))
;; Null forcing means no forcing either way
(defmethod action-forced-p ((forcing null) (operation operation) (component component))
nil)
(defmethod action-forced-not-p ((forcing null) (operation operation) (component component))
nil)
(defun or-function (fun1 fun2)
(cond
((or (null fun2) (eq fun1 :all)) fun1)
((or (null fun1) (eq fun2 :all)) fun2)
(t #'(lambda (x) (or (call-function fun1 x) (call-function fun2 x))))))
(defun make-forcing (&key performable-p system
(force nil force-p) (force-not nil force-not-p) &allow-other-keys)
(let* ((session-forcing (when *asdf-session* (forcing *asdf-session*)))
(system (and system (coerce-name system)))
(forced (normalize-forced-systems force system))
(forced-not (normalize-forced-not-systems force-not system))
(parameters `(,@(when force `(:force ,force))
,@(when force-not `(:force-not ,force-not))
,@(when (or (eq force t) (eq force-not t)) `(:system ,system))
,@(when performable-p `(:performable-p t))))
forcing)
(cond
((not session-forcing)
(setf forcing (make-instance 'forcing
:performable-p performable-p :parameters parameters
:forced forced :forced-not forced-not))
(when (and performable-p *asdf-session*)
(setf (forcing *asdf-session*) forcing)))
(performable-p
(when (and (not (equal parameters (parameters session-forcing)))
(or force-p force-not-p))
(parameter-error "~*~S and ~S arguments not allowed in a nested call to ~3:*~S ~
unless identically to toplevel"
(find-symbol* :operate :asdf) :force :force-not))
(setf forcing session-forcing))
(t
(setf forcing (make-instance 'forcing
;; Combine force and force-not with values from the toplevel-plan
:parameters `(,@parameters :on-top-of ,(parameters session-forcing))
:forced (or-function (forced session-forcing) forced)
:forced-not (or-function (forced-not session-forcing) forced-not)))))
forcing))
(defmethod print-object ((forcing forcing) stream)
(print-unreadable-object (forcing stream :type t)
(format stream "~{~S~^ ~}" (parameters forcing))))
;; During upgrade, the *asdf-session* may legitimately be NIL, so we must handle that case.
(defmethod forcing ((x null))
(if-let (session (toplevel-asdf-session))
(forcing session)
(make-forcing :performable-p t)))
;; When performing a plan that is a list of actions, use the toplevel asdf sesssion forcing.
(defmethod forcing ((x cons)) (forcing (toplevel-asdf-session))))
......@@ -8,10 +8,11 @@
#:loaded-systems ; makes for annoying SLIME completion
#:output-files-for-system-and-operation) ; ASDF-BINARY-LOCATION function we use to detect ABL
(:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/session
:asdf/component :asdf/system :asdf/system-registry :asdf/find-system :asdf/find-component
:asdf/component :asdf/system :asdf/system-registry :asdf/find-component
:asdf/operation :asdf/action :asdf/lisp-action
:asdf/output-translations :asdf/source-registry
:asdf/plan :asdf/operate :asdf/parse-defsystem :asdf/bundle :asdf/concatenate-source
:asdf/forcing :asdf/plan :asdf/operate :asdf/find-system :asdf/parse-defsystem
:asdf/bundle :asdf/concatenate-source
:asdf/backward-internals :asdf/backward-interface :asdf/package-inferred-system)
;; Note: (1) we are NOT automatically reexporting everything from previous packages.
;; (2) we only reexport UIOP functionality when backward-compatibility requires it.
......
......@@ -5,7 +5,7 @@
set here=%~dp0
set header_lisp=header.lisp
set driver_lisp=uiop\package.lisp + uiop\common-lisp.lisp + uiop\utility.lisp + uiop\version.lisp + uiop\os.lisp + uiop\pathname.lisp + uiop\filesystem.lisp + uiop\stream.lisp + uiop\image.lisp + uiop\lisp-build.lisp + uiop\launch-program.lisp + uiop\run-program.lisp + uiop\configuration.lisp + uiop\backward-driver.lisp + uiop\driver.lisp
set defsystem_lisp=upgrade.lisp + session.lisp + component.lisp + operation.lisp + system.lisp + system-registry.lisp + action.lisp + lisp-action.lisp + find-component.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
set defsystem_lisp=upgrade.lisp + session.lisp + component.lisp + operation.lisp + system.lisp + system-registry.lisp + action.lisp + lisp-action.lisp + find-component.lisp + forcing.lisp + plan.lisp + operate.lisp + find-system.lisp + parse-defsystem.lisp + bundle.lisp + concatenate-source.lisp + package-inferred-system.lisp + output-translations.lisp + source-registry.lisp + backward-internals.lisp + backward-interface.lisp + interface.lisp + user.lisp + footer.lisp
%~d0
cd "%~p0"
......
......@@ -6,7 +6,7 @@ here="$(dirname $0)"
header_lisp="header.lisp"
driver_lisp="uiop/package.lisp uiop/common-lisp.lisp uiop/utility.lisp uiop/version.lisp uiop/os.lisp uiop/pathname.lisp uiop/filesystem.lisp uiop/stream.lisp uiop/image.lisp uiop/lisp-build.lisp uiop/launch-program.lisp uiop/run-program.lisp uiop/configuration.lisp uiop/backward-driver.lisp uiop/driver.lisp"
defsystem_lisp="upgrade.lisp session.lisp component.lisp operation.lisp system.lisp system-registry.lisp action.lisp lisp-action.lisp find-component.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"
defsystem_lisp="upgrade.lisp session.lisp component.lisp operation.lisp system.lisp system-registry.lisp action.lisp lisp-action.lisp find-component.lisp forcing.lisp plan.lisp operate.lisp find-system.lisp parse-defsystem.lisp bundle.lisp concatenate-source.lisp package-inferred-system.lisp output-translations.lisp source-registry.lisp backward-internals.lisp backward-interface.lisp interface.lisp user.lisp footer.lisp"
all () {
# Default action: bootstrap asdf.lisp
......
......@@ -5,7 +5,7 @@
(:recycle :asdf/operate :asdf)
(:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/session
:asdf/component :asdf/system :asdf/system-registry :asdf/find-component
:asdf/operation :asdf/action :asdf/lisp-action :asdf/plan)
:asdf/operation :asdf/action :asdf/lisp-action :asdf/forcing :asdf/plan)
(:export
#:operate #:oos #:build-op #:make
#:load-system #:load-systems #:load-systems*
......@@ -14,7 +14,7 @@
(in-package :asdf/operate)
(with-upgradability ()
(defgeneric operate (operation component &key &allow-other-keys)
(defgeneric operate (operation component &key)
(:documentation
"Operate does mainly four things for the user:
......@@ -29,6 +29,7 @@ The entire computation is wrapped in WITH-COMPILATION-UNIT and error handling co
If a VERSION argument is supplied, then operate also ensures that the system found satisfies it
using the VERSION-SATISFIES method.
If a PLAN-CLASS argument is supplied, that class is used for the plan.
If a PLAN-OPTIONS argument is supplied, the options are passed to the plan.
The :FORCE or :FORCE-NOT argument to OPERATE can be:
T to force the inside of the specified system to be rebuilt (resp. not),
......@@ -50,61 +51,50 @@ But do NOT depend on it, for this is deprecated behavior."))
(defmethod operate :around (operation component &rest keys
&key verbose
(on-warnings *compile-file-warnings-behaviour*)
(on-failure *compile-file-failure-behaviour*) &allow-other-keys)
(on-failure *compile-file-failure-behaviour*))
(nest
(with-asdf-session ())
(let ((operation-remaker ;; how to remake the operation after ASDF was upgraded (if it was)
(etypecase operation
(operation (let ((name (type-of operation)))
#'(lambda () (make-operation name))))
((or symbol string) (constantly operation))))
(component-path (typecase component ;; to remake the component after ASDF upgrade
(component (component-find-path component))
(t component)))))
;; Before we operate on any system, make sure ASDF is up-to-date,
;; for if an upgrade is ever attempted at any later time, there may be BIG trouble.
(progn
(let* ((operation-remaker ;; how to remake the operation after ASDF was upgraded (if it was)
(etypecase operation
(operation (let ((name (type-of operation)))
#'(lambda () (make-operation name))))
((or symbol string) (constantly operation))))
(component-path (typecase component ;; to remake the component after ASDF upgrade
(component (component-find-path component))
(t component)))
(system-name (labels ((first-name (x)
(etypecase x
((or string symbol) x) ; NB: includes the NIL case.
(cons (or (first-name (car x)) (first-name (cdr x)))))))
(coerce-name (first-name component-path)))))
(apply 'make-forcing :performable-p t :system system-name keys)
;; Before we operate on any system, make sure ASDF is up-to-date,
;; for if an upgrade is ever attempted at any later time, there may be BIG trouble.
(unless (asdf-upgraded-p (toplevel-asdf-session))
(setf (asdf-upgraded-p (toplevel-asdf-session)) t)
(when (upgrade-asdf)
;; If we were upgraded, restart OPERATE the hardest of ways, for
;; its function may have been redefined.
(return-from operate
(with-asdf-session (:override t)
(with-asdf-session (:override t :override-cache t)
(apply 'operate (funcall operation-remaker) component-path keys))))))
;; Setup proper bindings around any operate call.
(let* ((*verbose-out* (and verbose *standard-output*))
(*compile-file-warnings-behaviour* on-warnings)
(*compile-file-failure-behaviour* on-failure))
(call-next-method))))
(*compile-file-failure-behaviour* on-failure)))
(call-next-method)))
(defmethod operate :before ((operation operation) (component component)
&key version &allow-other-keys)
&key version)
(unless (version-satisfies component version)
(error 'missing-component-of-version :requires component :version version))
(record-dependency nil operation component))
;; TODO: have plans accept parent plans and delegate force and force-not.
;; Ensure that only the toplevel session plan can specify force and force-not arguments.
(defun ensure-plan (operation component
&rest keys &key plan-class &allow-other-keys)
(declare (ignore operation))
(let ((session-plan (session-plan *asdf-session*)))
(cond
(session-plan
;; TODO: ensure compatibility between force in the two plans.
session-plan)
(t
(let ((new (apply 'make-instance (or plan-class *plan-class*)
:performable-p t
:system (component-system component) keys)))
(setf (session-plan *asdf-session*) new)
new)))))
(defmethod operate ((operation operation) (component component)
&rest keys &key plan-class &allow-other-keys)
(let ((plan (apply 'make-plan plan-class operation component keys)))
(apply 'perform-plan plan keys)
&key plan-class plan-options)
(let ((plan (apply 'make-plan plan-class operation component
:forcing (forcing *asdf-session*) plan-options)))
(perform-plan plan)
(values operation plan)))
(defun oos (operation component &rest args &key &allow-other-keys)
......@@ -251,7 +241,11 @@ the implementation's REQUIRE rather than by internal ASDF mechanisms."))
(let ((*verbose-out* (make-broadcast-stream)))
(let ((system (find-system system-name nil)))
(when system
(require-system system-name :verbose nil)
;; Do not use require-system after all, use load-system:
;; on the one hand, REQUIRE already uses *MODULES* not to load something twice,
;; on the other hand, REQUIRE-SYSTEM uses FORCE-NOT which may conflict with
;; the toplevel session forcing settings.
(load-system system :verbose nil)
t)))))))))
......
This diff is collapsed.
......@@ -11,7 +11,7 @@
#:do-asdf-cache #:normalize-namestring
#:call-with-asdf-session #:with-asdf-session
#:*asdf-session* #:*asdf-session-class* #:session #:toplevel-asdf-session
#:session-cache #:session-plan #:asdf-upgraded-p
#:session-cache #:forcing #:asdf-upgraded-p
#:visited-actions #:visiting-action-set #:visiting-action-list
#:total-action-count #:planned-action-count #:planned-output-action-count
#:clear-configuration-and-retry #:retry
......@@ -46,9 +46,9 @@
(asdf-upgraded-p
:initform nil :initarg :asdf-upgraded-p :accessor asdf-upgraded-p
:documentation "Was ASDF already upgraded in this session - only valid for toplevel-asdf-session.")
(plan
:initform nil :accessor session-plan
:documentation "Dependency graph of actions")
(forcing
:initform nil :initarg :forcing :accessor forcing
:documentation "Forcing parameters for the session")
;; Table that to actions already visited while walking the dependencies associates status
(visited-actions :initform (make-hash-table :test 'equal) :accessor visited-actions)
;; Actions that depend on those being currently walked through, to detect circularities
......@@ -103,7 +103,7 @@
;; 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-session (thunk &key override key override-cache)
(defun call-with-asdf-session (thunk &key override key override-cache override-forcing)
(let ((fun (if key #'(lambda () (consult-asdf-cache key thunk)) thunk)))
(if (and (not override) *asdf-session*)
(funcall fun)
......@@ -113,6 +113,8 @@
(apply 'make-instance *asdf-session-class*
(when *asdf-session*
`(:ancestor ,(toplevel-asdf-session)
,@(unless override-forcing
`(:forcing ,(forcing *asdf-session*)))
,@(unless override-cache
`(:session-cache ,(session-cache *asdf-session*))))))))
(return (funcall fun)))
......@@ -126,9 +128,11 @@
(clear-configuration)))))))
;; Syntactic sugar for call-with-asdf-session
(defmacro with-asdf-session ((&key key override override-cache) &body body)
(defmacro with-asdf-session ((&key key override override-cache override-forcing) &body body)
`(call-with-asdf-session
#'(lambda () ,@body) :override ,override :key ,key :override-cache ,override-cache))
#'(lambda () ,@body)
:override ,override :key ,key
:override-cache ,override-cache :override-forcing ,override-forcing))
;;; Define specific accessor for file (date) stamp.
......
......@@ -156,7 +156,7 @@ do_tests () {
echo "or more interactively (and maybe with rlwrap or in emacs), start with:" >&2
echo "(cd test ; $icmd )" >&2
echo "then copy/paste:" >&2
echo "'(#.(load \"script-support.lisp\") #.(asdf-test::da) #.(load-asdf) #.(frob-packages) #.(asdf::with-asdf-session () (load \"$i\")))" >&2
echo "'(#.(load \"script-support.lisp\") #.(asdf-test::da) #.(load-asdf) #.(frob-packages) #.(load \"$i\"))" >&2
fi
echo >&2
echo >&2
......
......@@ -408,7 +408,7 @@ is bound, write a message and exit on an error. If
(acall :print-condition-backtrace
c :count 69 :stream *error-output*))
(leave-test "Script failed" 1)))))
(funcall (or (asym :call-with-asdf-session) 'funcall) thunk)
(funcall thunk)
(leave-test "Script succeeded" 0)))))
(when *quit-when-done*
(exit-lisp result))))
......@@ -631,24 +631,27 @@ is bound, write a message and exit on an error. If
(format t "Being a bit verbose~%")
(when (asym :*asdf-verbose*) (setf (asymval :*asdf-verbose*) t))
(when (asym :*verbose-out*) (setf (asymval :*verbose-out*) *standard-output*))
(funcall
;; Old versions of ASDF don't always use with-asdf-session in locate system, but need it.
;; So we do it for them for the sake of testing upgrade from these old versions.
;; Yet older versions of ASDF don't even have this session cache, so then we don't.
(or (asym :call-with-asdf-session) (asym :call-with-asdf-cache) 'funcall)
(lambda ()
(when (and (asym :locate-system) (asym :pathname-directory-pathname) (asym :pathname-equal))
(format t "Comparing directories~%")
(let ((x (acall :pathname-directory-pathname (nth-value 2 (acall :locate-system :test-asdf)))))
(assert-pathname-equal-helper ;; not always EQUAL (!)
'*test-directory* *test-directory*
'(:pathname-directory-pathname (nth-value 2 (:locate-system :test-asdf))) x)
(unless (equal *test-directory* x)
(format t "Interestingly, while *test-directory* has components~% ~S~%~
ASDF finds the ASDs in~% ~S~%Using the latter.~%"
(pathname-components *test-directory*)
(pathname-components x)))
(setf *test-directory* x)))))
(when (and (asym :locate-system) (asym :pathname-directory-pathname) (asym :pathname-equal))
(format t "Comparing directories~%")
(let ((x (acall
:pathname-directory-pathname
;; Some old versions of ASDF want locate-system to be surrounded by with-asdf-cache
;; so we do it for them for the sake of testing upgrade from these old versions.
;; Yet older versions of ASDF don't even have this session cache, so then we don't.
;; Newer versions of ASDF implicitly use with-asdf-session (successor of the cache)
;; without our having to wrap it.
(funcall
(or (asym :call-with-asdf-cache) 'funcall)
(lambda () (nth-value 2 (acall :locate-system :test-asdf)))))))
(assert-pathname-equal-helper ;; not always EQUAL (!)
'*test-directory* *test-directory*
'(:pathname-directory-pathname (nth-value 2 (:locate-system :test-asdf))) x)
(unless (equal *test-directory* x)
(format t "Interestingly, while *test-directory* has components~% ~S~%~
ASDF finds the ASDs in~% ~S~%Using the latter.~%"
(pathname-components *test-directory*)
(pathname-components x)))
(setf *test-directory* x)))
t)
(defun frob-packages ()
......
(defpackage :show-progress (:use :cl))
(in-package :show-progress)
(eval-when (:load-toplevel) (defparameter *time* :load-toplevel))
(eval-when (:compile-toplevel) (defparameter *time* :compile-toplevel))
(eval-when (:execute) (defparameter *time* :execute))
(eval-when (:load-toplevel :compile-toplevel :execute)
(format t "It's ~A time!~%" *time*)
(defvar *times* '())
(push *time* *times*))
(defun foo (x)
(format t "~S~%" x))
(defmacro m1 () '(foo 1))
(defmacro m2 () '(foo 2))
(defmacro me () (error "Failing at compile-time"))
(defmacro mb () '(me))
(defmacro mc () '(m1))
......@@ -87,9 +87,13 @@
;; These are used by test-defsystem-depends-on-change.asd, test-defsystem-depends-on-change.script
(defvar *ta/dcc* 0)
(defsystem "test-asdf/dep-can-change"
:depends-on ("test-asdf-location-change")
:depends-on ("test-asdf-location-change" "test-asdf/dep-forced")
:components ((:file "show-progress"))
:perform (load-op (o c) (incf *ta/dcc*)))
(defsystem "test-asdf/dep-forced"
:components ((:file "file1")))
(defvar *ta/dcd* 0)
(defsystem "test-asdf/dep-can-disappear"
:depends-on ("test-asdf-location-change")
......
;;; -*- Lisp -*-
;;(trace source-file-type)
(progn
(format t "~D~%" (asdf:asdf-version))
(def-test-system test-builtin-source-file-type-1
:default-component-class cl-source-file.cl
:serial t
:components ((:cl-source-file "file1") ; for the package
(:file "test-tmp")))
(load-system 'test-builtin-source-file-type-1 :verbose t)
(assert (symbol-value (read-from-string "test-package::*test-tmp-cl*")))
(assert-equal
(mapcar #'pathname-type
(mapcar #'asdf:component-pathname (asdf:module-components (asdf:find-system :test-source-file-type-1))))
'("lisp" "cl"))
(delete-package :test-package)
(def-test-system
test-builtin-source-file-type-2
:default-component-class cl-source-file.cl
:serial t
:components ((:file "file1" :type "lisp") ; for package
(:file "test-tmp")))
(asdf:load-system 'test-builtin-source-file-type-2 :verbose t)
(assert (symbol-value (read-from-string "test-package::*test-tmp-cl*")))
(def-test-system test-builtin-source-file-type-3
:default-component-class cl-source-file.lsp
:serial t
:components ((:cl-source-file "file1") ; for the package
(:file "test-tmp")))
(asdf:load-system 'test-builtin-source-file-type-3 :verbose t)
(assert (symbol-value (read-from-string "test-package::*test-tmp-cl*")))
(assert-equal
(mapcar #'pathname-type
(mapcar #'asdf:component-pathname (asdf:module-components (asdf:find-system :test-source-file-type-1))))
'("lisp" "cl"))
(delete-package :test-package)
(def-test-system test-builtin-source-file-type-4
:default-component-class cl-source-file.lsp
:serial t
:components ((:file "file1" :type "lisp") ; for package
(:file "test-tmp")))
(asdf:load-system 'test-builtin-source-file-type-4 :verbose t)
(assert (symbol-value (read-from-string "test-package::*test-tmp-cl*"))))
(format t "~D~%" (asdf:asdf-version))
(def-test-system test-builtin-source-file-type-1
:default-component-class cl-source-file.cl
:serial t
:components ((:cl-source-file "file1") ; for the package
(:file "test-tmp")))
(load-system 'test-builtin-source-file-type-1 :verbose t)
(assert (symbol-value (read-from-string "test-package::*test-tmp-cl*")))
(assert-equal
(mapcar #'pathname-type
(mapcar #'asdf:component-pathname (asdf:module-components (asdf:find-system :test-source-file-type-1))))
'("lisp" "cl"))
(delete-package :test-package)
(def-test-system "test-builtin-source-file-type-2"
:default-component-class cl-source-file.cl
:serial t
:components ((:file "file1" :type "lisp") ; for package
(:file "test-tmp")))
(load-system 'test-builtin-source-file-type-2 :verbose t)
(assert (symbol-value (read-from-string "test-package::*test-tmp-cl*")))
(def-test-system test-builtin-source-file-type-3
:default-component-class cl-source-file.lsp
:serial t
:components ((:cl-source-file "file1") ; for the package
(:file "test-tmp")))
(load-system 'test-builtin-source-file-type-3 :verbose t)
(assert (symbol-value (read-from-string "test-package::*test-tmp-cl*")))
(assert-equal
(mapcar #'pathname-type
(mapcar #'asdf:component-pathname (asdf:module-components (asdf:find-system :test-source-file-type-1))))
'("lisp" "cl"))
(delete-package :test-package)
(def-test-system test-builtin-source-file-type-4
:default-component-class cl-source-file.lsp
:serial t
:components ((:file "file1" :type "lisp") ; for package
(:file "test-tmp")))
(load-system 'test-builtin-source-file-type-4 :verbose t)
(assert (symbol-value (read-from-string "test-package::*test-tmp-cl*")))
......@@ -45,7 +45,7 @@
(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")
(load-system "test-defsystem-depends-on-change" :force '("test-asdf/dep-forced"))
(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
......
;;; -*- Lisp -*-
(setf asdf::*asdf-session* (make-instance asdf::*asdf-session-class*))
(clear-system 'test-asdf/force)
(assert (not (component-loaded-p 'test-asdf/force)))
(require-system 'test-asdf/force)
(defun force-plan (&rest forcing-options)
(asdf::plan-actions
(asdf::make-plan nil 'load-op 'test-asdf/force
:forcing (apply 'asdf::make-forcing :system 'test-asdf/force forcing-options))))
(with-asdf-session (:override t :override-forcing t)
(load-system 'test-asdf/force))
(assert (component-loaded-p 'test-asdf/force))
(assert-equal (asymval :*file3* :test-package) t)
(assert-equal (asymval :*file4* :test-package) t)
......@@ -14,19 +22,18 @@
(defparameter file1-date (file-write-date file1))
(defparameter date1 (- file1-date 600))
(defparameter date2 (- file1-date 300))
(assert file1)
(assert file1-date)
(reset-session-visited)
(let ((plan (traverse 'load-op 'test-asdf/force :force t)))
(let ((plan (force-plan :force t)))
(DBG "Check that :force t forces the current system but not its dependencies" plan)
(assert (asdf::plan-operates-on-p plan '("test-asdf/force" "file4")))
(assert (not (asdf::plan-operates-on-p plan '("file3-only" "file3"))))
(assert (not (asdf::plan-operates-on-p plan '("test-asdf/force1" "file1")))))
(reset-session-visited)
(let ((plan (traverse 'load-op 'test-asdf/force :force :all)))
(let ((plan (force-plan :force :all)))
(DBG "Check that :force :all forces the current system and its dependencies" plan)
(assert plan)
(assert (asdf::plan-operates-on-p plan '("test-asdf/force" "file4")))
......@@ -34,7 +41,7 @@
(assert (asdf::plan-operates-on-p plan '("test-asdf/force1" "file1"))))
(reset-session-visited)
(let ((plan (traverse 'load-op 'test-asdf/force :force :all :force-not t)))
(let ((plan (force-plan :force :all :force-not t)))
(DBG "Check that :force-not takes precedence over :force, with t means \"all but current system\"" plan)
(assert plan)
(assert (asdf::plan-operates-on-p plan '("test-asdf/force" "file4")))
......@@ -42,24 +49,23 @@
(assert (not (asdf::plan-operates-on-p plan '("test-asdf/force1" "file1")))))
(reset-session-visited)
(let ((plan (traverse 'load-op 'test-asdf/force :force-not :all)))
(let ((plan (force-plan :force-not :all)))
(DBG "Check that :force-not :all means \"all systems\"" plan)
(assert (null plan)))
(reset-session-visited)
(let ((plan (traverse 'load-op 'test-asdf/force :force :all :force-not :all)))
(let ((plan (force-plan :force :all :force-not :all)))
(DBG "Check that :force-not :all takes precedence over :force" plan)
(assert (null plan)))
(reset-session-visited)
(let ((plan (traverse 'load-op 'test-asdf/force :force :all
:force-not '(:test-asdf/force :test-asdf/force1))))
(DBG "Check that :force-not :all takes precedence over :force" plan)
(let ((plan (force-plan :force :all :force-not '(:test-asdf/force :test-asdf/force1))))
(DBG "Check that :force-not with a list takes precedence over :force" plan)
(assert (null plan)))
(reset-session-visited)
(let* ((asdf::*immutable-systems* (list-to-hash-set '("test-asdf/force1")))
(plan (traverse 'load-op 'test-asdf/force :force :all)))
(plan (force-plan :force :all)))
(DBG "Check that immutable-systems will block forcing" plan)
(assert plan)
(assert (asdf::plan-operates-on-p plan '("test-asdf/force" "file4")))
......@@ -77,24 +83,30 @@
(assert-equal (get-file-stamp "file1.lisp") date1)
(assert-equal (get-file-stamp file1) date2)
(reset-session-visited)
(DBG "Check that require-system won't reload")
(require-system 'test-asdf/force1)
(reset-session-visited)
(with-asdf-session (:override t :override-forcing t)
(require-system 'test-asdf/force1))
(assert-equal (get-file-stamp file1) date2)
(assert-equal test-package::*file1* :modified)
(reset-session-visited)
(DBG "Check that load-system will reload")
(reset-session-visited)
(setf test-package::*file1* nil)
(assert (not test-package::*file1*))
(load-system 'test-asdf/force1)
(with-asdf-session (:override t :override-forcing t)
(load-system 'test-asdf/force1))
(assert test-package::*file1*)
;; forced, it should be later
(reset-session-visited)
(DBG "Check that force reloading loads again")
(reset-session-visited)
(setf test-package::*file3* :reset)