Skip to content
Snippets Groups Projects
Commit 2dcd42a2 authored by Francois-Rene Rideau's avatar Francois-Rene Rideau
Browse files

2.26.50: preserve timestamps for forced-not actions.

Also, remove previously commented-out utilities from exported symbols.
Reinstate action-already-done-p for the sake of POIU.
parent 67d64c35
No related branches found
No related tags found
No related merge requests found
...@@ -14,7 +14,7 @@ ...@@ -14,7 +14,7 @@
:licence "MIT" :licence "MIT"
:description "Another System Definition Facility" :description "Another System Definition Facility"
:long-description "ASDF builds Common Lisp software organized into defined systems." :long-description "ASDF builds Common Lisp software organized into defined systems."
:version "2.26.49" ;; to be automatically updated by bin/bump-revision :version "2.26.50" ;; to be automatically updated by bin/bump-revision
:depends-on () :depends-on ()
:components :components
((:file "asdf"))) ((:file "asdf")))
......
;; -*- mode: Common-Lisp; Base: 10 ; Syntax: ANSI-Common-Lisp ; coding: utf-8 -*- ;; -*- mode: Common-Lisp; Base: 10 ; Syntax: ANSI-Common-Lisp ; coding: utf-8 -*-
;;; This is ASDF 2.26.49: Another System Definition Facility. ;;; This is ASDF 2.26.50: Another System Definition Facility.
;;; ;;;
;;; Feedback, bug reports, and patches are all welcome: ;;; Feedback, bug reports, and patches are all welcome:
;;; please mail to <asdf-devel@common-lisp.net>. ;;; please mail to <asdf-devel@common-lisp.net>.
...@@ -120,7 +120,7 @@ ...@@ -120,7 +120,7 @@
;; "2.345.6" would be a development version in the official upstream ;; "2.345.6" would be a development version in the official upstream
;; "2.345.0.7" would be your seventh local modification of official release 2.345 ;; "2.345.0.7" would be your seventh local modification of official release 2.345
;; "2.345.6.7" would be your seventh local modification of development version 2.345.6 ;; "2.345.6.7" would be your seventh local modification of development version 2.345.6
(asdf-version "2.26.49") (asdf-version "2.26.50")
(existing-asdf (find-class 'component nil)) (existing-asdf (find-class 'component nil))
(existing-version *asdf-version*) (existing-version *asdf-version*)
(already-there (equal asdf-version existing-version))) (already-there (equal asdf-version existing-version)))
...@@ -191,10 +191,14 @@ ...@@ -191,10 +191,14 @@
(unless (eq sym (find-symbol* sym package)) (unless (eq sym (find-symbol* sym package))
(remove-symbol sym package))) (remove-symbol sym package)))
(use-package used package))) (use-package used package)))
(ensure-fmakunbound (package symbols) #-ecl (ensure-fmakunbound (package symbols)
(loop :for name :in symbols (loop :for name :in symbols
:for sym = (find-symbol* name package) :for sym = (find-symbol* name package)
:when sym :do (fmakunbound sym))) :when sym :do (fmakunbound sym)))
#-ecl (ensure-fmakunbound-setf (package symbols)
(loop :for name :in symbols
:for sym = (find-symbol* name package)
:when sym :do #-gcl (fmakunbound `(setf ,sym))))
(ensure-export (package export) (ensure-export (package export)
(let ((formerly-exported-symbols nil) (let ((formerly-exported-symbols nil)
(bothly-exported-symbols nil) (bothly-exported-symbols nil)
...@@ -215,25 +219,25 @@ ...@@ -215,25 +219,25 @@
(loop :for x :in newly-exported-symbols :do (loop :for x :in newly-exported-symbols :do
(export (intern* x package))))) (export (intern* x package)))))
(ensure-package (name &key nicknames use unintern (ensure-package (name &key nicknames use unintern
shadow export fmakunbound) shadow export fmakunbound fmakunbound-setf)
(let* ((p (ensure-exists name nicknames use))) (let* ((p (ensure-exists name nicknames use)))
#-ecl (ensure-fmakunbound p fmakunbound) #+ecl fmakunbound ;; do it later on ECL #-ecl (ensure-fmakunbound p fmakunbound) #+ecl fmakunbound ;; do it later on ECL
#-ecl (ensure-fmakunbound-setf p fmakunbound-setf) #+ecl fmakunbound-setf
(ensure-unintern p unintern) (ensure-unintern p unintern)
(ensure-shadow p shadow) (ensure-shadow p shadow)
(ensure-export p export) (ensure-export p export)
p))) p)))
(macrolet (macrolet
((pkgdcl (name &key nicknames use export ((pkgdcl (name &key nicknames use export
redefined-functions unintern shadow) fmakunbound fmakunbound-setf unintern shadow)
`(ensure-package `(ensure-package
',name :nicknames ',nicknames :use ',use :export ',export ',name :nicknames ',nicknames :use ',use :export ',export
:shadow ',shadow :shadow ',shadow :unintern ',unintern
:unintern ',unintern :fmakunbound ',fmakunbound :fmakunbound-setf ',fmakunbound-setf)))
:fmakunbound ',redefined-functions)))
(pkgdcl (pkgdcl
:asdf :asdf
:use (:common-lisp) :use (:common-lisp)
:redefined-functions :fmakunbound
(#:perform #:explain #:output-files #:operation-done-p #:do-traverse (#:perform #:explain #:output-files #:operation-done-p #:do-traverse
#:compute-action-stamp #:component-load-dependencies #:traverse-action #:compute-action-stamp #:component-load-dependencies #:traverse-action
#:component-depends-on #:perform-plan #:mark-operation-done #:component-depends-on #:perform-plan #:mark-operation-done
...@@ -243,6 +247,7 @@ ...@@ -243,6 +247,7 @@
#:system-relative-pathname #:source-file-type #:builtin-system-p #:system-relative-pathname #:source-file-type #:builtin-system-p
#:inherit-source-registry #:process-source-registry #:process-source-registry-directive #:inherit-source-registry #:process-source-registry #:process-source-registry-directive
#:compile-file* #:source-file-type #:trivial-system-p) #:compile-file* #:source-file-type #:trivial-system-p)
:fmakunbound-setf (#:output-translations)
:unintern :unintern
(#:*asdf-revision* #:around #:asdf-method-combination (#:*asdf-revision* #:around #:asdf-method-combination
#:split #:make-collector #:do-dep #:do-one-dep #:visit-action #:component-visited-p #:split #:make-collector #:do-dep #:do-one-dep #:visit-action #:component-visited-p
...@@ -366,36 +371,7 @@ ...@@ -366,36 +371,7 @@
#:user-source-registry #:user-source-registry
#:system-source-registry #:system-source-registry
#:user-source-registry-directory #:user-source-registry-directory
#:system-source-registry-directory #:system-source-registry-directory)))
;; Utilities: please use asdf-utils instead
#|
;; #:aif #:it
;; #:appendf #:orf
#:length=n-p
#:remove-keys #:remove-keyword
#:first-char #:last-char #:string-suffix-p
#:coerce-name
#:directory-pathname-p #:ensure-directory-pathname
#:absolute-pathname-p #:ensure-pathname-absolute #:pathname-root
#:getenv #:getenv-pathname #:getenv-pathnames
#:getenv-absolute-directory #:getenv-absolute-directories
#:probe-file*
#:find-symbol* #:strcat
#:make-pathname-component-logical #:make-pathname-logical
#:merge-pathnames* #:coerce-pathname #:subpathname #:subpathname*
#:pathname-directory-pathname #:pathname-parent-directory-pathname
#:read-file-forms
#:resolve-symlinks #:truenamize
#:split-string
#:component-name-to-pathname-components
#:split-name-type
#:subdirectories #:directory-files
#:while-collecting
#:*wild* #:*wild-file* #:*wild-directory* #:*wild-inferiors*
#:*wild-path* #:wilden
#:directorize-pathname-host-device|#
)))
#+genera (import 'scl:boolean :asdf) #+genera (import 'scl:boolean :asdf)
(setf *asdf-version* asdf-version (setf *asdf-version* asdf-version
*upgraded-p* (if existing-version *upgraded-p* (if existing-version
...@@ -2171,7 +2147,7 @@ PREVIOUS-TIME when not null is the time at which the PREVIOUS system was loaded. ...@@ -2171,7 +2147,7 @@ PREVIOUS-TIME when not null is the time at which the PREVIOUS system was loaded.
(defmethod find-operation ((operation operation) (sub symbol)) (defmethod find-operation ((operation operation) (sub symbol))
(let* ((ancestor (operation-ancestor operation)) (let* ((ancestor (operation-ancestor operation))
(operations (operation-children-by-name ancestor))) (operations (operation-children-by-name ancestor)))
(or (values (gethash sub operations)) (or (gethash sub operations)
(let ((new (if (eq sub (type-of ancestor)) (let ((new (if (eq sub (type-of ancestor))
ancestor ancestor
(make-instance sub :parent ancestor)))) (make-instance sub :parent ancestor))))
...@@ -2270,16 +2246,13 @@ PREVIOUS-TIME when not null is the time at which the PREVIOUS system was loaded. ...@@ -2270,16 +2246,13 @@ PREVIOUS-TIME when not null is the time at which the PREVIOUS system was loaded.
(gethash name override) (gethash name override)
t))))) t)))))
(defmethod operation-done-p ((o prepare-op) (c component))
(and (not (operation-forced-p o c)) (call-next-method)))
(defun* visit-dependencies (operation component fun &aux stamp) (defun* visit-dependencies (operation component fun &aux stamp)
(loop :for (dep-o-spec . dep-c-specs) :in (component-depends-on operation component) (loop :for (dep-o-spec . dep-c-specs) :in (component-depends-on operation component)
:unless (eq dep-o-spec 'feature) ;; avoid the "FEATURE" misfeature :unless (eq dep-o-spec 'feature) ;; avoid the "FEATURE" misfeature
:do (loop :with dep-o = (find-operation operation dep-o-spec) :do (loop :with dep-o = (find-operation operation dep-o-spec)
:for dep-c-spec :in dep-c-specs :for dep-c-spec :in dep-c-specs
:for dep-c = (resolve-dependency-spec component dep-c-spec) :do :for dep-c = (resolve-dependency-spec component dep-c-spec)
(latest-stamp-f stamp (funcall fun dep-o dep-c)))) :do (latest-stamp-f stamp (funcall fun dep-o dep-c))))
stamp) stamp)
(defgeneric* needed-in-image-p (operation component)) (defgeneric* needed-in-image-p (operation component))
...@@ -2296,7 +2269,7 @@ PREVIOUS-TIME when not null is the time at which the PREVIOUS system was loaded. ...@@ -2296,7 +2269,7 @@ PREVIOUS-TIME when not null is the time at which the PREVIOUS system was loaded.
(and (action-override-p o c 'operation-forced) (not (builtin-system-p c)))) (and (action-override-p o c 'operation-forced) (not (builtin-system-p c))))
(defmethod operation-forced-not-p ((o operation) (c component)) (defmethod operation-forced-not-p ((o operation) (c component))
(action-override-p o c 'operation-forced-not)) (and (action-override-p o c 'operation-forced-not) (not (operation-forced-p o c))))
(defgeneric action-valid-p (operation component) (defgeneric action-valid-p (operation component)
(:documentation "Is this action valid to include amongst dependencies?")) (:documentation "Is this action valid to include amongst dependencies?"))
...@@ -2304,8 +2277,7 @@ PREVIOUS-TIME when not null is the time at which the PREVIOUS system was loaded. ...@@ -2304,8 +2277,7 @@ PREVIOUS-TIME when not null is the time at which the PREVIOUS system was loaded.
(declare (ignorable o c)) (declare (ignorable o c))
(aif (component-if-feature c) (featurep it) t)) (aif (component-if-feature c) (featurep it) t))
(defmethod action-valid-p ((o operation) (s system)) (defmethod action-valid-p ((o operation) (s system))
(and (or (operation-forced-p o s) (not (operation-forced-not-p o s))) (and (not (operation-forced-not-p o s)) (call-next-method)))
(call-next-method)))
(defmethod action-valid-p ((o null) c) (declare (ignorable o c)) nil) (defmethod action-valid-p ((o null) c) (declare (ignorable o c)) nil)
(defmethod action-valid-p (o (c null)) (declare (ignorable o c)) nil) (defmethod action-valid-p (o (c null)) (declare (ignorable o c)) nil)
...@@ -2363,7 +2335,8 @@ If true, an integer indexing the action in the list of actions planned.")) ...@@ -2363,7 +2335,8 @@ If true, an integer indexing the action in the list of actions planned."))
(setf (gethash (node-for o c) (plan-visited-actions plan)) new-status)) (setf (gethash (node-for o c) (plan-visited-actions plan)) new-status))
(defmethod plan-action-status ((plan plan-traversal) (o operation) (c component)) (defmethod plan-action-status ((plan plan-traversal) (o operation) (c component))
(values (gethash (node-for o c) (plan-visited-actions plan)))) (or (and (operation-forced-not-p o c) (plan-action-status nil o c))
(values (gethash (node-for o c) (plan-visited-actions plan)))))
(defmethod component-operation-time ((o operation) (c component)) (defmethod component-operation-time ((o operation) (c component))
(gethash (type-of o) (component-operation-times c))) (gethash (type-of o) (component-operation-times c)))
...@@ -2372,6 +2345,9 @@ If true, an integer indexing the action in the list of actions planned.")) ...@@ -2372,6 +2345,9 @@ If true, an integer indexing the action in the list of actions planned."))
(setf (gethash (type-of o) (component-operation-times c)) (setf (gethash (type-of o) (component-operation-times c))
(compute-action-stamp o c :just-done t))) (compute-action-stamp o c :just-done t)))
(defun* action-already-done-p (plan operation component)
(action-done-p (plan-action-status plan operation component)))
(defmethod plan-action-status ((plan null) (o operation) (c component)) (defmethod plan-action-status ((plan null) (o operation) (c component))
(declare (ignorable plan)) (declare (ignorable plan))
(multiple-value-bind (stamp done-p) (component-operation-time o c) (multiple-value-bind (stamp done-p) (component-operation-time o c)
...@@ -2426,7 +2402,7 @@ If true, an integer indexing the action in the list of actions planned.")) ...@@ -2426,7 +2402,7 @@ If true, an integer indexing the action in the list of actions planned."))
;; 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))) (and all-present up-to-date-p (operation-done-p o c) (not (operation-forced-p o c))))
(values done-stamp ;; return the hard-earned timestamp (values done-stamp ;; return the hard-earned timestamp
(or just-done (or just-done
(or out-op ;; a file-creating op is done when all files are up to date (or out-op ;; a file-creating op is done when all files are up to date
...@@ -2499,7 +2475,7 @@ If true, an integer indexing the action in the list of actions planned.")) ...@@ -2499,7 +2475,7 @@ If true, an integer indexing the action in the list of actions planned."))
(defmethod traverse ((o operation) (c component)) (defmethod traverse ((o operation) (c component))
(let ((plan (make-instance 'sequential-plan))) (let ((plan (make-instance 'sequential-plan)))
(traverse-action plan o c t) (traverse-action plan o c t)
(reverse (plan-actions-r plan)))) (reverse (plan-actions-r plan)))) ;; backward compat: return a list, not the plan object.
(defmethod perform ((o operation) (c source-file)) (defmethod perform ((o operation) (c source-file))
(sysdef-error (sysdef-error
...@@ -2913,7 +2889,7 @@ T to force the inside of the specified system to be rebuilt (resp. not), ...@@ -2913,7 +2889,7 @@ T to force the inside of the specified system to be rebuilt (resp. not),
(map () 'load-system systems)) (map () 'load-system systems))
(defun* component-loaded-p (c) (defun* component-loaded-p (c)
(action-done-p (plan-action-status nil (make-instance 'load-op) (find-component c ())))) (action-already-done-p nil (make-instance 'load-op) (find-component c ())))
(defun* already-loaded-systems () (defun* already-loaded-systems ()
(remove-if-not 'component-loaded-p (registered-systems))) (remove-if-not 'component-loaded-p (registered-systems)))
......
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment