Commit a21342dd authored by Francois-Rene Rideau's avatar Francois-Rene Rideau

Restore status-index for the sake of POIU

parent 68e0407f
...@@ -10,7 +10,7 @@ ...@@ -10,7 +10,7 @@
:asdf/system :asdf/system-registry :asdf/find-component :asdf/forcing) :asdf/system :asdf/system-registry :asdf/find-component :asdf/forcing)
(:export (:export
#:plan #:plan-traversal #:sequential-plan #:*plan-class* #:plan #:plan-traversal #:sequential-plan #:*plan-class*
#:action-status #:status-stamp #:status-done-p #:status-keep-p #:status-need-p #:action-status #:status-stamp #:status-index #:status-done-p #:status-keep-p #:status-need-p
#:+status-good+ #:+status-todo+ #:+status-void+ #:+status-good+ #:+status-todo+ #:+status-void+
#:system-out-of-date #:action-up-to-date-p #:system-out-of-date #:action-up-to-date-p
#:circular-dependency #:circular-dependency-actions #:circular-dependency #:circular-dependency-actions
...@@ -63,7 +63,11 @@ ...@@ -63,7 +63,11 @@
(stamp (stamp
:type (or integer boolean) :initarg :stamp :reader status-stamp :type (or integer boolean) :initarg :stamp :reader status-stamp
:documentation "STAMP associated with the ACTION if it has been completed already :documentation "STAMP associated with the ACTION if it has been completed already
in some previous image, or T if it needs to be done.")) in some previous image, or T if it needs to be done.")
(index
:type (or integer null) :initarg :index :initform nil :reader status-index
:documentation "INDEX associated with the ACTION in the current session,
or NIL if no the status is considered outside of a specific plan."))
(:documentation "Status of an action in a plan")) (:documentation "Status of an action in a plan"))
;; STAMP KEEP-P DONE-P NEED-P symbol bitmap previously currently ;; STAMP KEEP-P DONE-P NEED-P symbol bitmap previously currently
...@@ -101,18 +105,19 @@ in some previous image, or T if it needs to be done.")) ...@@ -101,18 +105,19 @@ in some previous image, or T if it needs to be done."))
(make-instance 'action-status :bits +void-bits+ :stamp nil))) (make-instance 'action-status :bits +void-bits+ :stamp nil)))
(with-upgradability () (with-upgradability ()
(defun make-action-status (&key bits stamp) (defun make-action-status (&key bits stamp index)
(check-type bits (integer 0 7)) (check-type bits (integer 0 7))
(check-type stamp (or integer boolean)) (check-type stamp (or integer boolean))
(check-type index (or integer null))
(assert (eq (null stamp) (zerop (logand bits #.(logior +keep-bit+ +done-bit+)))) () (assert (eq (null stamp) (zerop (logand bits #.(logior +keep-bit+ +done-bit+)))) ()
"Bad action-status :bits ~S :stamp ~S" bits stamp) "Bad action-status :bits ~S :stamp ~S" bits stamp)
(case bits (block nil
(+void-bits+ +status-void+) (when (null index)
(+todo-bits+ +status-todo+) (case bits
(otherwise (#.+void-bits+ (return +status-void+))
(if (and (= bits +good-bits+) (eq stamp t)) (#.+todo-bits+ (return +status-todo+))
+status-good+ (#.+good-bits+ (when (eq stamp t) (return +status-good+)))))
(make-instance 'action-status :bits bits :stamp stamp))))) (make-instance 'action-status :bits bits :stamp stamp :index index)))
(defun status-keep-p (status) (defun status-keep-p (status)
(plusp (logand (status-bits status) #.+keep-bit+))) (plusp (logand (status-bits status) #.+keep-bit+)))
...@@ -125,7 +130,8 @@ in some previous image, or T if it needs to be done.")) ...@@ -125,7 +130,8 @@ in some previous image, or T if it needs to be done."))
"Return the latest status earlier than both status1 and status2" "Return the latest status earlier than both status1 and status2"
(make-action-status (make-action-status
:bits (logand (status-bits status1) (status-bits status2)) :bits (logand (status-bits status1) (status-bits status2))
:stamp (latest-stamp (status-stamp status1) (status-stamp status2)))) :stamp (latest-stamp (status-stamp status1) (status-stamp status2))
:index (or (status-index status1) (status-index status2))))
(defun mark-status-needed (status) (defun mark-status-needed (status)
"Return the same status but with the need bit set" "Return the same status but with the need bit set"
...@@ -133,7 +139,8 @@ in some previous image, or T if it needs to be done.")) ...@@ -133,7 +139,8 @@ in some previous image, or T if it needs to be done."))
status status
(make-action-status (make-action-status
:bits (logior (status-bits status) +need-bit+) :bits (logior (status-bits status) +need-bit+)
:stamp (status-stamp status)))) :stamp (status-stamp status)
:index (status-index status))))
(defmethod print-object ((status action-status) stream) (defmethod print-object ((status action-status) stream)
(print-unreadable-object (status stream :type t) (print-unreadable-object (status stream :type t)
...@@ -336,7 +343,8 @@ initialized with SEED." ...@@ -336,7 +343,8 @@ initialized with SEED."
:bits (logior (if stamp #.+keep-bit+ 0) :bits (logior (if stamp #.+keep-bit+ 0)
(if done-p #.+done-bit+ 0) (if done-p #.+done-bit+ 0)
(if need-p #.+need-bit+ 0)) (if need-p #.+need-bit+ 0))
:stamp stamp))) :stamp stamp
:index (incf (total-action-count *asdf-session*)))))
;; TRAVERSE-ACTION, in the context of a given PLAN object that accumulates dependency data, ;; TRAVERSE-ACTION, in the context of a given PLAN object that accumulates dependency data,
;; visits the action defined by its OPERATION and COMPONENT arguments, ;; visits the action defined by its OPERATION and COMPONENT arguments,
...@@ -528,4 +536,5 @@ return a list of the components involved in building the desired action." ...@@ -528,4 +536,5 @@ return a list of the components involved in building the desired action."
(setf (action-status plan o c) (setf (action-status plan o c)
(make-action-status (make-action-status
:bits (logior (status-bits perform-status) +done-bit+) :bits (logior (status-bits perform-status) +done-bit+)
:stamp (status-stamp perform-status))))))))) :stamp (status-stamp perform-status)
:index (status-index plan-status)))))))))
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