From 1dc29342a3621983ecc98e0d11830b07d79bdf68 Mon Sep 17 00:00:00 2001 From: Francois-Rene Rideau <tunes@google.com> Date: Sun, 9 Dec 2012 16:51:18 -0500 Subject: [PATCH] 2.26.15: more twiddling of compute-action-stamp. POIU works again at long last! --- asdf.asd | 2 +- asdf.lisp | 55 ++++++++++++++++++++++------------------ test/script-support.lisp | 7 +++-- 3 files changed, 37 insertions(+), 27 deletions(-) diff --git a/asdf.asd b/asdf.asd index 15118a513..b76c6b78f 100644 --- a/asdf.asd +++ b/asdf.asd @@ -14,7 +14,7 @@ :licence "MIT" :description "Another System Definition Facility" :long-description "ASDF builds Common Lisp software organized into defined systems." - :version "2.26.14" ;; to be automatically updated by bin/bump-revision + :version "2.26.15" ;; to be automatically updated by bin/bump-revision :depends-on () :components ((:file "asdf"))) diff --git a/asdf.lisp b/asdf.lisp index eb2393ded..b22e601b2 100644 --- a/asdf.lisp +++ b/asdf.lisp @@ -1,5 +1,5 @@ ;;; -*- mode: Common-Lisp; Base: 10 ; Syntax: ANSI-Common-Lisp ; coding: utf-8 -*- -;;; This is ASDF 2.26.14: Another System Definition Facility. +;;; This is ASDF 2.26.15: Another System Definition Facility. ;;; ;;; Feedback, bug reports, and patches are all welcome: ;;; please mail to <asdf-devel@common-lisp.net>. @@ -118,7 +118,7 @@ ;; "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.6.7" would be your seventh local modification of development version 2.345.6 - (asdf-version "2.26.14") + (asdf-version "2.26.15") (existing-asdf (find-class 'component nil)) (existing-version *asdf-version*) (already-there (equal asdf-version existing-version))) @@ -2049,13 +2049,6 @@ PREVIOUS-TIME when not null is the time at which the PREVIOUS system was loaded. (defmethod component-visited-p ((o operation) (c component)) (gethash (node-for o c) (operation-visited-nodes (operation-ancestor o)))) -(defun* component-visited-stamp (o c) - (let ((data (component-visited-p o c))) - (cond - (data (car data)) - (t ;;(when *asdf-verbose* (warn "looking up stamp for non-visited dependency: ~A ~A" o c)) - nil)))) - (defun* call-with-component-being-visited (o c fun) ;; Detect circular dependencies (let* ((node (node-for o c)) @@ -2130,7 +2123,9 @@ PREVIOUS-TIME when not null is the time at which the PREVIOUS system was loaded. (defmethod component-operation-time ((o operation) (c component)) (gethash (type-of o) (component-operation-times c))) -(defgeneric* compute-action-stamp (operation component &key mode base-stamp) +(defgeneric* action-visited-stamp (plan operation component)) + +(defgeneric* compute-action-stamp (operation component &key just-done plan base-stamp) (:documentation "Has this action been done, and at what timestamp has it or will it be done? Takes two keywords JUST-DONE and STAMP-LOOKUP: JUST-DONE is a boolean that is true if the action was just successfully performed, @@ -2264,7 +2259,7 @@ Returns two values: (defvar *visit-count* 0) ; counter that allows to sort nodes from operation-visited-nodes -(defun* visit-action (o c recurse fun base-stamp) +(defun* visit-action (o c base-stamp plan recurse fun) (block nil ;; Systems don't inherit force, but use operation-forced{,-not}. (let* ((force @@ -2287,7 +2282,7 @@ Returns two values: (visit-module-components o c (funcall recurse (later-stamp force dep-stamp))))) (multiple-value-bind (stamp done-p) (compute-action-stamp - o c :mode :plan + o c :plan plan :base-stamp (latest-stamp force dep-stamp components-stamp)) (funcall fun o c done-p stamp) stamp)))) @@ -2301,26 +2296,28 @@ Returns two values: (when p (return (car s)))) (with-component-being-visited (o c) (visit-action - o c + o c base-stamp 'traverse #'(lambda (stamp) #'(lambda (o c) (traverse-action o c stamp collect))) #'(lambda (o c done-p stamp) (mark-component-visited o c (cons stamp (unless done-p (incf *visit-count*)))) (if done-p (mark-operation-done o c) - (do-collect collect (cons o c)))) - base-stamp)))) + (do-collect collect (cons o c)))))))) (defmethod traverse ((o operation) (c component)) (while-collecting (collect) (let ((*visit-count* 0)) (traverse-action o c nil #'collect)))) -(defmethod compute-action-stamp ((o operation) (c component) &key (mode :query) base-stamp) - (let* ((stamp-lookup (ecase mode - ((:just-done :query) 'component-operation-time) - ((:plan) 'component-visited-stamp))) - (just-done (eq mode :just-done)) +(defmethod action-visited-stamp ((plan null) (o operation) (c component)) + (component-operation-time o c)) + +(defmethod action-visited-stamp ((plan (eql 'traverse)) (o operation) (c component)) + (car (component-visited-p o c))) + +(defmethod compute-action-stamp ((o operation) (c component) &key just-done plan base-stamp) + (let* ((stamp-lookup #'(lambda (o c) (action-visited-stamp plan o c))) (out-files (output-files o c)) (in-files (input-files o c)) (file-op (and out-files t)) @@ -2357,7 +2354,7 @@ Returns two values: (and (stamp<= latest-in earliest-out) (operation-done-p o c))) (values done-stamp - (and (or op-time out-files (and (null in-files) (null out-files))) + (and (or op-stamp file-op null-op) (if (realp op-stamp) (eql op-stamp done-stamp) t) all-present)) (values t nil)))) @@ -2373,7 +2370,7 @@ Returns two values: (defmethod mark-operation-done ((o operation) (c component)) (setf (gethash (type-of o) (component-operation-times c)) - (compute-action-stamp o c :mode :just-done))) + (compute-action-stamp o c :just-done t))) (defmethod perform-with-restarts (operation component) ;; TOO verbose, especially as the default. Add your own :before method @@ -2583,6 +2580,11 @@ Returns two values: (declare (ignorable o)) (format nil (compatfmt "~@<loaded ~3i~_~A~@:>") c)) +(defmethod operation-description ((o parent-load-op) (c component)) + (declare (ignorable o)) + (format nil (compatfmt "~@<loading dependencies of ~3i~_~A~@:>") c)) + + ;;;; ------------------------------------------------------------------------- ;;;; load-source-op @@ -2621,6 +2623,10 @@ Returns two values: (declare (ignorable o)) (format nil (compatfmt "~@<Loaded source of ~3i~_~A~@:>") c)) +(defmethod operation-description ((o parent-load-source-op) (c component)) + (declare (ignorable o)) + (format nil (compatfmt "~@<loading source for dependencies of ~3i~_~A~@:>") c)) + ;;;; ------------------------------------------------------------------------- ;;;; test-op @@ -2666,6 +2672,7 @@ Returns two values: ;; Invalidate all systems but ASDF itself. (setf *defined-systems* (make-defined-systems-table)) (register-system asdf) + (funcall (find-symbol* 'load-system :asdf) :asdf) ;; do it a second time, the right way. ;; If we're in the middle of something, restart it. (when *systems-being-defined* (let ((l (loop :for name :being :the :hash-keys :of *systems-being-defined* :collect name))) @@ -4818,9 +4825,9 @@ with a different configuration, so the configuration would be re-read then." (if (bundle-op-monolithic-p o) (values 'monolithic-lib-op 'monolithic-fasl-op) (values 'lib-op 'fasl-op)) - (list (list (make-sub-operation o lib-op :args (bundle-op-build-args o)) + (list (list (make-instance lib-op :parent o :args (bundle-op-build-args o)) s) - (list (make-sub-operation o fasl-op :args (bundle-op-build-args o)) + (list (make-instance fasl-op :parent o :args (bundle-op-build-args o)) s)))) (defmethod component-depends-on ((o binary-op) (s system)) diff --git a/test/script-support.lisp b/test/script-support.lisp index 07d0a5f6c..f92015c2f 100644 --- a/test/script-support.lisp +++ b/test/script-support.lisp @@ -56,6 +56,7 @@ (defun load-asdf () (load *asdf-fasl*) (use-package :asdf :asdf-test) + (import 'DBG :asdf) (setf *package* (find-package :asdf-test))) (defun common-lisp-user::load-asdf () @@ -187,7 +188,6 @@ is bound, write a message and exit on an error. If (defmacro test-asdf (&body body) `(testing-asdf #'(lambda () ,@body))) -#| (defmacro DBG (tag &rest exprs) "simple debug statement macro: outputs a tag plus a list of variable and their values, returns the last value" @@ -204,5 +204,8 @@ outputs a tag plus a list of variable and their values, returns the last value" exprs) (apply 'values ,res))))) - (DBG :cas o c just-done base-stamp stamp-lookup out-files in-files file-op null-op op-time dep-stamp out-stamps in-stamps missing-in missing-out all-present earliest-out latest-in done-stamp (stamp<= latest-in earliest-out) (operation-done-p o c)) +(pushnew :DBG *features*) + +#| +#+DBG (DBG :cas o c just-done base-stamp stamp-lookup out-files in-files file-op null-op op-time op-stamp dep-stamp out-stamps in-stamps missing-in missing-out all-present earliest-out latest-in done-stamp (stamp<= latest-in earliest-out) (operation-done-p o c)) |# -- GitLab