Commit 7ce11cfd authored by Francois-Rene Rideau's avatar Francois-Rene Rideau

Add support for *immutable-systems*.

Add regression tests for the feature.
Change the meaning of :force-not t to mean "anything but current system".
parent bc660a41
......@@ -50,9 +50,9 @@
(:file "find-system" :depends-on ("system" "cache"))
(:file "find-component" :depends-on ("find-system"))
(:file "operation" :depends-on ("upgrade"))
(:file "action" :depends-on ("find-component" "operation" "cache"))
(:file "action" :depends-on ("find-component" "operation"))
(:file "lisp-action" :depends-on ("action"))
(:file "plan" :depends-on ("lisp-action" "cache"))
(:file "plan" :depends-on ("lisp-action"))
(:file "operate" :depends-on ("plan"))
(:file "output-translations" :depends-on ("operate"))
(:file "source-registry" :depends-on ("find-system"))
......
......@@ -9,6 +9,9 @@ cl-asdf (2:3.1.1-1) unstable; urgency=low
subclasses of OPERATION implicitly propagate DOWNWARD and SIDEWAY.
Failure to explicitly inherit from own of the explicitly propagating
or non-propagating classes will result in a WARNING for now.
* force-not now takes precedence over force, and systems named in the
set (represented as an equal hash-table) *immutable-systems* are always
forced-not, and even their .asd is not refreshed from the filesystem.
* portability is much improved, with support for the latest GCL, and
fixes for ABCL, CLISP, ECL, LispWorks, SBCL, XCL, etc.
* bundle support was refactored; ECL support is fixed;
......
......@@ -1723,14 +1723,18 @@ If @var{force} is a list, then it specifies a list of systems that
are forced to be recompiled even if not modified since last compilation.
If @var{force-not} is @code{:all}, then all systems
are forced not to be recompiled even if modified since last compilation.
If @var{force-not} is @code{t}, then only the system being loaded
is forced not to be recompiled even if modified since last compilation,
but other systems are not affected.
If @var{force-not} is @code{t}, then all systems but the system being loaded
are forced not to be recompiled even if modified since last compilation
(note: this was changed in ASDF 3.1.1).
If @var{force-not} is a list, then it specifies a list of systems that
are forced not to be recompiled even if modified since last compilation.
Both @var{force} and @{force-not} apply to systems that are dependencies and were already compiled.
@var{force-not} takes precedences over @var{force},
as it should, really, but unhappily only since 3.1.1.
Both apply to systems that are dependencies and were already compiled.
as it should, really, but unhappily only since ASDF 3.1.1.
Moreover, systems the name of which is member of the set @var{*immutable-systems*}
(represented as an equal hash-table) are always considered @var{forced-not}, and
even their @file{.asd} is not refreshed from the filesystem.
To see what @code{operate} would do, you can use:
@example
......@@ -4290,8 +4294,8 @@ with fundamental issues in the original model being fixed.
Timestamps were not propagated at all, and now are.
The internal model of how actions depend on each other
is now both consistent and complete.
The :version and
the :force (system1 .. systemN) feature have been fixed.
The @code{:version} and
the @code{:force (system1 .. systemN)} feature have been fixed.
@item
Performance has been notably improved for large systems
......
......@@ -19,6 +19,7 @@
#:contrib-sysdef-search #:sysdef-find-asdf ;; backward compatibility symbols, functions removed
#:sysdef-preloaded-system-search #:register-preloaded-system #:*preloaded-systems*
#:clear-defined-systems #:*defined-systems*
#:*immutable-systems*
;; defined in source-registry, but specially mentioned here:
#:initialize-source-registry #:sysdef-source-registry-search))
(in-package :asdf/find-system)
......@@ -140,6 +141,7 @@ called with an object of type asdf:system."
(let ((name (coerce-name system)))
(flet ((try (f) (if-let ((x (funcall f name))) (return-from search-for-system-definition x))))
(try 'find-system-if-being-defined)
(try 'sysdef-immutable-system-search)
(map () #'try *system-definition-search-functions*)
(try 'sysdef-preloaded-system-search))))
......@@ -343,6 +345,25 @@ Going forward, we recommend new users should be using the source-registry.
old-version old-pathname version pathname))))
nil))))) ;; only issue the warning the first time, but always return nil
(defvar *immutable-systems* nil
"An hash-set (equal hash-table mapping keys to T) of systems that are immutable,
i.e. already loaded in memory and not to be refreshed from the filesystem.
They will be treated specially by find-system, and passed as :force-not argument to make-plan.
If you deliver an image with many systems precompiled, *and* do not want to check the filesystem
for them every time a user loads an extension, what more risk a problematic upgrade or catastrophic
downgrade, before you dump an image, use:
(setf asdf::*immutable-systems* (uiop:list-to-hash-set (asdf:already-loaded-systems)))")
(defun sysdef-immutable-system-search (requested)
(let ((name (coerce-name requested)))
(when (and *immutable-systems* (gethash name *immutable-systems*))
(or (cdr (system-registered-p requested))
(error 'formatted-system-definition-error
:format-control "Requested system ~A is in the *immutable-systems* set, ~
but not loaded in memory"
:format-arguments (list name))))))
(defun locate-system (name)
"Given a system NAME designator, try to locate where to load the system from.
Returns five values: FOUNDP FOUND-SYSTEM PATHNAME PREVIOUS PREVIOUS-TIME
......@@ -386,6 +407,10 @@ PREVIOUS-TIME when not null is the time at which the PREVIOUS system was loaded.
(restart-case
(multiple-value-bind (foundp found-system pathname previous previous-time)
(locate-system name)
(when (and found-system (eq found-system previous)
(or (gethash name *systems-being-defined*)
(and *immutable-systems* (gethash name *immutable-systems*))))
(return found-system))
(assert (eq foundp (and (or found-system pathname previous) t)))
(let ((previous-pathname (and previous (system-source-file previous)))
(system (or previous found-system)))
......
......@@ -103,7 +103,7 @@
#:*compile-file-warnings-behaviour*
#:*compile-file-failure-behaviour*
#:*resolve-symlinks*
#:*load-system-operation*
#:*load-system-operation* #:*immutable-systems*
#:*asdf-verbose* ;; unused. For backward-compatibility only.
#:*verbose-out*
......
......@@ -99,17 +99,26 @@ the action of OPERATION on COMPONENT in the PLAN"))
(defun normalize-forced-systems (x system)
(etypecase x
((member nil :all) x)
((or (member nil :all) hash-table function) x)
(cons (list-to-hash-set (mapcar #'coerce-name x)))
((eql t) (when system (list-to-hash-set (list (coerce-name system)))))))
(defun normalize-forced-not-systems (x system)
(let ((requested
(etypecase x
((or (member nil :all) hash-table function) x)
(cons (list-to-hash-set (mapcar #'coerce-name x)))
((eql t) (if system (let ((name (coerce-name system)))
#'(lambda (x) (not (equal x name))))
t)))))
(if (and *immutable-systems* requested)
#'(lambda (x) (or (call-function requested x) (call-function *immutable-systems* x)))
(or *immutable-systems* requested))))
(defun action-override-p (plan operation component override-accessor)
(declare (ignore operation))
(let* ((override (funcall override-accessor plan)))
(and override
(if (typep override 'hash-table)
(gethash (coerce-name (component-system (find-component () component))) override)
t))))
(call-function (funcall override-accessor plan)
(coerce-name (component-system (find-component () component)))))
(defmethod action-forced-p (plan operation component)
(and
......@@ -260,11 +269,11 @@ the action of OPERATION on COMPONENT in the PLAN"))
(:documentation "Detect circular dependencies"))
(defmethod initialize-instance :after ((plan plan-traversal)
&key (force () fp) (force-not () fnp) system
&key force force-not system
&allow-other-keys)
(with-slots (forced forced-not) plan
(when fp (setf forced (normalize-forced-systems force system)))
(when fnp (setf forced-not (normalize-forced-systems force-not system)))))
(setf forced (normalize-forced-systems force system))
(setf forced-not (normalize-forced-not-systems force-not system))))
(defmethod (setf plan-action-status) (new-status (plan plan-traversal) (o operation) (c component))
(setf (gethash (node-for o c) (plan-visited-actions plan)) new-status))
......@@ -436,12 +445,12 @@ the action of OPERATION on COMPONENT in the PLAN"))
(keep-component :initform t :initarg :keep-component :reader plan-keep-component)))
(defmethod initialize-instance :after ((plan filtered-sequential-plan)
&key (force () fp) (force-not () fnp)
&key force force-not
other-systems)
(declare (ignore force force-not))
(with-slots (forced forced-not action-filter system) plan
(unless fp (setf forced (normalize-forced-systems (if other-systems :all t) system)))
(unless fnp (setf forced-not (normalize-forced-systems (if other-systems nil :all) system)))
(setf forced (normalize-forced-systems (if other-systems :all t) system))
(setf forced-not (normalize-forced-not-systems (if other-systems nil t) system))
(setf action-filter (ensure-function action-filter))))
(defmethod action-valid-p ((plan filtered-sequential-plan) o c)
......
......@@ -68,3 +68,9 @@
(defsystem :test-asdf/bundle-2
:depends-on (:test-asdf/bundle-1) :components ((:file "file2")))
(defsystem :test-asdf/force
:depends-on (:test-asdf/force1)
:components ((:file "file3")))
(defsystem :test-asdf/force1
:components ((:file "file1")))
......@@ -5,9 +5,9 @@
;;; Check to see if the bundle functionality is doing something.
;;;---------------------------------------------------------------------------
(asdf:initialize-source-registry '(:source-registry :ignore-inherited-configuration))
(asdf:clear-system :test-asdf/bundle-1)
(asdf:clear-system :test-asdf/bundle-2)
(initialize-source-registry '(:source-registry :ignore-inherited-configuration))
(clear-system :test-asdf/bundle-1)
(clear-system :test-asdf/bundle-2)
(when (find-package :test-package) (delete-package :test-package))
#+(and darwin ecl)
......
;;; -*- Lisp -*-
(asdf:defsystem test-force
:components
((:file "file1")))
;;; -*- Lisp -*-
(load-system 'test-force)
(load-system 'test-asdf/force)
(defparameter file1 (test-fasl "file1"))
(defparameter file1-date (file-write-date file1))
......@@ -10,18 +10,45 @@
(assert file1)
(assert file1-date)
;; Check that force has some effect, but force-not takes precedence.
(assert (traverse 'load-op 'test-force :force t))
(assert (null (traverse 'load-op 'test-force :force-not t)))
(assert (null (traverse 'load-op 'test-force :force t :force-not t)))
(let ((plan (traverse 'load-op 'test-asdf/force :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" "file3")))
(assert (not (asdf::plan-operates-on-p plan '("test-asdf/force1" "file1")))))
(let ((plan (traverse 'load-op 'test-asdf/force :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" "file3")))
(assert (asdf::plan-operates-on-p plan '("test-asdf/force1" "file1"))))
(let ((plan (traverse 'load-op 'test-asdf/force :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" "file3")))
(assert (not (asdf::plan-operates-on-p plan '("test-asdf/force1" "file1")))))
(let ((plan (traverse 'load-op 'test-asdf/force :force-not :all)))
(DBG "Check that :force-not :all means \"all systems\"" plan)
(assert (null plan)))
(let ((plan (traverse 'load-op 'test-asdf/force :force :all :force-not :all)))
(DBG "Check that :force-not :all takes precedence over :force" plan)
(assert (null plan)))
(let* ((*immutable-systems* (list-to-hash-set '("test-asdf/force1")))
(plan (traverse 'load-op 'test-asdf/force :force :all :force-not t)))
(DBG "Check that immutable-systems will block forcing" plan)
(assert plan)
(assert (asdf::plan-operates-on-p plan '("test-asdf/force" "file3")))
(assert (not (asdf::plan-operates-on-p plan '("test-asdf/force1" "file1")))))
;; unforced, date should stay same
(touch-file "test-force.asd" :timestamp date1)
(touch-file "test-asdf.asd" :timestamp date1)
(touch-file "file1.lisp" :timestamp date1)
(touch-file file1 :timestamp date2)
(load-system 'test-force)
(load-system 'test-asdf/force)
(assert-equal (get-file-stamp file1) date2)
;; forced, it should be later
(load-system 'test-force :force t)
(load-system 'test-asdf/force :force :all)
(assert-compare (>= (get-file-stamp file1) file1-date))
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment