diff --git a/Makefile b/Makefile index 8e56422fc755b7209651567287b5928189a2413a..8a4398c031ce70299be0e509709ad0dcb8d1e13b 100644 --- a/Makefile +++ b/Makefile @@ -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 $* = $($*) diff --git a/asdf.asd b/asdf.asd index 855064fad6a1f332e53f38d1d57e445e43fedf4a..3f1249e0f3eb1af06de30ff4ab87f64e59cecad1 100644 --- a/asdf.asd +++ b/asdf.asd @@ -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")) diff --git a/bundle.lisp b/bundle.lisp index b9f3c5d011c2bfa2db0c0f4f2b5c6ca6db18e5ef..03d87b5ac105c7fb02cdc7e75dec46705ed93f7f 100644 --- a/bundle.lisp +++ b/bundle.lisp @@ -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 diff --git a/concatenate-source.lisp b/concatenate-source.lisp index 8540678cd0d43e1a59b3b31cd0dbf81c52b12429..da2322dacdfbd7122f2965df70382b30b23faaa6 100644 --- a/concatenate-source.lisp +++ b/concatenate-source.lisp @@ -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 diff --git a/find-system.lisp b/find-system.lisp index 22114504bd974e84a495d9b3a3aa8acd4f7ba17b..ede568c1689d8096c1c99804d3424262018df239 100644 --- a/find-system.lisp +++ b/find-system.lisp @@ -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 diff --git a/forcing.lisp b/forcing.lisp new file mode 100644 index 0000000000000000000000000000000000000000..848bbad10779ce213cf2cf81e08674ca2d45b49e --- /dev/null +++ b/forcing.lisp @@ -0,0 +1,135 @@ +;;;; ------------------------------------------------------------------------- +;;;; 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)))) diff --git a/interface.lisp b/interface.lisp index f8a45374e143c6be573a5a730ba220c46d505081..fe17dd7987c4d8135f7cfbcb0256106b29e0bebf 100644 --- a/interface.lisp +++ b/interface.lisp @@ -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. diff --git a/make-asdf.bat b/make-asdf.bat index c40e200949f69122f093959d81725ff0b8b32e0c..523fbe71da6ecbcd067f3acc86e43e27737647a3 100644 --- a/make-asdf.bat +++ b/make-asdf.bat @@ -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" diff --git a/make-asdf.sh b/make-asdf.sh index a3cc62cef07adb459bb1bd4380022724ea57b900..ec429fd2f01ad9d9ab8dbefb4232bb90773c37ea 100755 --- a/make-asdf.sh +++ b/make-asdf.sh @@ -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 diff --git a/operate.lisp b/operate.lisp index 9a4538d2ad3eb70fdfd868154ebb69fd5daf7c19..5c81221280bb358410a895a7c188efacb1b88791 100644 --- a/operate.lisp +++ b/operate.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))))))))) diff --git a/plan.lisp b/plan.lisp index f3c3d2b885ebb1122a97d37c0e9d009e0ed1c5d1..4400b8877292d0a6f0cffc6b5a30338dfa7efe97 100644 --- a/plan.lisp +++ b/plan.lisp @@ -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))) diff --git a/session.lisp b/session.lisp index 280213810a8b1ce91e1dd6fb07f774b260b339fc..ffc188ba69e6ba3f110287b16a393815f73b0b81 100644 --- a/session.lisp +++ b/session.lisp @@ -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. diff --git a/test/run-tests.sh b/test/run-tests.sh index e3ed416185e1b20f1186aa3eee4584e31f9eb0da..e1079cc9dc2faea43ac54c3250adc45b2c6bf6c0 100755 --- a/test/run-tests.sh +++ b/test/run-tests.sh @@ -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 diff --git a/test/script-support.lisp b/test/script-support.lisp index 30f42baf3a58c12449dc2b96964a9eee80799048..cf2de62222439c587997d4192335eba7b768feae 100644 --- a/test/script-support.lisp +++ b/test/script-support.lisp @@ -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 () diff --git a/test/show-progress.lisp b/test/show-progress.lisp new file mode 100644 index 0000000000000000000000000000000000000000..a60ccdbefcbd39c38d162e6c01edf18eae54a7ae --- /dev/null +++ b/test/show-progress.lisp @@ -0,0 +1,20 @@ +(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)) diff --git a/test/test-asdf.asd b/test/test-asdf.asd index ef2ff4aa5f5a2c44896ea698ed5ceb9c62f31fd5..a1d036a4902777672d578d54ef386c56d88e9f4b 100644 --- a/test/test-asdf.asd +++ b/test/test-asdf.asd @@ -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") diff --git a/test/test-builtin-source-file-type.script b/test/test-builtin-source-file-type.script index 058a251050520e163fddc48f3d2652db1e457a40..5997c96a19d9bb8c3f50b766b004faa7d95cce0b 100644 --- a/test/test-builtin-source-file-type.script +++ b/test/test-builtin-source-file-type.script @@ -1,51 +1,45 @@ ;;; -*- 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*"))) diff --git a/test/test-defsystem-depends-on-change.script b/test/test-defsystem-depends-on-change.script index 923974b6deee10012721efce5f8bde2547f96d28..b9e67992963e9a4f3ef2c9dd8532945cdc8d540f 100644 --- a/test/test-defsystem-depends-on-change.script +++ b/test/test-defsystem-depends-on-change.script @@ -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 diff --git a/test/test-force.script b/test/test-force.script index 4429d00824b88f4efcbf21363250b9037531655e..f673f025bb29b1b4567261bd33501c6cb196e24e 100644 --- a/test/test-force.script +++ b/test/test-force.script @@ -1,9 +1,17 @@ ;;; -*- 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) -(load-system 'test-asdf/force :force :all) +(with-asdf-session (:override t :override-forcing t) + (load-system 'test-asdf/force :force :all)) (assert-compare (>= (- (get-file-stamp file1) file1-date) 0)) (assert-equal test-package::*file3* t) @@ -104,21 +116,21 @@ (assert-equal (asymval :*file3-only-asd-loaded* :asdf-user) 2) +(DBG "Check that require-system called with touched .asd won't reload the asdf.") (setf test-package::*file3* :reset) - (reset-session-visited) -(DBG "Check that require-system called with touched .asd won't reload the asdf.") -(unset-asdf-cache-entry '(find-system "test-asdf")) -(unset-asdf-cache-entry '(find-system "test-asdf/force")) -(touch-file "test-asdf.asd" :timestamp (+ 10000 (get-file-stamp file1))) -(require-system 'test-asdf/force) +(with-asdf-session (:override t :override-forcing t) + (unset-asdf-cache-entry '(find-system "test-asdf")) + (unset-asdf-cache-entry '(find-system "test-asdf/force")) + (touch-file "test-asdf.asd" :timestamp (+ 10000 (get-file-stamp file1))) + (require-system 'test-asdf/force)) (assert-equal (asymval :*times-loaded* :test-asdf-system) 3) (assert-equal test-package::*file3* :reset) -(reset-session-visited) (DBG "Check that require-system called with untouched .asd won't reload the asdf.") -(require-system 'test-asdf/force) - -;;; Somehow, it loads the system... +(reset-session-visited) +(with-asdf-session (:override t :override-forcing t) + (require-system 'test-asdf/force)) +;; Somehow, it loads the system... (assert-equal (asymval :*times-loaded* :test-asdf-system) 3) (assert-equal test-package::*file3* :reset) diff --git a/test/test-module-depend.script b/test/test-module-depend.script index 97623a308c1520c699f8d9217bf6258bf40cec4e..3396fdcd52180a46136cb7ec53fa062fe1dc45f9 100644 --- a/test/test-module-depend.script +++ b/test/test-module-depend.script @@ -1,5 +1,7 @@ ;;; -*- Lisp -*- +(setf asdf::*asdf-session* (make-instance asdf::*asdf-session-class*)) + (load-system 'test-module-depend) ;; test that it compiled diff --git a/test/test-module-excessive-depend.script b/test/test-module-excessive-depend.script index f3187f9a622959de7c3e86781860b4c3d7059238..807b1f08b3ec382bd92b5ed3f31f3d3ab3292852 100644 --- a/test/test-module-excessive-depend.script +++ b/test/test-module-excessive-depend.script @@ -12,6 +12,8 @@ ;;; and reloading of "file2," but /not/ of system Y. ;;;--------------------------------------------------------------------------- +(setf asdf::*asdf-session* (make-instance asdf::*asdf-session-class*)) + (def-test-system :test-module-excessive-depend :components ((:file "file1") (:module "quux" diff --git a/test/test-mutual-redefinition.script b/test/test-mutual-redefinition.script index 228fc3b113977da038d3cd285270636738bcaac1..3f8b71a12da647fe017ee7a26282cdbb4235825c 100644 --- a/test/test-mutual-redefinition.script +++ b/test/test-mutual-redefinition.script @@ -7,7 +7,7 @@ (with-asdf-session (:override t) (terpri) - (DBG "loading test-mutual-redefinition-1") + (DBG "Loading test-mutual-redefinition-1") (let ((warned-p nil)) (handler-bind ((bad-system-name (lambda (c) (assert-equal (component-name c) "test-mutual-redefinition-2") @@ -23,14 +23,36 @@ (current-system-source-file "test-mutual-redefinition-2")) (terpri) - (DBG "loading test-mutual-redefinition-2 in the same cache session. It shouldn't affect asd paths") - (load-system 'test-mutual-redefinition-2) + (DBG "Loading test-mutual-redefinition-2 in the same cache session. +Looking for its definition should trigger a DEFINE-OP and cause the asd paths to be affected.") + (let ((warned-p nil)) + (handler-bind ((bad-system-name (lambda (c) + (assert-equal (component-name c) "test-mutual-redefinition-1") + (assert-equal (pathname-name (system-source-file c)) "test-mutual-redefinition-2") + (setf warned-p t)))) + (load-system 'test-mutual-redefinition-2)) + (assert warned-p)) (assert-pathname-equal - (test-source "test-mutual-redefinition-1.asd") + (test-source "test-mutual-redefinition-2.asd") + (current-system-source-file "test-mutual-redefinition-2")) + (assert-pathname-equal + (test-source "test-mutual-redefinition-2.asd") (current-system-source-file "test-mutual-redefinition-1")) + + (terpri) + (DBG "Loading test-mutual-redefinition-1 again in the same cache session. +It should be considered already loaded.") + (let ((warned-p nil)) + (handler-bind ((bad-system-name (lambda (c) + (setf warned-p t)))) + (load-system 'test-mutual-redefinition-2)) + (assert (not warned-p))) (assert-pathname-equal - (test-source "test-mutual-redefinition-1.asd") - (current-system-source-file "test-mutual-redefinition-2"))) + (test-source "test-mutual-redefinition-2.asd") + (current-system-source-file "test-mutual-redefinition-2")) + (assert-pathname-equal + (test-source "test-mutual-redefinition-2.asd") + (current-system-source-file "test-mutual-redefinition-1"))) (with-asdf-session (:override t) (terpri) diff --git a/test/test-source-file-type.script b/test/test-source-file-type.script index 2d93ebd6e9ad78f77bf09ca2530e6ab5b7d1dc3c..5d7484037408937229e572fe7f197b9fe0c8b65d 100644 --- a/test/test-source-file-type.script +++ b/test/test-source-file-type.script @@ -1,16 +1,11 @@ ;;; -*- Lisp -*- - - -;;(trace asdf::source-file-type asdf::source-file-explicit-type) - -(progn - (asdf:load-system 'test-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) - (asdf:load-system 'test-source-file-type-2 :verbose t) - (assert (symbol-value (read-from-string "test-package::*test-tmp-cl*")))) +(load-system 'test-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) +(load-system 'test-source-file-type-2 :verbose t) +(assert (symbol-value (read-from-string "test-package::*test-tmp-cl*"))) diff --git a/test/test-static-and-serial.script b/test/test-static-and-serial.script index cfa70b105a5c32c18f732a2e6feb2d1ca8195b55..7f5e4b1c7d59f5f08d73dcf254865a8e83c292de 100644 --- a/test/test-static-and-serial.script +++ b/test/test-static-and-serial.script @@ -6,6 +6,8 @@ don't cause full rebuilds all the time... (in-package :asdf-test) +(setf asdf::*asdf-session* (make-instance asdf::*asdf-session-class*)) + (defparameter s '(def-test-system static-and-serial :version "0.1" diff --git a/test/test-touch-system-1.script b/test/test-touch-system-1.script index d311894f79b38c6339dc97476a8c12224971ba9f..dc2dd541ff09a27b22bc2b497393f353a1a8dd11 100644 --- a/test/test-touch-system-1.script +++ b/test/test-touch-system-1.script @@ -2,6 +2,9 @@ ;;; test system def reloading if touched ;;; system that can be found using *system-definition-search-functions* + +(setf asdf::*asdf-session* (make-instance asdf::*asdf-session-class*)) + (defun system-registered-time (name) (car (asdf::system-registered-p name))) (setf (asdf-upgraded-p *asdf-session*) t) diff --git a/test/test-touch-system-2.script b/test/test-touch-system-2.script index 7cc05e4060d071cff31e102126435b77eab308e1..497f8e5521ffbf52078826760bef24a7850d5142 100644 --- a/test/test-touch-system-2.script +++ b/test/test-touch-system-2.script @@ -3,6 +3,8 @@ ;;; test system definition reloading if touched ;;; system that canNOT be found using *system-definition-search-functions* +(setf asdf::*asdf-session* (make-instance asdf::*asdf-session-class*)) + (defun system-registered-time (name) (car (asdf::system-registered-p name))) diff --git a/test/test-utilities.script b/test/test-utilities.script index bc0ffb94b00325d772ba04ff7feb0e1fc754774f..8c68119d9e84acc3c3455316c6caf3e3492c9931 100644 --- a/test/test-utilities.script +++ b/test/test-utilities.script @@ -1,6 +1,5 @@ ;;; -*- Lisp -*- -#+(and sbcl os-windows) (trace sb-ext:run-program) (proclaim '(optimize (debug 3) (speed 1) (safety 3) (compilation-speed 0))) (defun getcwd-from-run-program () diff --git a/test/test1.script b/test/test1.script index 985592e6f9d4e2211cad5abaaa2c7c717e68f368..8add05953435543998bb5f1bfc4737e5f044497d 100644 --- a/test/test1.script +++ b/test/test1.script @@ -1,5 +1,7 @@ ;;; -*- Lisp -*- +(setf asdf::*asdf-session* (make-instance asdf::*asdf-session-class*)) + ;; We need use the pathnames used by ASDF. (defparameter test1.asd (system-source-file 'test1)) (defparameter file1.lisp (component-pathname (find-component 'test1 "file1"))) @@ -20,7 +22,6 @@ (touch-file file2.lisp :timestamp *date* :offset 200) (assert-equal (get-file-stamp file1.lisp) (+ *date* 100)) (assert-equal (get-file-stamp file2.lisp) (+ *date* 200)) - (DBG "loading test1") (load-system 'test1) @@ -41,7 +42,6 @@ (clear-system 'test1) (DBG "load again") -;;(trace input-files asdf::compute-action-stamp) (defparameter *plan* (nth-value 1 (operate 'load-op 'test1))) (DBG "check that file1 is _not_ recompiled, but file2 is") (assert (in-plan-p *plan* '(compile-op "test1" "file2")))