Commit 897a142b authored by Francois-Rene Rideau's avatar Francois-Rene Rideau
Browse files

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 51accff1
...@@ -80,7 +80,7 @@ XCL ?= xcl ...@@ -80,7 +80,7 @@ XCL ?= xcl
header_lisp := header.lisp 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 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) all_lisp := $(header_lisp) $(driver_lisp) $(defsystem_lisp)
print-% : ; @echo $* = $($*) print-% : ; @echo $* = $($*)
......
...@@ -52,12 +52,13 @@ ...@@ -52,12 +52,13 @@
(:file "action" :depends-on ("session" "system" "operation")) (:file "action" :depends-on ("session" "system" "operation"))
(:file "lisp-action" :depends-on ("action")) (:file "lisp-action" :depends-on ("action"))
(:file "find-component" :depends-on ("component")) (: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 "operate" :depends-on ("plan"))
(:file "find-system" :depends-on ("system-registry" "operate")) (:file "find-system" :depends-on ("system-registry" "operate"))
(:file "parse-defsystem" :depends-on ("system-registry" "lisp-action" "operate")) (:file "parse-defsystem" :depends-on ("system-registry" "lisp-action" "operate"))
(:file "bundle" :depends-on ("lisp-action" "operate" "parse-defsystem")) (:file "bundle" :depends-on ("lisp-action" "parse-defsystem"))
(:file "concatenate-source" :depends-on ("plan" "parse-defsystem" "bundle")) (:file "concatenate-source" :depends-on ("bundle"))
(:file "package-inferred-system" :depends-on ("parse-defsystem")) (:file "package-inferred-system" :depends-on ("parse-defsystem"))
(:file "output-translations" :depends-on ("operate")) (:file "output-translations" :depends-on ("operate"))
(:file "source-registry" :depends-on ("find-system")) (:file "source-registry" :depends-on ("find-system"))
......
...@@ -4,8 +4,8 @@ ...@@ -4,8 +4,8 @@
(uiop/package:define-package :asdf/bundle (uiop/package:define-package :asdf/bundle
(:recycle :asdf/bundle :asdf) (:recycle :asdf/bundle :asdf)
(:use :uiop/common-lisp :uiop :asdf/upgrade (:use :uiop/common-lisp :uiop :asdf/upgrade
:asdf/component :asdf/system :asdf/find-system :asdf/find-component :asdf/operation :asdf/component :asdf/system :asdf/operation
:asdf/action :asdf/lisp-action :asdf/plan :asdf/operate :asdf/defsystem) :asdf/action :asdf/lisp-action :asdf/plan :asdf/operate :asdf/parse-defsystem)
(:export (:export
#:bundle-op #:bundle-type #:program-system #:bundle-op #:bundle-type #:program-system
#:bundle-system #:bundle-pathname-type #:direct-dependency-files #:bundle-system #:bundle-pathname-type #:direct-dependency-files
......
...@@ -5,7 +5,7 @@ ...@@ -5,7 +5,7 @@
(:recycle :asdf/concatenate-source :asdf) (:recycle :asdf/concatenate-source :asdf)
(:use :uiop/common-lisp :uiop :asdf/upgrade (:use :uiop/common-lisp :uiop :asdf/upgrade
:asdf/component :asdf/operation :asdf/component :asdf/operation
:asdf/system :asdf/find-system :asdf/system
:asdf/action :asdf/lisp-action :asdf/plan :asdf/bundle) :asdf/action :asdf/lisp-action :asdf/plan :asdf/bundle)
(:export (:export
#:concatenate-source-op #:concatenate-source-op
......
...@@ -249,9 +249,7 @@ PREVIOUS-TIME when not null is the time at which the PREVIOUS system was loaded. ...@@ -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. ;; TODO: check that all dependencies are up-to-date.
;; This necessitates traversing them without triggering ;; This necessitates traversing them without triggering
;; the adding of nodes to the plan. ;; the adding of nodes to the plan.
(loop :with plan = (or (and *asdf-session* (loop :with plan = (make-instance *plan-class*)
(session-plan *asdf-session*))
(make-instance *plan-class*))
:for action :in (definition-dependency-list previous) :for action :in (definition-dependency-list previous)
:always (handler-bind :always (handler-bind
((system-out-of-date ((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 @@ ...@@ -8,10 +8,11 @@
#:loaded-systems ; makes for annoying SLIME completion #:loaded-systems ; makes for annoying SLIME completion
#:output-files-for-system-and-operation) ; ASDF-BINARY-LOCATION function we use to detect ABL #:output-files-for-system-and-operation) ; ASDF-BINARY-LOCATION function we use to detect ABL
(:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/session (: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/operation :asdf/action :asdf/lisp-action
:asdf/output-translations :asdf/source-registry :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) :asdf/backward-internals :asdf/backward-interface :asdf/package-inferred-system)
;; Note: (1) we are NOT automatically reexporting everything from previous packages. ;; Note: (1) we are NOT automatically reexporting everything from previous packages.
;; (2) we only reexport UIOP functionality when backward-compatibility requires it. ;; (2) we only reexport UIOP functionality when backward-compatibility requires it.
......
...@@ -5,7 +5,7 @@ ...@@ -5,7 +5,7 @@
set here=%~dp0 set here=%~dp0
set header_lisp=header.lisp 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 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 %~d0
cd "%~p0" cd "%~p0"
......
...@@ -6,7 +6,7 @@ here="$(dirname $0)" ...@@ -6,7 +6,7 @@ here="$(dirname $0)"
header_lisp="header.lisp" 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" 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 () { all () {
# Default action: bootstrap asdf.lisp # Default action: bootstrap asdf.lisp
......
...@@ -5,7 +5,7 @@ ...@@ -5,7 +5,7 @@
(:recycle :asdf/operate :asdf) (:recycle :asdf/operate :asdf)
(:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/session (:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/session
:asdf/component :asdf/system :asdf/system-registry :asdf/find-component :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 (:export
#:operate #:oos #:build-op #:make #:operate #:oos #:build-op #:make
#:load-system #:load-systems #:load-systems* #:load-system #:load-systems #:load-systems*
...@@ -14,7 +14,7 @@ ...@@ -14,7 +14,7 @@
(in-package :asdf/operate) (in-package :asdf/operate)
(with-upgradability () (with-upgradability ()
(defgeneric operate (operation component &key &allow-other-keys) (defgeneric operate (operation component &key)
(:documentation (:documentation
"Operate does mainly four things for the user: "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 ...@@ -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 If a VERSION argument is supplied, then operate also ensures that the system found satisfies it
using the VERSION-SATISFIES method. using the VERSION-SATISFIES method.
If a PLAN-CLASS argument is supplied, that class is used for the plan. 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: The :FORCE or :FORCE-NOT argument to OPERATE can be:
T to force the inside of the specified system to be rebuilt (resp. not), 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.")) ...@@ -50,61 +51,50 @@ But do NOT depend on it, for this is deprecated behavior."))
(defmethod operate :around (operation component &rest keys (defmethod operate :around (operation component &rest keys
&key verbose &key verbose
(on-warnings *compile-file-warnings-behaviour*) (on-warnings *compile-file-warnings-behaviour*)
(on-failure *compile-file-failure-behaviour*) &allow-other-keys) (on-failure *compile-file-failure-behaviour*))
(nest (nest
(with-asdf-session ()) (with-asdf-session ())
(let ((operation-remaker ;; how to remake the operation after ASDF was upgraded (if it was) (let* ((operation-remaker ;; how to remake the operation after ASDF was upgraded (if it was)
(etypecase operation (etypecase operation
(operation (let ((name (type-of operation))) (operation (let ((name (type-of operation)))
#'(lambda () (make-operation name)))) #'(lambda () (make-operation name))))
((or symbol string) (constantly operation)))) ((or symbol string) (constantly operation))))
(component-path (typecase component ;; to remake the component after ASDF upgrade (component-path (typecase component ;; to remake the component after ASDF upgrade
(component (component-find-path component)) (component (component-find-path component))
(t component))))) (t component)))
;; Before we operate on any system, make sure ASDF is up-to-date, (system-name (labels ((first-name (x)
;; for if an upgrade is ever attempted at any later time, there may be BIG trouble. (etypecase x
(progn ((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)) (unless (asdf-upgraded-p (toplevel-asdf-session))
(setf (asdf-upgraded-p (toplevel-asdf-session)) t) (setf (asdf-upgraded-p (toplevel-asdf-session)) t)
(when (upgrade-asdf) (when (upgrade-asdf)
;; If we were upgraded, restart OPERATE the hardest of ways, for ;; If we were upgraded, restart OPERATE the hardest of ways, for
;; its function may have been redefined. ;; its function may have been redefined.
(return-from operate (return-from operate
(with-asdf-session (:override t) (with-asdf-session (:override t :override-cache t)
(apply 'operate (funcall operation-remaker) component-path keys)))))) (apply 'operate (funcall operation-remaker) component-path keys))))))
;; Setup proper bindings around any operate call. ;; Setup proper bindings around any operate call.
(let* ((*verbose-out* (and verbose *standard-output*)) (let* ((*verbose-out* (and verbose *standard-output*))
(*compile-file-warnings-behaviour* on-warnings) (*compile-file-warnings-behaviour* on-warnings)
(*compile-file-failure-behaviour* on-failure)) (*compile-file-failure-behaviour* on-failure)))
(call-next-method)))) (call-next-method)))
(defmethod operate :before ((operation operation) (component component) (defmethod operate :before ((operation operation) (component component)
&key version &allow-other-keys) &key version)
(unless (version-satisfies component version) (unless (version-satisfies component version)
(error 'missing-component-of-version :requires component :version version)) (error 'missing-component-of-version :requires component :version version))
(record-dependency nil operation component)) (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) (defmethod operate ((operation operation) (component component)
&rest keys &key plan-class &allow-other-keys) &key plan-class plan-options)
(let ((plan (apply 'make-plan plan-class operation component keys))) (let ((plan (apply 'make-plan plan-class operation component
(apply 'perform-plan plan keys) :forcing (forcing *asdf-session*) plan-options)))
(perform-plan plan)
(values operation plan))) (values operation plan)))
(defun oos (operation component &rest args &key &allow-other-keys) (defun oos (operation component &rest args &key &allow-other-keys)
...@@ -251,7 +241,11 @@ the implementation's REQUIRE rather than by internal ASDF mechanisms.")) ...@@ -251,7 +241,11 @@ the implementation's REQUIRE rather than by internal ASDF mechanisms."))
(let ((*verbose-out* (make-broadcast-stream))) (let ((*verbose-out* (make-broadcast-stream)))
(let ((system (find-system system-name nil))) (let ((system (find-system system-name nil)))
(when system (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))))))))) t)))))))))
......
...@@ -7,7 +7,7 @@ ...@@ -7,7 +7,7 @@
(:recycle :asdf/plan :asdf) (:recycle :asdf/plan :asdf)
(:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/session (:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/session
:asdf/component :asdf/operation :asdf/action :asdf/lisp-action :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 (:export
#:component-operation-time #:component-operation-time
#:plan #:plan-traversal #:sequential-plan #:*plan-class* #:plan #:plan-traversal #:sequential-plan #:*plan-class*
...@@ -16,14 +16,12 @@ ...@@ -16,14 +16,12 @@
#:circular-dependency #:circular-dependency-actions #:circular-dependency #:circular-dependency-actions
#:needed-in-image-p #:needed-in-image-p
#:record-dependency #:record-dependency
#:normalize-forced-systems #:action-forced-p #:action-forced-not-p
#:map-direct-dependencies #:reduce-direct-dependencies #:direct-dependencies #:map-direct-dependencies #:reduce-direct-dependencies #:direct-dependencies
#:compute-action-stamp #:traverse-action #:action-up-to-date-p #:compute-action-stamp #:traverse-action #:action-up-to-date-p
#:make-plan #:plan-actions #:perform-plan #:plan-operates-on-p #:make-plan #:plan-actions #:perform-plan #:plan-operates-on-p
#:planned-p #:index #:forced #:forced-not #:planned-p #:index
#:plan-actions-r #:plan-actions-r
#:required-components #:filtered-sequential-plan #:required-components #:filtered-sequential-plan
#:plan-system
#:plan-component-type #:plan-keep-operation #:plan-keep-component #:plan-component-type #:plan-keep-operation #:plan-keep-component
)) ))
(in-package :asdf/plan) (in-package :asdf/plan)
...@@ -33,18 +31,9 @@ ...@@ -33,18 +31,9 @@
(defclass plan () () (defclass plan () ()
(:documentation "Base class for a plan based on which ASDF can build a system")) (:documentation "Base class for a plan based on which ASDF can build a system"))
(defclass plan-traversal (plan) (defclass plan-traversal (plan)
(;; Can this plan be performed? A plan that has different force and force-not settings than the (;; The forcing parameters for this plan. Also indicates whether the plan is performable,
;; session plan can only be used for read-only queries that do not cause the status of any ;; in which case the forcing is the same as for the entire session.
;; action to be raised. (forcing :initform (forcing (toplevel-asdf-session)) :initarg :forcing :reader forcing))
(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))
(:documentation "Base class for plans that simply traverse dependencies"))) (:documentation "Base class for plans that simply traverse dependencies")))
...@@ -108,69 +97,6 @@ the action of OPERATION on COMPONENT in the PLAN")) ...@@ -108,69 +97,6 @@ the action of OPERATION on COMPONENT in the PLAN"))
new-status)) 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? ;;;; Is the action needed in this image?
(with-upgradability () (with-upgradability ()
(defgeneric needed-in-image-p (operation component) (defgeneric needed-in-image-p (operation component)
...@@ -276,7 +202,8 @@ initialized with SEED." ...@@ -276,7 +202,8 @@ initialized with SEED."
;; Any race condition is intrinsic to the limited timestamp resolution. ;; 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 (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. ;; 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 (values done-stamp ;; return the hard-earned timestamp
(or just-done (or just-done
out-op ;; a file-creating op is done when all files are up to date out-op ;; a file-creating op is done when all files are up to date
...@@ -287,14 +214,10 @@ initialized with SEED." ...@@ -287,14 +214,10 @@ initialized with SEED."
;;;; Generic support for plan-traversal ;;;; Generic support for plan-traversal
(with-upgradability () (when-upgrading (:version "3.1.7.35")
(defmethod initialize-instance :after ((plan plan-traversal) (defmethod initialize-instance :after ((plan plan-traversal) &key &allow-other-keys)))
&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))))
(with-upgradability ()
(defgeneric plan-actions (plan) (defgeneric plan-actions (plan)
(:documentation "Extract from a plan a list of actions to perform in sequence")) (:documentation "Extract from a plan a list of actions to perform in sequence"))
(defmethod plan-actions ((plan list)) (defmethod plan-actions ((plan list))
...@@ -304,7 +227,7 @@ initialized with SEED." ...@@ -304,7 +227,7 @@ initialized with SEED."
(setf (gethash (cons o c) (visited-actions *asdf-session*)) new-status)) (setf (gethash (cons o c) (visited-actions *asdf-session*)) new-status))