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)))))))))
......
......@@ -7,7 +7,7 @@
(:recycle :asdf/plan :asdf)
(:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/session
:asdf/component :asdf/operation :asdf/action :asdf/lisp-action
:asdf/system :asdf/system-registry :asdf/find-component)
:asdf/system :asdf/system-registry :asdf/find-component :asdf/forcing)
(:export
#:component-operation-time
#:plan #:plan-traversal #:sequential-plan #:*plan-class*
......@@ -16,14 +16,12 @@
#:circular-dependency #:circular-dependency-actions
#:needed-in-image-p
#: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 #:action-up-to-date-p
#:make-plan #:plan-actions #:perform-plan #:plan-operates-on-p
#:planned-p #:index #:forced #:forced-not
#:planned-p #:index
#:plan-actions-r
#:required-components #:filtered-sequential-plan
#:plan-system
#:plan-component-type #:plan-keep-operation #:plan-keep-component
))
(in-package :asdf/plan)
......@@ -33,18 +31,9 @@
(defclass plan () ()
(:documentation "Base class for a plan based on which ASDF can build a system"))
(defclass plan-traversal (plan)
(;; Can this plan be performed? A plan that has different force and force-not settings than the
;; session plan 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 plan-performable-p)
;; The parent plan from which this plan inherits forced status, etc.
(parent :initform nil :initarg :parent :reader plan-parent)
;; The system for which the plan is computed
(system :initform nil :initarg :system :accessor plan-system)
;; Table of systems specified via :force arguments
(forced :initform nil :initarg :force :accessor forced)
;; Table of systems specified via :force-not argument (and/or immutable)
(forced-not :initform nil :initarg :force-not :accessor forced-not))
(;; The forcing parameters for this plan. Also indicates whether the plan is performable,
;; in which case the forcing is the same as for the entire session.
(forcing :initform (forcing (toplevel-asdf-session)) :initarg :forcing :reader forcing))
(:documentation "Base class for plans that simply traverse dependencies")))
......@@ -108,69 +97,6 @@ the action of OPERATION on COMPONENT in the PLAN"))
new-status))
;;;; forcing
(with-upgradability ()
(defgeneric action-forced-p (plan operation component)
(:documentation "Is this action forced to happen in this plan?"))
(defgeneric action-forced-not-p (plan 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 (plan 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 plan)
(coerce-name (component-system (find-component () component)))))
(defmethod action-forced-p (plan operation component)
(and
;; Did the user ask us to re-perform the action?
(action-override-p plan operation component 'forced)
;; You really can't force a builtin system and :all doesn't apply to it,
;; except if it's the specifically the system currently being built.
(not (let ((system (component-system component)))
(and (builtin-system-p system)
(not (eq system (plan-system plan))))))))
(defmethod action-forced-not-p (plan 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 plan operation component 'forced-not))
(defmethod action-forced-p ((plan null) (operation operation) (component component))
nil)
(defmethod action-forced-not-p ((plan null) (operation operation) (component component))
nil))
;;;; Is the action needed in this image?
(with-upgradability ()
(defgeneric needed-in-image-p (operation component)
......@@ -276,7 +202,8 @@ initialized with SEED."
;; Any race condition is intrinsic to the limited timestamp resolution.
(if (or just-done ;; The done-stamp is valid: if we're just done, or
;; if all filesystem effects are up-to-date and there's no invalidating reason.
(and all-present up-to-date-p (operation-done-p o c) (not (action-forced-p plan o c))))
(and all-present up-to-date-p (operation-done-p o c)
(not (action-forced-p (forcing (or plan *asdf-session*)) o c))))
(values done-stamp ;; return the hard-earned timestamp
(or just-done
out-op ;; a file-creating op is done when all files are up to date
......@@ -287,14 +214,10 @@ initialized with SEED."
;;;; Generic support for plan-traversal
(with-upgradability ()
(defmethod initialize-instance :after ((plan plan-traversal)
&key force force-not system
&allow-other-keys)
(with-slots (forced forced-not) plan
(setf forced (normalize-forced-systems force system))
(setf forced-not (normalize-forced-not-systems force-not system))))
(when-upgrading (:version "3.1.7.35")
(defmethod initialize-instance :after ((plan plan-traversal) &key &allow-other-keys)))
(with-upgradability ()
(defgeneric plan-actions (plan)
(:documentation "Extract from a plan a list of actions to perform in sequence"))
(defmethod plan-actions ((plan list))
......@@ -304,7 +227,7 @@ initialized with SEED."
(setf (gethash (cons o c) (visited-actions *asdf-session*)) new-status))
(defmethod action-status ((p plan) (o operation) (c component))
(if (action-forced-not-p p o c)
(if (action-forced-not-p (forcing p) o c)
(action-status nil o c)
(values (gethash (cons o c) (visited-actions *asdf-session*)))))
......@@ -334,7 +257,7 @@ initialized with SEED."
(defmethod action-status :around ((plan plan) operation component)
;; TODO: should we instead test something like:
;; (action-forced-not-p plan operation (primary-system component))
(if (action-forced-not-p plan operation component)
(if (action-forced-not-p (forcing plan) operation component)
(let ((status (action-status nil operation component)))
(if (and status (action-done-p status))
status
......@@ -455,20 +378,18 @@ initialized with SEED."
(defmethod make-plan (plan-class (o operation) (c component) &rest keys &key &allow-other-keys)
(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))
(let ((plan (apply 'make-instance (or plan-class *plan-class*) keys)))
(traverse-action plan o c t)
plan)))
(defmethod perform-plan :around ((plan t) &key)
(assert (performable-p (forcing plan)))
(let ((*package* *package*)
(*readtable* *readtable*))
(with-compilation-unit () ;; backward-compatibility.
(call-next-method)))) ;; Going forward, see deferred-warning support in lisp-build.
(defmethod perform-plan ((plan t) &key &allow-other-keys)
(defmethod perform-plan ((plan t) &key)
(loop :for action :in (plan-actions plan)
:as o = (action-operation action)
:as c = (action-component action) :do
......@@ -495,15 +416,12 @@ initialized with SEED."
(:documentation "A variant of SEQUENTIAL-PLAN that only records a subset of actions."))
(defmethod initialize-instance :after ((plan filtered-sequential-plan)
&key force force-not
other-systems)
(declare (ignore force force-not))
&key system other-systems)
;; Ignore force and force-not, rely on other-systems:
;; force traversal of what we're interested in, i.e. current system or also others;
;; force-not traversal of what we're not interested in, i.e. other systems unless other-systems.
(with-slots (forced forced-not system) plan
(setf forced :all)
(setf forced-not (normalize-forced-not-systems (if other-systems nil t) system))))
(setf (slot-value plan 'forcing)
(make-forcing :system system :force :all :force-not (if other-systems nil t))))
(defmethod plan-actions ((plan filtered-sequential-plan))
(with-slots (keep-operation keep-component) plan
......@@ -520,7 +438,7 @@ initialized with SEED."
(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)))
(not (action-forced-not-p (forcing plan) operation component)))
(map-direct-dependencies operation component
#'(lambda (o c) (collect-action-dependencies plan o c)))
(push action (plan-actions-r plan))))))))
......@@ -531,7 +449,7 @@ initialized with SEED."
(defmethod collect-dependencies ((operation operation) (component component)
&rest keys &key &allow-other-keys)
(let ((plan (apply 'make-instance 'filtered-sequential-plan
:system (component-system component) :force :all keys)))
:system (component-system component) keys)))
(loop :for action :in (direct-dependencies operation component)
:do (collect-action-dependencies plan (action-operation action) (action-component action)))
(plan-actions plan)))
......
......@@ -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")